From 442e6551351a2b2547562fcb091d24518900f248 Mon Sep 17 00:00:00 2001 From: sandeep Date: Sun, 19 Mar 2000 22:32:25 +0000 Subject: * library/http2.1/http.tcl: Added -querychannel option and altered some of Brent's modifications to allow asynchronous posts (via -command). Also modified -queryprogress so that it calls the query callback as to be consistent with -progress. Added -queryblocksize option with default 8192 bytes for post blocksize. Fixed a bunch of potential memory leaks for the case when geturl receives bad args or can't open a socket, etc. Overall, the package really rocks now. * doc/http.n: Added -queryblocksize, -querychannel, and -queryprogress. Also, changed the description of -blocksize, which states that the -progress callback will be called for each block, to now qualify that with an "if -progress is specified". * tests/http.test: Added a querychannel test for synchronous and asynchronous posts, altered the queryprogress test such that the callback conforms to the -progress format. Also, had to use the -queryblocksize option to do the post 16K at a time to match Brent's expected results (and to test that -queryblocksize works). --- ChangeLog | 23 +++++++ doc/http.n | 26 +++++++- library/http/http.tcl | 164 ++++++++++++++++++++++++++++------------------- library/http2.1/http.tcl | 164 ++++++++++++++++++++++++++++------------------- library/http2.3/http.tcl | 164 ++++++++++++++++++++++++++++------------------- tests/http.test | 42 ++++++++++-- 6 files changed, 379 insertions(+), 204 deletions(-) diff --git a/ChangeLog b/ChangeLog index 940c264..3924baa 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,26 @@ +2000-03-19 Sandeep Tamhankar + + * library/http2.1/http.tcl: Added -querychannel option and altered + some of Brent's modifications to allow asynchronous posts (via + -command). Also modified -queryprogress so that it calls the + query callback as + to be consistent with -progress. Added -queryblocksize option + with default 8192 bytes for post blocksize. Fixed a bunch of + potential memory leaks for the case when geturl receives bad args + or can't open a socket, etc. Overall, the package really rocks + now. + + * doc/http.n: Added -queryblocksize, -querychannel, and + -queryprogress. Also, changed the description of -blocksize, + which states that the -progress callback will be called for each + block, to now qualify that with an "if -progress is specified". + + * tests/http.test: Added a querychannel test for synchronous and + asynchronous posts, altered the queryprogress test such that the + callback conforms to the -progress format. Also, had to use the + -queryblocksize option to do the post 16K at a time to match + Brent's expected results (and to test that -queryblocksize works). + 2000-03-15 Brent Welch * library/http2.1/http.tcl: Added -queryprogress callback to diff --git a/doc/http.n b/doc/http.n index 3e750d9..485c8a9 100644 --- a/doc/http.n +++ b/doc/http.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: http.n,v 1.8 1999/11/19 23:10:17 hobbs Exp $ +'\" RCS: @(#) $Id: http.n,v 1.9 2000/03/19 22:32:25 sandeep Exp $ '\" .so man.macros .TH "Http" n 8.3 Tcl "Tcl Built-In Commands" @@ -129,7 +129,7 @@ At most \fIsize\fR bytes are read at once. After each block, a call to the \fB\-progress\fR -callback is made. +callback is made (if that option is specified). .TP \fB\-channel\fP \fIname\fP Copy the URL contents to channel \fIname\fR instead of saving it in @@ -205,6 +205,28 @@ This flag causes \fB::http::geturl\fR to do a POST request that passes the formatted query. The \fB::http::formatQuery\fR procedure can be used to do the formatting. .TP +\fB\-queryblocksize\fP \fIsize\fP +The blocksize used when posting query data to the URL. +At most +\fIsize\fR +bytes are written at once. After each block, a call to the +\fB\-queryprogress\fR +callback is made (if that option is specified). +.TP +\fB\-querychannel\fP \fIchannelID\fP +This flag causes \fB::http::geturl\fR to do a POST request that passes the +data contained in \fIchannelID\fR to the server. The data contained in \fIchannelID\fR must be a x-url-encoding +formatted query unless the \fB\-type\fP option below is used. +If a Content-Length header is not specified via the \fB\-headers\fR options, +\fB::http::geturl\fR attempts to determine the size of the post data +in order to create that header. If it is +unable to determine the size, it returns an error. +.TP +\fB\-queryprogress\fP \fIcallback\fP +The \fIcallback\fR is made after each transfer of data to the URL +(i.e. POST) and acts exactly like the \fB\-progress\fR option (the +callback format is the same). +.TP \fB\-timeout\fP \fImilliseconds\fP If \fImilliseconds\fR is non-zero, then \fB::http::geturl\fR sets up a timeout to occur after the specified number of milliseconds. diff --git a/library/http/http.tcl b/library/http/http.tcl index 1460c85..b783dc7 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.22 2000/03/17 02:15:06 welch Exp $ +# RCS: @(#) $Id: http.tcl,v 1.23 2000/03/19 22:32:26 sandeep Exp $ package provide http 2.3 ;# This uses Tcl namespaces @@ -172,7 +172,6 @@ proc http::reset { token {why reset} } { variable $token upvar 0 $token state set state(status) $why - set state(querydone) $why catch {fileevent $state(sock) readable {}} catch {fileevent $state(sock) writable {}} Finish $token @@ -215,6 +214,7 @@ proc http::geturl { url args } { array set state { -blocksize 8192 + -queryblocksize 8192 -validate 0 -headers {} -timeout 0 @@ -229,7 +229,8 @@ proc http::geturl { url args } { status "" } set options {-blocksize -channel -command -handler -headers \ - -progress -query -queryprogress -validate -timeout -type} + -progress -query -queryblocksize -querychannel -queryprogress\ + -validate -timeout -type} set usage [join $options ", "] regsub -all -- - $options {} options set pat ^-([join $options |])$ @@ -239,15 +240,31 @@ proc http::geturl { url args } { if {[info exists state($flag)] && \ [string is integer -strict $state($flag)] && \ ![string is integer -strict $value]} { + unset $token return -code error "Bad value for $flag ($value), must be integer" } set state($flag) $value } else { + unset $token return -code error "Unknown option $flag, can be: $usage" } } + + # Make sure -query and -querychannel aren't both specified + if {[info exists state(-query)] && [info exists state(-querychannel)]} { + unset $token + return -code error "Can't combine -query and -querychannel options!" + } + + # Set a variable with whether or not we have a querychannel, because + # we need to do special logic later if it does exist, and we don't + # want to do a lot of [info exists...] + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ x prefix proto host y port srvurl]} { + unset $token error "Unsupported URL: $url" } if {[string length $proto] == 0} { @@ -255,6 +272,7 @@ proc http::geturl { url args } { set url ${proto}://$url } if {![info exists urlTypes($proto)]} { + unset $token return -code error "unsupported url type \"$proto\"" } set defport [lindex $urlTypes($proto) 0] @@ -291,9 +309,15 @@ proc http::geturl { url args } { if {[info exists phost] && [string length $phost]} { set srvurl $url - set s [eval $defcmd $async {$phost $pport}] + set conStat [catch {eval $defcmd $async {$phost $pport}} s] } else { - set s [eval $defcmd $async {$host $port}] + set conStat [catch {eval $defcmd $async {$host $port}} s] + } + if {$conStat} { + # something went wrong, so unset the state array and propagate the + # error to the caller + Finish $token $s + return $token } set state(sock) $s @@ -317,16 +341,28 @@ proc http::geturl { url args } { # is already in non-blocking mode in that case. catch {fconfigure $s -blocking off} - set len 0 set how GET - if {[info exists state(-query)]} { - set len [string length $state(-query)] - if {$len > 0} { + set state(querylength) 0 + if {$isQuery} { + set state(querylength) [string length $state(-query)] + if {$state(querylength) > 0} { set how POST + set contDone 0 + } else { + # there's no query data + unset state(-query) + set isQuery 0 } } elseif {$state(-validate)} { set how HEAD + } elseif {$isQueryChannel} { + set how POST + # The query channel must be blocking for the async Write to + # work properly. + fconfigure $state(-querychannel) -blocking 1 + set contDone 0 } + if {[catch { puts $s "$how $srvurl HTTP/1.0" puts $s "Accept: $http(-accept)" @@ -335,31 +371,37 @@ proc http::geturl { url args } { foreach {key value} $state(-headers) { regsub -all \[\n\r\] $value {} value set key [string trim $key] + if {[string equal $key "Content-Length"]} { + set contDone 1 + set state(querylength) $value + } if {[string length $key]} { puts $s "$key: $value" } } - if {$len > 0} { - puts $s "Content-Length: $len" + if {$isQueryChannel && $state(querylength)==0} { + # Try to determine size of data in channel + if {[catch {seek $state(-querychannel) 0 end}]} { + Finish $token "Unable to determine size of querychannel data" + return $token + } + set state(querylength) [tell $state(-querychannel)] + seek $state(-querychannel) 0 + } + + if {$isQuery || $isQueryChannel} { puts $s "Content-Type: $state(-type)" + if {!$contDone} { + puts $s "Content-Length: $state(querylength)" + } puts $s "" fconfigure $s -translation {auto binary} - - # If a timeout is specified or a queryprogress callback is specified - # we do the post in the background - - if {$state(-timeout) > 0 || [string length $state(-queryprogress)]} { - fileevent $s writable \ - [list http::Write $token $state(-query) $state(-queryprogress)] - WaitPost $token - } else { - puts -nonewline $s $state(-query) - } + fileevent $s writable [list http::Write $token] } else { puts $s "" + flush $s + fileevent $s readable [list http::Event $token] } - flush $s - fileevent $s readable [list http::Event $token] } err]} { # The socket probably was never connected, or the connection # dropped later. @@ -369,6 +411,8 @@ proc http::geturl { url args } { } if {! [info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. wait $token } return $token @@ -433,7 +477,8 @@ proc http::cleanup {token} { proc http::Connect {token} { variable $token upvar 0 $token state - if {[eof $state(sock)]} { + if {[eof $state(sock)] || \ + [string length [fconfigure $state(sock) -error]]} { set state(status) ioerror } else { set state(status) connect @@ -446,45 +491,55 @@ proc http::cleanup {token} { # # Arguments # token The token for the connection -# query The query data to write to the connection -# queryprogress The callback, if any, to make after each block # # Side Effects # Write the socket and handle callbacks. -proc http::Write {token query queryprogress} { +proc http::Write {token} { variable $token upvar 0 $token state set s $state(sock) + if {![info exist state(queryoffset)]} { set state(queryoffset) 0 - set state(querylength) [string length $query] } - set chunksize 16384 - # Output a block. Tcl will buffer this if the socket blocks - - if {$state(querylength) < $chunksize} { - set chunksize $state(querylength) - } + if {[catch { # Catch I/O errors on dead sockets - puts -nonewline $s [string range $query $state(queryoffset) \ - [incr state(queryoffset) $chunksize]] + if {[info exists state(-query)]} { + set outStr [string range $state(-query) $state(queryoffset) \ + [incr state(queryoffset) $state(-queryblocksize)]] + } else { + # querychannel + set outStr [read $state(-querychannel) $state(-queryblocksize)] + incr state(queryoffset) $state(-queryblocksize) + } + puts -nonewline $s $outStr - if {[string length $queryprogress]} { - eval $queryprogress [list $token $state(queryoffset) $state(querylength)] + if {$state(querylength)>0 && \ + $state(queryoffset) >= $state(querylength)} { + set state(queryoffset) $state(querylength) } - if {$state(queryoffset) >= $state(querylength)} { + if {[string length $state(-queryprogress)]} { + eval $state(-queryprogress) [list $token $state(querylength)\ + $state(queryoffset)] + } + + if {($state(querylength)>0 && \ + $state(queryoffset) >= $state(querylength)) || \ + ([info exists state(-querychannel)] && \ + [eof $state(-querychannel)])} { fileevent $s writable {} - set state(querydone) ok + flush $s + fileevent $s readable [list http::Event $token] } } err]} { - set state(querydone) $err fileevent $s writable {} + Finish $token $err } } @@ -662,30 +717,6 @@ proc http::wait {token} { return $state(status) } -# http::WaitPost -- -# -# Wait for the post data to be written out -# -# Arguments: -# token Connection token. -# -# Results: -# The status after the wait. - -proc http::WaitPost {token} { - variable $token - upvar 0 $token state - - # We must wait on the original variable name, not the upvar alias - vwait $token\(querydone) - if {[string compare $state(querydone) ok] != 0} { - # throw an error to unwind geturl - return -code error $state(querydone) - } else { - return $state(querydone) - } -} - # http::formatQuery -- # # See documentaion for details. @@ -695,6 +726,7 @@ proc http::WaitPost {token} { # # Arguments: # args A list of name-value pairs. +# # Results: # TODO diff --git a/library/http2.1/http.tcl b/library/http2.1/http.tcl index 1460c85..b783dc7 100644 --- a/library/http2.1/http.tcl +++ b/library/http2.1/http.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.22 2000/03/17 02:15:06 welch Exp $ +# RCS: @(#) $Id: http.tcl,v 1.23 2000/03/19 22:32:26 sandeep Exp $ package provide http 2.3 ;# This uses Tcl namespaces @@ -172,7 +172,6 @@ proc http::reset { token {why reset} } { variable $token upvar 0 $token state set state(status) $why - set state(querydone) $why catch {fileevent $state(sock) readable {}} catch {fileevent $state(sock) writable {}} Finish $token @@ -215,6 +214,7 @@ proc http::geturl { url args } { array set state { -blocksize 8192 + -queryblocksize 8192 -validate 0 -headers {} -timeout 0 @@ -229,7 +229,8 @@ proc http::geturl { url args } { status "" } set options {-blocksize -channel -command -handler -headers \ - -progress -query -queryprogress -validate -timeout -type} + -progress -query -queryblocksize -querychannel -queryprogress\ + -validate -timeout -type} set usage [join $options ", "] regsub -all -- - $options {} options set pat ^-([join $options |])$ @@ -239,15 +240,31 @@ proc http::geturl { url args } { if {[info exists state($flag)] && \ [string is integer -strict $state($flag)] && \ ![string is integer -strict $value]} { + unset $token return -code error "Bad value for $flag ($value), must be integer" } set state($flag) $value } else { + unset $token return -code error "Unknown option $flag, can be: $usage" } } + + # Make sure -query and -querychannel aren't both specified + if {[info exists state(-query)] && [info exists state(-querychannel)]} { + unset $token + return -code error "Can't combine -query and -querychannel options!" + } + + # Set a variable with whether or not we have a querychannel, because + # we need to do special logic later if it does exist, and we don't + # want to do a lot of [info exists...] + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ x prefix proto host y port srvurl]} { + unset $token error "Unsupported URL: $url" } if {[string length $proto] == 0} { @@ -255,6 +272,7 @@ proc http::geturl { url args } { set url ${proto}://$url } if {![info exists urlTypes($proto)]} { + unset $token return -code error "unsupported url type \"$proto\"" } set defport [lindex $urlTypes($proto) 0] @@ -291,9 +309,15 @@ proc http::geturl { url args } { if {[info exists phost] && [string length $phost]} { set srvurl $url - set s [eval $defcmd $async {$phost $pport}] + set conStat [catch {eval $defcmd $async {$phost $pport}} s] } else { - set s [eval $defcmd $async {$host $port}] + set conStat [catch {eval $defcmd $async {$host $port}} s] + } + if {$conStat} { + # something went wrong, so unset the state array and propagate the + # error to the caller + Finish $token $s + return $token } set state(sock) $s @@ -317,16 +341,28 @@ proc http::geturl { url args } { # is already in non-blocking mode in that case. catch {fconfigure $s -blocking off} - set len 0 set how GET - if {[info exists state(-query)]} { - set len [string length $state(-query)] - if {$len > 0} { + set state(querylength) 0 + if {$isQuery} { + set state(querylength) [string length $state(-query)] + if {$state(querylength) > 0} { set how POST + set contDone 0 + } else { + # there's no query data + unset state(-query) + set isQuery 0 } } elseif {$state(-validate)} { set how HEAD + } elseif {$isQueryChannel} { + set how POST + # The query channel must be blocking for the async Write to + # work properly. + fconfigure $state(-querychannel) -blocking 1 + set contDone 0 } + if {[catch { puts $s "$how $srvurl HTTP/1.0" puts $s "Accept: $http(-accept)" @@ -335,31 +371,37 @@ proc http::geturl { url args } { foreach {key value} $state(-headers) { regsub -all \[\n\r\] $value {} value set key [string trim $key] + if {[string equal $key "Content-Length"]} { + set contDone 1 + set state(querylength) $value + } if {[string length $key]} { puts $s "$key: $value" } } - if {$len > 0} { - puts $s "Content-Length: $len" + if {$isQueryChannel && $state(querylength)==0} { + # Try to determine size of data in channel + if {[catch {seek $state(-querychannel) 0 end}]} { + Finish $token "Unable to determine size of querychannel data" + return $token + } + set state(querylength) [tell $state(-querychannel)] + seek $state(-querychannel) 0 + } + + if {$isQuery || $isQueryChannel} { puts $s "Content-Type: $state(-type)" + if {!$contDone} { + puts $s "Content-Length: $state(querylength)" + } puts $s "" fconfigure $s -translation {auto binary} - - # If a timeout is specified or a queryprogress callback is specified - # we do the post in the background - - if {$state(-timeout) > 0 || [string length $state(-queryprogress)]} { - fileevent $s writable \ - [list http::Write $token $state(-query) $state(-queryprogress)] - WaitPost $token - } else { - puts -nonewline $s $state(-query) - } + fileevent $s writable [list http::Write $token] } else { puts $s "" + flush $s + fileevent $s readable [list http::Event $token] } - flush $s - fileevent $s readable [list http::Event $token] } err]} { # The socket probably was never connected, or the connection # dropped later. @@ -369,6 +411,8 @@ proc http::geturl { url args } { } if {! [info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. wait $token } return $token @@ -433,7 +477,8 @@ proc http::cleanup {token} { proc http::Connect {token} { variable $token upvar 0 $token state - if {[eof $state(sock)]} { + if {[eof $state(sock)] || \ + [string length [fconfigure $state(sock) -error]]} { set state(status) ioerror } else { set state(status) connect @@ -446,45 +491,55 @@ proc http::cleanup {token} { # # Arguments # token The token for the connection -# query The query data to write to the connection -# queryprogress The callback, if any, to make after each block # # Side Effects # Write the socket and handle callbacks. -proc http::Write {token query queryprogress} { +proc http::Write {token} { variable $token upvar 0 $token state set s $state(sock) + if {![info exist state(queryoffset)]} { set state(queryoffset) 0 - set state(querylength) [string length $query] } - set chunksize 16384 - # Output a block. Tcl will buffer this if the socket blocks - - if {$state(querylength) < $chunksize} { - set chunksize $state(querylength) - } + if {[catch { # Catch I/O errors on dead sockets - puts -nonewline $s [string range $query $state(queryoffset) \ - [incr state(queryoffset) $chunksize]] + if {[info exists state(-query)]} { + set outStr [string range $state(-query) $state(queryoffset) \ + [incr state(queryoffset) $state(-queryblocksize)]] + } else { + # querychannel + set outStr [read $state(-querychannel) $state(-queryblocksize)] + incr state(queryoffset) $state(-queryblocksize) + } + puts -nonewline $s $outStr - if {[string length $queryprogress]} { - eval $queryprogress [list $token $state(queryoffset) $state(querylength)] + if {$state(querylength)>0 && \ + $state(queryoffset) >= $state(querylength)} { + set state(queryoffset) $state(querylength) } - if {$state(queryoffset) >= $state(querylength)} { + if {[string length $state(-queryprogress)]} { + eval $state(-queryprogress) [list $token $state(querylength)\ + $state(queryoffset)] + } + + if {($state(querylength)>0 && \ + $state(queryoffset) >= $state(querylength)) || \ + ([info exists state(-querychannel)] && \ + [eof $state(-querychannel)])} { fileevent $s writable {} - set state(querydone) ok + flush $s + fileevent $s readable [list http::Event $token] } } err]} { - set state(querydone) $err fileevent $s writable {} + Finish $token $err } } @@ -662,30 +717,6 @@ proc http::wait {token} { return $state(status) } -# http::WaitPost -- -# -# Wait for the post data to be written out -# -# Arguments: -# token Connection token. -# -# Results: -# The status after the wait. - -proc http::WaitPost {token} { - variable $token - upvar 0 $token state - - # We must wait on the original variable name, not the upvar alias - vwait $token\(querydone) - if {[string compare $state(querydone) ok] != 0} { - # throw an error to unwind geturl - return -code error $state(querydone) - } else { - return $state(querydone) - } -} - # http::formatQuery -- # # See documentaion for details. @@ -695,6 +726,7 @@ proc http::WaitPost {token} { # # Arguments: # args A list of name-value pairs. +# # Results: # TODO diff --git a/library/http2.3/http.tcl b/library/http2.3/http.tcl index 1460c85..b783dc7 100644 --- a/library/http2.3/http.tcl +++ b/library/http2.3/http.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.22 2000/03/17 02:15:06 welch Exp $ +# RCS: @(#) $Id: http.tcl,v 1.23 2000/03/19 22:32:26 sandeep Exp $ package provide http 2.3 ;# This uses Tcl namespaces @@ -172,7 +172,6 @@ proc http::reset { token {why reset} } { variable $token upvar 0 $token state set state(status) $why - set state(querydone) $why catch {fileevent $state(sock) readable {}} catch {fileevent $state(sock) writable {}} Finish $token @@ -215,6 +214,7 @@ proc http::geturl { url args } { array set state { -blocksize 8192 + -queryblocksize 8192 -validate 0 -headers {} -timeout 0 @@ -229,7 +229,8 @@ proc http::geturl { url args } { status "" } set options {-blocksize -channel -command -handler -headers \ - -progress -query -queryprogress -validate -timeout -type} + -progress -query -queryblocksize -querychannel -queryprogress\ + -validate -timeout -type} set usage [join $options ", "] regsub -all -- - $options {} options set pat ^-([join $options |])$ @@ -239,15 +240,31 @@ proc http::geturl { url args } { if {[info exists state($flag)] && \ [string is integer -strict $state($flag)] && \ ![string is integer -strict $value]} { + unset $token return -code error "Bad value for $flag ($value), must be integer" } set state($flag) $value } else { + unset $token return -code error "Unknown option $flag, can be: $usage" } } + + # Make sure -query and -querychannel aren't both specified + if {[info exists state(-query)] && [info exists state(-querychannel)]} { + unset $token + return -code error "Can't combine -query and -querychannel options!" + } + + # Set a variable with whether or not we have a querychannel, because + # we need to do special logic later if it does exist, and we don't + # want to do a lot of [info exists...] + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ x prefix proto host y port srvurl]} { + unset $token error "Unsupported URL: $url" } if {[string length $proto] == 0} { @@ -255,6 +272,7 @@ proc http::geturl { url args } { set url ${proto}://$url } if {![info exists urlTypes($proto)]} { + unset $token return -code error "unsupported url type \"$proto\"" } set defport [lindex $urlTypes($proto) 0] @@ -291,9 +309,15 @@ proc http::geturl { url args } { if {[info exists phost] && [string length $phost]} { set srvurl $url - set s [eval $defcmd $async {$phost $pport}] + set conStat [catch {eval $defcmd $async {$phost $pport}} s] } else { - set s [eval $defcmd $async {$host $port}] + set conStat [catch {eval $defcmd $async {$host $port}} s] + } + if {$conStat} { + # something went wrong, so unset the state array and propagate the + # error to the caller + Finish $token $s + return $token } set state(sock) $s @@ -317,16 +341,28 @@ proc http::geturl { url args } { # is already in non-blocking mode in that case. catch {fconfigure $s -blocking off} - set len 0 set how GET - if {[info exists state(-query)]} { - set len [string length $state(-query)] - if {$len > 0} { + set state(querylength) 0 + if {$isQuery} { + set state(querylength) [string length $state(-query)] + if {$state(querylength) > 0} { set how POST + set contDone 0 + } else { + # there's no query data + unset state(-query) + set isQuery 0 } } elseif {$state(-validate)} { set how HEAD + } elseif {$isQueryChannel} { + set how POST + # The query channel must be blocking for the async Write to + # work properly. + fconfigure $state(-querychannel) -blocking 1 + set contDone 0 } + if {[catch { puts $s "$how $srvurl HTTP/1.0" puts $s "Accept: $http(-accept)" @@ -335,31 +371,37 @@ proc http::geturl { url args } { foreach {key value} $state(-headers) { regsub -all \[\n\r\] $value {} value set key [string trim $key] + if {[string equal $key "Content-Length"]} { + set contDone 1 + set state(querylength) $value + } if {[string length $key]} { puts $s "$key: $value" } } - if {$len > 0} { - puts $s "Content-Length: $len" + if {$isQueryChannel && $state(querylength)==0} { + # Try to determine size of data in channel + if {[catch {seek $state(-querychannel) 0 end}]} { + Finish $token "Unable to determine size of querychannel data" + return $token + } + set state(querylength) [tell $state(-querychannel)] + seek $state(-querychannel) 0 + } + + if {$isQuery || $isQueryChannel} { puts $s "Content-Type: $state(-type)" + if {!$contDone} { + puts $s "Content-Length: $state(querylength)" + } puts $s "" fconfigure $s -translation {auto binary} - - # If a timeout is specified or a queryprogress callback is specified - # we do the post in the background - - if {$state(-timeout) > 0 || [string length $state(-queryprogress)]} { - fileevent $s writable \ - [list http::Write $token $state(-query) $state(-queryprogress)] - WaitPost $token - } else { - puts -nonewline $s $state(-query) - } + fileevent $s writable [list http::Write $token] } else { puts $s "" + flush $s + fileevent $s readable [list http::Event $token] } - flush $s - fileevent $s readable [list http::Event $token] } err]} { # The socket probably was never connected, or the connection # dropped later. @@ -369,6 +411,8 @@ proc http::geturl { url args } { } if {! [info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. wait $token } return $token @@ -433,7 +477,8 @@ proc http::cleanup {token} { proc http::Connect {token} { variable $token upvar 0 $token state - if {[eof $state(sock)]} { + if {[eof $state(sock)] || \ + [string length [fconfigure $state(sock) -error]]} { set state(status) ioerror } else { set state(status) connect @@ -446,45 +491,55 @@ proc http::cleanup {token} { # # Arguments # token The token for the connection -# query The query data to write to the connection -# queryprogress The callback, if any, to make after each block # # Side Effects # Write the socket and handle callbacks. -proc http::Write {token query queryprogress} { +proc http::Write {token} { variable $token upvar 0 $token state set s $state(sock) + if {![info exist state(queryoffset)]} { set state(queryoffset) 0 - set state(querylength) [string length $query] } - set chunksize 16384 - # Output a block. Tcl will buffer this if the socket blocks - - if {$state(querylength) < $chunksize} { - set chunksize $state(querylength) - } + if {[catch { # Catch I/O errors on dead sockets - puts -nonewline $s [string range $query $state(queryoffset) \ - [incr state(queryoffset) $chunksize]] + if {[info exists state(-query)]} { + set outStr [string range $state(-query) $state(queryoffset) \ + [incr state(queryoffset) $state(-queryblocksize)]] + } else { + # querychannel + set outStr [read $state(-querychannel) $state(-queryblocksize)] + incr state(queryoffset) $state(-queryblocksize) + } + puts -nonewline $s $outStr - if {[string length $queryprogress]} { - eval $queryprogress [list $token $state(queryoffset) $state(querylength)] + if {$state(querylength)>0 && \ + $state(queryoffset) >= $state(querylength)} { + set state(queryoffset) $state(querylength) } - if {$state(queryoffset) >= $state(querylength)} { + if {[string length $state(-queryprogress)]} { + eval $state(-queryprogress) [list $token $state(querylength)\ + $state(queryoffset)] + } + + if {($state(querylength)>0 && \ + $state(queryoffset) >= $state(querylength)) || \ + ([info exists state(-querychannel)] && \ + [eof $state(-querychannel)])} { fileevent $s writable {} - set state(querydone) ok + flush $s + fileevent $s readable [list http::Event $token] } } err]} { - set state(querydone) $err fileevent $s writable {} + Finish $token $err } } @@ -662,30 +717,6 @@ proc http::wait {token} { return $state(status) } -# http::WaitPost -- -# -# Wait for the post data to be written out -# -# Arguments: -# token Connection token. -# -# Results: -# The status after the wait. - -proc http::WaitPost {token} { - variable $token - upvar 0 $token state - - # We must wait on the original variable name, not the upvar alias - vwait $token\(querydone) - if {[string compare $state(querydone) ok] != 0} { - # throw an error to unwind geturl - return -code error $state(querydone) - } else { - return $state(querydone) - } -} - # http::formatQuery -- # # See documentaion for details. @@ -695,6 +726,7 @@ proc http::WaitPost {token} { # # Arguments: # args A list of name-value pairs. +# # Results: # TODO diff --git a/tests/http.test b/tests/http.test index af231d7..c242ae0 100644 --- a/tests/http.test +++ b/tests/http.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # -# RCS: @(#) $Id: http.test,v 1.15 2000/03/17 02:15:18 welch Exp $ +# RCS: @(#) $Id: http.test,v 1.16 2000/03/19 22:32:26 sandeep Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -194,14 +194,48 @@ test http-3.10 {http::geturl queryprogress} { proc postProgress {token x y} { global postProgress - lappend postProgress $x + lappend postProgress $y } set postProgress {} set t [http::geturl $posturl -query $query \ - -queryprogress postProgress] + -queryprogress postProgress -queryblocksize 16384] http::wait $t list [http::status $t] [string length $query] $postProgress [http::data $t] -} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 131072} {Got 122879 bytes}} +} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}} + +test http-3.11 {http::geturl querychannel with -command} { + set query foo=bar + set sep "" + set i 0 + # Create about 120K of query data + while {$i < 14} { + incr i + append query $sep$query + set sep & + } + ::tcltest::makeFile $query outdata + set fp [open outdata] + + proc asyncCB {token} { + global postResult + lappend postResult [http::data $token] + } + set postResult [list ] + set t [http::geturl $posturl -querychannel $fp] + http::wait $t + set testRes [list [http::status $t] [string length $query] [http::data $t]] + + # Now do async + http::cleanup $t + close $fp + set fp [open outdata] + set t [http::geturl $posturl -querychannel $fp -command asyncCB] + set postResult [list PostStart] + http::wait $t + + lappend testRes [http::status $t] $postResult + set testRes +} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}} test http-4.1 {http::Event} { -- cgit v0.12