-- 
cgit v0.12

From f0db029a8a8640d92c9f9e3fdd9571c65aa66539 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 6 Sep 2022 00:25:31 +0000
Subject: Add explicit return to most commands.

---
 library/http/http.tcl | 30 +++++++++++++++++++++++++++++-
 1 file changed, 29 insertions(+), 1 deletion(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 48e1b4b..fb30a5e 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -101,6 +101,7 @@ namespace eval http {
 	array set socketWrQueue {}
 	array set socketClosing {}
 	array set socketPlayCmd {}
+	return
     }
     init
 
@@ -230,6 +231,7 @@ proc http::config {args} {
 	    }
 	    set http($flag) $value
 	}
+	return
     }
 }
 
@@ -327,6 +329,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     } {
 	http::CloseQueuedQueries $connId $token
     }
+    return
 }
 
 # http::KeepSocket -
@@ -512,6 +515,7 @@ proc http::KeepSocket {token} {
 	# There is no socketMapping($state(socketinfo)), so it does not matter
 	# that CloseQueuedQueries is not called.
     }
+    return
 }
 
 # http::CheckEof -
@@ -537,6 +541,7 @@ proc http::CheckEof {sock} {
 	# will then be error-handled.
 	CloseSocket $sock
     }
+    return
 }
 
 # http::CloseSocket -
@@ -592,6 +597,7 @@ proc http::CloseSocket {s {token {}}} {
 	    Log "Error closing socket: $err"
 	}
     }
+    return
 }
 
 # http::CloseQueuedQueries
@@ -648,6 +654,7 @@ proc http::CloseQueuedQueries {connId {token {}}} {
 		- token $token
 	{*}$unfinished
     }
+    return
 }
 
 # http::Unset
@@ -673,6 +680,7 @@ proc http::Unset {connId} {
     unset -nocomplain socketWrQueue($connId)
     unset -nocomplain socketClosing($connId)
     unset -nocomplain socketPlayCmd($connId)
+    return
 }
 
 # http::reset --
@@ -698,6 +706,7 @@ proc http::reset {token {why reset}} {
 	unset state
 	eval ::error $errorlist
     }
+    return
 }
 
 # http::geturl --
@@ -1601,6 +1610,7 @@ proc http::Connected {token proto phost srvurl} {
 	    Finish $token $err
 	}
     }
+    return
 }
 
 # http::registerError
@@ -1706,6 +1716,7 @@ proc http::DoneRequest {token} {
 	# In the nonpipeline case, connection for reading always occurs.
 	ReceiveResponse $token
     }
+    return
 }
 
 # http::ReceiveResponse
@@ -1880,6 +1891,7 @@ proc http::NextPipelinedWrite {token} {
 	#Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
 	set socketWrState($connId) peNding
     }
+    return
 }
 
 # http::CancelReadPipeline
@@ -1912,6 +1924,7 @@ proc http::CancelReadPipeline {name1 connId op} {
 	}
 	set socketRdQueue($connId) {}
     }
+    return
 }
 
 # http::CancelWritePipeline
@@ -1945,6 +1958,7 @@ proc http::CancelWritePipeline {name1 connId op} {
 	}
 	set socketWrQueue($connId) {}
     }
+    return
 }
 
 # http::ReplayIfDead --
@@ -2078,6 +2092,7 @@ proc http::ReplayIfDead {tokenArg doing} {
     #   to new values in ReplayCore.
 
     ReplayCore $newQueue
+    return
 }
 
 # http::ReplayIfClose --
@@ -2117,6 +2132,7 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
     # 2. Cleanup - none needed, done by the caller.
 
     ReplayCore $newQueue
+    return
 }
 
 # http::ReInit --
@@ -2323,6 +2339,7 @@ proc http::ReplayCore {newQueue} {
     # Connect does its own fconfigure.
     fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs]
     #Log ---- $sock << conn to $token for HTTP request (e)
+    return
 }
 
 # Data access functions:
@@ -2374,7 +2391,7 @@ proc http::error {token} {
     if {[info exists state(error)]} {
 	return $state(error)
     }
-    return ""
+    return
 }
 
 # http::cleanup
@@ -2400,6 +2417,7 @@ proc http::cleanup {token} {
     if {[info exists state]} {
 	unset state
     }
+    return
 }
 
 # http::Connect
@@ -2443,6 +2461,7 @@ proc http::Connect {token proto phost srvurl} {
 	fileevent $state(sock) writable {}
 	::http::Connected $token $proto $phost $srvurl
     }
+    return
 }
 
 # http::Write
@@ -2547,6 +2566,7 @@ proc http::Write {token} {
 	eval $state(-queryprogress) \
 	    [list $token $state(querylength) $state(queryoffset)]
     }
+    return
 }
 
 # http::Event
@@ -3059,6 +3079,7 @@ proc http::Event {sock token} {
 	    return
 	}
     }
+    return
 }
 
 # http::TestForReplay
@@ -3324,6 +3345,7 @@ proc http::CopyStart {sock token {initial 1}} {
 	    Finish $token $err
 	}
     }
+    return
 }
 
 proc http::CopyChunk {token chunk} {
@@ -3353,6 +3375,7 @@ proc http::CopyChunk {token chunk} {
 	}
 	Eot $token ;# FIX ME: pipelining.
     }
+    return
 }
 
 # http::CopyDone
@@ -3383,6 +3406,7 @@ proc http::CopyDone {token count {error {}}} {
     } else {
 	CopyStart $sock $token 0
     }
+    return
 }
 
 # http::Eot
@@ -3452,6 +3476,7 @@ proc http::Eot {token {reason {}}} {
 	}
     }
     Finish $token $reason
+    return
 }
 
 # http::wait --
@@ -3550,6 +3575,8 @@ proc http::ProxyRequired {host} {
 	    set http(-proxyport) 8080
 	}
 	return [list $http(-proxyhost) $http(-proxyport)]
+    } else {
+	return
     }
 }
 
@@ -3698,6 +3725,7 @@ proc http::GetFieldValue {headers fieldName} {
 proc http::make-transformation-chunked {chan command} {
     coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command
     chan event $chan readable [namespace current]::dechunk$chan
+    return
 }
 
 # Local variables:
-- 
cgit v0.12


From e2d3a22117be56d8e4985323046560db17ad682b Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 6 Sep 2022 01:00:26 +0000
Subject: Refactor some variable, command and coroutine names.

---
 library/http/http.tcl | 126 ++++++++++++++++++++++++--------------------------
 1 file changed, 61 insertions(+), 65 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index fb30a5e..34cad93 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -267,8 +267,8 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	set state(error) [list $errormsg $errorInfo $errorCode]
 	set state(status) "error"
     }
-    if {[info commands ${token}EventCoroutine] ne {}} {
-	rename ${token}EventCoroutine {}
+    if {[info commands ${token}--EventCoroutine] ne {}} {
+	rename ${token}--EventCoroutine {}
     }
 
     # Is this an upgrade request/response?
@@ -387,9 +387,6 @@ proc http::KeepSocket {token} {
 	    # queued, arrange to read it.
 	    set token3 [lindex $socketRdQueue($connId) 0]
 	    set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end]
-	    variable $token3
-	    upvar 0 $token3 state3
-	    set tk2 [namespace tail $token3]
 
 	    #Log pipelined, GRANT read access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
@@ -428,8 +425,7 @@ proc http::KeepSocket {token} {
 	    #   first item in the write queue, a non-pipelined request that is
 	    #   waiting for the read queue to empty.  That has now happened: so
 	    #   give that request read and write access.
-	    variable $token3
-	    set conn [set ${token3}(tmpConnArgs)]
+	    set conn [set ${token3}(connArgs)]
 	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
@@ -473,8 +469,7 @@ proc http::KeepSocket {token} {
 	    # Code:
 	    # - The code is the same as the code below for the nonpipelined
 	    #   case with a queued request.
-	    variable $token3
-	    set conn [set ${token3}(tmpConnArgs)]
+	    set conn [set ${token3}(connArgs)]
 	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
@@ -495,8 +490,7 @@ proc http::KeepSocket {token} {
 	    # If the next request is pipelined, it receives premature read
 	    # access to the socket. This is not a problem.
 	    set token3 [lindex $socketWrQueue($connId) 0]
-	    variable $token3
-	    set conn [set ${token3}(tmpConnArgs)]
+	    set conn [set ${token3}(connArgs)]
 	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
@@ -967,6 +961,9 @@ proc http::geturl {url args} {
     if {![catch {$http(-proxyfilter) $host} proxy]} {
 	set phost [lindex $proxy 0]
 	set pport [lindex $proxy 1]
+    } else {
+	set phost {}
+	set pport {}
     }
 
     # OK, now reassemble into a full URL
@@ -1235,10 +1232,11 @@ proc http::geturl {url args} {
     if {![info exists phost]} {
 	set phost ""
     }
+    set state(connArgs) [list $proto $phost $srvurl]
     if {$reusing} {
 	# For use by http::ReplayIfDead if the persistent connection has died.
 	# Also used by NextPipelinedWrite.
-	set state(tmpConnArgs) [list $proto $phost $srvurl]
+	set state(tmpConnArgs) $state(connArgs)
     }
 
     # The element socketWrState($connId) has a value which is either the name of
@@ -1735,11 +1733,11 @@ proc http::ReceiveResponse {token} {
 		     -buffersize $state(-blocksize)
     Log ^D$tk begin receiving response - token $token
 
-    coroutine ${token}EventCoroutine http::Event $sock $token
+    coroutine ${token}--EventCoroutine http::Event $sock $token
     if {[info exists state(-handler)] || [info exists state(-progress)]} {
         fileevent $sock readable [list http::EventGateway $sock $token]
     } else {
-        fileevent $sock readable ${token}EventCoroutine
+        fileevent $sock readable ${token}--EventCoroutine
     }
     return
 }
@@ -1763,8 +1761,8 @@ proc http::EventGateway {sock token} {
     variable $token
     upvar 0 $token state
     fileevent $sock readable {}
-    catch {${token}EventCoroutine} res opts
-    if {[info commands ${token}EventCoroutine] ne {}} {
+    catch {${token}--EventCoroutine} res opts
+    if {[info commands ${token}--EventCoroutine] ne {}} {
         # The coroutine can be deleted by completion (a non-yield return), by
         # http::Finish (when there is a premature end to the transaction), by
         # http::reset or http::cleanup, or if the caller set option -channel
@@ -1832,7 +1830,7 @@ proc http::NextPipelinedWrite {token} {
     } {
 	# - The usual case for a pipelined connection, ready for a new request.
 	#Log pipelined, GRANT write access to $token2 in NextPipelinedWrite
-	set conn [set ${token2}(tmpConnArgs)]
+	set conn [set ${token2}(connArgs)]
 	set socketWrState($connId) $token2
 	set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	# Connect does its own fconfigure.
@@ -1857,9 +1855,7 @@ proc http::NextPipelinedWrite {token} {
 	# The case in which the next request will be non-pipelined, and the read
 	# and write queues is ready: which is the condition for a non-pipelined
 	# write.
-	variable $token3
-	upvar 0 $token3 state3
-	set conn [set ${token3}(tmpConnArgs)]
+	set conn [set ${token3}(connArgs)]
 	#Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
 	set socketRdState($connId) $token3
 	set socketWrState($connId) $token3
@@ -1981,7 +1977,7 @@ proc http::CancelWritePipeline {name1 connId op} {
 # Side Effects:
 #	Use the same token, but try to open a new socket.
 
-proc http::ReplayIfDead {tokenArg doing} {
+proc http::ReplayIfDead {token doing} {
     variable socketMapping
     variable socketRdState
     variable socketWrState
@@ -1990,10 +1986,10 @@ proc http::ReplayIfDead {tokenArg doing} {
     variable socketClosing
     variable socketPlayCmd
 
-    variable $tokenArg
-    upvar 0 $tokenArg stateArg
+    variable $token
+    upvar 0 $token state
 
-    Log running http::ReplayIfDead for $tokenArg $doing
+    Log running http::ReplayIfDead for $token $doing
 
     # 1. Merge the tokens for transactions in flight, the read (response) queue,
     #    and the write (request) queue.
@@ -2002,85 +1998,85 @@ proc http::ReplayIfDead {tokenArg doing} {
     set InFlightW {}
 
     # Obtain the tokens for transactions in flight.
-    if {$stateArg(-pipeline)} {
+    if {$state(-pipeline)} {
 	# Two transactions may be in flight.  The "read" transaction was first.
 	# It is unlikely that the server would close the socket if a response
 	# was pending; however, an earlier request (as well as the present
 	# request) may have been sent and ignored if the socket was half-closed
 	# by the server.
 
-	if {    [info exists socketRdState($stateArg(socketinfo))]
-	     && ($socketRdState($stateArg(socketinfo)) ne "Rready")
+	if {    [info exists socketRdState($state(socketinfo))]
+	     && ($socketRdState($state(socketinfo)) ne "Rready")
 	} {
-	    lappend InFlightR $socketRdState($stateArg(socketinfo))
+	    lappend InFlightR $socketRdState($state(socketinfo))
 	} elseif {($doing eq "read")} {
-	    lappend InFlightR $tokenArg
+	    lappend InFlightR $token
 	}
 
-	if {    [info exists socketWrState($stateArg(socketinfo))]
-	     && $socketWrState($stateArg(socketinfo)) ni {Wready peNding}
+	if {    [info exists socketWrState($state(socketinfo))]
+	     && $socketWrState($state(socketinfo)) ni {Wready peNding}
 	} {
-	    lappend InFlightW $socketWrState($stateArg(socketinfo))
+	    lappend InFlightW $socketWrState($state(socketinfo))
 	} elseif {($doing eq "write")} {
-	    lappend InFlightW $tokenArg
+	    lappend InFlightW $token
 	}
 
-	# Report any inconsistency of $tokenArg with socket*state.
+	# Report any inconsistency of $token with socket*state.
 	if {    ($doing eq "read")
-	     && [info exists socketRdState($stateArg(socketinfo))]
-	     && ($tokenArg ne $socketRdState($stateArg(socketinfo)))
+	     && [info exists socketRdState($state(socketinfo))]
+	     && ($token ne $socketRdState($state(socketinfo)))
 	} {
-	    Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \
-		    ne socketRdState($stateArg(socketinfo)) \
-		      $socketRdState($stateArg(socketinfo))
+	    Log WARNING - ReplayIfDead pipelined token $token $doing \
+		    ne socketRdState($state(socketinfo)) \
+		      $socketRdState($state(socketinfo))
 
 	} elseif {
 		($doing eq "write")
-	     && [info exists socketWrState($stateArg(socketinfo))]
-	     && ($tokenArg ne $socketWrState($stateArg(socketinfo)))
+	     && [info exists socketWrState($state(socketinfo))]
+	     && ($token ne $socketWrState($state(socketinfo)))
 	} {
-	    Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \
-		    ne socketWrState($stateArg(socketinfo)) \
-		      $socketWrState($stateArg(socketinfo))
+	    Log WARNING - ReplayIfDead pipelined token $token $doing \
+		    ne socketWrState($state(socketinfo)) \
+		      $socketWrState($state(socketinfo))
 	}
     } else {
 	# One transaction should be in flight.
 	# socketRdState, socketWrQueue are used.
 	# socketRdQueue should be empty.
 
-	# Report any inconsistency of $tokenArg with socket*state.
-	if {$tokenArg ne $socketRdState($stateArg(socketinfo))} {
-	    Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \
-		    ne socketRdState($stateArg(socketinfo)) \
-		      $socketRdState($stateArg(socketinfo))
+	# Report any inconsistency of $token with socket*state.
+	if {$token ne $socketRdState($state(socketinfo))} {
+	    Log WARNING - ReplayIfDead nonpipeline token $token $doing \
+		    ne socketRdState($state(socketinfo)) \
+		      $socketRdState($state(socketinfo))
 	}
 
 	# Report the inconsistency that socketRdQueue is non-empty.
-	if {    [info exists socketRdQueue($stateArg(socketinfo))]
-	     && ($socketRdQueue($stateArg(socketinfo)) ne {})
+	if {    [info exists socketRdQueue($state(socketinfo))]
+	     && ($socketRdQueue($state(socketinfo)) ne {})
 	} {
-	    Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \
-		    has read queue socketRdQueue($stateArg(socketinfo)) \
-		    $socketRdQueue($stateArg(socketinfo)) ne {}
+	    Log WARNING - ReplayIfDead nonpipeline token $token $doing \
+		    has read queue socketRdQueue($state(socketinfo)) \
+		    $socketRdQueue($state(socketinfo)) ne {}
 	}
 
-	lappend InFlightW $socketRdState($stateArg(socketinfo))
-	set socketRdQueue($stateArg(socketinfo)) {}
+	lappend InFlightW $socketRdState($state(socketinfo))
+	set socketRdQueue($state(socketinfo)) {}
     }
 
     set newQueue {}
     lappend newQueue {*}$InFlightR
-    lappend newQueue {*}$socketRdQueue($stateArg(socketinfo))
+    lappend newQueue {*}$socketRdQueue($state(socketinfo))
     lappend newQueue {*}$InFlightW
-    lappend newQueue {*}$socketWrQueue($stateArg(socketinfo))
+    lappend newQueue {*}$socketWrQueue($state(socketinfo))
 
 
-    # 2. Tidy up tokenArg.  This is a cut-down form of Finish/CloseSocket.
+    # 2. Tidy up token.  This is a cut-down form of Finish/CloseSocket.
     #    Do not change state(status).
-    #    No need to after cancel stateArg(after) - either this is done in
+    #    No need to after cancel state(after) - either this is done in
     #    ReplayCore/ReInit, or Finish is called.
 
-    catch {close $stateArg(sock)}
+    catch {close $state(sock)}
 
     # 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit.
     # - Transactions, if any, that are awaiting responses cannot be completed.
@@ -2407,8 +2403,8 @@ proc http::error {token} {
 proc http::cleanup {token} {
     variable $token
     upvar 0 $token state
-    if {[info commands ${token}EventCoroutine] ne {}} {
-	rename ${token}EventCoroutine {}
+    if {[info commands ${token}--EventCoroutine] ne {}} {
+	rename ${token}--EventCoroutine {}
     }
     if {[info exists state(after)]} {
 	after cancel $state(after)
@@ -2572,7 +2568,7 @@ proc http::Write {token} {
 # http::Event
 #
 #	Handle input on the socket. This command is the core of
-#	the coroutine commands ${token}EventCoroutine that are
+#	the coroutine commands ${token}--EventCoroutine that are
 #	bound to "fileevent $sock readable" and process input.
 #
 # Arguments
@@ -2823,7 +2819,7 @@ proc http::Event {sock token} {
 		    if {![info exists state(-handler)]} {
 			# Initiate a sequence of background fcopies.
 			fileevent $sock readable {}
-			rename ${token}EventCoroutine {}
+			rename ${token}--EventCoroutine {}
 			CopyStart $sock $token
 			return
 		    }
-- 
cgit v0.12


From 5b6aa149be96496401121819fd44e5b1d5f923a5 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 6 Sep 2022 01:53:02 +0000
Subject: Minor bugfixes, improvments to layout, comments, logging.

---
 library/http/http.tcl | 65 ++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 46 insertions(+), 19 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 34cad93..ce337e6 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -224,6 +224,9 @@ proc http::config {args} {
 	    return -code error "Unknown option $flag, must be: $usage"
 	}
 	return $http($flag)
+    } elseif {[llength $args] % 2} {
+	return -code error "If more than one argument is supplied, the\
+		number of arguments must be even"
     } else {
 	foreach {flag value} $args {
 	    if {![regexp -- $pat $flag]} {
@@ -273,10 +276,15 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 
     # Is this an upgrade request/response?
     set upgradeResponse \
-	[expr {    [info exists state(upgradeRequest)] && $state(upgradeRequest)
-		&& [info exists state(http)] && [ncode $token] eq {101}
-		&& [info exists state(connection)] && "upgrade" in $state(connection)
-		&& [info exists state(upgrade)] && "" ne $state(upgrade)}]
+	[expr {    [info exists state(upgradeRequest)]
+		&& $state(upgradeRequest)
+		&& [info exists state(http)]
+		&& ([ncode $token] eq {101})
+		&& [info exists state(connection)]
+		&& ("upgrade" in $state(connection))
+		&& [info exists state(upgrade)]
+		&& ("" ne $state(upgrade))
+	}]
 
     if {  ($state(status) eq "timeout")
        || ($state(status) eq "error")
@@ -328,6 +336,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	 && ($socketMapping($connId) eq $sock)
     } {
 	http::CloseQueuedQueries $connId $token
+	# This calls Unset.  Other cases do not need the call.
     }
     return
 }
@@ -579,16 +588,19 @@ proc http::CloseSocket {s {token {}}} {
 	Log "Closing connection $connId (sock $socketMapping($connId))"
 	if {[catch {close $socketMapping($connId)} err]} {
 	    Log "Error closing connection: $err"
+	} else {
 	}
 	if {$token eq {}} {
 	    # Cases with a non-empty token are handled by Finish, so the tokens
 	    # are finished in connection order.
 	    http::CloseQueuedQueries $connId
+	} else {
 	}
     } else {
 	Log "Closing socket $s (no connection info)"
 	if {[catch {close $s} err]} {
 	    Log "Error closing socket: $err"
+	} else {
 	}
     }
     return
@@ -611,6 +623,7 @@ proc http::CloseQueuedQueries {connId {token {}}} {
     variable socketClosing
     variable socketPlayCmd
 
+    ##Log CloseQueuedQueries $connId
     if {![info exists socketMapping($connId)]} {
 	# Command has already been called.
 	# Don't come here again - especially recursively.
@@ -645,7 +658,7 @@ proc http::CloseQueuedQueries {connId {token {}}} {
 
     if {$unfinished ne {}} {
 	Log ^R$tk Any unfinished transactions (excluding $token) failed \
-		- token $token
+		- token $token - unfinished $unfinished
 	{*}$unfinished
     }
     return
@@ -796,8 +809,8 @@ proc http::geturl {url args} {
 	    }
 	    if {($flag eq "-headers") && ([llength $value] % 2 != 0)} {
 		unset $token
-		return -code error \
-		    "Bad value for $flag ($value), number of list elements must be even"
+		return -code error "Bad value for $flag ($value), number\
+			of list elements must be even"
 	    }
 	    set state($flag) $value
 	} else {
@@ -1084,14 +1097,17 @@ proc http::geturl {url args} {
 		# causes a call to Finish.
 		set reusing 1
 		set sock $socketMapping($state(socketinfo))
-		Log "reusing socket $sock for $state(socketinfo) - token $token"
+		Log "reusing closing socket $sock for $state(socketinfo) - token $token"
 
 		set alreadyQueued 1
 		lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3
 		lappend com3 $token
 		set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3]
 		lappend socketWrQueue($state(socketinfo)) $token
+		##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo))
+		##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo))
 	    } elseif {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
+		###Log "Socket $socketMapping($state(socketinfo)) for $state(socketinfo)"
 		# FIXME Is it still possible for this code to be executed? If
 		#       so, this could be another place to call TestForReplay,
 		#       rather than discarding the queued transactions.
@@ -1105,14 +1121,13 @@ proc http::geturl {url args} {
 		Unset $state(socketinfo)
 	    } else {
 		# Use the persistent socket.
-		# The socket may not be ready to write: an earlier request might
-		# still be still writing (in the pipelined case) or
-		# writing/reading (in the nonpipeline case). This possibility
-		# is handled by socketWrQueue later in this command.
+		# - The socket may not be ready to write: an earlier request might
+		#   still be still writing (in the pipelined case) or
+		#   writing/reading (in the nonpipeline case). This possibility
+		#   is handled by socketWrQueue later in this command.
 		set reusing 1
 		set sock $socketMapping($state(socketinfo))
-		Log "reusing socket $sock for $state(socketinfo) - token $token"
-
+		Log "reusing open socket $sock for $state(socketinfo) - token $token"
 	    }
 	    # Do not automatically close the connection socket.
 	    set state(connection) keep-alive
@@ -1315,7 +1330,17 @@ proc http::geturl {url args} {
 		[list http::Connect $token $proto $phost $srvurl]
     }
 
-    # Wait for the connection to complete.
+    # --------------------------------------------------------------------------
+    # Synchronous Call to http::geturl
+    # --------------------------------------------------------------------------
+    # - If the call to http::geturl is asynchronous, it is now complete (apart
+    #   from delivering the return value).
+    # - If the call to http::geturl is synchronous, the command must now wait
+    #   for the HTTP transaction to be completed.  The call to http::wait uses
+    #   vwait, which may be inappropriate if the caller makes other HTTP
+    #   requests in the background.
+    # --------------------------------------------------------------------------
+
     if {![info exists state(-command)]} {
 	# geturl does EVERYTHING asynchronously, so if the user
 	# calls it synchronously, we just do a wait here.
@@ -2077,6 +2102,7 @@ proc http::ReplayIfDead {token doing} {
     #    ReplayCore/ReInit, or Finish is called.
 
     catch {close $state(sock)}
+    Unset $state(socketinfo)
 
     # 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit.
     # - Transactions, if any, that are awaiting responses cannot be completed.
@@ -2119,7 +2145,7 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
     if {$Wstate ni {Wready peNding}} {
 	lappend InFlightW $Wstate
     }
-
+    ##Log $Rqueue -- $InFlightW -- $Wqueue
     set newQueue {}
     lappend newQueue {*}$Rqueue
     lappend newQueue {*}$InFlightW
@@ -2318,7 +2344,7 @@ proc http::ReplayCore {newQueue} {
 	} else {
 	    set ${tok}(reusing) 1
 	    set ${tok}(sock) NONE
-	    Finish $token {cannot send this request again}
+	    Finish $tok {cannot send this request again}
 	}
     }
 
@@ -2745,7 +2771,8 @@ proc http::Event {sock token} {
 				{ReplayIfClose Wready {} {}}
 		    }
 
-		    # Do not allow further connections on this socket.
+		    # Do not allow further connections on this socket (but
+		    # geturl can add new requests to the replay).
 		    set socketClosing($state(socketinfo)) 1
 		}
 
@@ -3318,7 +3345,7 @@ proc http::BlockingGets {sock} {
 #	This closes the connection upon error
 
 proc http::CopyStart {sock token {initial 1}} {
-    upvar #0 $token state
+    upvar 0 $token state
     if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
 	foreach coding [ContentEncoding $token] {
 	    lappend state(zlib) [zlib stream $coding]
-- 
cgit v0.12


From 79d5320ceb313aa0509fd80893563022e1e2093e Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 6 Sep 2022 04:06:21 +0000
Subject: Revise http::geturl to open its socket in an idletask coroutine. 
 This is preparation for a workaround to bug 824251.  Revise test http-4.15
 because error message has changed.  This commit passes all tests.

---
 library/http/http.tcl | 895 +++++++++++++++++++++++++++++++++++++-------------
 tests/http.test       |   6 +-
 2 files changed, 665 insertions(+), 236 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index ce337e6..c3679f1 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -70,8 +70,10 @@ namespace eval http {
 	variable socketWrState
 	variable socketRdQueue
 	variable socketWrQueue
+	variable socketPhQueue
 	variable socketClosing
 	variable socketPlayCmd
+	variable socketCoEvent
 	if {[info exists socketMapping]} {
 	    # Close open sockets on re-init.  Do not permit retries.
 	    foreach {url sock} [array get socketMapping] {
@@ -92,15 +94,19 @@ namespace eval http {
 	array unset socketWrState
 	array unset socketRdQueue
 	array unset socketWrQueue
+	array unset socketPhQueue
 	array unset socketClosing
 	array unset socketPlayCmd
+	array unset socketCoEvent
 	array set socketMapping {}
 	array set socketRdState {}
 	array set socketWrState {}
 	array set socketRdQueue {}
 	array set socketWrQueue {}
+	array set socketPhQueue {}
 	array set socketClosing {}
 	array set socketPlayCmd {}
+	array set socketCoEvent {}
 	return
     }
     init
@@ -141,6 +147,8 @@ namespace eval http {
 	)?
     }
 
+    variable TmpSockCounter 0
+
     namespace export geturl config reset wait formatQuery quoteString
     namespace export register unregister registerError
     # - Useful, but not exported: data, size, status, code, cleanup, error,
@@ -259,8 +267,10 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     variable $token
     upvar 0 $token state
@@ -273,6 +283,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     if {[info commands ${token}--EventCoroutine] ne {}} {
 	rename ${token}--EventCoroutine {}
     }
+    if {[info commands ${token}--SocketCoroutine] ne {}} {
+	rename ${token}--SocketCoroutine {}
+    }
 
     # Is this an upgrade request/response?
     set upgradeResponse \
@@ -292,8 +305,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     } {
 	set closeQueue 1
 	set connId $state(socketinfo)
-	set sock $state(sock)
-	CloseSocket $state(sock) $token
+	if {[info exists state(sock)]} {
+	    set sock $state(sock)
+	    CloseSocket $state(sock) $token
+	} else {
+            # When opening the socket and calling http::reset
+            # immediately, the socket may not yet exist.
+            # Test http-4.11 may come here.
+	}
     } elseif {$upgradeResponse} {
 	# Special handling for an upgrade request/response.
 	# - geturl ensures that this is not a "persistent" socket used for
@@ -310,8 +329,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     } {
 	set closeQueue 1
 	set connId $state(socketinfo)
-	set sock $state(sock)
-	CloseSocket $state(sock) $token
+	if {[info exists state(sock)]} {
+	    set sock $state(sock)
+	    CloseSocket $state(sock) $token
+	} else {
+            # When opening the socket and calling http::reset
+            # immediately, the socket may not yet exist.
+            # Test http-4.11 may come here.
+	}
     } elseif {
 	  ([info exists state(-keepalive)] && $state(-keepalive))
        && ([info exists state(connection)] && ("close" ni $state(connection)))
@@ -360,8 +385,10 @@ proc http::KeepSocket {token} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     variable $token
     upvar 0 $token state
@@ -560,8 +587,10 @@ proc http::CloseSocket {s {token {}}} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     set tk [namespace tail $token]
 
@@ -620,8 +649,10 @@ proc http::CloseQueuedQueries {connId {token {}}} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     ##Log CloseQueuedQueries $connId
     if {![info exists socketMapping($connId)]} {
@@ -677,8 +708,10 @@ proc http::Unset {connId} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     unset socketMapping($connId)
     unset socketRdState($connId)
@@ -729,11 +762,74 @@ proc http::reset {token {why reset}} {
 #	array that the caller should unset to garbage collect the state.
 
 proc http::geturl {url args} {
+    set token [CreateToken $url {*}$args]
+    variable $token
+    upvar 0 $token state
+
+    AsyncTransaction $token
+
+    # --------------------------------------------------------------------------
+    # Synchronous Call to http::geturl
+    # --------------------------------------------------------------------------
+    # - If the call to http::geturl is asynchronous, it is now complete (apart
+    #   from delivering the return value).
+    # - If the call to http::geturl is synchronous, the command must now wait
+    #   for the HTTP transaction to be completed.  The call to http::wait uses
+    #   vwait, which may be inappropriate if the caller makes other HTTP
+    #   requests in the background.
+    # --------------------------------------------------------------------------
+
+    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]} {
+	    # If we timed out then Finish has been called and the users
+	    # command callback may have cleaned up the token. If so we end up
+	    # here with nothing left to do.
+	    return $token
+	} elseif {$state(status) eq "error"} {
+	    # Something went wrong while trying to establish the connection.
+	    # 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.
+	    set err [lindex $state(error) 0]
+	    cleanup $token
+	    return -code error $err
+	}
+    }
+
+    return $token
+}
+
+# ------------------------------------------------------------------------------
+#  Proc http::CreateToken
+# ------------------------------------------------------------------------------
+# Command to convert arguments into an initialised request token.
+# The return value is the variable name of the token.
+#
+# Other effects:
+# - Sets ::http::http(uid) if not already done
+# - Increments ::http::http(uid)
+# - May increment ::http::TmpSockCounter
+# - Alters ::http::socketPlayCmd, ::http::socketWrQueue if a -keepalive 1
+#   request is appended to the queue of a persistent socket that is already
+#   scheduled to close.
+#   This also sets state(alreadyQueued) to 1.
+# - Alters ::http::socketPhQueue if a -keepalive 1 request is appended to the
+#   queue of a persistent socket that has not yet been created (and is therefore
+#   represented by a placeholder).
+#   This also sets state(ReusingPlaceholder) to 1.
+# ------------------------------------------------------------------------------
+
+proc http::CreateToken {url args} {
     variable http
     variable urlTypes
     variable defaultCharset
     variable defaultKeepalive
     variable strict
+    variable TmpSockCounter
 
     # Initialize the state variable, an array. We'll return the name of this
     # array as the token for the transaction.
@@ -993,17 +1089,6 @@ proc http::geturl {url args} {
     # Don't append the fragment!
     set state(url) $url
 
-    set sockopts [list -async]
-
-    # If we are using the proxy, we must pass in the full URL that includes
-    # the server name.
-
-    if {[info exists phost] && ($phost ne "")} {
-	set srvurl $url
-	set targetAddr [list $phost $pport]
-    } else {
-	set targetAddr [list $host $port]
-    }
     # Proxy connections aren't shared among different hosts.
     set state(socketinfo) $host:$port
 
@@ -1057,6 +1142,25 @@ proc http::geturl {url args} {
 	set state(-keepalive) 0
     }
 
+    # If we are using the proxy, we must pass in the full URL that includes
+    # the server name.
+    if {$phost ne ""} {
+	set srvurl $url
+	set targetAddr [list $phost $pport]
+    } else {
+	set targetAddr [list $host $port]
+    }
+
+    set sockopts [list -async]
+
+    # Pass -myaddr directly to the socket command
+    if {[info exists state(-myaddr)]} {
+	lappend sockopts -myaddr $state(-myaddr)
+    }
+
+    set state(connArgs) [list $proto $phost $srvurl]
+    set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr]
+
     # See if we are supposed to use a previously opened channel.
     # - In principle, ANY call to http::geturl could use a previously opened
     #   channel if it is available - the "Connection: keep-alive" header is a
@@ -1066,15 +1170,18 @@ proc http::geturl {url args} {
     #   $state(socketinfo). This property simplifies the mapping of open
     #   channels.
     set reusing 0
-    set alreadyQueued 0
+    set state(alreadyQueued) 0
+    set state(ReusingPlaceholder) 0
     if {$state(-keepalive)} {
 	variable socketMapping
 	variable socketRdState
 	variable socketWrState
 	variable socketRdQueue
 	variable socketWrQueue
+	variable socketPhQueue
 	variable socketClosing
 	variable socketPlayCmd
+	variable socketCoEvent
 
 	if {[info exists socketMapping($state(socketinfo))]} {
 	    # - If the connection is idle, it has a "fileevent readable" binding
@@ -1099,14 +1206,16 @@ proc http::geturl {url args} {
 		set sock $socketMapping($state(socketinfo))
 		Log "reusing closing socket $sock for $state(socketinfo) - token $token"
 
-		set alreadyQueued 1
+		set state(alreadyQueued) 1
 		lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3
 		lappend com3 $token
 		set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3]
 		lappend socketWrQueue($state(socketinfo)) $token
 		##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo))
 		##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo))
-	    } elseif {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
+	    } elseif {   [catch {fconfigure $socketMapping($state(socketinfo))}]
+	              && (![SockIsPlaHolder $socketMapping($state(socketinfo))])
+	    } {
 		###Log "Socket $socketMapping($state(socketinfo)) for $state(socketinfo)"
 		# FIXME Is it still possible for this code to be executed? If
 		#       so, this could be another place to call TestForReplay,
@@ -1125,8 +1234,14 @@ proc http::geturl {url args} {
 		#   still be still writing (in the pipelined case) or
 		#   writing/reading (in the nonpipeline case). This possibility
 		#   is handled by socketWrQueue later in this command.
+		# - The socket may not yet exist, and be defined with a placeholder.
 		set reusing 1
 		set sock $socketMapping($state(socketinfo))
+		if {[SockIsPlaHolder $sock]} {
+		    set state(ReusingPlaceholder) 1
+		    lappend socketPhQueue($sock) $token
+		} else {
+		}
 		Log "reusing open socket $sock for $state(socketinfo) - token $token"
 	    }
 	    # Do not automatically close the connection socket.
@@ -1134,29 +1249,94 @@ proc http::geturl {url args} {
 	}
     }
 
-    if {$reusing} {
-	# Define state(tmpState) and state(tmpOpenCmd) for use
-	# by http::ReplayIfDead if the persistent connection has died.
-	set state(tmpState) [array get state]
+    set state(reusing) $reusing
+    unset reusing
 
-	# Pass -myaddr directly to the socket command
-	if {[info exists state(-myaddr)]} {
-	    lappend sockopts -myaddr $state(-myaddr)
-	}
+    if {![info exists sock]} {
+        # N.B. At this point ([info exists sock] == $state(reusing)).
+        # This will no longer be true after we set a value of sock here.
+	# Give the socket a placeholder name.
+	set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
+    }
+    set state(sock) $sock
 
-	set state(tmpOpenCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr]
+    if {$state(reusing)} {
+	# Define these for use (only) by http::ReplayIfDead if the persistent
+	# connection has died.
+	set state(tmpConnArgs) $state(connArgs)
+	set state(tmpState) [array get state]
+	set state(tmpOpenCmd) $state(openCmd)
     }
+    return $token
+}
 
-    set state(reusing) $reusing
-    # Excluding ReplayIfDead and the decision whether to call it, there are four
-    # places outside http::geturl where state(reusing) is used:
-    # - Connected   - if reusing and not pipelined, start the state(-timeout)
-    #                 timeout (when writing).
-    # - DoneRequest - if reusing and pipelined, send the next pipelined write
-    # - Event       - if reusing and pipelined, start the state(-timeout)
-    #                 timeout (when reading).
-    # - Event       - if (not reusing) and pipelined, send the next pipelined
-    #                 write
+
+# ------------------------------------------------------------------------------
+#  Proc ::http::SockIsPlaHolder
+# ------------------------------------------------------------------------------
+# Command to return 0 if the argument is a genuine socket handle, or 1 if is a
+# placeholder value generated by geturl or ReplayCore before the real socket is
+# created.
+#
+# Arguments:
+# sock        - either a valid socket handle or a placeholder value
+#
+# Return Value: 0 or 1
+# ------------------------------------------------------------------------------
+
+proc http::SockIsPlaHolder {sock} {
+    expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}}
+}
+
+
+# ------------------------------------------------------------------------------
+# state(reusing)
+# ------------------------------------------------------------------------------
+# - state(reusing) is set by geturl, ReplayCore
+# - state(reusing) is used by geturl, AsyncTransaction, OpenSocket,
+#   ConfigureNewSocket, and ScheduleRequest when creating and configuring the
+#   connection.
+# - state(reusing) is used by Connect, Connected, Event x 2 when deciding
+#   whether to call TestForReplay.
+# - Other places where state(reusing) is used:
+#   - Connected   - if reusing and not pipelined, start the state(-timeout)
+#                   timeout (when writing).
+#   - DoneRequest - if reusing and pipelined, send the next pipelined write
+#   - Event       - if reusing and pipelined, start the state(-timeout)
+#                   timeout (when reading).
+#   - Event       - if (not reusing) and pipelined, send the next pipelined
+#                   write.
+# ------------------------------------------------------------------------------
+
+
+# ------------------------------------------------------------------------------
+#  Proc http::AsyncTransaction
+# ------------------------------------------------------------------------------
+# This command is called by geturl and ReplayCore to prepare the HTTP
+# transaction prescribed by a suitably prepared token.
+#
+# Arguments:
+# token         - connection token (name of an array)
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::AsyncTransaction {token} {
+    variable $token
+    upvar 0 $token state
+    set tk [namespace tail $token]
+
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketPhQueue
+    variable socketClosing
+    variable socketPlayCmd
+    variable socketCoEvent
+
+    set sock $state(sock)
 
     # See comments above re the start of this timeout in other cases.
     if {(!$state(reusing)) && ($state(-timeout) > 0)} {
@@ -1164,29 +1344,185 @@ proc http::geturl {url args} {
 		[list http::reset $token timeout]]
     }
 
-    if {![info exists sock]} {
-	# Pass -myaddr directly to the socket command
-	if {[info exists state(-myaddr)]} {
-	    lappend sockopts -myaddr $state(-myaddr)
-	}
+    if {    $state(-keepalive)
+	 && (![info exists socketMapping($state(socketinfo))])
+    } {
+	# This code is executed only for the first -keepalive request on a
+	# socket.  It makes the socket persistent.
+	##Log "  PreparePersistentConnection" $token -- $sock -- DO
+        set DoLater [PreparePersistentConnection $token]
+    } else {
+        ##Log "  PreparePersistentConnection" $token -- $sock -- SKIP
+        set DoLater {-traceread 0 -tracewrite 0}
+    }
+
+    if {$state(ReusingPlaceholder)} {
+        # - This request is scheduled to re-use a persistent connection;
+        # - But the connection has not yet been created and is a placeholder;
+        # - And the placeholder was created by an earlier request.
+        # - When that earlier request calls OpenSocket, its placeholder is
+        #   replaced with a true socket, and it then executes the equivalent of
+        #   OpenSocket for any subsequent requests that have
+        #   $state(ReusingPlaceholder).
+        Log >J$tk after idle coro NO - ReusingPlaceholder
+    } else {
+        Log >J$tk after idle coro YES
+        # Called if (not reusing) || (socket is not a placeholder).
+        set CoroName ${token}--SocketCoroutine
+        set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
+                $token $DoLater]]
+        dict set socketCoEvent($state(socketinfo)) $token $cancel
+    }
+
+    return
+}
+
+
+# ------------------------------------------------------------------------------
+#  Proc http::PreparePersistentConnection
+# ------------------------------------------------------------------------------
+# This command is called by AsyncTransaction to initialise a "persistent
+# connection" based upon a socket placeholder.  It is called the first time the
+# socket is associated with a "-keepalive" request.
+#
+# Arguments:
+# token         - connection token (name of an array)
+#
+# Return Value: - DoLater, a dictionary of boolean values listing unfinished
+#                 tasks; to be passed to ConfigureNewSocket via OpenSocket.
+# ------------------------------------------------------------------------------
+
+proc http::PreparePersistentConnection {token} {
+    variable $token
+    upvar 0 $token state
+
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketPhQueue
+    variable socketClosing
+    variable socketPlayCmd
+    variable socketCoEvent
+
+    set DoLater {-traceread 0 -tracewrite 0}
+    set socketMapping($state(socketinfo)) $state(sock)
+
+    if {![info exists socketRdState($state(socketinfo))]} {
+        set socketRdState($state(socketinfo)) {}
+        # set varName ::http::socketRdState($state(socketinfo))
+        # trace add variable $varName unset ::http::CancelReadPipeline
+        dict set DoLater -traceread 1
+    }
+    if {![info exists socketWrState($state(socketinfo))]} {
+        set socketWrState($state(socketinfo)) {}
+        # set varName ::http::socketWrState($state(socketinfo))
+        # trace add variable $varName unset ::http::CancelWritePipeline
+        dict set DoLater -tracewrite 1
+    }
+
+    if {$state(-pipeline)} {
+        #Log new, init for pipelined, GRANT write access to $token in geturl
+        # Also grant premature read access to the socket. This is OK.
+        set socketRdState($state(socketinfo)) $token
+        set socketWrState($state(socketinfo)) $token
+    } else {
+        # socketWrState is not used by this non-pipelined transaction.
+        # We cannot leave it as "Wready" because the next call to
+        # http::geturl with a pipelined transaction would conclude that the
+        # socket is available for writing.
+        #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
+        set socketRdState($state(socketinfo)) $token
+        set socketWrState($state(socketinfo)) $token
+    }
+
+    set socketRdQueue($state(socketinfo)) {}
+    set socketWrQueue($state(socketinfo)) {}
+    set socketPhQueue($state(socketinfo)) {}
+    set socketClosing($state(socketinfo)) 0
+    set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
+    set socketCoEvent($state(socketinfo)) {}
+
+    return $DoLater
+}
+
+# ------------------------------------------------------------------------------
+#  Proc ::http::OpenSocket
+# ------------------------------------------------------------------------------
+# This command is called as a coroutine idletask to start the asynchronous HTTP
+# transaction in most cases.  For the exceptions, see the calling code in
+# command AsyncTransaction.
+#
+# Arguments:
+# token       - connection token (name of an array)
+# DoLater     - dictionary of boolean values listing unfinished tasks
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::OpenSocket {token DoLater} {
+    variable $token
+    upvar 0 $token state
+    set tk [namespace tail $token]
+
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketPhQueue
+    variable socketClosing
+    variable socketPlayCmd
+    variable socketCoEvent
+
+    Log >K$tk Start OpenSocket coroutine
+
+    if {![info exists state(-keepalive)]} {
+        # The request has already been cancelled by the calling script.
+        return
+    }
+
+    set sockOld $state(sock)
+
+    dict unset socketCoEvent($state(socketinfo)) $token
+
+    set reusing $state(reusing)
+
+    if {$reusing} {
+	# If ($reusing) is true, then we do not need to create a new socket,
+	# even if $sockOld is only a placeholder for a socket.
+        set sock $sockOld
+    } else {
+	# set sock in the [catch] below.
 	set pre [clock milliseconds]
 	##Log pre socket opened, - token $token
-	##Log [concat $defcmd $sockopts $targetAddr] - token $token
-	if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} {
+	##Log $state(openCmd) - token $token
+	if {[catch {eval $state(openCmd)} sock errdict]} {
+	    # ERROR CASE
 	    # Something went wrong while trying to establish the connection.
-	    # 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.
+	    # Tidy up after events and such, but DON'T call the command
+	    # callback (if available).
+	    # - When this was inline code in http::geturl, it threw an exception
+	    #   from here instead.
+	    # - Now that this code is called from geturl as an idletask and not
+	    #   as inline code, it is inappropriate to run cleanup or throw an
+	    #   exception.  Instead do a normal return, and let Finish report
+	    #   the error using token/state and the -command callback.
+	    #   Finish also undoes PreparePersistentConnection.
 
 	    set state(sock) NONE
-	    Finish $token $sock 1
-	    cleanup $token
-	    dict unset errdict -level
-	    return -options $errdict $sock
+	    set ::errorInfo [dict get $errdict -errorinfo]
+	    set ::errorCode [dict get $errdict -errorcode]
+	    Finish $token $sock
+	    # cleanup $token
+	    return
 	} else {
+	    # Normal return from $state(openCmd) always returns a valid socket.
 	    # Initialisation of a new socket.
 	    ##Log post socket opened, - token $token
 	    ##Log socket opened, now fconfigure - token $token
+	    set state(sock) $sock
 	    set delay [expr {[clock milliseconds] - $pre}]
 	    if {$delay > 3000} {
 		Log socket delay $delay - token $token
@@ -1196,84 +1532,220 @@ proc http::geturl {url args} {
 	    ##Log socket opened, DONE fconfigure - token $token
 	}
     }
-    # Command [socket] is called with -async, but takes 5s to 5.1s to return,
-    # with probability of order 1 in 10,000.  This may be a bizarre scheduling
-    # issue with my (KJN's) system (Fedora Linux).
-    # This does not cause a problem (unless the request times out when this
-    # command returns).
 
-    set state(sock) $sock
     Log "Using $sock for $state(socketinfo) - token $token" \
 	[expr {$state(-keepalive)?"keepalive":""}]
 
-    if {    $state(-keepalive)
-	 && (![info exists socketMapping($state(socketinfo))])
-    } {
-	# Freshly-opened socket that we would like to become persistent.
-	set socketMapping($state(socketinfo)) $sock
+    # Code above has set state(sock) $sock
+    ConfigureNewSocket $token $sockOld $DoLater
+
+    ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token
+    return
+}
+
+
+# ------------------------------------------------------------------------------
+#  Proc ::http::ConfigureNewSocket
+# ------------------------------------------------------------------------------
+# Command to initialise a newly-created socket.  Called only from OpenSocket.
+#
+# This command is called by OpenSocket whenever a genuine socket (sockNew) has
+# been opened for for use by HTTP.  It does two things:
+# (1) If $token uses a placeholder socket, this command replaces the placeholder
+#     socket with the real socket, not only in $token but in all other requests
+#     that use the same placeholder.
+# (2) It calls ScheduleRequest to schedule each request that uses the socket.
+# 
+#
+# Value of sockOld/sockNew can be "sock" (genuine socket) or "ph" (placeholder).
+# sockNew is ${token}(sock)
+# sockOld   sockNew  CASES
+#  sock       sock   (if $reusing, and sockOld is sock)
+#  ph         sock   (if (not $reusing), and sockOld is ph)
+#  ph         ph     (if $reusing, and sockOld is ph) - not called in this case
+#  sock       ph     (cannot occur unless a bug)      - not called in this case
+#                    (if (not $reusing), and sockOld is sock) - illogical
+#
+# Arguments:
+# token         - connection token (name of an array)
+# sockOld       - handle or placeholder used for a socket before the call to OpenSocket
+# DoLater       - dictionary of boolean values listing unfinished tasks
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::ConfigureNewSocket {token sockOld DoLater} {
+    variable $token
+    upvar 0 $token state
+    set tk [namespace tail $token]
+
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketPhQueue
+    variable socketClosing
+    variable socketPlayCmd
+    variable socketCoEvent
+
+    ##Log "  ConfigureNewSocket" $token $sockOld $sock ...
+
+    set reusing $state(reusing)
+    set sock $state(sock)
+
+    if {(!$reusing) && ($sock ne $sockOld)} {
+        # Replace the placeholder value sockOld with sock.
 
-	if {![info exists socketRdState($state(socketinfo))]} {
-	    set socketRdState($state(socketinfo)) {}
+        if {    [info exists socketMapping($state(socketinfo))]
+             && ($socketMapping($state(socketinfo)) eq $sockOld)
+        } {
+            set socketMapping($state(socketinfo)) $sock
+            ##Log set socketMapping($state(socketinfo)) $sock
+        }
+
+        # Now finish any tasks left over from PreparePersistentConnection on
+        # the connection.
+        #
+        # The "unset" traces are fired by init (clears entire arrays), and
+        # by http::Unset.
+        # Unset is called by CloseQueuedQueries and (possibly never) by geturl.
+        #
+        # CancelReadPipeline, CancelWritePipeline call http::Finish for each
+        # token.
+        #
+        # FIXME If Finish is placeholder-aware, these traces can be set earlier,
+        # in PreparePersistentConnection.
+    
+        if {[dict get $DoLater -traceread]} {
 	    set varName ::http::socketRdState($state(socketinfo))
 	    trace add variable $varName unset ::http::CancelReadPipeline
-	}
-	if {![info exists socketWrState($state(socketinfo))]} {
-	    set socketWrState($state(socketinfo)) {}
+        }
+        if {[dict get $DoLater -tracewrite]} {
 	    set varName ::http::socketWrState($state(socketinfo))
 	    trace add variable $varName unset ::http::CancelWritePipeline
-	}
+        }
+    }
 
-	if {$state(-pipeline)} {
-	    #Log new, init for pipelined, GRANT write access to $token in geturl
-	    # Also grant premature read access to the socket. This is OK.
-	    set socketRdState($state(socketinfo)) $token
-	    set socketWrState($state(socketinfo)) $token
-	} else {
-	    # socketWrState is not used by this non-pipelined transaction.
-	    # We cannot leave it as "Wready" because the next call to
-	    # http::geturl with a pipelined transaction would conclude that the
-	    # socket is available for writing.
-	    #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
-	    set socketRdState($state(socketinfo)) $token
-	    set socketWrState($state(socketinfo)) $token
-	}
+    # Do this in all cases.
+    ScheduleRequest $token
 
-	set socketRdQueue($state(socketinfo)) {}
-	set socketWrQueue($state(socketinfo)) {}
-	set socketClosing($state(socketinfo)) 0
-	set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
-    }
+    # Now look at all other tokens that use the placeholder $sockOld.
+    if {    (!$reusing)
+         && ($sock ne $sockOld)
+         && [info exists socketPhQueue($sockOld)]
+    } {
+        foreach tok $socketPhQueue($sockOld) {
+	    # 1. Amend the token's (sock).
+	    ##Log set ${tok}(sock) $sock
+	    set ${tok}(sock) $sock
 
-    if {![info exists phost]} {
-	set phost ""
-    }
-    set state(connArgs) [list $proto $phost $srvurl]
-    if {$reusing} {
-	# For use by http::ReplayIfDead if the persistent connection has died.
-	# Also used by NextPipelinedWrite.
-	set state(tmpConnArgs) $state(connArgs)
+	    # 2. Schedule the token's HTTP request.
+	    # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0.
+	    set ${tok}(reusing) 1
+	    set ${tok}(alreadyQueued) 0
+	    ScheduleRequest $tok
+	}
+	set socketPhQueue($sockOld) {}
     }
 
-    # The element socketWrState($connId) has a value which is either the name of
-    # the token that is permitted to write to the socket, or "Wready" if no
-    # token is permitted to write.
-    #
-    # The code that sets the value to Wready immediately calls
-    # http::NextPipelinedWrite, which examines socketWrQueue($connId) and
-    # processes the next request in the queue, if there is one.  The value
-    # Wready is not found when the interpreter is in the event loop unless the
-    # socket is idle.
-    #
-    # The element socketRdState($connId) has a value which is either the name of
-    # the token that is permitted to read from the socket, or "Rready" if no
-    # token is permitted to read.
-    #
-    # The code that sets the value to Rready then examines
-    # socketRdQueue($connId) and processes the next request in the queue, if
-    # there is one.  The value Rready is not found when the interpreter is in
-    # the event loop unless the socket is idle.
+    return
+}
+
+
+# ------------------------------------------------------------------------------
+# The values of array variables socketMapping etc.
+# ------------------------------------------------------------------------------
+# connId                 "$host:$port"
+# socketMapping($connId) the handle or placeholder for the socket that is used
+#                        for "-keepalive 1" requests to $connId.
+# socketRdState($connId) the token that is currently reading from the socket.
+#                        Other values: Rready (ready for next token to read).
+# socketWrState($connId) the token that is currently writing to the socket.
+#                        Other values: Wready (ready for next token to write),
+#                        peNding (would be ready for next write, except that
+#                        the integrity of a non-pipelined transaction requires
+#                        waiting until the read(s) in progress are finished).
+# socketRdQueue($connId) List of tokens that are queued for reading later.
+# socketWrQueue($connId) List of tokens that are queued for writing later.
+# socketPhQueue($connId) List of tokens that are queued to use a placeholder
+#                        socket, when the real socket has not yet been created.
+# socketClosing($connId) (boolean) true iff a server response header indicates
+#                        that the server will close the connection at the end of
+#                        the current response.
+# socketPlayCmd($connId) The command to execute to replay pending and
+#                        part-completed transactions if the socket closes early.
+# socketCoEvent($connId) Identifier for the "after idle" event that will launch
+#                        an OpenSocket coroutine to open or re-use a socket.
+# ------------------------------------------------------------------------------
+
+
+# ------------------------------------------------------------------------------
+# Using socketWrState(*), socketWrQueue(*), socketRdState(*), socketRdQueue(*)
+# ------------------------------------------------------------------------------
+# The element socketWrState($connId) has a value which is either the name of
+# the token that is permitted to write to the socket, or "Wready" if no
+# token is permitted to write.
+#
+# The code that sets the value to Wready immediately calls
+# http::NextPipelinedWrite, which examines socketWrQueue($connId) and
+# processes the next request in the queue, if there is one.  The value
+# Wready is not found when the interpreter is in the event loop unless the
+# socket is idle.
+#
+# The element socketRdState($connId) has a value which is either the name of
+# the token that is permitted to read from the socket, or "Rready" if no
+# token is permitted to read.
+#
+# The code that sets the value to Rready then examines
+# socketRdQueue($connId) and processes the next request in the queue, if
+# there is one.  The value Rready is not found when the interpreter is in
+# the event loop unless the socket is idle.
+# ------------------------------------------------------------------------------
+
+
+# ------------------------------------------------------------------------------
+#  Proc http::ScheduleRequest
+# ------------------------------------------------------------------------------
+# Command to either begin the HTTP request, or add it to the appropriate queue.
+# Called from two places in ConfigureNewSocket.
+#
+# Arguments:
+# token         - connection token (name of an array)
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
 
-    if {$alreadyQueued} {
+proc http::ScheduleRequest {token} {
+    variable $token
+    upvar 0 $token state
+    set tk [namespace tail $token]
+
+    Log >L$tk ScheduleRequest
+
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketPhQueue
+    variable socketClosing
+    variable socketPlayCmd
+    variable socketCoEvent
+
+    set Unfinished 0
+
+    set reusing $state(reusing)
+    set sockNew $state(sock)
+
+    # The "if" tests below: must test against the current values of
+    # socketWrState, socketRdState, and so the tests must be done here,
+    # not earlier in PreparePersistentConnection.
+
+    if {$state(alreadyQueued)} {
+	# The request has been appended to the queue of a persistent socket
+	# (that is scheduled to close and have its queue replayed).
+	#
 	# A write may or may not be in progress.  There is no need to set
 	# socketWrState to prevent another call stealing write access - all
 	# subsequent calls on this socket will come here because the socket
@@ -1306,65 +1778,56 @@ proc http::geturl {url args} {
 	# pipelined request jumping the queue.
 	##Log "HTTP request for token $token is queued for nonpipeline use"
 	#Log re-use nonpipeline, GRANT delayed write access to $token in geturl
-
 	set socketWrState($state(socketinfo)) peNding
 	lappend socketWrQueue($state(socketinfo)) $token
 
     } else {
-	if {$reusing && $state(-pipeline)} {
-	    #Log re-use pipelined, GRANT write access to $token in geturl
-	    set socketWrState($state(socketinfo)) $token
-
-	} elseif {$reusing} {
-	    # Cf tests above - both are ready.
-	    #Log re-use nonpipeline, GRANT r/w access to $token in geturl
-	    set socketRdState($state(socketinfo)) $token
-	    set socketWrState($state(socketinfo)) $token
-	}
-
-	# All (!$reusing) cases come here, and also some $reusing cases if the
-	# connection is ready.
+        if {$reusing && $state(-pipeline)} {
+	    #Log new, init for pipelined, GRANT write access to $token in geturl
+	    # DO NOT grant premature read access to the socket.
+            # set socketRdState($state(socketinfo)) $token
+            set socketWrState($state(socketinfo)) $token
+        } elseif {$reusing} {
+	    # socketWrState is not used by this non-pipelined transaction.
+	    # We cannot leave it as "Wready" because the next call to
+	    # http::geturl with a pipelined transaction would conclude that the
+	    # socket is available for writing.
+	    #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
+            set socketRdState($state(socketinfo)) $token
+            set socketWrState($state(socketinfo)) $token
+        } else {
+        }
+
+	# Process the request now.
+	# - Command is not called unless $state(sock) is a real socket handle
+	#   and not a placeholder.
+	# - All (!$reusing) cases come here.
+	# - Some $reusing cases come here too if the connection is
+	#   marked as ready.  Those $reusing cases are:
+	#   $reusing && ($socketWrState($state(socketinfo)) eq "Wready") &&
+	#   EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready")
+	#   OR      $pipeline
+	#
 	#Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
+	##Log "  ScheduleRequest" $token -- fileevent $state(sock) writable for $token
 	# Connect does its own fconfigure.
-	fileevent $sock writable \
-		[list http::Connect $token $proto $phost $srvurl]
-    }
 
-    # --------------------------------------------------------------------------
-    # Synchronous Call to http::geturl
-    # --------------------------------------------------------------------------
-    # - If the call to http::geturl is asynchronous, it is now complete (apart
-    #   from delivering the return value).
-    # - If the call to http::geturl is synchronous, the command must now wait
-    #   for the HTTP transaction to be completed.  The call to http::wait uses
-    #   vwait, which may be inappropriate if the caller makes other HTTP
-    #   requests in the background.
-    # --------------------------------------------------------------------------
+        lassign $state(connArgs) proto phost srvurl
 
-    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]} {
-	    # If we timed out then Finish has been called and the users
-	    # command callback may have cleaned up the token. If so we end up
-	    # here with nothing left to do.
-	    return $token
-	} elseif {$state(status) eq "error"} {
-	    # Something went wrong while trying to establish the connection.
-	    # 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.
-	    set err [lindex $state(error) 0]
-	    cleanup $token
-	    return -code error $err
+	if {[catch {
+		fileevent $state(sock) writable \
+			[list http::Connect $token $proto $phost $srvurl]
+	} res opts]} {
+	    # The socket no longer exists.
+	    ##Log bug -- socket gone -- $res -- $opts
 	}
+
     }
-    ##Log Leaving http::geturl - token $token
-    return $token
+
+    return
 }
 
+
 # http::Connected --
 #
 #	Callback used when the connection to the HTTP server is actually
@@ -1386,8 +1849,10 @@ proc http::Connected {token proto phost srvurl} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     variable $token
     upvar 0 $token state
@@ -1679,8 +2144,10 @@ proc http::DoneRequest {token} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     variable $token
     upvar 0 $token state
@@ -2008,8 +2475,10 @@ proc http::ReplayIfDead {token doing} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     variable $token
     upvar 0 $token state
@@ -2237,13 +2706,17 @@ proc http::ReInit {token} {
 #	Use existing tokens, but try to open a new socket.
 
 proc http::ReplayCore {newQueue} {
+    variable TmpSockCounter
+
     variable socketMapping
     variable socketRdState
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     if {[llength $newQueue] == 0} {
 	# Nothing to do.
@@ -2275,72 +2748,20 @@ proc http::ReplayCore {newQueue} {
     unset state(tmpConnArgs)
 
     set state(reusing) 0
+    set state(ReusingPlaceholder) 0
+    set state(alreadyQueued) 0
 
-    if {$state(-timeout) > 0} {
-	set resetCmd [list http::reset $token timeout]
-	set state(after) [after $state(-timeout) $resetCmd]
-    }
-
-    set pre [clock milliseconds]
-    ##Log pre socket opened, - token $token
-    ##Log $tmpOpenCmd - token $token
-    # 4. Open a socket.
-    if {[catch {eval $tmpOpenCmd} sock]} {
-	# Something went wrong while trying to establish the connection.
-	Log FAILED - $sock
-	set state(sock) NONE
-	Finish $token $sock
-	return
-    }
-    ##Log post socket opened, - token $token
-    set delay [expr {[clock milliseconds] - $pre}]
-    if {$delay > 3000} {
-	Log socket delay $delay - token $token
-    }
-    # Command [socket] is called with -async, but takes 5s to 5.1s to return,
-    # with probability of order 1 in 10,000.  This may be a bizarre scheduling
-    # issue with my (KJN's) system (Fedora Linux).
-    # This does not cause a problem (unless the request times out when this
-    # command returns).
-
-    # 5. Configure the persistent socket data.
-    if {$state(-keepalive)} {
-	set socketMapping($state(socketinfo)) $sock
-
-	if {![info exists socketRdState($state(socketinfo))]} {
-	    set socketRdState($state(socketinfo)) {}
-	    set varName ::http::socketRdState($state(socketinfo))
-	    trace add variable $varName unset ::http::CancelReadPipeline
-	}
-
-	if {![info exists socketWrState($state(socketinfo))]} {
-	    set socketWrState($state(socketinfo)) {}
-	    set varName ::http::socketWrState($state(socketinfo))
-	    trace add variable $varName unset ::http::CancelWritePipeline
-	}
-
-	if {$state(-pipeline)} {
-	    #Log new, init for pipelined, GRANT write acc to $token ReplayCore
-	    set socketRdState($state(socketinfo)) $token
-	    set socketWrState($state(socketinfo)) $token
-	} else {
-	    #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore
-	    set socketRdState($state(socketinfo)) $token
-	    set socketWrState($state(socketinfo)) $token
-	}
-
-	set socketRdQueue($state(socketinfo)) {}
-	set socketWrQueue($state(socketinfo)) $newQueue
-	set socketClosing($state(socketinfo)) 0
-	set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
-    }
+    # Give the socket a placeholder name before it is created.
+    set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
+    set state(sock) $sock
 
-    ##Log pre newQueue ReInit, - token $token
-    # 6. Configure sockets in the queue.
+    # Move the $newQueue into the placeholder socket's socketPhQueue.
+    set socketPhQueue($sock) {}
     foreach tok $newQueue {
 	if {[ReInit $tok]} {
 	    set ${tok}(reusing) 1
 	    set ${tok}(sock) $sock
+	    lappend socketPhQueue($sock) $tok
 	} else {
 	    set ${tok}(reusing) 1
 	    set ${tok}(sock) NONE
@@ -2348,19 +2769,8 @@ proc http::ReplayCore {newQueue} {
 	}
     }
 
-    # 7. Configure the socket for newToken to send a request.
-    set state(sock) $sock
-    Log "Using $sock for $state(socketinfo) - token $token" \
-	[expr {$state(-keepalive)?"keepalive":""}]
+    AsyncTransaction $token
 
-    # Initialisation of a new socket.
-    ##Log socket opened, now fconfigure - token $token
-    fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
-    ##Log socket opened, DONE fconfigure - token $token
-
-    # Connect does its own fconfigure.
-    fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs]
-    #Log ---- $sock << conn to $token for HTTP request (e)
     return
 }
 
@@ -2432,6 +2842,9 @@ proc http::cleanup {token} {
     if {[info commands ${token}--EventCoroutine] ne {}} {
 	rename ${token}--EventCoroutine {}
     }
+    if {[info commands ${token}--SocketCoroutine] ne {}} {
+	rename ${token}--SocketCoroutine {}
+    }
     if {[info exists state(after)]} {
 	after cancel $state(after)
 	unset state(after)
@@ -2503,8 +2916,10 @@ proc http::Write {token} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     variable $token
     upvar 0 $token state
@@ -2611,8 +3026,10 @@ proc http::Event {sock token} {
     variable socketWrState
     variable socketRdQueue
     variable socketWrQueue
+    variable socketPhQueue
     variable socketClosing
     variable socketPlayCmd
+    variable socketCoEvent
 
     variable $token
     upvar 0 $token state
@@ -2736,6 +3153,17 @@ proc http::Event {sock token} {
 		    # response.
 		    ##Log WARNING - socket will close after response for $token
 		    # Prepare data for a call to ReplayIfClose.
+
+		    # 1. Cancel socket-assignment coro events that have not yet
+		    # launched, and add the tokens to the write queue.
+		    if {[info exists socketCoEvent($state(socketinfo))]} {
+			foreach {tok can} $socketCoEvent($state(socketinfo)) {
+			    lappend socketWrQueue($state(socketinfo)) $tok
+			    after cancel $can
+			}
+			set socketCoEvent($state(socketinfo)) {}
+		    }
+
 		    if {    ($socketRdQueue($state(socketinfo)) ne {})
 			 || ($socketWrQueue($state(socketinfo)) ne {})
 			 || ($socketWrState($state(socketinfo)) ni
@@ -2748,7 +3176,6 @@ proc http::Event {sock token} {
 			    set msg "token ${InFlightW} is InFlightW"
 			    ##Log $msg - token $token
 			}
-
 			set socketPlayCmd($state(socketinfo)) \
 				[list ReplayIfClose $InFlightW \
 				$socketRdQueue($state(socketinfo)) \
diff --git a/tests/http.test b/tests/http.test
index a6f1ce6..59078f2 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -611,17 +611,19 @@ test http-4.14 {http::Event} -body {
 } -cleanup {
     catch {http::cleanup $token}
 } -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
     # expected and is not a problem with Tcl.
     set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#]
     http::wait $token
-    http::status $token
+    set result "[http::status $token] -- [lindex [http::error $token] 0]"
     # error codes vary among platforms.
 } -cleanup {
     catch {http::cleanup $token}
-} -returnCodes 1 -match glob -result "couldn't open socket*"
+} -match glob -result "error -- couldn't open socket*"
+
 test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
     proc list-difference {l1 l2} {
 	lmap item $l2 {if {$item in $l1} continue; set item}
-- 
cgit v0.12


From d041253d886295e7de0e6171a443ccb3f319f3ad Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 6 Sep 2022 15:53:20 +0000
Subject: (Still buggy.) Add the ::socket replacement ::http::socket and its
 dependencies as a workaround to bug 824251.  Integrate with tls. Allow
 configuration -threadlevel for socket creation (package Thread may not be
 available and by default it is not used).  Revise tests http-1.1, http-1.4,
 http-1.5 for new option -threadlevel.  Run tests for each value of
 -threadlevel.

---
 doc/http.n              |  27 +++++
 library/http/http.tcl   | 300 ++++++++++++++++++++++++++++++++++++++++++++++--
 tests/http.test         |  49 +++++---
 tests/http11.test       |  22 +++-
 tests/httpPipeline.test |  26 ++++-
 5 files changed, 398 insertions(+), 26 deletions(-)

diff --git a/doc/http.n b/doc/http.n
index 4781a1b..2c9f809 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -173,6 +173,19 @@ retrying the POST.  The value \fBtrue\fR should be used only under certain
 conditions. See the \fBPERSISTENT SOCKETS\fR section for details. The
 default is 0.
 .TP
+\fB\-threadlevel\fR \fIlevel\fR
+.
+Specifies whether and how to use the \fBThread\fR package.  Possible values of \fIlevel\fR are 0, 1 or 2.
+.RS
+.PP
+.DS
+0 - (the default) do not use Thread
+1 - use Thread if it is available, do not use it if it is unavailable
+2 - use Thread if it is available, raise an error if it is unavailable
+.DE
+The Tcl \fBsocket -async\fR command can block in adverse cases (e.g. a slow DNS lookup).  Using the Thread package works around this problem, for both HTTP and HTTPS transactions.  Values of \fIlevel\fR other than 0 are available only to the main interpreter in each thread.  See section \fBTHREADS\fR for more information.
+.RE
+.TP
 \fB\-urlencoding\fR \fIencoding\fR
 .
 The \fIencoding\fR used for creating the x-url-encoded URLs with
@@ -986,6 +999,20 @@ the server response code is a 307 redirect, and the response header
 again in order to fetch this URL.
 See https://w3c.github.io/webappsec-upgrade-insecure-requests/
 .PP
+.SH THREADS
+.PP
+.SS "PURPOSE"
+.PP
+Command \fB::http::geturl\fR uses the Tcl \fB::socket\fR command with the \-async option to connect to a remote server, but the return from this command can be delayed in adverse cases (e.g. a slow DNS lookup), preventing the event loop from processing other events.  This delay is avoided if the \fB::socket\fR command is evaluated in another thread.  The Thread package is not part of Tcl but is provided in "Batteries Included" distributions.  Instead of the \fB::socket\fR command, the http package uses \fB::http::socket\fR which makes connections in the manner specified by the value of \-threadlevel and the availability of package Thread.
+.PP
+.SS "WITH TLS (HTTPS)"
+.PP
+The same \-threadlevel configuration applies to both HTTP and HTTPS connections. HTTPS is enabled by using the \fBhttp::register\fR command, typically by specifying the \fB::tls::socket\fR command of the tls package to handle TLS cryptography.  The \fB::tls::socket\fR command connects to the remote server by using the command specified by the value of variable \fI::tls::socketCmd\fR, and this value defaults to "::socket".  If http::geturl finds that \fI::tls::socketCmd\fR has this value, it replaces it with the value "::http::socket".  If \fI::tls::socketCmd\fR has a value other than "::socket", i.e. if the script or the Tcl installation has replaced the value "::socket" with the name of a different command, then http does not change the value.  The script or installation that modified \fI::tls::socketCmd\fR is responsible for integrating \fR::http::socket\fR into its own replacement command.
+.PP
+.SS "WITH A CHILD INTERPRETER"
+.PP
+The peer thread can transfer the socket only to the main interpreter of the script's thread.  Therefore the thread-based \fB::http::socket\fR works with non-zero \-threadlevel values only if the script runs in the main interpreter.  A child interpreter must use \-threadlevel 0 unless the parent interpreter has provided alternative facilities.  The main parent interpreter may grant full \-threadlevel facilities to a child interpreter, for example by aliasing, to \fB::http::socket\fR in the child, a command that runs \fBhttp::socket\fR in the parent, and then transfers the socket to the child.
+.PP
 .SH EXAMPLE
 .PP
 This example creates a procedure to copy a URL to a file while printing a
diff --git a/library/http/http.tcl b/library/http/http.tcl
index c3679f1..01d3f8b 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -27,6 +27,7 @@ namespace eval http {
 	    -proxyport {}
 	    -proxyfilter http::ProxyRequired
 	    -repost 0
+	    -threadlevel 0
 	    -urlencoding utf-8
 	    -zip 1
 	}
@@ -113,7 +114,7 @@ namespace eval http {
 
     variable urlTypes
     if {![info exists urlTypes]} {
-	set urlTypes(http) [list 80 ::socket]
+	set urlTypes(http) [list 80 ::http::socket]
     }
 
     variable encodings [string tolower [encoding names]]
@@ -148,6 +149,7 @@ namespace eval http {
     }
 
     variable TmpSockCounter 0
+    variable ThreadCounter  0
 
     namespace export geturl config reset wait formatQuery quoteString
     namespace export register unregister registerError
@@ -240,6 +242,9 @@ proc http::config {args} {
 	    if {![regexp -- $pat $flag]} {
 		return -code error "Unknown option $flag, must be: $usage"
 	    }
+	    if {($flag eq {-threadlevel}) && ($value ni {0 1 2})} {
+		return -code error {Option -threadlevel must be 0, 1 or 2}
+	    }
 	    set http($flag) $value
 	}
 	return
@@ -313,6 +318,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
             # immediately, the socket may not yet exist.
             # Test http-4.11 may come here.
 	}
+	if {$state(tid) ne {}} {
+            # When opening the socket in a thread, and calling http::reset
+            # immediately, the thread may still exist.
+            # Test http-4.11 may come here.
+	    thread::release $state(tid)
+	    set state(tid) {}
+	} else {
+	}
     } elseif {$upgradeResponse} {
 	# Special handling for an upgrade request/response.
 	# - geturl ensures that this is not a "persistent" socket used for
@@ -762,6 +775,24 @@ proc http::reset {token {why reset}} {
 #	array that the caller should unset to garbage collect the state.
 
 proc http::geturl {url args} {
+    variable urlTypes
+
+    # The value is set in the namespace header of this file.  If the file has
+    # not been modified the value is "::http::socket".
+    set socketCmd [lindex $urlTypes(http) 1]
+
+    # - If ::tls::socketCmd has its default value "::socket", change it to the
+    #   new value $socketCmd.
+    # - If the old value is different, then it has been modified either by the
+    #   script or by the Tcl installation, and replaced by a new command.  The
+    #   script or installation that modified ::tls::socketCmd is also
+    #   responsible for integrating ::http::socket into its own "new" command,
+    #   if it wishes to do so.
+    
+    if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} {
+        set ::tls::socketCmd $socketCmd
+    }
+
     set token [CreateToken $url {*}$args]
     variable $token
     upvar 0 $token state
@@ -810,6 +841,7 @@ proc http::geturl {url args} {
 # The return value is the variable name of the token.
 #
 # Other effects:
+# - Sets ::http::http(usingThread) if not already done
 # - Sets ::http::http(uid) if not already done
 # - Increments ::http::http(uid)
 # - May increment ::http::TmpSockCounter
@@ -834,6 +866,9 @@ proc http::CreateToken {url args} {
     # Initialize the state variable, an array. We'll return the name of this
     # array as the token for the transaction.
 
+    if {![info exists http(usingThread)]} {
+	set http(usingThread) 0
+    }
     if {![info exists http(uid)]} {
 	set http(uid) 0
     }
@@ -871,6 +906,7 @@ proc http::CreateToken {url args} {
 	status		""
 	http		""
 	connection	keep-alive
+	tid             {}
     }
     set state(-keepalive) $defaultKeepalive
     set state(-strict) $strict
@@ -1086,7 +1122,7 @@ proc http::CreateToken {url args} {
 	append url : $port
     }
     append url $srvurl
-    # Don't append the fragment!
+    # Don't append the fragment! RFC 7230 Sec 5.1
     set state(url) $url
 
     # Proxy connections aren't shared among different hosts.
@@ -1213,8 +1249,9 @@ proc http::CreateToken {url args} {
 		lappend socketWrQueue($state(socketinfo)) $token
 		##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo))
 		##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo))
-	    } elseif {   [catch {fconfigure $socketMapping($state(socketinfo))}]
-	              && (![SockIsPlaHolder $socketMapping($state(socketinfo))])
+	    } elseif {
+		   [catch {fconfigure $socketMapping($state(socketinfo))}]
+		&& (![SockIsPlaceHolder $socketMapping($state(socketinfo))])
 	    } {
 		###Log "Socket $socketMapping($state(socketinfo)) for $state(socketinfo)"
 		# FIXME Is it still possible for this code to be executed? If
@@ -1237,7 +1274,7 @@ proc http::CreateToken {url args} {
 		# - The socket may not yet exist, and be defined with a placeholder.
 		set reusing 1
 		set sock $socketMapping($state(socketinfo))
-		if {[SockIsPlaHolder $sock]} {
+		if {[SockIsPlaceHolder $sock]} {
 		    set state(ReusingPlaceholder) 1
 		    lappend socketPhQueue($sock) $token
 		} else {
@@ -1272,7 +1309,7 @@ proc http::CreateToken {url args} {
 
 
 # ------------------------------------------------------------------------------
-#  Proc ::http::SockIsPlaHolder
+#  Proc ::http::SockIsPlaceHolder
 # ------------------------------------------------------------------------------
 # Command to return 0 if the argument is a genuine socket handle, or 1 if is a
 # placeholder value generated by geturl or ReplayCore before the real socket is
@@ -1284,7 +1321,7 @@ proc http::CreateToken {url args} {
 # Return Value: 0 or 1
 # ------------------------------------------------------------------------------
 
-proc http::SockIsPlaHolder {sock} {
+proc http::SockIsPlaceHolder {sock} {
     expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}}
 }
 
@@ -4178,6 +4215,255 @@ proc http::make-transformation-chunked {chan command} {
     return
 }
 
+
+# ------------------------------------------------------------------------------
+#  Proc http::socket
+# ------------------------------------------------------------------------------
+# This command is a drop-in replacement for ::socket.
+# Arguments and return value as for ::socket.
+#
+# Notes.
+# - http::socket is specified in place of ::socket by the definition of urlTypes
+#   in the namespace header of this file (http.tcl).
+# - The command makes a simple call to ::socket unless the user has called
+#   http::config to change the value of -threadlevel from the default value 0.
+# - For -threadlevel 1 or 2, if the Thread package is available, the command
+#   waits in the event loop while the socket is opened in another thread.  This
+#   is a workaround for bug [824251] - it prevents http::geturl from blocking
+#   the event loop if the DNS lookup or server connection is slow.
+# - FIXME Use a thread pool if connections are very frequent.
+# - FIXME The peer thread can transfer the socket only to the main interpreter
+#   in the present thread.  Therefore this code works only if this script runs
+#   in the main interpreter.  In a child interpreter, the parent must alias a
+#   command to ::http::socket in the child, run http::socket in the parent,
+#   and then transfer the socket to the child.
+# - The http::socket command is simple, and can easily be replaced with an
+#   alternative command that uses a different technique to open a socket while
+#   entering the event loop.
+# ------------------------------------------------------------------------------
+
+proc http::socket {args} {
+    variable ThreadVar
+    variable ThreadCounter
+    variable http
+
+    LoadThreadIfNeeded
+
+    set targ [lsearch -exact $args -token]
+    if {$targ != -1} {
+        set token [lindex $args $targ+1]
+        set args [lreplace $args $targ $targ+1]
+        upvar 0 $token state
+    }
+
+    if {!$http(usingThread)} {
+        # Use plain "::socket".  This is the default.
+        return [eval ::socket $args]
+    }
+
+    set defcmd ::socket
+    set sockargs $args
+    set script "
+        [list proc ::SockInThread {caller defcmd sockargs} [info body http::SockInThread]]
+        [list ::SockInThread [thread::id] $defcmd $sockargs]
+    "
+
+    set state(tid) [thread::create]
+    set varName ::http::ThreadVar([incr ThreadCounter])
+    thread::send -async $state(tid) $script $varName
+    Log >T Thread Start Wait $args -- coro [info coroutine] $varName
+    if {[info coroutine] ne {}} {
+        # All callers in the http package are coroutines launched by
+        # the event loop.
+        # The cwait command requires a coroutine because it yields
+        # to the caller; $varName is traced and the coroutine resumes
+        # when the variable is written.
+        cwait $varName
+    } else {
+        return -code error {code must run in a coroutine}
+        # For testing with a non-coroutine caller outside the http package.
+        # vwait $varName
+    }
+    Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName]
+    thread::release $state(tid)
+    set state(tid) {}
+    lassign [set $varName] catchCode errdict sock
+    unset $varName
+    dict set errdict -code $catchCode
+    return -options $errdict $sock
+}
+
+# The commands below are dependencies of http::socket and
+# are not used elsewhere.
+
+# ------------------------------------------------------------------------------
+#  Proc http::LoadThreadIfNeeded
+# ------------------------------------------------------------------------------
+# Command to load the Thread package if it is needed.  If it is needed and not
+# loadable, the outcome depends on $http(-threadlevel):
+# value 0 => Thread package not required, no problem
+# value 1 => operate as if -threadlevel 0
+# value 2 => error return
+#
+# Arguments: none
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::LoadThreadIfNeeded {} {
+    variable http
+    if {$http(usingThread) || ($http(-threadlevel) == 0)} {
+        return
+    }
+    if {[catch {package require Thread}]} {
+        if {$http(-threadlevel) == 2} {
+            set msg {[http::config -threadlevel] has value 2,\
+                     but the Thread package is not available}
+            return -code error $msg
+        }
+        return
+    }
+    set http(usingThread) 1
+    return
+}
+
+
+# ------------------------------------------------------------------------------
+#  Proc http::SockInThread
+# ------------------------------------------------------------------------------
+# Command http::socket is a ::socket replacement.  It defines and runs this
+# command, http::SockInThread, in a peer thread.
+#
+# Arguments:
+# caller
+# defcmd
+# sockargs
+#
+# Return value: list of values that describe the outcome.  The return is
+# intended to be a normal (non-error) return in all cases.
+# ------------------------------------------------------------------------------
+
+proc http::SockInThread {caller defcmd sockargs} {
+    package require Thread
+    
+    set catchCode [catch {eval $defcmd $sockargs} sock errdict]
+    if {$catchCode == 0} {
+        set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
+    }
+    return [list $catchCode $errdict $sock]
+}
+
+
+# ------------------------------------------------------------------------------
+#  Proc ::http::cwaiter::cwait
+# ------------------------------------------------------------------------------
+# Command to substitute for vwait, without the ordering issues.
+# A command that uses cwait must be a coroutine that is launched by an event,
+# e.g. fileevent or after idle, and has no calling code to be resumed upon
+# "yield".  It cannot return a value.
+#
+# Arguments:
+# varName      - fully-qualified name of the variable that the calling script
+#                will write to resume the coroutine.  Any scalar variable or
+#                array element is permitted.
+# coroName     - (optional) name of the coroutine to be called when varName is
+#                written - defaults to this coroutine
+# timeout      - (optional) timeout value in ms
+# timeoutValue - (optional) value to assign to varName if there is a timeout
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+namespace eval ::http::cwaiter {
+    namespace export cwait
+    variable log   {}
+    variable logOn 0
+}
+
+proc ::http::cwaiter::cwait {
+    varName {coroName {}} {timeout {}} {timeoutValue {}}
+} {
+    set thisCoro [info coroutine]
+    if {$thisCoro eq {}} {
+        return -code error {cwait cannot be called outside a coroutine}
+    }
+    if {$coroName eq {}} {
+        set coroName $thisCoro
+    }
+    if {[string range $varName 0 1] ne {::}} {
+        return -code error {argument varName must be fully qualified}
+    }
+    if {$timeout eq {}} {
+        set toe {}
+    } elseif {[string is integer -strict $timeout] && ($timeout > 0)} {
+        set toe [after $timeout [list set $varName $timeoutValue]]
+    } else {
+        return -code error {if timeout is supplied it must be a positive integer}
+    }
+
+    set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
+    trace add variable $varName write $cmd
+    CoLog "Yield $varName $coroName"
+    yield
+    CoLog "Resume $varName $coroName"
+    return
+}
+
+
+# ------------------------------------------------------------------------------
+#  Proc ::http::cwaiter::CwaitHelper
+# ------------------------------------------------------------------------------
+# Helper command called by the trace set by cwait.
+# - Ignores the arguments added by trace.
+# - A simple call to $coroName works, and in error cases gives a suitable stack
+#   trace, but because it is inside a trace the headline error message is
+#   something like {can't set "::Result(6)": error}, not the actual
+#   error.  So let the trace command return.
+# - Remove the trace immediately.  We don't want multiple calls.
+# ------------------------------------------------------------------------------
+
+proc ::http::cwaiter::CwaitHelper {varName coroName toe args} {
+    CoLog "got $varName for $coroName"
+    set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
+    trace remove variable $varName write $cmd
+    after cancel $toe
+
+    after 0 $coroName
+    return
+}
+
+
+# ------------------------------------------------------------------------------
+#  Proc ::http::cwaiter::LogInit
+# ------------------------------------------------------------------------------
+# Call this command to initiate debug logging and clear the log.
+# ------------------------------------------------------------------------------
+
+proc ::http::cwaiter::LogInit {} {
+    variable log
+    variable logOn
+    set log {}
+    set logOn 1
+    return
+}
+
+proc ::http::cwaiter::LogRead {} {
+    variable log
+    return $log
+}
+
+proc ::http::cwaiter::CoLog {msg} {
+    variable log
+    variable logOn
+    if {$logOn} {
+        append log $msg \n
+    }
+    return
+}
+
+namespace eval ::http {
+    namespace import ::http::cwaiter::*
+}
+
 # Local variables:
 # indent-tabs-mode: t
 # End:
diff --git a/tests/http.test b/tests/http.test
index 59078f2..26ba710 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -17,20 +17,7 @@ if {"::tcltest" ni [namespace children]} {
 }
 package require tcltests
 
-if {[catch {package require http 2} version]} {
-    if {[info exists http2]} {
-	catch {puts "Cannot load http 2.* package"}
-	return
-    } else {
-	catch {puts "Running http 2.* tests in child interp"}
-	set interp [interp create http2]
-	$interp eval [list set http2 "running"]
-	$interp eval [list set argv $argv]
-	$interp eval [list source [info script]]
-	interp delete $interp
-	return
-    }
-}
+package require http 2.10
 
 proc bgerror {args} {
     global errorInfo
@@ -78,11 +65,31 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
 	return
     }
 }
+
+if {![info exists ThreadLevel]} {
+    if {[catch {package require Thread}] == 0} {
+        set ValueRange {0 1 2}
+    } else {
+        set ValueRange {0 1}
+    }
+
+    # For each value of ThreadLevel, source this file recursively in the
+    # same interpreter.
+    foreach ThreadLevel $ValueRange {
+        source [info script]
+    }
+    catch {unset ThreadLevel}
+    catch {unset ValueRange}
+    return
+}
+
+catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
+http::config -threadlevel $ThreadLevel
 
 test http-1.1 {http::config} {
     http::config -useragent UserAgent
     http::config
-} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1]
 test http-1.2 {http::config} {
     http::config -proxyfilter
 } http::ProxyRequired
@@ -97,10 +104,10 @@ test http-1.4 {http::config} {
     set x [http::config]
     http::config {*}$savedconf
     set x
-} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1]
 test http-1.5 {http::config} -returnCodes error -body {
     http::config -proxyhost {} -junk 8080
-} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
+} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip}
 test http-1.6 {http::config} -setup {
     set oldenc [http::config -urlencoding]
 } -body {
@@ -139,9 +146,11 @@ test http-2.8 {http::CharsetToEncoding} {
 test http-3.1 {http::geturl} -returnCodes error -body {
     http::geturl -bogus flag
 } -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
+
 test http-3.2 {http::geturl} -returnCodes error -body {
     http::geturl http:junk
 } -result {Unsupported URL: http:junk}
+
 set url //${::HOST}:$port
 set badurl //${::HOST}:[expr {$port+1}]
 test http-3.3 {http::geturl} -body {
@@ -153,6 +162,7 @@ test http-3.3 {http::geturl} -body {
 <h1>Hello, World!</h1>
 <h2>GET /</h2>
 </body></html>"
+
 set tail /a/b/c
 set url //${::HOST}:$port/a/b/c
 set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c
@@ -162,6 +172,7 @@ set posturl //${::HOST}:$port/post
 set badposturl //${::HOST}:$port/droppost
 set authorityurl //${::HOST}:$port
 set ipv6url http://\[::1\]:$port/
+
 test http-3.4 {http::geturl} -body {
     set token [http::geturl $url]
     http::data $token
@@ -572,6 +583,7 @@ test http-4.10 {http::Event} -body {
 } -cleanup {
     http::cleanup $token
 } -result {111}
+
 # Timeout cases
 #	Short timeout to working server (the test server). This lets us try a
 #	reset during the connection.
@@ -582,6 +594,7 @@ test http-4.11 {http::Event} -body {
 } -cleanup {
     http::cleanup $token
 } -result {reset}
+
 #	Longer timeout with reset.
 test http-4.12 {http::Event} -body {
     set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#]
@@ -590,6 +603,7 @@ test http-4.12 {http::Event} -body {
 } -cleanup {
     http::cleanup $token
 } -result {reset}
+
 #	Medium timeout to working server that waits even longer. The timeout
 #	hits while waiting for a reply.
 test http-4.13 {http::Event} -body {
@@ -599,6 +613,7 @@ test http-4.13 {http::Event} -body {
 } -cleanup {
     http::cleanup $token
 } -result {timeout}
+
 #	Longer timeout to good host, bad port, gets an error after the
 #	connection "completes" but the socket is bad.
 test http-4.14 {http::Event} -body {
diff --git a/tests/http11.test b/tests/http11.test
index 4f6fb92..346e334 100644
--- a/tests/http11.test
+++ b/tests/http11.test
@@ -12,7 +12,7 @@ if {"::tcltest" ni [namespace children]} {
     namespace import -force ::tcltest::*
 }
 
-package require http 2.9
+package require http 2.10
 
 # start the server
 variable httpd_output
@@ -87,6 +87,26 @@ proc check_crc {tok args} {
 }
 
 makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html
+
+if {![info exists ThreadLevel]} {
+    if {[catch {package require Thread}] == 0} {
+        set ValueRange {0 1 2}
+    } else {
+        set ValueRange {0 1}
+    }
+
+    # For each value of ThreadLevel, source this file recursively in the
+    # same interpreter.
+    foreach ThreadLevel $ValueRange {
+        source [info script]
+    }
+    catch {unset ThreadLevel}
+    catch {unset ValueRange}
+    return
+}
+
+catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
+http::config -threadlevel $ThreadLevel
 
 # -------------------------------------------------------------------------
 
diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
index 4e55a10..161519f 100644
--- a/tests/httpPipeline.test
+++ b/tests/httpPipeline.test
@@ -13,7 +13,31 @@ if {"::tcltest" ni [namespace children]} {
     namespace import -force ::tcltest::*
 }
 
-package require http 2.9
+package require http 2.10
+
+# ------------------------------------------------------------------------------
+# (0) Socket Creation in Thread, which triples the number of tests.
+# ------------------------------------------------------------------------------
+
+if {![info exists ThreadLevel]} {
+    if {[catch {package require Thread}] == 0} {
+        set ValueRange {0 1 2}
+    } else {
+        set ValueRange {0 1}
+    }
+
+    # For each value of ThreadLevel, source this file recursively in the
+    # same interpreter.
+    foreach ThreadLevel $ValueRange {
+        source [info script]
+    }
+    catch {unset ThreadLevel}
+    catch {unset ValueRange}
+    return
+}
+
+catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
+http::config -threadlevel $ThreadLevel
 
 set sourcedir [file normalize [file dirname [info script]]]
 source [file join $sourcedir httpTest.tcl]
-- 
cgit v0.12


From 04fca9a30cb9aef5ab11d633a18fcba33db0a036 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Thu, 8 Sep 2022 14:49:33 +0000
Subject: Bugfixes - treat a disappearing socket as eof; do not open a (second)
 socket for a request that is already queued; cancel idletasks when no longer
 needed. This commit passes all tests.

---
 library/http/http.tcl | 86 +++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 62 insertions(+), 24 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 01d3f8b..38e07cc 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -291,6 +291,11 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     if {[info commands ${token}--SocketCoroutine] ne {}} {
 	rename ${token}--SocketCoroutine {}
     }
+    if {[info exists state(socketcoro)]} {
+        Log $token Cancel socket after-idle event (Finish)
+        after cancel $state(socketcoro)
+        unset state(socketcoro)
+    }
 
     # Is this an upgrade request/response?
     set upgradeResponse \
@@ -691,6 +696,7 @@ proc http::CloseQueuedQueries {connId {token {}}} {
 	# - Also clear the queues to prevent calls to Finish that would set the
 	#   state for the requests that will be retried to "finished with error
 	#   status".
+	# - At this stage socketPhQueue is empty.
 	set unfinished $socketPlayCmd($connId)
 	set socketRdQueue($connId) {}
 	set socketWrQueue($connId) {}
@@ -704,6 +710,7 @@ proc http::CloseQueuedQueries {connId {token {}}} {
 	Log ^R$tk Any unfinished transactions (excluding $token) failed \
 		- token $token - unfinished $unfinished
 	{*}$unfinished
+	# Calls ReplayIfClose.
     }
     return
 }
@@ -1394,7 +1401,8 @@ proc http::AsyncTransaction {token} {
     }
 
     if {$state(ReusingPlaceholder)} {
-        # - This request is scheduled to re-use a persistent connection;
+        # - This request was added to the socketPhQueue of a persistent
+        #   connection.
         # - But the connection has not yet been created and is a placeholder;
         # - And the placeholder was created by an earlier request.
         # - When that earlier request calls OpenSocket, its placeholder is
@@ -1402,13 +1410,18 @@ proc http::AsyncTransaction {token} {
         #   OpenSocket for any subsequent requests that have
         #   $state(ReusingPlaceholder).
         Log >J$tk after idle coro NO - ReusingPlaceholder
+    } elseif {$state(alreadyQueued)} {
+        # - This request was added to the socketWrQueue and socketPlayCmd
+        #   of a persistent connection that will close at the end of its current
+        #   read operation.
+        Log >J$tk after idle coro NO - alreadyQueued
     } else {
         Log >J$tk after idle coro YES
-        # Called if (not reusing) || (socket is not a placeholder).
         set CoroName ${token}--SocketCoroutine
         set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
                 $token $DoLater]]
         dict set socketCoEvent($state(socketinfo)) $token $cancel
+        set state(socketcoro) $cancel
     }
 
     return
@@ -1523,6 +1536,7 @@ proc http::OpenSocket {token DoLater} {
     set sockOld $state(sock)
 
     dict unset socketCoEvent($state(socketinfo)) $token
+    unset -nocomplain state(socketcoro)
 
     set reusing $state(reusing)
 
@@ -1626,10 +1640,9 @@ proc http::ConfigureNewSocket {token sockOld DoLater} {
     variable socketPlayCmd
     variable socketCoEvent
 
-    ##Log "  ConfigureNewSocket" $token $sockOld $sock ...
-
     set reusing $state(reusing)
     set sock $state(sock)
+    ##Log "  ConfigureNewSocket" $token $sockOld ... -- $sock
 
     if {(!$reusing) && ($sock ne $sockOld)} {
         # Replace the placeholder value sockOld with sock.
@@ -1672,6 +1685,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} {
          && ($sock ne $sockOld)
          && [info exists socketPhQueue($sockOld)]
     } {
+        ##Log "  ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld)
         foreach tok $socketPhQueue($sockOld) {
 	    # 1. Amend the token's (sock).
 	    ##Log set ${tok}(sock) $sock
@@ -1685,6 +1699,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} {
 	}
 	set socketPhQueue($sockOld) {}
     }
+    ##Log "  ConfigureNewSocket" $token DONE
 
     return
 }
@@ -2704,6 +2719,11 @@ proc http::ReInit {token} {
 	after cancel $state(after)
 	unset state(after)
     }
+    if {[info exists state(socketcoro)]} {
+        Log $token Cancel socket after-idle event (ReInit)
+        after cancel $state(socketcoro)
+        unset state(socketcoro)
+    }
 
     # Don't alter state(status) - this would trigger http::wait if it is in use.
     set tmpState    $state(tmpState)
@@ -2886,6 +2906,11 @@ proc http::cleanup {token} {
 	after cancel $state(after)
 	unset state(after)
     }
+    if {[info exists state(socketcoro)]} {
+        Log $token Cancel socket after-idle event (cleanup)
+        after cancel $state(socketcoro)
+        unset state(socketcoro)
+    }
     if {[info exists state]} {
 	unset state
     }
@@ -2907,11 +2932,20 @@ proc http::Connect {token proto phost srvurl} {
     variable $token
     upvar 0 $token state
     set tk [namespace tail $token]
-    set err "due to unexpected EOF"
-    if {
-	[eof $state(sock)] ||
-	[set err [fconfigure $state(sock) -error]] ne ""
-    } {
+
+    if {[catch {eof $state(sock)} tmp] || $tmp} {
+        set err "due to unexpected EOF"
+    } elseif {[set err [fconfigure $state(sock) -error]] ne ""} {
+        # set err is done in test
+    } else {
+        # All OK
+	set state(state) connecting
+	fileevent $state(sock) writable {}
+	::http::Connected $token $proto $phost $srvurl
+	return
+    }
+
+    # Error cases.
 	Log "WARNING - if testing, pay special attention to this\
 		case (GJ) which is seldom executed - token $token"
 	if {[info exists state(reusing)] && $state(reusing)} {
@@ -2928,11 +2962,6 @@ proc http::Connect {token proto phost srvurl} {
 	    # be discarded.
 	}
 	Finish $token "connect failed $err"
-    } else {
-	set state(state) connecting
-	fileevent $state(sock) writable {}
-	::http::Connected $token $proto $phost $srvurl
-    }
     return
 }
 
@@ -3077,7 +3106,7 @@ proc http::Event {sock token} {
 
 	if {![info exists state]} {
 	    Log "Event $sock with invalid token '$token' - remote close?"
-	    if {![eof $sock]} {
+	    if {!([catch {eof $sock} tmp] || $tmp)} {
 		if {[set d [read $sock]] ne ""} {
 		    Log "WARNING: additional data left on closed socket\
 			    - token $token"
@@ -3122,7 +3151,7 @@ proc http::Event {sock token} {
 	    } elseif {$nsl >= 0} {
 		##Log - connecting 1 - token $token
 		set state(state) "header"
-	    } elseif {    [eof $sock]
+	    } elseif {    ([catch {eof $sock} tmp] || $tmp)
 		       && [info exists state(reusing)]
 		       && $state(reusing)
 	    } {
@@ -3190,13 +3219,16 @@ proc http::Event {sock token} {
 		    # response.
 		    ##Log WARNING - socket will close after response for $token
 		    # Prepare data for a call to ReplayIfClose.
-
+		    Log $token socket will close after this transaction
 		    # 1. Cancel socket-assignment coro events that have not yet
 		    # launched, and add the tokens to the write queue.
 		    if {[info exists socketCoEvent($state(socketinfo))]} {
 			foreach {tok can} $socketCoEvent($state(socketinfo)) {
 			    lappend socketWrQueue($state(socketinfo)) $tok
+			    unset -nocomplain ${tok}(socketcoro)
 			    after cancel $can
+			    Log $tok Cancel socket after-idle event (Event)
+			    Log Move $tok from socketCoEvent to socketWrQueue and cancel its after idle coro
 			}
 			set socketCoEvent($state(socketinfo)) {}
 		    }
@@ -3228,8 +3260,9 @@ proc http::Event {sock token} {
 				after cancel [set ${tokenVal}(after)]
 				unset ${tokenVal}(after)
 			    }
+			    # Tokens in the read queue have no (socketcoro) to
+			    # cancel.
 			}
-
 		    } else {
 			set socketPlayCmd($state(socketinfo)) \
 				{ReplayIfClose Wready {} {}}
@@ -3540,7 +3573,8 @@ proc http::Event {sock token} {
 
 	# catch as an Eot above may have closed the socket already
 	# $state(state) may be connecting, header, body, or complete
-	if {![set cc [catch {eof $sock} eof]] && $eof} {
+	if {(![catch {eof $sock} eof]) && $eof} {
+	    # [eof sock] succeeded and the result was 1
 	    ##Log eof - token $token
 	    if {[info exists $token]} {
 		set state(connection) close
@@ -3562,8 +3596,9 @@ proc http::Event {sock token} {
 		Log ^X$tk end of response (token error) - token $token
 		CloseSocket $sock
 	    }
-	} elseif {$cc} {
-	    return
+	} else {
+	    # EITHER [eof sock] failed - presumed done by Eot
+	    # OR     [eof sock] succeeded and the result was 0
 	}
     }
     return
@@ -3736,7 +3771,8 @@ proc http::ParseCookie {token value} {
 # http::getTextLine --
 #
 #	Get one line with the stream in crlf mode.
-#	Used if Transfer-Encoding is chunked.
+#	Used if Transfer-Encoding is chunked, to read the line that
+#	reports the size of the following chunk.
 #	Empty line is not distinguished from eof.  The caller must
 #	be able to handle this.
 #
@@ -3759,6 +3795,8 @@ proc http::getTextLine {sock} {
 #
 #	Replacement for a blocking read.
 #	The caller must be a coroutine.
+#	Used when we expect to read a chunked-encoding
+#	chunk of known size.
 
 proc http::BlockingRead {sock size} {
     if {$size < 1} {
@@ -3768,7 +3806,7 @@ proc http::BlockingRead {sock size} {
     while 1 {
 	set need [expr {$size - [string length $result]}]
 	set block [read $sock $need]
-	set eof [eof $sock]
+	set eof [expr {[catch {eof $sock} tmp] || $tmp}]
 	append result $block
 	if {[string length $result] >= $size || $eof} {
 	    return $result
@@ -3788,7 +3826,7 @@ proc http::BlockingRead {sock size} {
 proc http::BlockingGets {sock} {
     while 1 {
 	set count [gets $sock line]
-	set eof [eof $sock]
+	set eof [expr {[catch {eof $sock} tmp] || $tmp}]
 	if {$count >= 0 || $eof} {
 	    return $line
 	} else {
-- 
cgit v0.12


From 673f931995a184eea390ad5d745cd102312e6343 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 9 Sep 2022 12:04:29 +0000
Subject: Change TclObjInterpProc() to a macro, since extensions should never
 invoke it directly, always through TclGetObjInterpProc()

---
 generic/tclBasic.c    | 1 +
 generic/tclIntDecls.h | 2 ++
 generic/tclProc.c     | 2 ++
 generic/tclStubInit.c | 1 +
 4 files changed, 6 insertions(+)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 4bacba6..b806c33 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -780,6 +780,7 @@ Tcl_CreateInterp(void)
 	Tcl_MutexUnlock(&cancelLock);
     }
 
+#undef TclObjInterpProc
     if (commandTypeInit == 0) {
         TclRegisterCommandTypeName(TclObjInterpProc, "proc");
         TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 69aee7c..588a1fa 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -1418,6 +1418,8 @@ extern const TclIntStubs *tclIntStubsPtr;
 #undef TclGuessPackageName
 #undef TclUnusedStubEntry
 #undef TclSetPreInitScript
+#undef TclObjInterpProc
+#define TclObjInterpProc TclGetObjInterpProc()
 #ifndef TCL_NO_DEPRECATED
 #   define TclSetPreInitScript Tcl_SetPreInitScript
 #   define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0)
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 9a3785c..059e751 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -148,6 +148,7 @@ static const Tcl_ObjType lambdaType = {
  *----------------------------------------------------------------------
  */
 
+#undef TclObjInterpProc
 int
 Tcl_ProcObjCmd(
     TCL_UNUSED(ClientData),
@@ -1645,6 +1646,7 @@ TclPushProcCallFrame(
  *----------------------------------------------------------------------
  */
 
+#undef TclObjInterpProc
 int
 TclObjInterpProc(
     ClientData clientData,	/* Record describing procedure to be
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 87c9d0a..ae00b04 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -83,6 +83,7 @@
 #undef Tcl_UtfAtIndex
 #undef Tcl_GetRange
 #undef Tcl_GetUniChar
+#undef TclObjInterpProc
 
 #if defined(_WIN32) || defined(__CYGWIN__)
 #define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError
-- 
cgit v0.12


From a81159df88c89e6950dff666b7e507a0285c616a Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 9 Sep 2022 13:12:43 +0000
Subject: Fix formatting in http.n

---
 doc/http.n | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/doc/http.n b/doc/http.n
index 2c9f809..d531995 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -1007,7 +1007,7 @@ Command \fB::http::geturl\fR uses the Tcl \fB::socket\fR command with the \-asyn
 .PP
 .SS "WITH TLS (HTTPS)"
 .PP
-The same \-threadlevel configuration applies to both HTTP and HTTPS connections. HTTPS is enabled by using the \fBhttp::register\fR command, typically by specifying the \fB::tls::socket\fR command of the tls package to handle TLS cryptography.  The \fB::tls::socket\fR command connects to the remote server by using the command specified by the value of variable \fI::tls::socketCmd\fR, and this value defaults to "::socket".  If http::geturl finds that \fI::tls::socketCmd\fR has this value, it replaces it with the value "::http::socket".  If \fI::tls::socketCmd\fR has a value other than "::socket", i.e. if the script or the Tcl installation has replaced the value "::socket" with the name of a different command, then http does not change the value.  The script or installation that modified \fI::tls::socketCmd\fR is responsible for integrating \fR::http::socket\fR into its own replacement command.
+The same \-threadlevel configuration applies to both HTTP and HTTPS connections. HTTPS is enabled by using the \fBhttp::register\fR command, typically by specifying the \fB::tls::socket\fR command of the tls package to handle TLS cryptography.  The \fB::tls::socket\fR command connects to the remote server by using the command specified by the value of variable \fB::tls::socketCmd\fR, and this value defaults to "::socket".  If http::geturl finds that \fB::tls::socketCmd\fR has this value, it replaces it with the value "::http::socket".  If \fB::tls::socketCmd\fR has a value other than "::socket", i.e. if the script or the Tcl installation has replaced the value "::socket" with the name of a different command, then http does not change the value.  The script or installation that modified \fB::tls::socketCmd\fR is responsible for integrating \fB::http::socket\fR into its own replacement command.
 .PP
 .SS "WITH A CHILD INTERPRETER"
 .PP
-- 
cgit v0.12