ALPHALINUX5/util/ALPHALINUX5/lib/tcl8.3/http2.3/http.tcl

   1 # http.tcl --
   2 #
   3 #       Client-side HTTP for GET, POST, and HEAD commands.
   4 #       These routines can be used in untrusted code that uses
   5 #       the Safesock security policy.  These procedures use a
   6 #       callback interface to avoid using vwait, which is not
   7 #       defined in the safe base.
   8 #
   9 # See the file "license.terms" for information on usage and
  10 # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11 #
  12 # RCS: @(#) $Id: http.tcl,v 1.32 2000/04/22 07:07:59 sandeep Exp $
  13
  14 # Rough version history:
  15 # 1.0   Old http_get interface
  16 # 2.0   http:: namespace and http::geturl
  17 # 2.1   Added callbacks to handle arriving data, and timeouts
  18 # 2.2   Added ability to fetch into a channel
  19 # 2.3   Added SSL support, and ability to post from a channel
  20 #       This version also cleans up error cases and eliminates the
  21 #       "ioerror" status in favor of raising an error
  22
  23 package provide http 2.3
  24
  25 namespace eval http {
  26     variable http
  27     array set http {
  28         -accept */*
  29         -proxyhost {}
  30         -proxyport {}
  31         -useragent {Tcl http client package 2.3}
  32         -proxyfilter http::ProxyRequired
  33     }
  34
  35     variable formMap
  36     variable alphanumeric a-zA-Z0-9
  37     variable c
  38     variable i 0
  39     for {} {$i <= 256} {incr i} {
  40         set c [format %c $i]
  41         if {![string match \[$alphanumeric\] $c]} {
  42             set formMap($c) %[format %.2x $i]
  43         }
  44     }
  45     # These are handled specially
  46     array set formMap {
  47         " " +   \n %0d%0a
  48     }
  49
  50     variable urlTypes
  51     array set urlTypes {
  52         http    {80 ::socket}
  53     }
  54
  55     namespace export geturl config reset wait formatQuery register unregister
  56     # Useful, but not exported: data size status code
  57 }
  58
  59 # http::register --
  60 #
  61 #     See documentaion for details.
  62 #
  63 # Arguments:
  64 #     proto           URL protocol prefix, e.g. https
  65 #     port            Default port for protocol
  66 #     command         Command to use to create socket
  67 # Results:
  68 #     list of port and command that was registered.
  69
  70 proc http::register {proto port command} {
  71     variable urlTypes
  72     set urlTypes($proto) [list $port $command]
  73 }
  74
  75 # http::unregister --
  76 #
  77 #     Unregisters URL protocol handler
  78 #
  79 # Arguments:
  80 #     proto           URL protocol prefix, e.g. https
  81 # Results:
  82 #     list of port and command that was unregistered.
  83
  84 proc http::unregister {proto} {
  85     variable urlTypes
  86     if {![info exists urlTypes($proto)]} {
  87         return -code error "unsupported url type \"$proto\""
  88     }
  89     set old $urlTypes($proto)
  90     unset urlTypes($proto)
  91     return $old
  92 }
  93
  94 # http::config --
  95 #
  96 #       See documentaion for details.
  97 #
  98 # Arguments:
  99 #       args            Options parsed by the procedure.
 100 # Results:
 101 #        TODO
 102
 103 proc http::config {args} {
 104     variable http
 105     set options [lsort [array names http -*]]
 106     set usage [join $options ", "]
 107     if {[llength $args] == 0} {
 108         set result {}
 109         foreach name $options {
 110             lappend result $name $http($name)
 111         }
 112         return $result
 113     }
 114     regsub -all -- - $options {} options
 115     set pat ^-([join $options |])$
 116     if {[llength $args] == 1} {
 117         set flag [lindex $args 0]
 118         if {[regexp -- $pat $flag]} {
 119             return $http($flag)
 120         } else {
 121             return -code error "Unknown option $flag, must be: $usage"
 122         }
 123     } else {
 124         foreach {flag value} $args {
 125             if {[regexp -- $pat $flag]} {
 126                 set http($flag) $value
 127             } else {
 128                 return -code error "Unknown option $flag, must be: $usage"
 129             }
 130         }
 131     }
 132 }
 133
 134 # http::Finish --
 135 #
 136 #       Clean up the socket and eval close time callbacks
 137 #
 138 # Arguments:
 139 #       token       Connection token.
 140 #       errormsg    (optional) If set, forces status to error.
 141 #       skipCB      (optional) If set, don't call the -command callback.  This
 142 #                   is useful when geturl wants to throw an exception instead
 143 #                   of calling the callback.  That way, the same error isn't
 144 #                   reported to two places.
 145 #
 146 # Side Effects:
 147 #        Closes the socket
 148
 149 proc http::Finish { token {errormsg ""} {skipCB 0}} {
 150     variable $token
 151     upvar 0 $token state
 152     global errorInfo errorCode
 153     if {[string length $errormsg] != 0} {
 154         set state(error) [list $errormsg $errorInfo $errorCode]
 155         set state(status) error
 156     }
 157     catch {close $state(sock)}
 158     catch {after cancel $state(after)}
 159     if {[info exists state(-command)] && !$skipCB} {
 160         if {[catch {eval $state(-command) {$token}} err]} {
 161             if {[string length $errormsg] == 0} {
 162                 set state(error) [list $err $errorInfo $errorCode]
 163                 set state(status) error
 164             }
 165         }
 166         if {[info exist state(-command)]} {
 167             # Command callback may already have unset our state
 168             unset state(-command)
 169         }
 170     }
 171 }
 172
 173 # http::reset --
 174 #
 175 #       See documentaion for details.
 176 #
 177 # Arguments:
 178 #       token   Connection token.
 179 #       why     Status info.
 180 #
 181 # Side Effects:
 182 #       See Finish
 183
 184 proc http::reset { token {why reset} } {
 185     variable $token
 186     upvar 0 $token state
 187     set state(status) $why
 188     catch {fileevent $state(sock) readable {}}
 189     catch {fileevent $state(sock) writable {}}
 190     Finish $token
 191     if {[info exists state(error)]} {
 192         set errorlist $state(error)
 193         unset state
 194         eval error $errorlist
 195     }
 196 }
 197
 198 # http::geturl --
 199 #
 200 #       Establishes a connection to a remote url via http.
 201 #
 202 # Arguments:
 203 #       url             The http URL to goget.
 204 #       args            Option value pairs. Valid options include:
 205 #                               -blocksize, -validate, -headers, -timeout
 206 # Results:
 207 #       Returns a token for this connection.
 208 #       This token is the name of an array that the caller should
 209 #       unset to garbage collect the state.
 210
 211 proc http::geturl { url args } {
 212     variable http
 213     variable urlTypes
 214
 215     # Initialize the state variable, an array.  We'll return the
 216     # name of this array as the token for the transaction.
 217
 218     if {![info exists http(uid)]} {
 219         set http(uid) 0
 220     }
 221     set token [namespace current]::[incr http(uid)]
 222     variable $token
 223     upvar 0 $token state
 224     reset $token
 225
 226     # Process command options.
 227
 228     array set state {
 229         -blocksize      8192
 230         -queryblocksize 8192
 231         -validate       0
 232         -headers        {}
 233         -timeout        0
 234         -type           application/x-www-form-urlencoded
 235         -queryprogress  {}
 236         state           header
 237         meta            {}
 238         currentsize     0
 239         totalsize       0
 240         querylength     0
 241         queryoffset     0
 242         type            text/html
 243         body            {}
 244         status          ""
 245         http            ""
 246     }
 247     set options {-blocksize -channel -command -handler -headers \
 248             -progress -query -queryblocksize -querychannel -queryprogress\
 249             -validate -timeout -type}
 250     set usage [join $options ", "]
 251     regsub -all -- - $options {} options
 252     set pat ^-([join $options |])$
 253     foreach {flag value} $args {
 254         if {[regexp $pat $flag]} {
 255             # Validate numbers
 256             if {[info exists state($flag)] && \
 257                     [string is integer -strict $state($flag)] && \
 258                     ![string is integer -strict $value]} {
 259                 unset $token
 260                 return -code error "Bad value for $flag ($value), must be integer"
 261             }
 262             set state($flag) $value
 263         } else {
 264             unset $token
 265             return -code error "Unknown option $flag, can be: $usage"
 266         }
 267     }
 268
 269     # Make sure -query and -querychannel aren't both specified
 270
 271     set isQueryChannel [info exists state(-querychannel)]
 272     set isQuery [info exists state(-query)]
 273     if {$isQuery && $isQueryChannel} {
 274         unset $token
 275         return -code error "Can't combine -query and -querychannel options!"
 276     }
 277
 278     # Validate URL, determine the server host and port, and check proxy case
 279
 280     if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
 281             x prefix proto host y port srvurl]} {
 282         unset $token
 283         error "Unsupported URL: $url"
 284     }
 285     if {[string length $proto] == 0} {
 286         set proto http
 287         set url ${proto}://$url
 288     }
 289     if {![info exists urlTypes($proto)]} {
 290         unset $token
 291         return -code error "unsupported url type \"$proto\""
 292     }
 293     set defport [lindex $urlTypes($proto) 0]
 294     set defcmd [lindex $urlTypes($proto) 1]
 295
 296     if {[string length $port] == 0} {
 297         set port $defport
 298     }
 299     if {[string length $srvurl] == 0} {
 300         set srvurl /
 301     }
 302     if {[string length $proto] == 0} {
 303         set url http://$url
 304     }
 305     set state(url) $url
 306     if {![catch {$http(-proxyfilter) $host} proxy]} {
 307         set phost [lindex $proxy 0]
 308         set pport [lindex $proxy 1]
 309     }
 310
 311     # If a timeout is specified we set up the after event
 312     # and arrange for an asynchronous socket connection.
 313
 314     if {$state(-timeout) > 0} {
 315         set state(after) [after $state(-timeout) \
 316                 [list http::reset $token timeout]]
 317         set async -async
 318     } else {
 319         set async ""
 320     }
 321
 322     # If we are using the proxy, we must pass in the full URL that
 323     # includes the server name.
 324
 325     if {[info exists phost] && [string length $phost]} {
 326         set srvurl $url
 327         set conStat [catch {eval $defcmd $async {$phost $pport}} s]
 328     } else {
 329         set conStat [catch {eval $defcmd $async {$host $port}} s]
 330     }
 331     if {$conStat} {
 332
 333         # something went wrong while trying to establish the connection
 334         # Clean up after events and such, but DON'T call the command callback
 335         # (if available) because we're going to throw an exception from here
 336         # instead.
 337         Finish $token "" 1
 338         cleanup $token
 339         return -code error $s
 340     }
 341     set state(sock) $s
 342
 343     # Wait for the connection to complete
 344
 345     if {$state(-timeout) > 0} {
 346         fileevent $s writable [list http::Connect $token]
 347         http::wait $token
 348         if {$state(status) != "connect"} {
 349
 350             # Likely to be connection timeout.  If there was a connection
 351             # error, (e.g., bad port), then http::wait will have
 352             # raised an error already
 353
 354             return $token
 355         }
 356         set state(status) ""
 357     }
 358
 359     # Send data in cr-lf format, but accept any line terminators
 360
 361     fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
 362
 363     # The following is disallowed in safe interpreters, but the socket
 364     # is already in non-blocking mode in that case.
 365
 366     catch {fconfigure $s -blocking off}
 367     set how GET
 368     if {$isQuery} {
 369         set state(querylength) [string length $state(-query)]
 370         if {$state(querylength) > 0} {
 371             set how POST
 372             set contDone 0
 373         } else {
 374             # there's no query data
 375             unset state(-query)
 376             set isQuery 0
 377         }
 378     } elseif {$state(-validate)} {
 379         set how HEAD
 380     } elseif {$isQueryChannel} {
 381         set how POST
 382         # The query channel must be blocking for the async Write to
 383         # work properly.
 384         fconfigure $state(-querychannel) -blocking 1 -translation binary
 385         set contDone 0
 386     }
 387
 388     if {[catch {
 389         puts $s "$how $srvurl HTTP/1.0"
 390         puts $s "Accept: $http(-accept)"
 391         puts $s "Host: $host"
 392         puts $s "User-Agent: $http(-useragent)"
 393         foreach {key value} $state(-headers) {
 394             regsub -all \[\n\r\]  $value {} value
 395             set key [string trim $key]
 396             if {[string equal $key "Content-Length"]} {
 397                 set contDone 1
 398                 set state(querylength) $value
 399             }
 400             if {[string length $key]} {
 401                 puts $s "$key: $value"
 402             }
 403         }
 404         if {$isQueryChannel && $state(querylength) == 0} {
 405             # Try to determine size of data in channel
 406             # If we cannot seek, the surrounding catch will trap us
 407
 408             set start [tell $state(-querychannel)]
 409             seek $state(-querychannel) 0 end
 410             set state(querylength) \
 411                     [expr {[tell $state(-querychannel)] - $start}]
 412             seek $state(-querychannel) $start
 413         }
 414
 415         # Flush the request header and set up the fileevent that will
 416         # either push the POST data or read the response.
 417         #
 418         # fileevent note:
 419         #
 420         # It is possible to have both the read and write fileevents active
 421         # at this point.  The only scenario it seems to affect is a server
 422         # that closes the connection without reading the POST data.
 423         # (e.g., early versions TclHttpd in various error cases).
 424         # Depending on the platform, the client may or may not be able to
 425         # get the response from the server because of the error it will
 426         # get trying to write the post data.  Having both fileevents active
 427         # changes the timing and the behavior, but no two platforms
 428         # (among Solaris, Linux, and NT)  behave the same, and none
 429         # behave all that well in any case.  Servers should always read thier
 430         # POST data if they expect the client to read their response.
 431
 432         if {$isQuery || $isQueryChannel} {
 433             puts $s "Content-Type: $state(-type)"
 434             if {!$contDone} {
 435                 puts $s "Content-Length: $state(querylength)"
 436             }
 437             puts $s ""
 438             fconfigure $s -translation {auto binary}
 439             fileevent $s writable [list http::Write $token]
 440         } else {
 441             puts $s ""
 442             flush $s
 443             fileevent $s readable [list http::Event $token]
 444         }
 445
 446         if {! [info exists state(-command)]} {
 447
 448             # geturl does EVERYTHING asynchronously, so if the user
 449             # calls it synchronously, we just do a wait here.
 450
 451             wait $token
 452         }
 453     } err]} {
 454         # The socket probably was never connected,
 455         # or the connection dropped later.
 456
 457         # Clean up after events and such, but DON'T call the command callback
 458         # (if available) because we're going to throw an exception from here
 459         # instead.
 460
 461         Finish $token $err 1
 462         cleanup $token
 463         return -code error $err
 464     }
 465
 466     return $token
 467 }
 468
 469 # Data access functions:
 470 # Data - the URL data
 471 # Status - the transaction status: ok, reset, eof, timeout
 472 # Code - the HTTP transaction code, e.g., 200
 473 # Size - the size of the URL data
 474
 475 proc http::data {token} {
 476     variable $token
 477     upvar 0 $token state
 478     return $state(body)
 479 }
 480 proc http::status {token} {
 481     variable $token
 482     upvar 0 $token state
 483     return $state(status)
 484 }
 485 proc http::code {token} {
 486     variable $token
 487     upvar 0 $token state
 488     return $state(http)
 489 }
 490 proc http::ncode {token} {
 491     variable $token
 492     upvar 0 $token state
 493     if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
 494         return $numeric_code
 495     } else {
 496         return $state(http)
 497     }
 498 }
 499 proc http::size {token} {
 500     variable $token
 501     upvar 0 $token state
 502     return $state(currentsize)
 503 }
 504
 505 # http::cleanup
 506 #
 507 #       Garbage collect the state associated with a transaction
 508 #
 509 # Arguments
 510 #       token   The token returned from http::geturl
 511 #
 512 # Side Effects
 513 #       unsets the state array
 514
 515 proc http::cleanup {token} {
 516     variable $token
 517     upvar 0 $token state
 518     if {[info exist state]} {
 519         unset state
 520     }
 521 }
 522
 523 # http::Connect
 524 #
 525 #       This callback is made when an asyncronous connection completes.
 526 #
 527 # Arguments
 528 #       token   The token returned from http::geturl
 529 #
 530 # Side Effects
 531 #       Sets the status of the connection, which unblocks
 532 #       the waiting geturl call
 533
 534  proc http::Connect {token} {
 535     variable $token
 536     upvar 0 $token state
 537     global errorInfo errorCode
 538     if {[eof $state(sock)] ||
 539             [string length [fconfigure $state(sock) -error]]} {
 540         set state(status) error
 541         set state(error) [list \
 542                 "connect failed [fconfigure $state(sock) -error]" \
 543                 $errorInfo $errorCode]
 544     } else {
 545         set state(status) connect
 546     }
 547     fileevent $state(sock) writable {}
 548  }
 549
 550 # http::Write
 551 #
 552 #       Write POST query data to the socket
 553 #
 554 # Arguments
 555 #       token   The token for the connection
 556 #
 557 # Side Effects
 558 #       Write the socket and handle callbacks.
 559
 560 proc http::Write {token} {
 561     variable $token
 562     upvar 0 $token state
 563     set s $state(sock)
 564
 565     # Output a block.  Tcl will buffer this if the socket blocks
 566
 567     set done 0
 568     if {[catch {
 569
 570         # Catch I/O errors on dead sockets
 571
 572         if {[info exists state(-query)]} {
 573
 574             # Chop up large query strings so queryprogress callback
 575             # can give smooth feedback
 576
 577             puts -nonewline $s \
 578                     [string range $state(-query) $state(queryoffset) \
 579                     [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
 580             incr state(queryoffset) $state(-queryblocksize)
 581             if {$state(queryoffset) >= $state(querylength)} {
 582                 set state(queryoffset) $state(querylength)
 583                 set done 1
 584             }
 585         } else {
 586
 587             # Copy blocks from the query channel
 588
 589             set outStr [read $state(-querychannel) $state(-queryblocksize)]
 590             puts -nonewline $s $outStr
 591             incr state(queryoffset) [string length $outStr]
 592             if {[eof $state(-querychannel)]} {
 593                 set done 1
 594             }
 595         }
 596     } err]} {
 597         # Do not call Finish here, but instead let the read half of
 598         # the socket process whatever server reply there is to get.
 599
 600         set state(posterror) $err
 601         set done 1
 602     }
 603     if {$done} {
 604         catch {flush $s}
 605         fileevent $s writable {}
 606         fileevent $s readable [list http::Event $token]
 607     }
 608
 609     # Callback to the client after we've completely handled everything
 610
 611     if {[string length $state(-queryprogress)]} {
 612         eval $state(-queryprogress) [list $token $state(querylength)\
 613                 $state(queryoffset)]
 614     }
 615 }
 616
 617 # http::Event
 618 #
 619 #       Handle input on the socket
 620 #
 621 # Arguments
 622 #       token   The token returned from http::geturl
 623 #
 624 # Side Effects
 625 #       Read the socket and handle callbacks.
 626
 627  proc http::Event {token} {
 628     variable $token
 629     upvar 0 $token state
 630     set s $state(sock)
 631
 632      if {[eof $s]} {
 633         Eof $token
 634         return
 635     }
 636     if {[string equal $state(state) "header"]} {
 637         if {[catch {gets $s line} n]} {
 638             Finish $token $n
 639         } elseif {$n == 0} {
 640             set state(state) body
 641             if {![regexp -nocase ^text $state(type)]} {
 642                 # Turn off conversions for non-text data
 643                 fconfigure $s -translation binary
 644                 if {[info exists state(-channel)]} {
 645                     fconfigure $state(-channel) -translation binary
 646                 }
 647             }
 648             if {[info exists state(-channel)] &&
 649                     ![info exists state(-handler)]} {
 650                 # Initiate a sequence of background fcopies
 651                 fileevent $s readable {}
 652                 CopyStart $s $token
 653             }
 654         } elseif {$n > 0} {
 655             if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
 656                 set state(type) [string trim $type]
 657             }
 658             if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
 659                 set state(totalsize) [string trim $length]
 660             }
 661             if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 662                 lappend state(meta) $key [string trim $value]
 663             } elseif {[regexp ^HTTP $line]} {
 664                 set state(http) $line
 665             }
 666         }
 667     } else {
 668         if {[catch {
 669             if {[info exists state(-handler)]} {
 670                 set n [eval $state(-handler) {$s $token}]
 671             } else {
 672                 set block [read $s $state(-blocksize)]
 673                 set n [string length $block]
 674                 if {$n >= 0} {
 675                     append state(body) $block
 676                 }
 677             }
 678             if {$n >= 0} {
 679                 incr state(currentsize) $n
 680             }
 681         } err]} {
 682             Finish $token $err
 683         } else {
 684             if {[info exists state(-progress)]} {
 685                 eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
 686             }
 687         }
 688     }
 689 }
 690
 691 # http::CopyStart
 692 #
 693 #       Error handling wrapper around fcopy
 694 #
 695 # Arguments
 696 #       s       The socket to copy from
 697 #       token   The token returned from http::geturl
 698 #
 699 # Side Effects
 700 #       This closes the connection upon error
 701
 702  proc http::CopyStart {s token} {
 703     variable $token
 704     upvar 0 $token state
 705     if {[catch {
 706         fcopy $s $state(-channel) -size $state(-blocksize) -command \
 707             [list http::CopyDone $token]
 708     } err]} {
 709         Finish $token $err
 710     }
 711 }
 712
 713 # http::CopyDone
 714 #
 715 #       fcopy completion callback
 716 #
 717 # Arguments
 718 #       token   The token returned from http::geturl
 719 #       count   The amount transfered
 720 #
 721 # Side Effects
 722 #       Invokes callbacks
 723
 724  proc http::CopyDone {token count {error {}}} {
 725     variable $token
 726     upvar 0 $token state
 727     set s $state(sock)
 728     incr state(currentsize) $count
 729     if {[info exists state(-progress)]} {
 730         eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
 731     }
 732     # At this point the token may have been reset
 733     if {[string length $error]} {
 734         Finish $token $error
 735     } elseif {[catch {eof $s} iseof] || $iseof} {
 736         Eof $token
 737     } else {
 738         CopyStart $s $token
 739     }
 740 }
 741
 742 # http::Eof
 743 #
 744 #       Handle eof on the socket
 745 #
 746 # Arguments
 747 #       token   The token returned from http::geturl
 748 #
 749 # Side Effects
 750 #       Clean up the socket
 751
 752  proc http::Eof {token} {
 753     variable $token
 754     upvar 0 $token state
 755     if {[string equal $state(state) "header"]} {
 756         # Premature eof
 757         set state(status) eof
 758     } else {
 759         set state(status) ok
 760     }
 761     set state(state) eof
 762     Finish $token
 763 }
 764
 765 # http::wait --
 766 #
 767 #       See documentaion for details.
 768 #
 769 # Arguments:
 770 #       token   Connection token.
 771 #
 772 # Results:
 773 #        The status after the wait.
 774
 775 proc http::wait {token} {
 776     variable $token
 777     upvar 0 $token state
 778
 779     if {![info exists state(status)] || [string length $state(status)] == 0} {
 780         # We must wait on the original variable name, not the upvar alias
 781         vwait $token\(status)
 782     }
 783     if {[info exists state(error)]} {
 784         set errorlist $state(error)
 785         unset state
 786         eval error $errorlist
 787     }
 788     return $state(status)
 789 }
 790
 791 # http::formatQuery --
 792 #
 793 #       See documentaion for details.
 794 #       Call http::formatQuery with an even number of arguments, where
 795 #       the first is a name, the second is a value, the third is another
 796 #       name, and so on.
 797 #
 798 # Arguments:
 799 #       args    A list of name-value pairs.
 800 #
 801 # Results:
 802 #        TODO
 803
 804 proc http::formatQuery {args} {
 805     set result ""
 806     set sep ""
 807     foreach i $args {
 808         append result $sep [mapReply $i]
 809         if {[string compare $sep "="]} {
 810             set sep =
 811         } else {
 812             set sep &
 813         }
 814     }
 815     return $result
 816 }
 817
 818 # http::mapReply --
 819 #
 820 #       Do x-www-urlencoded character mapping
 821 #
 822 # Arguments:
 823 #       string  The string the needs to be encoded
 824 #
 825 # Results:
 826 #       The encoded string
 827
 828  proc http::mapReply {string} {
 829     variable formMap
 830
 831     # The spec says: "non-alphanumeric characters are replaced by '%HH'"
 832     # 1 leave alphanumerics characters alone
 833     # 2 Convert every other character to an array lookup
 834     # 3 Escape constructs that are "special" to the tcl parser
 835     # 4 "subst" the result, doing all the array substitutions
 836
 837     set alphanumeric    a-zA-Z0-9
 838     regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
 839     regsub -all \n $string {\\n} string
 840     regsub -all \t $string {\\t} string
 841     regsub -all {[][{})\\]\)} $string {\\&} string
 842     return [subst $string]
 843 }
 844
 845 # http::ProxyRequired --
 846 #       Default proxy filter.
 847 #
 848 # Arguments:
 849 #       host    The destination host
 850 #
 851 # Results:
 852 #       The current proxy settings
 853
 854  proc http::ProxyRequired {host} {
 855     variable http
 856     if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
 857         if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
 858             set http(-proxyport) 8080
 859         }
 860         return [list $http(-proxyhost) $http(-proxyport)]
 861     } else {
 862         return {}
 863     }
 864 }