2000-04-21 Sandeep Tamhankar <sandeep@scriptics.com>

	* library/http2.1/http.tcl: Fixed a newly introduced bug where if
	there's a -command callback and something goes wrong, geturl threw
	an exception, called the callback, and unset the token.  I changed
	it so that it will not call the callback when throwing an
	exception (so the caller only finds out about a given error from
	one place).  Also, fixed http::ncode so that it actually gives you
	back the http return code (i.e. 200, 404, etc.) instead of the
	first digit of the version of HTTP being used (i.e. 1).

5 files changed, 69 insertions, 29 deletions

diff --git a/ChangeLog b/ChangeLog
index f5918d7..46189f8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2000-04-21  Sandeep Tamhankar <sandeep@scriptics.com>
+
+	* library/http2.1/http.tcl: Fixed a newly introduced bug where if
+	there's a -command callback and something goes wrong, geturl threw
+	an exception, called the callback, and unset the token.  I changed
+	it so that it will not call the callback when throwing an
+	exception (so the caller only finds out about a given error from
+	one place).  Also, fixed http::ncode so that it actually gives you
+	back the http return code (i.e. 200, 404, etc.) instead of the
+	first digit of the version of HTTP being used (i.e. 1).
+
 2000-04-21  Brent Welch <welch@scriptics.com>
 
 	* library/http2.1/http.tcl: More thrashing with the "server closes
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 2137b00..a524415 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.31 2000/04/22 00:37:33 welch Exp $
+# RCS: @(#) $Id: http.tcl,v 1.32 2000/04/22 07:07:59 sandeep Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface
@@ -136,13 +136,17 @@ proc http::config {args} {
 #	Clean up the socket and eval close time callbacks
 #
 # Arguments:
-#	token	Connection token.
-#	errormsg	If set, forces status to error.
+#	token	    Connection token.
+#	errormsg    (optional) If set, forces status to error.
+#       skipCB      (optional) If set, don't call the -command callback.  This
+#                   is useful when geturl wants to throw an exception instead
+#                   of calling the callback.  That way, the same error isn't
+#                   reported to two places.
 #
 # Side Effects:
 #        Closes the socket
 
- proc http::Finish { token {errormsg ""} } {
+proc http::Finish { token {errormsg ""} {skipCB 0}} {
     variable $token
     upvar 0 $token state
     global errorInfo errorCode
@@ -152,7 +156,7 @@ proc http::config {args} {
     }
     catch {close $state(sock)}
     catch {after cancel $state(after)}
-    if {[info exists state(-command)]} {
+    if {[info exists state(-command)] && !$skipCB} {
 	if {[catch {eval $state(-command) {$token}} err]} {
 	    if {[string length $errormsg] == 0} {
 		set state(error) [list $err $errorInfo $errorCode]
@@ -327,8 +331,10 @@ proc http::geturl { url args } {
     if {$conStat} {
 
 	# something went wrong while trying to establish the connection
-
-	Finish $token
+	# 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 "" 1
 	cleanup $token
 	return -code error $s
     }
@@ -448,7 +454,11 @@ proc http::geturl { url args } {
 	# The socket probably was never connected,
 	# or the connection dropped later.
 
-	Finish $token $err
+	# 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
 	cleanup $token
 	return -code error $err
     }
@@ -480,7 +490,7 @@ proc http::code {token} {
 proc http::ncode {token} {
     variable $token
     upvar 0 $token state
-    if {[regexp {[0-9]+} $state(http) numeric_code]} {
+    if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
 	return $numeric_code
     } else {
 	return $state(http)
diff --git a/library/http2.1/http.tcl b/library/http2.1/http.tcl
index 2137b00..a524415 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.31 2000/04/22 00:37:33 welch Exp $
+# RCS: @(#) $Id: http.tcl,v 1.32 2000/04/22 07:07:59 sandeep Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface
@@ -136,13 +136,17 @@ proc http::config {args} {
 #	Clean up the socket and eval close time callbacks
 #
 # Arguments:
-#	token	Connection token.
-#	errormsg	If set, forces status to error.
+#	token	    Connection token.
+#	errormsg    (optional) If set, forces status to error.
+#       skipCB      (optional) If set, don't call the -command callback.  This
+#                   is useful when geturl wants to throw an exception instead
+#                   of calling the callback.  That way, the same error isn't
+#                   reported to two places.
 #
 # Side Effects:
 #        Closes the socket
 
- proc http::Finish { token {errormsg ""} } {
+proc http::Finish { token {errormsg ""} {skipCB 0}} {
     variable $token
     upvar 0 $token state
     global errorInfo errorCode
@@ -152,7 +156,7 @@ proc http::config {args} {
     }
     catch {close $state(sock)}
     catch {after cancel $state(after)}
-    if {[info exists state(-command)]} {
+    if {[info exists state(-command)] && !$skipCB} {
 	if {[catch {eval $state(-command) {$token}} err]} {
 	    if {[string length $errormsg] == 0} {
 		set state(error) [list $err $errorInfo $errorCode]
@@ -327,8 +331,10 @@ proc http::geturl { url args } {
     if {$conStat} {
 
 	# something went wrong while trying to establish the connection
-
-	Finish $token
+	# 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 "" 1
 	cleanup $token
 	return -code error $s
     }
@@ -448,7 +454,11 @@ proc http::geturl { url args } {
 	# The socket probably was never connected,
 	# or the connection dropped later.
 
-	Finish $token $err
+	# 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
 	cleanup $token
 	return -code error $err
     }
@@ -480,7 +490,7 @@ proc http::code {token} {
 proc http::ncode {token} {
     variable $token
     upvar 0 $token state
-    if {[regexp {[0-9]+} $state(http) numeric_code]} {
+    if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
 	return $numeric_code
     } else {
 	return $state(http)
diff --git a/library/http2.3/http.tcl b/library/http2.3/http.tcl
index 2137b00..a524415 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.31 2000/04/22 00:37:33 welch Exp $
+# RCS: @(#) $Id: http.tcl,v 1.32 2000/04/22 07:07:59 sandeep Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface
@@ -136,13 +136,17 @@ proc http::config {args} {
 #	Clean up the socket and eval close time callbacks
 #
 # Arguments:
-#	token	Connection token.
-#	errormsg	If set, forces status to error.
+#	token	    Connection token.
+#	errormsg    (optional) If set, forces status to error.
+#       skipCB      (optional) If set, don't call the -command callback.  This
+#                   is useful when geturl wants to throw an exception instead
+#                   of calling the callback.  That way, the same error isn't
+#                   reported to two places.
 #
 # Side Effects:
 #        Closes the socket
 
- proc http::Finish { token {errormsg ""} } {
+proc http::Finish { token {errormsg ""} {skipCB 0}} {
     variable $token
     upvar 0 $token state
     global errorInfo errorCode
@@ -152,7 +156,7 @@ proc http::config {args} {
     }
     catch {close $state(sock)}
     catch {after cancel $state(after)}
-    if {[info exists state(-command)]} {
+    if {[info exists state(-command)] && !$skipCB} {
 	if {[catch {eval $state(-command) {$token}} err]} {
 	    if {[string length $errormsg] == 0} {
 		set state(error) [list $err $errorInfo $errorCode]
@@ -327,8 +331,10 @@ proc http::geturl { url args } {
     if {$conStat} {
 
 	# something went wrong while trying to establish the connection
-
-	Finish $token
+	# 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 "" 1
 	cleanup $token
 	return -code error $s
     }
@@ -448,7 +454,11 @@ proc http::geturl { url args } {
 	# The socket probably was never connected,
 	# or the connection dropped later.
 
-	Finish $token $err
+	# 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
 	cleanup $token
 	return -code error $err
     }
@@ -480,7 +490,7 @@ proc http::code {token} {
 proc http::ncode {token} {
     variable $token
     upvar 0 $token state
-    if {[regexp {[0-9]+} $state(http) numeric_code]} {
+    if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
 	return $numeric_code
     } else {
 	return $state(http)
diff --git a/tests/http.test b/tests/http.test
index a7c1045..4efde80 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.18 2000/04/10 17:18:59 ericm Exp $
+# RCS: @(#) $Id: http.test,v 1.19 2000/04/22 07:07:59 sandeep Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -475,4 +475,3 @@ if {[info exist removeHttpd]} {
 }
 
 ::tcltest::cleanupTests
-return