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