From 5509d8c61ac942f877ccfa4f9eeb08e4ed835bd6 Mon Sep 17 00:00:00 2001 From: sandeep Date: Sat, 22 Apr 2000 07:07:59 +0000 Subject: 2000-04-21 Sandeep Tamhankar * 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 --- ChangeLog | 11 +++++++++++ library/http/http.tcl | 28 +++++++++++++++++++--------- library/http2.1/http.tcl | 28 +++++++++++++++++++--------- library/http2.3/http.tcl | 28 +++++++++++++++++++--------- tests/http.test | 3 +-- 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 + + * 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 * 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 -- cgit v0.12