summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2013-01-23 09:03:46 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2013-01-23 09:03:46 (GMT)
commit6f64df6c74bca1f0645d629ff7ed7198cdc5316e (patch)
treea80ea51247a38ad3dde075fa8e13506c8e3c316b
parentb63a137be6a9a9491e5927f5613bbaf84f00532b (diff)
parentae2b9cd377978ef7018b95e2d16b17042e2eb76b (diff)
downloadtcl-6f64df6c74bca1f0645d629ff7ed7198cdc5316e.zip
tcl-6f64df6c74bca1f0645d629ff7ed7198cdc5316e.tar.gz
tcl-6f64df6c74bca1f0645d629ff7ed7198cdc5316e.tar.bz2
Fix [2911139]: connect asynchronously, but without unnecessary internal waits.
-rw-r--r--ChangeLog8
-rw-r--r--library/http/http.tcl64
-rw-r--r--tests/http.test5
3 files changed, 43 insertions, 34 deletions
diff --git a/ChangeLog b/ChangeLog
index 9328946..130364c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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 6b82894..4a517ac 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -528,11 +528,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
@@ -588,10 +587,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]} {
@@ -607,13 +611,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)
@@ -746,35 +766,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]} then {
# 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:
@@ -858,7 +860,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"
@@ -866,10 +868,10 @@ proc http::Connect {token} {
[eof $state(sock)] ||
[set err [fconfigure $state(sock) -error]] ne ""
} then {
- 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 3a9d4ba..3ec0a6f 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -464,9 +464,8 @@ 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 -result {(connect failed|couldn't open socket)}
+ lindex [http::error $token] 0
+} -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