mingw/lib/tcl8/8.4/http-2.7.1.tm

   1 # http.tcl --
   2 #
   3 #       Client-side HTTP for GET, POST, and HEAD commands. These routines can
   4 #       be used in untrusted code that uses the Safesock security policy. These
   5 #       procedures use a callback interface to avoid using vwait, which is not
   6 #       defined in the safe base.
   7 #
   8 # See the file "license.terms" for information on usage and redistribution of
   9 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10 #
  11 # RCS: @(#) $Id: http.tcl,v 1.67.2.4 2008/08/11 21:57:14 dgp Exp $
  12
  13 package require Tcl 8.4
  14 # Keep this in sync with pkgIndex.tcl and with the install directories
  15 # in Makefiles
  16 package provide http 2.7.1
  17
  18 namespace eval http {
  19     # Allow resourcing to not clobber existing data
  20
  21     variable http
  22     if {![info exists http]} {
  23         array set http {
  24             -accept */*
  25             -proxyhost {}
  26             -proxyport {}
  27             -proxyfilter http::ProxyRequired
  28             -urlencoding utf-8
  29         }
  30         set http(-useragent) "Tcl http client package [package provide http]"
  31     }
  32
  33     proc init {} {
  34         # Set up the map for quoting chars. RFC3986 Section 2.3 say percent
  35         # encode all except: "... percent-encoded octets in the ranges of ALPHA
  36         # (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period (%2E),
  37         # underscore (%5F), or tilde (%7E) should not be created by URI
  38         # producers ..."
  39         for {set i 0} {$i <= 256} {incr i} {
  40             set c [format %c $i]
  41             if {![string match {[-._~a-zA-Z0-9]} $c]} {
  42                 set map($c) %[format %.2x $i]
  43             }
  44         }
  45         # These are handled specially
  46         set map(\n) %0d%0a
  47         variable formMap [array get map]
  48
  49         # Create a map for HTTP/1.1 open sockets
  50         variable socketmap
  51         if {[info exists socketmap]} {
  52             # Close but don't remove open sockets on re-init
  53             foreach {url sock} [array get socketmap] {
  54                 catch {close $sock}
  55             }
  56         }
  57         array set socketmap {}
  58     }
  59     init
  60
  61     variable urlTypes
  62     if {![info exists urlTypes]} {
  63         set urlTypes(http) [list 80 ::socket]
  64     }
  65
  66     variable encodings [string tolower [encoding names]]
  67     # This can be changed, but iso8859-1 is the RFC standard.
  68     variable defaultCharset
  69     if {![info exists defaultCharset]} {
  70         set defaultCharset "iso8859-1"
  71     }
  72
  73     # Force RFC 3986 strictness in geturl url verification?
  74     variable strict
  75     if {![info exists strict]} {
  76         set strict 1
  77     }
  78
  79     # Let user control default keepalive for compatibility
  80     variable defaultKeepalive
  81     if {![info exists defaultKeepalive]} {
  82         set defaultKeepalive 0
  83     }
  84
  85     namespace export geturl config reset wait formatQuery register unregister
  86     # Useful, but not exported: data size status code
  87 }
  88
  89 # http::Log --
  90 #
  91 #       Debugging output -- define this to observe HTTP/1.1 socket usage.
  92 #       Should echo any args received.
  93 #
  94 # Arguments:
  95 #     msg       Message to output
  96 #
  97 proc http::Log {args} {}
  98
  99 # http::register --
 100 #
 101 #     See documentation for details.
 102 #
 103 # Arguments:
 104 #     proto           URL protocol prefix, e.g. https
 105 #     port            Default port for protocol
 106 #     command         Command to use to create socket
 107 # Results:
 108 #     list of port and command that was registered.
 109
 110 proc http::register {proto port command} {
 111     variable urlTypes
 112     set urlTypes($proto) [list $port $command]
 113 }
 114
 115 # http::unregister --
 116 #
 117 #     Unregisters URL protocol handler
 118 #
 119 # Arguments:
 120 #     proto           URL protocol prefix, e.g. https
 121 # Results:
 122 #     list of port and command that was unregistered.
 123
 124 proc http::unregister {proto} {
 125     variable urlTypes
 126     if {![info exists urlTypes($proto)]} {
 127         return -code error "unsupported url type \"$proto\""
 128     }
 129     set old $urlTypes($proto)
 130     unset urlTypes($proto)
 131     return $old
 132 }
 133
 134 # http::config --
 135 #
 136 #       See documentation for details.
 137 #
 138 # Arguments:
 139 #       args            Options parsed by the procedure.
 140 # Results:
 141 #        TODO
 142
 143 proc http::config {args} {
 144     variable http
 145     set options [lsort [array names http -*]]
 146     set usage [join $options ", "]
 147     if {[llength $args] == 0} {
 148         set result {}
 149         foreach name $options {
 150             lappend result $name $http($name)
 151         }
 152         return $result
 153     }
 154     set options [string map {- ""} $options]
 155     set pat ^-([join $options |])$
 156     if {[llength $args] == 1} {
 157         set flag [lindex $args 0]
 158         if {[regexp -- $pat $flag]} {
 159             return $http($flag)
 160         } else {
 161             return -code error "Unknown option $flag, must be: $usage"
 162         }
 163     } else {
 164         foreach {flag value} $args {
 165             if {[regexp -- $pat $flag]} {
 166                 set http($flag) $value
 167             } else {
 168                 return -code error "Unknown option $flag, must be: $usage"
 169             }
 170         }
 171     }
 172 }
 173
 174 # http::Finish --
 175 #
 176 #       Clean up the socket and eval close time callbacks
 177 #
 178 # Arguments:
 179 #       token       Connection token.
 180 #       errormsg    (optional) If set, forces status to error.
 181 #       skipCB      (optional) If set, don't call the -command callback. This
 182 #                   is useful when geturl wants to throw an exception instead
 183 #                   of calling the callback. That way, the same error isn't
 184 #                   reported to two places.
 185 #
 186 # Side Effects:
 187 #        Closes the socket
 188
 189 proc http::Finish { token {errormsg ""} {skipCB 0}} {
 190     variable $token
 191     upvar 0 $token state
 192     global errorInfo errorCode
 193     if {$errormsg ne ""} {
 194         set state(error) [list $errormsg $errorInfo $errorCode]
 195         set state(status) "error"
 196     }
 197     if {($state(status) eq "timeout") || ($state(status) eq "error")
 198         || ([info exists state(connection)] && ($state(connection) eq "close"))
 199     } {
 200         CloseSocket $state(sock) $token
 201     }
 202     if {[info exists state(after)]} { after cancel $state(after) }
 203     if {[info exists state(-command)] && !$skipCB} {
 204         if {[catch {eval $state(-command) {$token}} err]} {
 205             if {$errormsg eq ""} {
 206                 set state(error) [list $err $errorInfo $errorCode]
 207                 set state(status) error
 208             }
 209         }
 210         # Command callback may already have unset our state
 211         unset -nocomplain state(-command)
 212     }
 213 }
 214
 215 # http::CloseSocket -
 216 #
 217 #       Close a socket and remove it from the persistent sockets table.
 218 #       If possible an http token is included here but when we are called
 219 #       from a fileevent on remote closure we need to find the correct
 220 #       entry - hence the second section.
 221
 222 proc ::http::CloseSocket {s {token {}}} {
 223     variable socketmap
 224     catch {fileevent $s readable {}}
 225     set conn_id {}
 226     if {$token ne ""} {
 227         variable $token
 228         upvar 0 $token state
 229         if {[info exists state(socketinfo)]} {
 230             set conn_id $state(socketinfo)
 231         }
 232     } else {
 233         set map [array get socketmap]
 234         set ndx [lsearch -exact $map $s]
 235         if {$ndx != -1} {
 236             incr ndx -1
 237             set conn_id [lindex $map $ndx]
 238         }
 239     }
 240     if {$conn_id eq {} || ![info exists socketmap($conn_id)]} {
 241         Log "Closing socket $s (no connection info)"
 242         if {[catch {close $s} err]} { Log "Error: $err" }
 243     } else {
 244         if {[info exists socketmap($conn_id)]} {
 245             Log "Closing connection $conn_id (sock $socketmap($conn_id))"
 246             if {[catch {close $socketmap($conn_id)} err]} { Log "Error: $err" }
 247             unset socketmap($conn_id)
 248         } else {
 249             Log "Cannot close connection $conn_id - no socket in socket map"
 250         }
 251     }
 252 }
 253
 254 # http::reset --
 255 #
 256 #       See documentation for details.
 257 #
 258 # Arguments:
 259 #       token   Connection token.
 260 #       why     Status info.
 261 #
 262 # Side Effects:
 263 #       See Finish
 264
 265 proc http::reset { token {why reset} } {
 266     variable $token
 267     upvar 0 $token state
 268     set state(status) $why
 269     catch {fileevent $state(sock) readable {}}
 270     catch {fileevent $state(sock) writable {}}
 271     Finish $token
 272     if {[info exists state(error)]} {
 273         set errorlist $state(error)
 274         unset state
 275         eval ::error $errorlist
 276     }
 277 }
 278
 279 # http::geturl --
 280 #
 281 #       Establishes a connection to a remote url via http.
 282 #
 283 # Arguments:
 284 #       url             The http URL to goget.
 285 #       args            Option value pairs. Valid options include:
 286 #                               -blocksize, -validate, -headers, -timeout
 287 # Results:
 288 #       Returns a token for this connection. This token is the name of an array
 289 #       that the caller should unset to garbage collect the state.
 290
 291 proc http::geturl { url args } {
 292     variable http
 293     variable urlTypes
 294     variable defaultCharset
 295     variable defaultKeepalive
 296     variable strict
 297
 298     # Initialize the state variable, an array. We'll return the name of this
 299     # array as the token for the transaction.
 300
 301     if {![info exists http(uid)]} {
 302         set http(uid) 0
 303     }
 304     set token [namespace current]::[incr http(uid)]
 305     variable $token
 306     upvar 0 $token state
 307     reset $token
 308
 309     # Process command options.
 310
 311     array set state {
 312         -binary         false
 313         -blocksize      8192
 314         -queryblocksize 8192
 315         -validate       0
 316         -headers        {}
 317         -timeout        0
 318         -type           application/x-www-form-urlencoded
 319         -queryprogress  {}
 320         -protocol       1.1
 321         binary          0
 322         state           header
 323         meta            {}
 324         coding          {}
 325         currentsize     0
 326         totalsize       0
 327         querylength     0
 328         queryoffset     0
 329         type            text/html
 330         body            {}
 331         status          ""
 332         http            ""
 333         connection      close
 334     }
 335     set state(-keepalive) $defaultKeepalive
 336     set state(-strict) $strict
 337     # These flags have their types verified [Bug 811170]
 338     array set type {
 339         -binary         boolean
 340         -blocksize      integer
 341         -queryblocksize integer
 342         -strict         boolean
 343         -timeout        integer
 344         -validate       boolean
 345     }
 346     set state(charset)  $defaultCharset
 347     set options {
 348         -binary -blocksize -channel -command -handler -headers -keepalive
 349         -method -myaddr -progress -protocol -query -queryblocksize
 350         -querychannel -queryprogress -strict -timeout -type -validate
 351     }
 352     set usage [join [lsort $options] ", "]
 353     set options [string map {- ""} $options]
 354     set pat ^-([join $options |])$
 355     foreach {flag value} $args {
 356         if {[regexp -- $pat $flag]} {
 357             # Validate numbers
 358             if {[info exists type($flag)] &&
 359                 ![string is $type($flag) -strict $value]} {
 360                 unset $token
 361                 return -code error "Bad value for $flag ($value), must be $type($flag)"
 362             }
 363             set state($flag) $value
 364         } else {
 365             unset $token
 366             return -code error "Unknown option $flag, can be: $usage"
 367         }
 368     }
 369
 370     # Make sure -query and -querychannel aren't both specified
 371
 372     set isQueryChannel [info exists state(-querychannel)]
 373     set isQuery [info exists state(-query)]
 374     if {$isQuery && $isQueryChannel} {
 375         unset $token
 376         return -code error "Can't combine -query and -querychannel options!"
 377     }
 378
 379     # Validate URL, determine the server host and port, and check proxy case
 380     # Recognize user:pass@host URLs also, although we do not do anything with
 381     # that info yet.
 382
 383     # URLs have basically four parts.
 384     # First, before the colon, is the protocol scheme (e.g. http)
 385     # Second, for HTTP-like protocols, is the authority
 386     #   The authority is preceded by // and lasts up to (but not including)
 387     #   the following / and it identifies up to four parts, of which only one,
 388     #   the host, is required (if an authority is present at all). All other
 389     #   parts of the authority (user name, password, port number) are optional.
 390     # Third is the resource name, which is split into two parts at a ?
 391     #   The first part (from the single "/" up to "?") is the path, and the
 392     #   second part (from that "?" up to "#") is the query. *HOWEVER*, we do
 393     #   not need to separate them; we send the whole lot to the server.
 394     # Fourth is the fragment identifier, which is everything after the first
 395     #   "#" in the URL. The fragment identifier MUST NOT be sent to the server
 396     #   and indeed, we don't bother to validate it (it could be an error to
 397     #   pass it in here, but it's cheap to strip).
 398     #
 399     # An example of a URL that has all the parts:
 400     #   http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes
 401     # The "http" is the protocol, the user is "jschmoe", the password is
 402     # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is
 403     # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes".
 404     #
 405     # Note that the RE actually combines the user and password parts, as
 406     # recommended in RFC 3986. Indeed, that RFC states that putting passwords
 407     # in URLs is a Really Bad Idea, something with which I would agree utterly.
 408     # Also note that we do not currently support IPv6 addresses.
 409     #
 410     # From a validation perspective, we need to ensure that the parts of the
 411     # URL that are going to the server are correctly encoded.
 412     # This is only done if $state(-strict) is true (inherited from
 413     # $::http::strict).
 414
 415     set URLmatcher {(?x)                # this is _expanded_ syntax
 416         ^
 417         (?: (\w+) : ) ?                 # <protocol scheme>
 418         (?: //
 419             (?:
 420                 (
 421                     [^@/\#?]+           # <userinfo part of authority>
 422                 ) @
 423             )?
 424             ( [^/:\#?]+ )               # <host part of authority>
 425             (?: : (\d+) )?              # <port part of authority>
 426         )?
 427         ( / [^\#?]* (?: \? [^\#?]* )?)? # <path> (including query)
 428         (?: \# (.*) )?                  # <fragment>
 429         $
 430     }
 431
 432     # Phase one: parse
 433     if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
 434         unset $token
 435         return -code error "Unsupported URL: $url"
 436     }
 437     # Phase two: validate
 438     if {$host eq ""} {
 439         # Caller has to provide a host name; we do not have a "default host"
 440         # that would enable us to handle relative URLs.
 441         unset $token
 442         return -code error "Missing host part: $url"
 443         # Note that we don't check the hostname for validity here; if it's
 444         # invalid, we'll simply fail to resolve it later on.
 445     }
 446     if {$port ne "" && $port > 65535} {
 447         unset $token
 448         return -code error "Invalid port number: $port"
 449     }
 450     # The user identification and resource identification parts of the URL can
 451     # have encoded characters in them; take care!
 452     if {$user ne ""} {
 453         # Check for validity according to RFC 3986, Appendix A
 454         set validityRE {(?xi)
 455             ^
 456             (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
 457             $
 458         }
 459         if {$state(-strict) && ![regexp -- $validityRE $user]} {
 460             unset $token
 461             # Provide a better error message in this error case
 462             if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
 463                 return -code error \
 464                         "Illegal encoding character usage \"$bad\" in URL user"
 465             }
 466             return -code error "Illegal characters in URL user"
 467         }
 468     }
 469     if {$srvurl ne ""} {
 470         # Check for validity according to RFC 3986, Appendix A
 471         set validityRE {(?xi)
 472             ^
 473             # Path part (already must start with / character)
 474             (?:       [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
 475             # Query part (optional, permits ? characters)
 476             (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
 477             $
 478         }
 479         if {$state(-strict) && ![regexp -- $validityRE $srvurl]} {
 480             unset $token
 481             # Provide a better error message in this error case
 482             if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
 483                 return -code error \
 484                         "Illegal encoding character usage \"$bad\" in URL path"
 485             }
 486             return -code error "Illegal characters in URL path"
 487         }
 488     } else {
 489         set srvurl /
 490     }
 491     if {$proto eq ""} {
 492         set proto http
 493     }
 494     if {![info exists urlTypes($proto)]} {
 495         unset $token
 496         return -code error "Unsupported URL type \"$proto\""
 497     }
 498     set defport [lindex $urlTypes($proto) 0]
 499     set defcmd [lindex $urlTypes($proto) 1]
 500
 501     if {$port eq ""} {
 502         set port $defport
 503     }
 504     if {![catch {$http(-proxyfilter) $host} proxy]} {
 505         set phost [lindex $proxy 0]
 506         set pport [lindex $proxy 1]
 507     }
 508
 509     # OK, now reassemble into a full URL
 510     set url ${proto}://
 511     if {$user ne ""} {
 512         append url $user
 513         append url @
 514     }
 515     append url $host
 516     if {$port != $defport} {
 517         append url : $port
 518     }
 519     append url $srvurl
 520     # Don't append the fragment!
 521     set state(url) $url
 522
 523     # If a timeout is specified we set up the after event and arrange for an
 524     # asynchronous socket connection.
 525
 526     set sockopts [list]
 527     if {$state(-timeout) > 0} {
 528         set state(after) [after $state(-timeout) \
 529                 [list http::reset $token timeout]]
 530         lappend sockopts -async
 531     }
 532
 533     # If we are using the proxy, we must pass in the full URL that includes
 534     # the server name.
 535
 536     if {[info exists phost] && ($phost ne "")} {
 537         set srvurl $url
 538         set targetAddr [list $phost $pport]
 539     } else {
 540         set targetAddr [list $host $port]
 541     }
 542     # Proxy connections aren't shared among different hosts.
 543     set state(socketinfo) $host:$port
 544
 545     # See if we are supposed to use a previously opened channel.
 546     if {$state(-keepalive)} {
 547         variable socketmap
 548         if {[info exists socketmap($state(socketinfo))]} {
 549             if {[catch {fconfigure $socketmap($state(socketinfo))}]} {
 550                 Log "WARNING: socket for $state(socketinfo) was closed"
 551                 unset socketmap($state(socketinfo))
 552             } else {
 553                 set sock $socketmap($state(socketinfo))
 554                 Log "reusing socket $sock for $state(socketinfo)"
 555                 catch {fileevent $sock writable {}}
 556                 catch {fileevent $sock readable {}}
 557             }
 558         }
 559         # don't automatically close this connection socket
 560         set state(connection) {}
 561     }
 562     if {![info exists sock]} {
 563         # Pass -myaddr directly to the socket command
 564         if {[info exists state(-myaddr)]} {
 565             lappend sockopts -myaddr $state(-myaddr)
 566         }
 567         if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
 568             # something went wrong while trying to establish the
 569             # connection. Clean up after events and such, but DON'T call the
 570             # command callback (if available) because we're going to throw an
 571             # exception from here instead.
 572
 573             set state(sock) $sock
 574             Finish $token "" 1
 575             cleanup $token
 576             return -code error $sock
 577         }
 578     }
 579     set state(sock) $sock
 580     Log "Using $sock for $state(socketinfo)" \
 581         [expr {$state(-keepalive)?"keepalive":""}]
 582     if {$state(-keepalive)} {
 583         set socketmap($state(socketinfo)) $sock
 584     }
 585
 586     # Wait for the connection to complete.
 587
 588     if {$state(-timeout) > 0} {
 589         fileevent $sock writable [list http::Connect $token]
 590         http::wait $token
 591
 592         if {![info exists state]} {
 593             # If we timed out then Finish has been called and the users
 594             # command callback may have cleaned up the token. If so
 595             # we end up here with nothing left to do.
 596             return $token
 597         } elseif {$state(status) eq "error"} {
 598             # Something went wrong while trying to establish the connection.
 599             # Clean up after events and such, but DON'T call the command
 600             # callback (if available) because we're going to throw an
 601             # exception from here instead.
 602             set err [lindex $state(error) 0]
 603             cleanup $token
 604             return -code error $err
 605         } elseif {$state(status) ne "connect"} {
 606             # Likely to be connection timeout
 607             return $token
 608         }
 609         set state(status) ""
 610     }
 611
 612     # Send data in cr-lf format, but accept any line terminators
 613
 614     fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
 615
 616     # The following is disallowed in safe interpreters, but the socket is
 617     # already in non-blocking mode in that case.
 618
 619     catch {fconfigure $sock -blocking off}
 620     set how GET
 621     if {$isQuery} {
 622         set state(querylength) [string length $state(-query)]
 623         if {$state(querylength) > 0} {
 624             set how POST
 625             set contDone 0
 626         } else {
 627             # There's no query data.
 628             unset state(-query)
 629             set isQuery 0
 630         }
 631     } elseif {$state(-validate)} {
 632         set how HEAD
 633     } elseif {$isQueryChannel} {
 634         set how POST
 635         # The query channel must be blocking for the async Write to
 636         # work properly.
 637         fconfigure $state(-querychannel) -blocking 1 -translation binary
 638         set contDone 0
 639     }
 640     if {[info exists state(-method)] && $state(-method) ne ""} {
 641         set how $state(-method)
 642     }
 643
 644     if {[catch {
 645         puts $sock "$how $srvurl HTTP/$state(-protocol)"
 646         puts $sock "Accept: $http(-accept)"
 647         array set hdrs $state(-headers)
 648         if {[info exists hdrs(Host)]} {
 649             # Allow Host spoofing [Bug 928154]
 650             puts $sock "Host: $hdrs(Host)"
 651         } elseif {$port == $defport} {
 652             # Don't add port in this case, to handle broken servers.
 653             # [Bug #504508]
 654             puts $sock "Host: $host"
 655         } else {
 656             puts $sock "Host: $host:$port"
 657         }
 658         unset hdrs
 659         puts $sock "User-Agent: $http(-useragent)"
 660         if {$state(-protocol) == 1.0 && $state(-keepalive)} {
 661             puts $sock "Connection: keep-alive"
 662         }
 663         if {$state(-protocol) > 1.0 && !$state(-keepalive)} {
 664             puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
 665         }
 666         if {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
 667             puts $sock "Proxy-Connection: Keep-Alive"
 668         }
 669         set accept_encoding_seen 0
 670         foreach {key value} $state(-headers) {
 671             if {[string equal -nocase $key "host"]} { continue }
 672             if {[string equal -nocase $key "accept-encoding"]} {
 673                 set accept_encoding_seen 1
 674             }
 675             set value [string map [list \n "" \r ""] $value]
 676             set key [string trim $key]
 677             if {[string equal -nocase $key "content-length"]} {
 678                 set contDone 1
 679                 set state(querylength) $value
 680             }
 681             if {[string length $key]} {
 682                 puts $sock "$key: $value"
 683             }
 684         }
 685         # Soft zlib dependency check - no package require
 686         if {!$accept_encoding_seen && [llength [package provide zlib]]
 687             && !([info exists state(-channel)] || [info exists state(-handler)])
 688         } {
 689             puts $sock "Accept-Encoding: gzip, identity, *;q=0.1"
 690         }
 691         if {$isQueryChannel && $state(querylength) == 0} {
 692             # Try to determine size of data in channel. If we cannot seek, the
 693             # surrounding catch will trap us
 694
 695             set start [tell $state(-querychannel)]
 696             seek $state(-querychannel) 0 end
 697             set state(querylength) \
 698                     [expr {[tell $state(-querychannel)] - $start}]
 699             seek $state(-querychannel) $start
 700         }
 701
 702         # Flush the request header and set up the fileevent that will either
 703         # push the POST data or read the response.
 704         #
 705         # fileevent note:
 706         #
 707         # It is possible to have both the read and write fileevents active at
 708         # this point. The only scenario it seems to affect is a server that
 709         # closes the connection without reading the POST data. (e.g., early
 710         # versions TclHttpd in various error cases). Depending on the platform,
 711         # the client may or may not be able to get the response from the server
 712         # because of the error it will get trying to write the post data.
 713         # Having both fileevents active changes the timing and the behavior,
 714         # but no two platforms (among Solaris, Linux, and NT) behave the same,
 715         # and none behave all that well in any case. Servers should always read
 716         # their POST data if they expect the client to read their response.
 717
 718         if {$isQuery || $isQueryChannel} {
 719             puts $sock "Content-Type: $state(-type)"
 720             if {!$contDone} {
 721                 puts $sock "Content-Length: $state(querylength)"
 722             }
 723             puts $sock ""
 724             fconfigure $sock -translation {auto binary}
 725             fileevent $sock writable [list http::Write $token]
 726         } else {
 727             puts $sock ""
 728             flush $sock
 729             fileevent $sock readable [list http::Event $sock $token]
 730         }
 731
 732         if {! [info exists state(-command)]} {
 733             # geturl does EVERYTHING asynchronously, so if the user calls it
 734             # synchronously, we just do a wait here.
 735
 736             wait $token
 737             if {$state(status) eq "error"} {
 738                 # Something went wrong, so throw the exception, and the
 739                 # enclosing catch will do cleanup.
 740                 return -code error [lindex $state(error) 0]
 741             }
 742         }
 743     } err]} {
 744         # The socket probably was never connected, or the connection dropped
 745         # later.
 746
 747         # Clean up after events and such, but DON'T call the command callback
 748         # (if available) because we're going to throw an exception from here
 749         # instead.
 750
 751         # if state(status) is error, it means someone's already called Finish
 752         # to do the above-described clean up.
 753         if {$state(status) ne "error"} {
 754             Finish $token $err 1
 755         }
 756         cleanup $token
 757         return -code error $err
 758     }
 759
 760     return $token
 761 }
 762
 763 # Data access functions:
 764 # Data - the URL data
 765 # Status - the transaction status: ok, reset, eof, timeout
 766 # Code - the HTTP transaction code, e.g., 200
 767 # Size - the size of the URL data
 768
 769 proc http::data {token} {
 770     variable $token
 771     upvar 0 $token state
 772     return $state(body)
 773 }
 774 proc http::status {token} {
 775     if {![info exists $token]} { return "error" }
 776     variable $token
 777     upvar 0 $token state
 778     return $state(status)
 779 }
 780 proc http::code {token} {
 781     variable $token
 782     upvar 0 $token state
 783     return $state(http)
 784 }
 785 proc http::ncode {token} {
 786     variable $token
 787     upvar 0 $token state
 788     if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
 789         return $numeric_code
 790     } else {
 791         return $state(http)
 792     }
 793 }
 794 proc http::size {token} {
 795     variable $token
 796     upvar 0 $token state
 797     return $state(currentsize)
 798 }
 799 proc http::meta {token} {
 800     variable $token
 801     upvar 0 $token state
 802     return $state(meta)
 803 }
 804 proc http::error {token} {
 805     variable $token
 806     upvar 0 $token state
 807     if {[info exists state(error)]} {
 808         return $state(error)
 809     }
 810     return ""
 811 }
 812
 813 # http::cleanup
 814 #
 815 #       Garbage collect the state associated with a transaction
 816 #
 817 # Arguments
 818 #       token   The token returned from http::geturl
 819 #
 820 # Side Effects
 821 #       unsets the state array
 822
 823 proc http::cleanup {token} {
 824     variable $token
 825     upvar 0 $token state
 826     if {[info exists state]} {
 827         unset state
 828     }
 829 }
 830
 831 # http::Connect
 832 #
 833 #       This callback is made when an asyncronous connection completes.
 834 #
 835 # Arguments
 836 #       token   The token returned from http::geturl
 837 #
 838 # Side Effects
 839 #       Sets the status of the connection, which unblocks
 840 #       the waiting geturl call
 841
 842 proc http::Connect {token} {
 843     variable $token
 844     upvar 0 $token state
 845     global errorInfo errorCode
 846     if {[eof $state(sock)] ||
 847         [string length [fconfigure $state(sock) -error]]} {
 848             Finish $token "connect failed [fconfigure $state(sock) -error]" 1
 849     } else {
 850         set state(status) connect
 851         fileevent $state(sock) writable {}
 852     }
 853     return
 854 }
 855
 856 # http::Write
 857 #
 858 #       Write POST query data to the socket
 859 #
 860 # Arguments
 861 #       token   The token for the connection
 862 #
 863 # Side Effects
 864 #       Write the socket and handle callbacks.
 865
 866 proc http::Write {token} {
 867     variable $token
 868     upvar 0 $token state
 869     set sock $state(sock)
 870
 871     # Output a block.  Tcl will buffer this if the socket blocks
 872     set done 0
 873     if {[catch {
 874         # Catch I/O errors on dead sockets
 875
 876         if {[info exists state(-query)]} {
 877             # Chop up large query strings so queryprogress callback can give
 878             # smooth feedback.
 879
 880             puts -nonewline $sock \
 881                 [string range $state(-query) $state(queryoffset) \
 882                      [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
 883             incr state(queryoffset) $state(-queryblocksize)
 884             if {$state(queryoffset) >= $state(querylength)} {
 885                 set state(queryoffset) $state(querylength)
 886                 puts $sock ""
 887                 set done 1
 888             }
 889         } else {
 890             # Copy blocks from the query channel
 891
 892             set outStr [read $state(-querychannel) $state(-queryblocksize)]
 893             puts -nonewline $sock $outStr
 894             incr state(queryoffset) [string length $outStr]
 895             if {[eof $state(-querychannel)]} {
 896                 set done 1
 897             }
 898         }
 899     } err]} {
 900         # Do not call Finish here, but instead let the read half of the socket
 901         # process whatever server reply there is to get.
 902
 903         set state(posterror) $err
 904         set done 1
 905     }
 906     if {$done} {
 907         catch {flush $sock}
 908         fileevent $sock writable {}
 909         fileevent $sock readable [list http::Event $sock $token]
 910     }
 911
 912     # Callback to the client after we've completely handled everything.
 913
 914     if {[string length $state(-queryprogress)]} {
 915         eval $state(-queryprogress) \
 916             [list $token $state(querylength) $state(queryoffset)]
 917     }
 918 }
 919
 920 # http::Event
 921 #
 922 #       Handle input on the socket
 923 #
 924 # Arguments
 925 #       sock    The socket receiving input.
 926 #       token   The token returned from http::geturl
 927 #
 928 # Side Effects
 929 #       Read the socket and handle callbacks.
 930
 931 proc http::Event {sock token} {
 932     variable $token
 933     upvar 0 $token state
 934
 935     if {![info exists state]} {
 936         Log "Event $sock with invalid token '$token' - remote close?"
 937         if {! [eof $sock]} {
 938             if {[string length [set d [read $sock]]] != 0} {
 939                 Log "WARNING: additional data left on closed socket"
 940             }
 941         }
 942         CloseSocket $sock
 943         return
 944     }
 945     if {$state(state) eq "header"} {
 946         if {[catch {gets $sock line} n]} {
 947             return [Finish $token $n]
 948         } elseif {$n == 0} {
 949             # We have now read all headers
 950             # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
 951             if {$state(http) == "" || [lindex $state(http) 1] == 100} { return }
 952
 953             set state(state) body
 954
 955             # If doing a HEAD, then we won't get any body
 956             if {$state(-validate)} {
 957                 Eof $token
 958                 return
 959             }
 960
 961             # For non-chunked transfer we may have no body -- in this case we
 962             # may get no further file event if the connection doesn't close and
 963             # no more data is sent. We can tell and must finish up now - not
 964             # later.
 965             if {!(([info exists state(connection)]
 966                    && ($state(connection) eq "close"))
 967                   || [info exists state(transfer)])
 968                 &&  $state(totalsize) == 0
 969             } then {
 970                 Log "body size is 0 and no events likely - complete."
 971                 Eof $token
 972                 return
 973             }
 974
 975             # We have to use binary translation to count bytes properly.
 976             fconfigure $sock -translation binary
 977
 978             if {$state(-binary) || ![string match -nocase text* $state(type)]} {
 979                 # Turn off conversions for non-text data
 980                 set state(binary) 1
 981             }
 982             if {$state(binary) || [string match *gzip* $state(coding)]
 983                 || [string match *compress* $state(coding)]} {
 984                 if {[info exists state(-channel)]} {
 985                     fconfigure $state(-channel) -translation binary
 986                 }
 987             }
 988             if {[info exists state(-channel)] &&
 989                 ![info exists state(-handler)]} {
 990                 # Initiate a sequence of background fcopies
 991                 fileevent $sock readable {}
 992                 CopyStart $sock $token
 993                 return
 994             }
 995         } elseif {$n > 0} {
 996             # Process header lines
 997             if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 998                 switch -- [string tolower $key] {
 999                     content-type {
1000                         set state(type) [string trim [string tolower $value]]
1001                         # grab the optional charset information
1002                         regexp -nocase {charset\s*=\s*(\S+?);?} \
1003                             $state(type) -> state(charset)
1004                     }
1005                     content-length {
1006                         set state(totalsize) [string trim $value]
1007                     }
1008                     content-encoding {
1009                         set state(coding) [string trim $value]
1010                     }
1011                     transfer-encoding {
1012                         set state(transfer) \
1013                             [string trim [string tolower $value]]
1014                     }
1015                     proxy-connection -
1016                     connection {
1017                         set state(connection) \
1018                             [string trim [string tolower $value]]
1019                     }
1020                 }
1021                 lappend state(meta) $key [string trim $value]
1022             } elseif {[string match HTTP* $line]} {
1023                 set state(http) $line
1024             }
1025         }
1026     } else {
1027         # Now reading body
1028         if {[catch {
1029             if {[info exists state(-handler)]} {
1030                 set n [eval $state(-handler) [list $sock $token]]
1031             } elseif {[info exists state(transfer_final)]} {
1032                 set line [getTextLine $sock]
1033                 set n [string length $line]
1034                 if {$n > 0} {
1035                     Log "found $n bytes following final chunk"
1036                     append state(transfer_final) $line
1037                 } else {
1038                     Log "final chunk part"
1039                     Eof $token
1040                 }
1041             } elseif {[info exists state(transfer)]
1042                       && $state(transfer) eq "chunked"} {
1043                 set size 0
1044                 set chunk [getTextLine $sock]
1045                 set n [string length $chunk]
1046                 if {[string trim $chunk] ne ""} {
1047                     scan $chunk %x size
1048                     if {$size != 0} {
1049                         set bl [fconfigure $sock -blocking]
1050                         fconfigure $sock -blocking 1
1051                         set chunk [read $sock $size]
1052                         fconfigure $sock -blocking $bl
1053                         set n [string length $chunk]
1054                         if {$n >= 0} {
1055                             append state(body) $chunk
1056                         }
1057                         if {$size != [string length $chunk]} {
1058                             Log "WARNING: mis-sized chunk:\
1059                                 was [string length $chunk], should be $size"
1060                         }
1061                         getTextLine $sock
1062                     } else {
1063                         set state(transfer_final) {}
1064                     }
1065                 }
1066             } else {
1067                 #Log "read non-chunk $state(currentsize) of $state(totalsize)"
1068                 set block [read $sock $state(-blocksize)]
1069                 set n [string length $block]
1070                 if {$n >= 0} {
1071                     append state(body) $block
1072                 }
1073             }
1074             if {[info exists state]} {
1075                 if {$n >= 0} {
1076                     incr state(currentsize) $n
1077                 }
1078                 # If Content-Length - check for end of data.
1079                 if {($state(totalsize) > 0)
1080                     && ($state(currentsize) >= $state(totalsize))} {
1081                     Eof $token
1082                 }
1083             }
1084         } err]} {
1085             return [Finish $token $err]
1086         } else {
1087             if {[info exists state(-progress)]} {
1088                 eval $state(-progress) \
1089                     [list $token $state(totalsize) $state(currentsize)]
1090             }
1091         }
1092     }
1093
1094     # catch as an Eof above may have closed the socket already
1095     if {![catch {eof $sock} eof] && $eof} {
1096         if {[info exists $token]} {
1097             set state(connection) close
1098             Eof $token
1099         } else {
1100             # open connection closed on a token that has been cleaned up.
1101             CloseSocket $sock
1102         }
1103         return
1104     }
1105 }
1106
1107 # http::getTextLine --
1108 #
1109 #       Get one line with the stream in blocking crlf mode
1110 #
1111 # Arguments
1112 #       sock    The socket receiving input.
1113 #
1114 # Results:
1115 #       The line of text, without trailing newline
1116
1117 proc http::getTextLine {sock} {
1118     set tr [fconfigure $sock -translation]
1119     set bl [fconfigure $sock -blocking]
1120     fconfigure $sock -translation crlf -blocking 1
1121     set r [gets $sock]
1122     fconfigure $sock -translation $tr -blocking $bl
1123     return $r
1124 }
1125
1126 # http::CopyStart
1127 #
1128 #       Error handling wrapper around fcopy
1129 #
1130 # Arguments
1131 #       sock    The socket to copy from
1132 #       token   The token returned from http::geturl
1133 #
1134 # Side Effects
1135 #       This closes the connection upon error
1136
1137 proc http::CopyStart {sock token} {
1138     variable $token
1139     upvar 0 $token state
1140     if {[catch {
1141         fcopy $sock $state(-channel) -size $state(-blocksize) -command \
1142             [list http::CopyDone $token]
1143     } err]} {
1144         Finish $token $err
1145     }
1146 }
1147
1148 # http::CopyDone
1149 #
1150 #       fcopy completion callback
1151 #
1152 # Arguments
1153 #       token   The token returned from http::geturl
1154 #       count   The amount transfered
1155 #
1156 # Side Effects
1157 #       Invokes callbacks
1158
1159 proc http::CopyDone {token count {error {}}} {
1160     variable $token
1161     upvar 0 $token state
1162     set sock $state(sock)
1163     incr state(currentsize) $count
1164     if {[info exists state(-progress)]} {
1165         eval $state(-progress) \
1166             [list $token $state(totalsize) $state(currentsize)]
1167     }
1168     # At this point the token may have been reset
1169     if {[string length $error]} {
1170         Finish $token $error
1171     } elseif {[catch {eof $sock} iseof] || $iseof} {
1172         Eof $token
1173     } else {
1174         CopyStart $sock $token
1175     }
1176 }
1177
1178 # http::Eof
1179 #
1180 #       Handle eof on the socket
1181 #
1182 # Arguments
1183 #       token   The token returned from http::geturl
1184 #
1185 # Side Effects
1186 #       Clean up the socket
1187
1188 proc http::Eof {token {force 0}} {
1189     variable $token
1190     upvar 0 $token state
1191     if {$state(state) eq "header"} {
1192         # Premature eof
1193         set state(status) eof
1194     } else {
1195         set state(status) ok
1196     }
1197
1198     if {($state(coding) eq "gzip") && [string length $state(body)] > 0} {
1199         if {[catch {
1200             set state(body) [Gunzip $state(body)]
1201         } err]} {
1202             return [Finish $token $err]
1203         }
1204     }
1205
1206     if {!$state(binary)} {
1207
1208         # If we are getting text, set the incoming channel's
1209         # encoding correctly.  iso8859-1 is the RFC default, but
1210         # this could be any IANA charset.  However, we only know
1211         # how to convert what we have encodings for.
1212
1213         set enc [CharsetToEncoding $state(charset)]
1214         if {$enc ne "binary"} {
1215             set state(body) [encoding convertfrom $enc $state(body)]
1216         }
1217
1218         # Translate text line endings.
1219         set state(body) [string map {\r\n \n \r \n} $state(body)]
1220     }
1221
1222     Finish $token
1223 }
1224
1225 # http::wait --
1226 #
1227 #       See documentation for details.
1228 #
1229 # Arguments:
1230 #       token   Connection token.
1231 #
1232 # Results:
1233 #        The status after the wait.
1234
1235 proc http::wait {token} {
1236     variable $token
1237     upvar 0 $token state
1238
1239     if {![info exists state(status)] || $state(status) eq ""} {
1240         # We must wait on the original variable name, not the upvar alias
1241         vwait ${token}(status)
1242     }
1243
1244     return [status $token]
1245 }
1246
1247 # http::formatQuery --
1248 #
1249 #       See documentation for details.  Call http::formatQuery with an even
1250 #       number of arguments, where the first is a name, the second is a value,
1251 #       the third is another name, and so on.
1252 #
1253 # Arguments:
1254 #       args    A list of name-value pairs.
1255 #
1256 # Results:
1257 #       TODO
1258
1259 proc http::formatQuery {args} {
1260     set result ""
1261     set sep ""
1262     foreach i $args {
1263         append result $sep [mapReply $i]
1264         if {$sep eq "="} {
1265             set sep &
1266         } else {
1267             set sep =
1268         }
1269     }
1270     return $result
1271 }
1272
1273 # http::mapReply --
1274 #
1275 #       Do x-www-urlencoded character mapping
1276 #
1277 # Arguments:
1278 #       string  The string the needs to be encoded
1279 #
1280 # Results:
1281 #       The encoded string
1282
1283 proc http::mapReply {string} {
1284     variable http
1285     variable formMap
1286
1287     # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use
1288     # a pre-computed map and [string map] to do the conversion (much faster
1289     # than [regsub]/[subst]). [Bug 1020491]
1290
1291     if {$http(-urlencoding) ne ""} {
1292         set string [encoding convertto $http(-urlencoding) $string]
1293         return [string map $formMap $string]
1294     }
1295     set converted [string map $formMap $string]
1296     if {[string match "*\[\u0100-\uffff\]*" $converted]} {
1297         regexp {[\u0100-\uffff]} $converted badChar
1298         # Return this error message for maximum compatability... :^/
1299         return -code error \
1300             "can't read \"formMap($badChar)\": no such element in array"
1301     }
1302     return $converted
1303 }
1304
1305 # http::ProxyRequired --
1306 #       Default proxy filter.
1307 #
1308 # Arguments:
1309 #       host    The destination host
1310 #
1311 # Results:
1312 #       The current proxy settings
1313
1314 proc http::ProxyRequired {host} {
1315     variable http
1316     if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
1317         if {![info exists http(-proxyport)] || \
1318                 ![string length $http(-proxyport)]} {
1319             set http(-proxyport) 8080
1320         }
1321         return [list $http(-proxyhost) $http(-proxyport)]
1322     }
1323 }
1324
1325 # http::CharsetToEncoding --
1326 #
1327 #       Tries to map a given IANA charset to a tcl encoding.
1328 #       If no encoding can be found, returns binary.
1329 #
1330
1331 proc http::CharsetToEncoding {charset} {
1332     variable encodings
1333
1334     set charset [string tolower $charset]
1335     if {[regexp {iso-?8859-([0-9]+)} $charset - num]} {
1336         set encoding "iso8859-$num"
1337     } elseif {[regexp {iso-?2022-(jp|kr)} $charset - ext]} {
1338         set encoding "iso2022-$ext"
1339     } elseif {[regexp {shift[-_]?js} $charset -]} {
1340         set encoding "shiftjis"
1341     } elseif {[regexp {(windows|cp)-?([0-9]+)} $charset - - num]} {
1342         set encoding "cp$num"
1343     } elseif {$charset eq "us-ascii"} {
1344         set encoding "ascii"
1345     } elseif {[regexp {(iso-?)?lat(in)?-?([0-9]+)} $charset - - - num]} {
1346         switch -- $num {
1347             5 {set encoding "iso8859-9"}
1348             1 -
1349             2 -
1350             3 {set encoding "iso8859-$num"}
1351         }
1352     } else {
1353         # other charset, like euc-xx, utf-8,...  may directly maps to encoding
1354         set encoding $charset
1355     }
1356     set idx [lsearch -exact $encodings $encoding]
1357     if {$idx >= 0} {
1358         return $encoding
1359     } else {
1360         return "binary"
1361     }
1362 }
1363
1364 # http::Gunzip --
1365 #
1366 #       Decompress data transmitted using the gzip transfer coding.
1367 #
1368
1369 # FIX ME: redo using zlib sinflate
1370 proc http::Gunzip {data} {
1371     binary scan $data Scb5icc magic method flags time xfl os
1372     set pos 10
1373     if {$magic != 0x1f8b} {
1374         return -code error "invalid data: supplied data is not in gzip format"
1375     }
1376     if {$method != 8} {
1377         return -code error "invalid compression method"
1378     }
1379
1380     foreach {f_text f_crc f_extra f_name f_comment} [split $flags ""] break
1381     set extra ""
1382     if { $f_extra } {
1383         binary scan $data @${pos}S xlen
1384         incr pos 2
1385         set extra [string range $data $pos $xlen]
1386         set pos [incr xlen]
1387     }
1388
1389     set name ""
1390     if { $f_name } {
1391         set ndx [string first \0 $data $pos]
1392         set name [string range $data $pos $ndx]
1393         set pos [incr ndx]
1394     }
1395
1396     set comment ""
1397     if { $f_comment } {
1398         set ndx [string first \0 $data $pos]
1399         set comment [string range $data $pos $ndx]
1400         set pos [incr ndx]
1401     }
1402
1403     set fcrc ""
1404     if { $f_crc } {
1405         set fcrc [string range $data $pos [incr pos]]
1406         incr pos
1407     }
1408
1409     binary scan [string range $data end-7 end] ii crc size
1410     set inflated [zlib inflate [string range $data $pos end-8]]
1411     set chk [zlib crc32 $inflated]
1412     if { ($crc & 0xffffffff) != ($chk & 0xffffffff)} {
1413         return -code error "invalid data: checksum mismatch $crc != $chk"
1414     }
1415     return $inflated
1416 }
1417
1418 # Local variables:
1419 # indent-tabs-mode: t
1420 # End: