From a5cfbafa9098e5ae4018b3142702fd8138417776 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 17 Jan 2013 13:29:07 +0000
Subject: Proposed fix, by kakaroto, for Bug 2911139: http::geturl abuses vwait
 on async call

---
 library/http/http.tcl | 64 ++++++++++++++++++++++++++-------------------------
 1 file changed, 33 insertions(+), 31 deletions(-)

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
 }
-- 
cgit v0.12