2000-05-29 Sandeep Tamhankar <sandeep@scriptics.com>

	* tests/http.test
	* doc/http.n
	* library/http2.3/http.tcl: Fixed bug 5741, where unsuccessful
	geturl calls sometimes leaked memory and resources (sockets).
	Also, switched around some of the logic so that http::wait never
	throws an exception.  This is because in an asynchronous geturl,
	the command callback will probably end up doing all the error
	handling anyway, and in an asynchronous situation, the user
	expects to check the state when the transaction completes, as
	opposed to being thrown an exception.	For the http package, this
	menas the user can check http::status for "error" and http::error
	for the error message after doing the http::wait.

5 files changed, 164 insertions, 69 deletions

diff --git a/ChangeLog b/ChangeLog
index 01bbaa8..63a719f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2000-05-29  Sandeep Tamhankar <sandeep@scriptics.com>
+
+	* tests/http.test
+	* doc/http.n
+	* library/http2.3/http.tcl: Fixed bug 5741, where unsuccessful
+	geturl calls sometimes leaked memory and resources (sockets).  
+	Also, switched around some of the logic so that http::wait never 
+	throws an exception.  This is because in an asynchronous geturl, 
+	the command callback will probably end up doing all the error 
+	handling anyway, and in an asynchronous situation, the user
+	expects to check the state when the transaction completes, as
+	opposed to being thrown an exception.	For the http package, this
+	menas the user can check http::status for "error" and http::error
+	for the error message after doing the http::wait.
+
 2000-05-31  Jeff Hobbs  <hobbs@scriptics.com>
 
 	* tests/set-old.test:
diff --git a/doc/http.n b/doc/http.n
index 45473f1..b56a5bc 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -1,11 +1,11 @@
 '\"
 '\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
-'\" Copyright (c) 1999 by Scriptics Corporation.
+'\" Copyright (c) 1998-2000 by Ajuba Solutions.
 '\"
 '\" 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.10 2000/04/09 23:55:54 welch Exp $
+'\" RCS: @(#) $Id: http.n,v 1.11 2000/06/02 23:14:46 hobbs Exp $
 '\" 
 .so man.macros
 .TH "Http" n 8.3 Tcl "Tcl Built-In Commands"
@@ -14,7 +14,7 @@
 .SH NAME
 Http \- Client-side implementation of the HTTP/1.0 protocol.
 .SH SYNOPSIS
-\fBpackage require http ?2.2?\fP
+\fBpackage require http ?2.3?\fP
 .sp
 \fB::http::config \fI?options?\fR
 .sp
@@ -32,8 +32,12 @@ Http \- Client-side implementation of the HTTP/1.0 protocol.
 .sp
 \fB::http::code \fItoken\fR
 .sp
+\fB::http::ncode \fItoken\fR
+.sp
 \fB::http::data \fItoken\fR
 .sp
+\fB::http::error \fItoken\fR
+.sp
 \fB::http::cleanup \fItoken\fR
 .sp
 \fB::http::register \fIproto port command\fR
@@ -57,9 +61,8 @@ Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction
 is performed.  
 The return value of \fB::http::geturl\fR is a token for the transaction.
 The value is also the name of an array in the ::http namespace
- that contains state
-information about the transaction.  The elements of this array are
-described in the STATE ARRAY section.
+that contains state information about the transaction.  The elements
+of this array are described in the STATE ARRAY section.
 .PP
 If the \fB-command\fP option is specified, then
 the HTTP operation is done in the background.
@@ -262,12 +265,20 @@ any.  This sets the \fBstate(status)\fP value to \fIwhy\fP, which defaults to \f
 \fB::http::wait\fP \fItoken\fP
 This is a convenience procedure that blocks and waits for the
 transaction to complete.  This only works in trusted code because it
-uses \fBvwait\fR.
+uses \fBvwait\fR.  Also, it's not useful for the case where
+\fB::http::geturl\fP is called \fIwithout\fP the \fB-command\fP option
+because in this case the \fB::http::geturl\fP call doesn't return
+until the HTTP transaction is complete, and thus there's nothing to
+wait for.
 .TP
 \fB::http::data\fP \fItoken\fP
 This is a convenience procedure that returns the \fBbody\fP element
 (i.e., the URL data) of the state array.
 .TP
+\fB::http::error\fP \fItoken\fP
+This is a convenience procedure that returns the \fBerror\fP element
+of the state array.
+.TP
 \fB::http::status\fP \fItoken\fP
 This is a convenience procedure that returns the \fBstatus\fP element of
 the state array.
@@ -276,15 +287,24 @@ the state array.
 This is a convenience procedure that returns the \fBhttp\fP element of the
 state array.
 .TP
+\fB::http::ncode\fP \fItoken\fP
+This is a convenience procedure that returns just the numeric return
+code (200, 404, etc.) from the \fBhttp\fP element of the state array.
+.TP
 \fB::http::size\fP \fItoken\fP
 This is a convenience procedure that returns the \fBcurrentsize\fP
-element of the state array.
+element of the state array, which represents the number of bytes
+received from the URL in the \fB::http::geturl\fP call.
 .TP
 \fB::http::cleanup\fP \fItoken\fP
 This procedure cleans up the state associated with the connection
 identified by \fItoken\fP.  After this call, the procedures
 like \fB::http::data\fP cannot be used to get information
-about the operation.
+about the operation.  It is \fIstrongly\fP recommended that you call
+this function after you're done with a given HTTP request.  Not doing
+so will result in memory not being freed, and if your app calls
+\fB::http::geturl\fP enough times, the memory leak could cause a
+performance hit...or worse.
 .TP
 \fB::http::register\fP \fIproto port command\fP
 This procedure allows one to provide custom HTTP transport types
@@ -309,19 +329,36 @@ registered via \fBhttp::register\fR.
 The \fBhttp::geturl\fP procedure will raise errors in the following cases:
 invalid command line options,
 an invalid URL,
-or a URL on a non-existent host,
+a URL on a non-existent host,
+or a URL at a bad port on an existing host.
 These errors mean that it
 cannot even start the network transaction.
 It will also raise an error if it gets an I/O error while
 writing out the HTTP request header.
+For synchronous \fB::http::geturl\fP calls (where \fB-command\fP is
+not specified), it will raise an error if it gets an I/O error while
+reading the HTTP reply headers or data.  Because \fB::http::geturl\fP
+doesn't return a token in these cases, it does all the required
+cleanup and there's no issue of your app having to call
+\fB::http::cleanup\fP.
+.PP
+For asynchronous \fB::http::geturl\fP calls, all of the above error
+situations apply, except that if there's any error while 
+reading the
+HTTP reply headers or data, no exception is thrown.  This is because
+after writing the HTTP headers, \fB::http::geturl\fP returns, and the
+rest of the HTTP transaction occurs in the background.  The command
+callback can check if any error occurred during the read by calling
+\fB::http::status\fP to check the status and if it's \fIerror\fP,
+calling \fB::http::error\fP to get the error message.
+.PP
+Alternatively, if the main program flow reaches a point where it needs
+to know the result of the asynchronous HTTP request, it can call
+\fB::http::wait\fP and then check status and error, just as the
+callback does.
 .PP
-The \fBhttp::wait\fP procedure will raise errors if an I/O error
-occurs while reading the HTTP reply headers or data.  If the
-\fB-command\fP flag is not passed to \fBhttp::geturl\fP,
-then it will call \fBhttp::wait\fP and so these errors will
-occur in \fBhttp::geturl\fP.
-If you get an error from \fBhttp::wait\fP, you must still call
-\fBhttp::cleanup\fP to delete the state array.
+In any case, you must still call
+\fBhttp::cleanup\fP to delete the state array when you're done.
 .PP
 There are other possible results of the HTTP transaction
 determined by examining the status from \fBhttp::status\fP.
@@ -336,12 +373,11 @@ procedure returns a value like "HTTP 404 File not found".
 .TP
 eof
 If the server closes the socket without replying, then no error
-is rasied, but the status of the transaction will be \fBeof\fP.
+is raised, but the status of the transaction will be \fBeof\fP.
 .TP
 error
-In this case \fBhttp::wait\fP should have raised an error.
 The error message will also be stored in the \fBerror\fP status
-array element.
+array element, accessible via \fB::http::error\fP.
 .PP
 Another error possibility is that \fBhttp::geturl\fP is unable to
 write all the post query data to the server before the server
@@ -424,7 +460,8 @@ the post query data to the server.
 .TP
 \fBstatus\fR
 Either \fBok\fR, for successful completion, \fBreset\fR for
-user-reset, or \fBerror\fR for an error condition.  During the
+user-reset, \fBtimeout\fP if a timeout occurred before the transaction
+could complete, or \fBerror\fR for an error condition.  During the
 transaction this value is the empty string.
 .TP
 \fBtotalsize\fR
diff --git a/library/http/http.tcl b/library/http/http.tcl
index a524415..c8c9908 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.32 2000/04/22 07:07:59 sandeep Exp $
+# RCS: @(#) $Id: http.tcl,v 1.33 2000/06/02 23:14:46 hobbs Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface
@@ -280,7 +280,7 @@ proc http::geturl { url args } {
     if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
 	    x prefix proto host y port srvurl]} {
 	unset $token
-	error "Unsupported URL: $url"
+	return -code error "Unsupported URL: $url"
     }
     if {[string length $proto] == 0} {
 	set proto http
@@ -288,7 +288,7 @@ proc http::geturl { url args } {
     }
     if {![info exists urlTypes($proto)]} {
 	unset $token
-	return -code error "unsupported url type \"$proto\""
+	return -code error "Unsupported URL type \"$proto\""
     }
     set defport [lindex $urlTypes($proto) 0]
     set defcmd [lindex $urlTypes($proto) 1]
@@ -345,12 +345,17 @@ proc http::geturl { url args } {
     if {$state(-timeout) > 0} {
 	fileevent $s writable [list http::Connect $token]
 	http::wait $token
-	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
 
+	if {[string equal $state(status) "error"]} {
+	    # something went wrong while trying to establish the connection
+	    # Clean up after events and such, but DON'T call the command
+	    # callback (if available) because we're going to throw an 
+	    # exception from here instead.
+	    set err [lindex $state(error) 0]
+	    cleanup $token
+	    return -code error $err
+	} elseif {![string equal $state(status) "connect"]} {
+	    # Likely to be connection timeout
 	    return $token
 	}
 	set state(status) ""
@@ -449,6 +454,11 @@ proc http::geturl { url args } {
 	    # calls it synchronously, we just do a wait here.
 
 	    wait $token
+	    if {[string equal $state(status) "error"]} {
+		# Something went wrong, so throw the exception, and the
+		# enclosing catch will do cleanup.
+		return -code error [lindex $state(error) 0]
+	    }		
 	}
     } err]} {
 	# The socket probably was never connected,
@@ -457,8 +467,12 @@ proc http::geturl { url args } {
 	# Clean up after events and such, but DON'T call the command callback
 	# (if available) because we're going to throw an exception from here
 	# instead.
-
-	Finish $token $err 1
+	
+	# if state(status) is error, it means someone's already called Finish
+	# to do the above-described clean up.
+	if {[string equal $state(status) "error"]} {
+	    Finish $token $err 1
+	}
 	cleanup $token
 	return -code error $err
     }
@@ -502,6 +516,15 @@ proc http::size {token} {
     return $state(currentsize)
 }
 
+proc http::error {token} {
+    variable $token
+    upvar 0 $token state
+    if {[info exists state(error)]} {
+	return $state(error)
+    }
+    return ""
+}
+
 # http::cleanup
 #
 #	Garbage collect the state associated with a transaction
@@ -531,21 +554,19 @@ proc http::cleanup {token} {
 #	Sets the status of the connection, which unblocks
 # 	the waiting geturl call
 
- proc http::Connect {token} {
+proc http::Connect {token} {
     variable $token
     upvar 0 $token state
     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]
+	[string length [fconfigure $state(sock) -error]]} {
+	    Finish $token "connect failed [fconfigure $state(sock) -error]" 1
     } else {
 	set state(status) connect
+	fileevent $state(sock) writable {}
     }
-    fileevent $state(sock) writable {}
- }
+    return
+}
 
 # http::Write
 #
@@ -780,11 +801,7 @@ proc http::wait {token} {
 	# We must wait on the original variable name, not the upvar alias
 	vwait $token\(status)
     }
-    if {[info exists state(error)]} {
-	set errorlist $state(error)
-	unset state
-	eval error $errorlist
-    }
+
     return $state(status)
 }
 
diff --git a/library/http2.3/http.tcl b/library/http2.3/http.tcl
index a524415..c8c9908 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.32 2000/04/22 07:07:59 sandeep Exp $
+# RCS: @(#) $Id: http.tcl,v 1.33 2000/06/02 23:14:46 hobbs Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface
@@ -280,7 +280,7 @@ proc http::geturl { url args } {
     if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
 	    x prefix proto host y port srvurl]} {
 	unset $token
-	error "Unsupported URL: $url"
+	return -code error "Unsupported URL: $url"
     }
     if {[string length $proto] == 0} {
 	set proto http
@@ -288,7 +288,7 @@ proc http::geturl { url args } {
     }
     if {![info exists urlTypes($proto)]} {
 	unset $token
-	return -code error "unsupported url type \"$proto\""
+	return -code error "Unsupported URL type \"$proto\""
     }
     set defport [lindex $urlTypes($proto) 0]
     set defcmd [lindex $urlTypes($proto) 1]
@@ -345,12 +345,17 @@ proc http::geturl { url args } {
     if {$state(-timeout) > 0} {
 	fileevent $s writable [list http::Connect $token]
 	http::wait $token
-	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
 
+	if {[string equal $state(status) "error"]} {
+	    # something went wrong while trying to establish the connection
+	    # Clean up after events and such, but DON'T call the command
+	    # callback (if available) because we're going to throw an 
+	    # exception from here instead.
+	    set err [lindex $state(error) 0]
+	    cleanup $token
+	    return -code error $err
+	} elseif {![string equal $state(status) "connect"]} {
+	    # Likely to be connection timeout
 	    return $token
 	}
 	set state(status) ""
@@ -449,6 +454,11 @@ proc http::geturl { url args } {
 	    # calls it synchronously, we just do a wait here.
 
 	    wait $token
+	    if {[string equal $state(status) "error"]} {
+		# Something went wrong, so throw the exception, and the
+		# enclosing catch will do cleanup.
+		return -code error [lindex $state(error) 0]
+	    }		
 	}
     } err]} {
 	# The socket probably was never connected,
@@ -457,8 +467,12 @@ proc http::geturl { url args } {
 	# Clean up after events and such, but DON'T call the command callback
 	# (if available) because we're going to throw an exception from here
 	# instead.
-
-	Finish $token $err 1
+	
+	# if state(status) is error, it means someone's already called Finish
+	# to do the above-described clean up.
+	if {[string equal $state(status) "error"]} {
+	    Finish $token $err 1
+	}
 	cleanup $token
 	return -code error $err
     }
@@ -502,6 +516,15 @@ proc http::size {token} {
     return $state(currentsize)
 }
 
+proc http::error {token} {
+    variable $token
+    upvar 0 $token state
+    if {[info exists state(error)]} {
+	return $state(error)
+    }
+    return ""
+}
+
 # http::cleanup
 #
 #	Garbage collect the state associated with a transaction
@@ -531,21 +554,19 @@ proc http::cleanup {token} {
 #	Sets the status of the connection, which unblocks
 # 	the waiting geturl call
 
- proc http::Connect {token} {
+proc http::Connect {token} {
     variable $token
     upvar 0 $token state
     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]
+	[string length [fconfigure $state(sock) -error]]} {
+	    Finish $token "connect failed [fconfigure $state(sock) -error]" 1
     } else {
 	set state(status) connect
+	fileevent $state(sock) writable {}
     }
-    fileevent $state(sock) writable {}
- }
+    return
+}
 
 # http::Write
 #
@@ -780,11 +801,7 @@ proc http::wait {token} {
 	# We must wait on the original variable name, not the upvar alias
 	vwait $token\(status)
     }
-    if {[info exists state(error)]} {
-	set errorlist $state(error)
-	unset state
-	eval error $errorlist
-    }
+
     return $state(status)
 }
 
diff --git a/tests/http.test b/tests/http.test
index 4efde80..c18a3c9 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -6,13 +6,13 @@
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-2000 by Ajuba Solutions.
 #
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
 #
-# RCS: @(#) $Id: http.test,v 1.19 2000/04/22 07:07:59 sandeep Exp $
+# RCS: @(#) $Id: http.test,v 1.20 2000/06/02 23:14:47 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -290,6 +290,15 @@ test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
     list [http::status $t] [http::code $t]
 } {ok {HTTP/1.0 200 Data follows}}
 
+test http-3.13 {http::geturl socket leak test} {
+    set chanCount [llength [file channels]]
+    for {set i 0} {$i<200} {incr i} {
+	catch {http::geturl $badurl -timeout 10000} 
+    }
+
+    # No extra channels should be taken
+    expr {[llength [file channels]] == $chanCount}
+} 1
 
 test http-4.1 {http::Event} {
     set token [http::geturl $url]