* 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 <callback> <token> <total size> <current size>
	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).

1 files changed, 98 insertions, 66 deletions

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