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