Adjusted file events and unified error handling.

1 files changed, 110 insertions, 71 deletions

diff --git a/library/http/http.tcl b/library/http/http.tcl
index c7369e4..fbf94b8 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -9,9 +9,16 @@
 # 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.29 2000/04/05 00:30:15 sandeep Exp $
+# RCS: @(#) $Id: http.tcl,v 1.30 2000/04/09 23:56:13 welch Exp $
 
-package provide http 2.3	;# This uses Tcl namespaces
+# Rough version history:
+# 1.0	Old http_get interface
+# 2.0	http:: namespace and http::geturl
+# 2.1	Added callbacks to handle arriving data, and timeouts
+# 2.2	Added ability to fetch into a channel
+# 2.3	Added SSL support, and ability to post from a channel
+
+package provide http 2.3
 
 namespace eval http {
     variable http
@@ -19,7 +26,7 @@ namespace eval http {
 	-accept */*
 	-proxyhost {}
 	-proxyport {}
-	-useragent {Tcl http client package 2.2}
+	-useragent {Tcl http client package 2.3}
 	-proxyfilter http::ProxyRequired
     }
 
@@ -224,6 +231,8 @@ proc http::geturl { url args } {
 	meta		{}
 	currentsize	0
 	totalsize	0
+	querylength	0
+	queryoffset	0
         type            text/html
         body            {}
 	status		""
@@ -252,16 +261,15 @@ proc http::geturl { url args } {
     }
 
     # Make sure -query and -querychannel aren't both specified
-    if {[info exists state(-query)] && [info exists state(-querychannel)]} {
+
+    set isQueryChannel [info exists state(-querychannel)]
+    set isQuery [info exists state(-query)]
+    if {$isQuery && $isQueryChannel} {
 	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)]
+    # Validate URL, determine the server host and port, and check proxy case
 
     if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
 	    x prefix proto host y port srvurl]} {
@@ -315,15 +323,12 @@ proc http::geturl { url args } {
 	set conStat [catch {eval $defcmd $async {$host $port}} s]
     }
     if {$conStat} {
+
 	# something went wrong while trying to establish the connection
-	# The proper response is probably to give the caller a token
-	# containing error info, but that would break backwards compatibility.
-	# So, let's follow tradition and throw an exception (after unsetting
-	# the array).
-	unset $token
-	error $s
-	#Finish $token $s
-	#return $token
+
+	Finish $token
+	cleanup $token
+	return -code error $s
     }
     set state(sock) $s
 
@@ -332,8 +337,12 @@ proc http::geturl { url args } {
     if {$state(-timeout) > 0} {
 	fileevent $s writable [list http::Connect $token]
 	http::wait $token
-	catch {fileevent $s writable {}}
-	if {![string equal $state(status) "connect"]} {
+	if {$state(status) != "connect"} {
+	    
+	    # Likely to be connection timeout.  If there was a connection
+	    # error, (e.g., bad port), then http::wait will have 
+	    # raised an error already
+
 	    return $token
 	}
 	set state(status) ""
@@ -348,7 +357,6 @@ proc http::geturl { url args } {
 
     catch {fconfigure $s -blocking off}
     set how GET
-    set state(querylength) 0
     if {$isQuery} {
 	set state(querylength) [string length $state(-query)]
 	if {$state(querylength) > 0} {
@@ -385,14 +393,15 @@ proc http::geturl { url args } {
 		puts $s "$key: $value"
 	    }
 	}
-	if {$isQueryChannel && $state(querylength)==0} {
+	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 we cannot seek, the surrounding catch will trap us
+
+	    set start [tell $state(-querychannel)]
+	    seek $state(-querychannel) 0 end
+	    set state(querylength) \
+		    [expr {[tell $state(-querychannel)] - $start}]
+	    seek $state(-querychannel) $start
 	}
 		
 	if {$isQuery || $isQueryChannel} {
@@ -405,22 +414,31 @@ proc http::geturl { url args } {
 	    fileevent $s writable [list http::Write $token]
 	} else {
 	    puts $s ""
-	    flush $s
-	    fileevent $s readable [list http::Event $token]
+	}
+	# Set up the read file event here in either case.  This seems to
+	# help in the case where the server replies but does not
+	# read the query post data, and the server is on the same
+	# machine so the loopback interface is being used.
+
+	flush $s
+	fileevent $s readable [list http::Event $token]
+
+	if {! [info exists state(-command)]} {
+
+	    # geturl does EVERYTHING asynchronously, so if the user
+	    # calls it synchronously, we just do a wait here.
+
+	    wait $token
 	}
     } err]} {
-	# The socket probably was never connected, or the connection
-	# dropped later.
+	# The socket probably was never connected,
+	# or the connection dropped later.
 
-	reset $token ioerror
-	return $token
+	Finish $token $err
+	cleanup $token
+	return -code error $err
     }
 
-    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
 }
 
@@ -445,6 +463,15 @@ proc http::code {token} {
     upvar 0 $token state
     return $state(http)
 }
+proc http::ncode {token} {
+    variable $token
+    upvar 0 $token state
+    if {[regexp {[0-9]+} $state(http) numeric_code]} {
+	return $numeric_code
+    } else {
+	return $state(http)
+    }
+}
 proc http::size {token} {
     variable $token
     upvar 0 $token state
@@ -471,7 +498,7 @@ proc http::cleanup {token} {
 
 # http::Connect
 #
-#	Wait for an asynchronous connection to complete
+#	This callback is made when an asyncronous connection completes.
 #
 # Arguments
 #	token	The token returned from http::geturl
@@ -483,12 +510,17 @@ proc http::cleanup {token} {
  proc http::Connect {token} {
     variable $token
     upvar 0 $token state
-    if {[eof $state(sock)] || \
-	[string length [fconfigure $state(sock) -error]]} {
-	set state(status) ioerror
+    global errorInfo errorCode
+    if {[eof $state(sock)] ||
+	    [string length [fconfigure $state(sock) -error]]} {
+	set state(status) error
+	set state(error) [list \
+		"connect failed [fconfigure $state(sock) -error]" \
+		$errorInfo $errorCode]
     } else {
 	set state(status) connect
     }
+    fileevent $state(sock) writable {}
  }
 
 # http::Write
@@ -506,46 +538,53 @@ proc http::Write {token} {
     upvar 0 $token state
     set s $state(sock)
     
-    if {![info exist state(queryoffset)]} {
-	set state(queryoffset) 0
-    }
     # Output a block.  Tcl will buffer this if the socket blocks
     
     if {[catch {
 	
 	# Catch I/O errors on dead sockets
 
+	set done 0
 	if {[info exists state(-query)]} {
-	    set outStr [string range $state(-query) $state(queryoffset) \
+	    
+	    # Chop up large query strings so queryprogress callback
+	    # can give smooth feedback
+
+	    puts -nonewline $s \
+		    [string range $state(-query) $state(queryoffset) \
 		    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
 	    incr state(queryoffset) $state(-queryblocksize)
+	    if {$state(queryoffset) >= $state(querylength)} {
+		set state(queryoffset) $state(querylength)
+		flush $s
+		fileevent $s writable {}
+	    }
 	} else {
-	    # querychannel
-	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
-	    incr state(queryoffset) $state(-queryblocksize)
-	}
-	puts -nonewline $s $outStr
-	
-	if {$state(querylength)>0 && \
-		$state(queryoffset) >= $state(querylength)} {
-	    set state(queryoffset) $state(querylength)
-	}
+	    
+	    # Copy blocks from the query channel
 
-	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 {}
-	    flush $s
-	    fileevent $s readable [list http::Event $token]
+	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
+	    puts -nonewline $s $outStr
+	    incr state(queryoffset) [string length $outStr]
+	    if {[eof $state(-querychannel)]} {
+		flush $s
+		fileevent $s writable {}
+	    }
 	}
     } err]} {
-	Finish $token $err
+	# Do not call Finish here, but instead let the read half of
+	# the socket process whatever server reply there is to get.
+	# Simply turn off this write process
+
+	set state(posterror) $err
+	fileevent $s writable {}
+    }
+
+    # Callback to the client after we've completely handled everything
+
+    if {[string length $state(-queryprogress)]} {
+	eval $state(-queryprogress) [list $token $state(querylength)\
+		$state(queryoffset)]
     }
 }
 
@@ -564,7 +603,7 @@ proc http::Write {token} {
     upvar 0 $token state
     set s $state(sock)
 
-     if {[::eof $s]} {
+     if {[eof $s]} {
 	Eof $token
 	return
     }
@@ -667,7 +706,7 @@ proc http::Write {token} {
     # At this point the token may have been reset
     if {[string length $error]} {
 	Finish $token $error
-    } elseif {[catch {::eof $s} iseof] || $iseof} {
+    } elseif {[catch {eof $s} iseof] || $iseof} {
 	Eof $token
     } else {
 	CopyStart $s $token