diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | library/http/http.tcl | 64 | ||||
| -rw-r--r-- | tests/http.test | 7 | ||||
| -rw-r--r-- | unix/tclUnixCompat.c | 2 |
4 files changed, 45 insertions, 36 deletions
@@ -1,3 +1,11 @@ +2013-01-23 Donal K. Fellows <dkf@users.sf.net> + + * library/http/http.tcl (http::geturl): [Bug 2911139]: Do not do vwait + for connect to avoid reentrancy problems (except when operating + without a -command option). Internally, this means that all sockets + created by the http package will always be operated in asynchronous + mode. + 2013-01-18 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclPort.h: [Bug 3598300]: unix: tcl.h does not include diff --git a/library/http/http.tcl b/library/http/http.tcl index 442cdc5..98066af 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -537,11 +537,10 @@ proc http::geturl {url args} { # If a timeout is specified we set up the after event and arrange for an # asynchronous socket connection. - set sockopts [list] + set sockopts [list -async] if {$state(-timeout) > 0} { set state(after) [after $state(-timeout) \ [list http::reset $token timeout]] - lappend sockopts -async } # If we are using the proxy, we must pass in the full URL that includes @@ -597,10 +596,15 @@ proc http::geturl {url args} { set socketmap($state(socketinfo)) $sock } - # Wait for the connection to complete. + if {![info exists phost]} { + set phost "" + } + fileevent $sock writable [list http::Connect $token $proto $phost $srvurl] - if {$state(-timeout) > 0} { - fileevent $sock writable [list http::Connect $token] + # Wait for the connection to complete. + if {![info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. http::wait $token if {![info exists state]} { @@ -616,13 +620,29 @@ proc http::geturl {url args} { set err [lindex $state(error) 0] cleanup $token return -code error $err - } elseif {$state(status) ne "connect"} { - # Likely to be connection timeout - return $token } - set state(status) "" } + return $token +} + + +proc http::Connected { token proto phost srvurl} { + variable http + variable urlTypes + + variable $token + upvar 0 $token state + + # Set back the variables needed here + set sock $state(sock) + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + set host [lindex [split $state(socketinfo) :] 0] + set port [lindex [split $state(socketinfo) :] 1] + + set defport [lindex $urlTypes($proto) 0] + # Send data in cr-lf format, but accept any line terminators fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) @@ -753,35 +773,17 @@ proc http::geturl {url args} { fileevent $sock readable [list http::Event $sock $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 - if {$state(status) eq "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, or the connection dropped # later. - # 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. - # if state(status) is error, it means someone's already called Finish # to do the above-described clean up. if {$state(status) ne "error"} { - Finish $token $err 1 + Finish $token $err } - cleanup $token - return -code error $err } - return $token } # Data access functions: @@ -865,7 +867,7 @@ proc http::cleanup {token} { # Sets the status of the connection, which unblocks # the waiting geturl call -proc http::Connect {token} { +proc http::Connect {token proto phost srvurl} { variable $token upvar 0 $token state set err "due to unexpected EOF" @@ -873,10 +875,10 @@ proc http::Connect {token} { [eof $state(sock)] || [set err [fconfigure $state(sock) -error]] ne "" } { - Finish $token "connect failed $err" 1 + Finish $token "connect failed $err" } else { - set state(status) connect fileevent $state(sock) writable {} + ::http::Connected $token $proto $phost $srvurl } return } diff --git a/tests/http.test b/tests/http.test index 9861e0e..e2de7d8 100644 --- a/tests/http.test +++ b/tests/http.test @@ -547,11 +547,10 @@ test http-4.14 {http::Event} -body { error "bogus return from http::geturl" } http::wait $token - http::status $token - # error code varies among platforms. -} -returnCodes 1 -match regexp -cleanup { + lindex [http::error $token] 0 +} -cleanup { catch {http::cleanup $token} -} -result {(connect failed|couldn't open socket)} +} -result {connect failed connection refused} # Bogus host test http-4.15 {http::Event} -body { # This test may fail if you use a proxy server. That is to be diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index bcf7d40..6de6e75 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -998,7 +998,7 @@ TclWinCPUID( "mov %%ebx, %%esi \n\t" /* save what cpuid just put in %ebx */ "mov %%edi, %%ebx \n\t" /* restore the old %ebx */ : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) - : "a"(index) : "edi"); + : "a"(index) : "edi","ebx"); status = TCL_OK; #endif return status; |