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).


FossilOrigin-Name: 8f0cd2d9ba92eb62fec82ddad2fe103b91ea1e67

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