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