summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2013-01-23 14:04:27 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2013-01-23 14:04:27 (GMT)
commit5c9b640714bee1ace568923c48755f7b04d9fd9c (patch)
tree8b2992828b0de88a747dac0aa8cfc97311fe4d25
parent2c854d97760abc9997260aa03924af5bd0315fb8 (diff)
parent6f64df6c74bca1f0645d629ff7ed7198cdc5316e (diff)
downloadtcl-5c9b640714bee1ace568923c48755f7b04d9fd9c.zip
tcl-5c9b640714bee1ace568923c48755f7b04d9fd9c.tar.gz
tcl-5c9b640714bee1ace568923c48755f7b04d9fd9c.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.test7
3 files changed, 44 insertions, 35 deletions
diff --git a/ChangeLog b/ChangeLog
index 1532676..0b853e4 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-21 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclInt.decls: Put back Tcl[GS]etStartupScript(Path|FileName)
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 01bf772..ddf066e 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