-- 
cgit v0.12

From 45f91441a5885c285f3ce537e1f11b0bdbe8ac2a Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:03:58 +0000
Subject: Adjust whitespace to Tcl 8+4 tab convention.

---
 library/http/http.tcl | 100 +++++++++++++++++++++++++-------------------------
 1 file changed, 50 insertions(+), 50 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 9f5310b..d897fce 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -32,14 +32,14 @@ namespace eval http {
 	# ::tcl_platform(osVersion).
 	if {[interp issafe]} {
 	    set http(-useragent) "Mozilla/5.0\
-                (Windows; U;\
-                Windows NT 10.0)\
-                http/[package provide http] Tcl/[package provide Tcl]"
+		(Windows; U;\
+		Windows NT 10.0)\
+		http/[package provide http] Tcl/[package provide Tcl]"
 	} else {
 	    set http(-useragent) "Mozilla/5.0\
-                ([string totitle $::tcl_platform(platform)]; U;\
-                $::tcl_platform(os) $::tcl_platform(osVersion))\
-                http/[package provide http] Tcl/[package provide Tcl]"
+		([string totitle $::tcl_platform(platform)]; U;\
+		$::tcl_platform(os) $::tcl_platform(osVersion))\
+		http/[package provide http] Tcl/[package provide Tcl]"
 	}
     }
 
@@ -211,7 +211,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
        || ([info exists state(-keepalive)] && !$state(-keepalive))
        || ([info exists state(connection)] && ($state(connection) eq "close"))
     } {
-        CloseSocket $state(sock) $token
+	CloseSocket $state(sock) $token
     }
     if {[info exists state(after)]} {
 	after cancel $state(after)
@@ -238,22 +238,22 @@ proc ::http::CloseSocket {s {token {}}} {
     catch {fileevent $s readable {}}
     set conn_id {}
     if {$token ne ""} {
-        variable $token
-        upvar 0 $token state
-        if {[info exists state(socketinfo)]} {
+	variable $token
+	upvar 0 $token state
+	if {[info exists state(socketinfo)]} {
 	    set conn_id $state(socketinfo)
-        }
+	}
     } else {
-        set map [array get socketmap]
-        set ndx [lsearch -exact $map $s]
-        if {$ndx != -1} {
+	set map [array get socketmap]
+	set ndx [lsearch -exact $map $s]
+	if {$ndx != -1} {
 	    incr ndx -1
 	    set conn_id [lindex $map $ndx]
-        }
+	}
     }
     if {$conn_id eq {} || ![info exists socketmap($conn_id)]} {
-        Log "Closing socket $s (no connection info)"
-        if {[catch {close $s} err]} {
+	Log "Closing socket $s (no connection info)"
+	if {[catch {close $s} err]} {
 	    Log "Error: $err"
 	}
     } else {
@@ -602,7 +602,7 @@ proc http::geturl {url args} {
 	if {[info exists state(-myaddr)]} {
 	    lappend sockopts -myaddr $state(-myaddr)
 	}
-        if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
+	if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
 	    # 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
@@ -612,13 +612,13 @@ proc http::geturl {url args} {
 	    Finish $token "" 1
 	    cleanup $token
 	    return -code error $sock
-        }
+	}
     }
     set state(sock) $sock
     Log "Using $sock for $state(socketinfo)" \
-        [expr {$state(-keepalive)?"keepalive":""}]
+	[expr {$state(-keepalive)?"keepalive":""}]
     if {$state(-keepalive)} {
-        set socketmap($state(socketinfo)) $sock
+	set socketmap($state(socketinfo)) $sock
     }
 
     if {![info exists phost]} {
@@ -731,16 +731,16 @@ proc http::Connected {token proto phost srvurl} {
 	    puts $sock "Host: $host:$port"
 	}
 	puts $sock "User-Agent: $http(-useragent)"
-        if {$state(-protocol) == 1.0 && $state(-keepalive)} {
+	if {$state(-protocol) == 1.0 && $state(-keepalive)} {
 	    puts $sock "Connection: keep-alive"
-        }
-        if {$state(-protocol) > 1.0 && !$state(-keepalive)} {
+	}
+	if {$state(-protocol) > 1.0 && !$state(-keepalive)} {
 	    puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
-        }
-        if {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
+	}
+	if {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
 	    puts $sock "Proxy-Connection: Keep-Alive"
-        }
-        set accept_encoding_seen 0
+	}
+	set accept_encoding_seen 0
 	set content_type_seen 0
 	dict for {key value} $state(-headers) {
 	    set value [string map [list \n "" \r ""] $value]
@@ -770,9 +770,9 @@ proc http::Connected {token proto phost srvurl} {
 	if {!$accept_types_seen} {
 	    puts $sock "Accept: $state(accept-types)"
 	}
-        if {!$accept_encoding_seen && ![info exists state(-handler)]} {
+	if {!$accept_encoding_seen && ![info exists state(-handler)]} {
 	    puts $sock "Accept-Encoding: gzip,deflate,compress"
-        }
+	}
 	if {$isQueryChannel && $state(querylength) == 0} {
 	    # Try to determine size of data in channel. If we cannot seek, the
 	    # surrounding catch will trap us
@@ -1548,31 +1548,31 @@ proc http::ContentEncoding {token} {
 
 proc http::make-transformation-chunked {chan command} {
     set lambda {{chan command} {
-        set data ""
-        set size -1
-        yield
-        while {1} {
-            chan configure $chan -translation {crlf binary}
-            while {[gets $chan line] < 1} { yield }
-            chan configure $chan -translation {binary binary}
-            if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" }
-            set chunk ""
-            while {$size && ![chan eof $chan]} {
-                set part [chan read $chan $size]
-                incr size -[string length $part]
-                append chunk $part
-            }
-            if {[catch {
+	set data ""
+	set size -1
+	yield
+	while {1} {
+	    chan configure $chan -translation {crlf binary}
+	    while {[gets $chan line] < 1} { yield }
+	    chan configure $chan -translation {binary binary}
+	    if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" }
+	    set chunk ""
+	    while {$size && ![chan eof $chan]} {
+		set part [chan read $chan $size]
+		incr size -[string length $part]
+		append chunk $part
+	    }
+	    if {[catch {
 		uplevel #0 [linsert $command end $chunk]
 	    }]} {
 		http::Log "Error in callback: $::errorInfo"
 	    }
-            if {[string length $chunk] == 0} {
+	    if {[string length $chunk] == 0} {
 		# channel might have been closed in the callback
-                catch {chan event $chan readable {}}
-                return
-            }
-        }
+		catch {chan event $chan readable {}}
+		return
+	    }
+	}
     }}
     coroutine dechunk$chan ::apply $lambda $chan $command
     chan event $chan readable [namespace origin dechunk$chan]
-- 
cgit v0.12


From 0a9706f48fcc2f0a675701d6d5097e08501d334e Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:05:42 +0000
Subject: Adjust to 80 columns except one 82-column line which would be less
 intelligible.

---
 library/http/http.tcl | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index d897fce..6abd223 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -25,9 +25,9 @@ namespace eval http {
 	    -proxyfilter http::ProxyRequired
 	    -urlencoding utf-8
 	}
-	# We need a useragent string of this style or various servers will refuse to
-	# send us compressed content even when we ask for it. This follows the
-	# de-facto layout of user-agent strings in current browsers.
+	# We need a useragent string of this style or various servers will
+	# refuse to send us compressed content even when we ask for it. This
+	# follows the de-facto layout of user-agent strings in current browsers.
 	# Safe interpreters do not have ::tcl_platform(os) or
 	# ::tcl_platform(osVersion).
 	if {[interp issafe]} {
@@ -1026,7 +1026,9 @@ proc http::Event {sock token} {
 	} elseif {$n == 0} {
 	    # We have now read all headers
 	    # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
-	    if {$state(http) == "" || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} {
+	    if {    ($state(http) == "")
+		 || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)
+	    } {
 		set state(state) "connecting"
 		return
 	    }
@@ -1369,8 +1371,8 @@ proc http::Eof {token {force 0}} {
 
 	if {!$state(binary)} {
 	    # If we are getting text, set the incoming channel's encoding
-	    # correctly.  iso8859-1 is the RFC default, but this could be any IANA
-	    # charset.  However, we only know how to convert what we have
+	    # correctly.  iso8859-1 is the RFC default, but this could be any
+	    # IANA charset.  However, we only know how to convert what we have
 	    # encodings for.
 
 	    set enc [CharsetToEncoding $state(charset)]
@@ -1538,7 +1540,8 @@ proc http::ContentEncoding {token} {
 		compress - x-compress { lappend r decompress }
 		identity {}
 		default {
-		    return -code error "unsupported content-encoding \"$coding\""
+		    set msg "unsupported content-encoding \"$coding\""
+		    return -code error $msg
 		}
 	    }
 	}
@@ -1555,7 +1558,9 @@ proc http::make-transformation-chunked {chan command} {
 	    chan configure $chan -translation {crlf binary}
 	    while {[gets $chan line] < 1} { yield }
 	    chan configure $chan -translation {binary binary}
-	    if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" }
+	    if {[scan $line %x size] != 1} {
+		return -code error "invalid size: \"$line\""
+	    }
 	    set chunk ""
 	    while {$size && ![chan eof $chan]} {
 		set part [chan read $chan $size]
-- 
cgit v0.12


From d88d33f74d687fe01610c0d278a4ce228898c7f5 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:07:05 +0000
Subject: Give all procs an explicit return, except where commented as
 "Implicit Return".

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

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 6abd223..db3c044 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -68,6 +68,7 @@ namespace eval http {
 	    }
 	}
 	array set socketmap {}
+	return
     }
     init
 
@@ -123,6 +124,7 @@ if {[info command http::Log] eq {}} {proc http::Log {args} {}}
 proc http::register {proto port command} {
     variable urlTypes
     set urlTypes([string tolower $proto]) [list $port $command]
+    # N.B. Implicit Return.
 }
 
 # http::unregister --
@@ -180,6 +182,7 @@ proc http::config {args} {
 	    }
 	    set http($flag) $value
 	}
+	return
     }
 }
 
@@ -224,6 +227,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	    set state(status) error
 	}
     }
+    return
 }
 
 # http::CloseSocket -
@@ -267,6 +271,7 @@ proc ::http::CloseSocket {s {token {}}} {
 	    Log "Cannot close connection $conn_id - no socket in socket map"
 	}
     }
+    return
 }
 
 # http::reset --
@@ -292,6 +297,7 @@ proc http::reset {token {why reset}} {
 	unset state
 	eval ::error $errorlist
     }
+    return
 }
 
 # http::geturl --
@@ -827,6 +833,7 @@ proc http::Connected {token proto phost srvurl} {
 	    Finish $token $err
 	}
     }
+    return
 }
 
 # Data access functions:
@@ -897,6 +904,7 @@ proc http::cleanup {token} {
     if {[info exists state]} {
 	unset state
     }
+    return
 }
 
 # http::Connect
@@ -987,6 +995,7 @@ proc http::Write {token} {
 	eval $state(-queryprogress) \
 	    [list $token $state(querylength) $state(queryoffset)]
     }
+    return
 }
 
 # http::Event
@@ -1192,8 +1201,8 @@ proc http::Event {sock token} {
 	    # open connection closed on a token that has been cleaned up.
 	    CloseSocket $sock
 	}
-	return
     }
+    return
 }
 
 # http::IsBinaryContentType --
@@ -1278,6 +1287,7 @@ proc http::CopyStart {sock token {initial 1}} {
 	    Finish $token $err
 	}
     }
+    return
 }
 
 proc http::CopyChunk {token chunk} {
@@ -1307,6 +1317,7 @@ proc http::CopyChunk {token chunk} {
 	}
 	Eof $token ;# FIX ME: pipelining.
     }
+    return
 }
 
 # http::CopyDone
@@ -1337,6 +1348,7 @@ proc http::CopyDone {token count {error {}}} {
     } else {
 	CopyStart $sock $token 0
     }
+    return
 }
 
 # http::Eof
@@ -1385,6 +1397,7 @@ proc http::Eof {token {force 0}} {
 	}
     }
     Finish $token
+    return
 }
 
 # http::wait --
@@ -1487,6 +1500,7 @@ proc http::ProxyRequired {host} {
 	}
 	return [list $http(-proxyhost) $http(-proxyport)]
     }
+    return
 }
 
 # http::CharsetToEncoding --
-- 
cgit v0.12


From 97721e9675b4ddd37cd3d9a8ad151961e778fee3 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:08:19 +0000
Subject: Add parentheses to some "if" tests; transform one test without
 changing its outcome.

---
 library/http/http.tcl | 43 +++++++++++++++++++++++++++----------------
 1 file changed, 27 insertions(+), 16 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index db3c044..16e0c19 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -209,7 +209,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	set state(error) [list $errormsg $errorInfo $errorCode]
 	set state(status) "error"
     }
-    if { ($state(status) eq "timeout")
+    if {  ($state(status) eq "timeout")
        || ($state(status) eq "error")
        || ([info exists state(-keepalive)] && !$state(-keepalive))
        || ([info exists state(connection)] && ($state(connection) eq "close"))
@@ -219,8 +219,8 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     if {[info exists state(after)]} {
 	after cancel $state(after)
     }
-    if {[info exists state(-command)] && !$skipCB
-	    && ![info exists state(done-command-cb)]} {
+    if {[info exists state(-command)] && (!$skipCB)
+	    && (![info exists state(done-command-cb)])} {
 	set state(done-command-cb) yes
 	if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} {
 	    set state(error) [list $err $errorInfo $errorCode]
@@ -715,7 +715,7 @@ proc http::Connected {token proto phost srvurl} {
 	fconfigure $state(-querychannel) -blocking 1 -translation binary
 	set contDone 0
     }
-    if {[info exists state(-method)] && $state(-method) ne ""} {
+    if {[info exists state(-method)] && ($state(-method) ne "")} {
 	set how $state(-method)
     }
     # We cannot handle chunked encodings with -handler, so force HTTP/1.0
@@ -737,10 +737,10 @@ proc http::Connected {token proto phost srvurl} {
 	    puts $sock "Host: $host:$port"
 	}
 	puts $sock "User-Agent: $http(-useragent)"
-	if {$state(-protocol) == 1.0 && $state(-keepalive)} {
+	if {($state(-protocol) == 1.0) && $state(-keepalive)} {
 	    puts $sock "Connection: keep-alive"
 	}
-	if {$state(-protocol) > 1.0 && !$state(-keepalive)} {
+	if {($state(-protocol) > 1.0) && !$state(-keepalive)} {
 	    puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
 	}
 	if {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
@@ -779,7 +779,7 @@ proc http::Connected {token proto phost srvurl} {
 	if {!$accept_encoding_seen && ![info exists state(-handler)]} {
 	    puts $sock "Accept-Encoding: gzip,deflate,compress"
 	}
-	if {$isQueryChannel && $state(querylength) == 0} {
+	if {$isQueryChannel && ($state(querylength) == 0)} {
 	    # Try to determine size of data in channel. If we cannot seek, the
 	    # surrounding catch will trap us
 
@@ -1050,15 +1050,26 @@ proc http::Event {sock token} {
 		return
 	    }
 
-	    # For non-chunked transfer we may have no body - in this case we
-	    # may get no further file event if the connection doesn't close
-	    # and no more data is sent. We can tell and must finish up now -
-	    # not later.
-	    if {
-		!(([info exists state(connection)]
-			&& ($state(connection) eq "close"))
-		    || [info exists state(transfer)])
-		&& ($state(totalsize) == 0)
+	    # - For non-chunked transfer we may have no body - in this case we
+	    #   may get no further file event if the connection doesn't close
+	    #   and no more data is sent. We can tell and must finish up now -
+	    #   not later - the alternative would be to wait until the server
+	    #   times out.
+	    # - In this case, the server has NOT told the client it will close
+	    #   the connection, AND it has NOT indicated the resource length
+	    #   EITHER by setting the Content-Length (totalsize) OR by using
+	    #   chunked Transer-Encoding.
+	    # - Do not worry here about the case (Connection: close) because
+	    #   the server should close the connection.
+	    # - IF (NOT Connection: close) AND (NOT chunked encoding) AND
+	    #      (totalsize == 0).
+
+	    if {    (!(    [info exists state(connection)]
+			&& ($state(connection) eq "close")
+		      )
+		    )
+		 && (![info exists state(transfer)])
+		 && ($state(totalsize) == 0)
 	    } {
 		Log "body size is 0 and no events likely - complete."
 		Eof $token
-- 
cgit v0.12


From 58eff8f224ea6ee52db925d9ff2a214f271a7e50 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:10:50 +0000
Subject: Rename some variables and commands. Details in ticket 46b6edad51.

---
 library/http/http.tcl | 100 ++++++++++++++++++++++++++++----------------------
 1 file changed, 57 insertions(+), 43 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 16e0c19..f22dc17 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -60,14 +60,14 @@ namespace eval http {
 	variable formMap [array get map]
 
 	# Create a map for HTTP/1.1 open sockets
-	variable socketmap
-	if {[info exists socketmap]} {
+	variable socketMapping
+	if {[info exists socketMapping]} {
 	    # Close but don't remove open sockets on re-init
-	    foreach {url sock} [array get socketmap] {
+	    foreach {url sock} [array get socketMapping] {
 		catch {close $sock}
 	    }
 	}
-	array set socketmap {}
+	array set socketMapping {}
 	return
     }
     init
@@ -238,37 +238,37 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 #	the second section.
 
 proc ::http::CloseSocket {s {token {}}} {
-    variable socketmap
+    variable socketMapping
     catch {fileevent $s readable {}}
-    set conn_id {}
+    set connId {}
     if {$token ne ""} {
 	variable $token
 	upvar 0 $token state
 	if {[info exists state(socketinfo)]} {
-	    set conn_id $state(socketinfo)
+	    set connId $state(socketinfo)
 	}
     } else {
-	set map [array get socketmap]
+	set map [array get socketMapping]
 	set ndx [lsearch -exact $map $s]
 	if {$ndx != -1} {
 	    incr ndx -1
-	    set conn_id [lindex $map $ndx]
+	    set connId [lindex $map $ndx]
 	}
     }
-    if {$conn_id eq {} || ![info exists socketmap($conn_id)]} {
+    if {$connId eq {} || ![info exists socketMapping($connId)]} {
 	Log "Closing socket $s (no connection info)"
 	if {[catch {close $s} err]} {
 	    Log "Error: $err"
 	}
     } else {
-	if {[info exists socketmap($conn_id)]} {
-	    Log "Closing connection $conn_id (sock $socketmap($conn_id))"
-	    if {[catch {close $socketmap($conn_id)} err]} {
+	if {[info exists socketMapping($connId)]} {
+	    Log "Closing connection $connId (sock $socketMapping($connId))"
+	    if {[catch {close $socketMapping($connId)} err]} {
 		Log "Error: $err"
 	    }
-	    unset socketmap($conn_id)
+	    unset socketMapping($connId)
 	} else {
-	    Log "Cannot close connection $conn_id - no socket in socket map"
+	    Log "Cannot close connection $connId - no socket in socket map"
 	}
     }
     return
@@ -588,13 +588,13 @@ proc http::geturl {url args} {
 
     # See if we are supposed to use a previously opened channel.
     if {$state(-keepalive)} {
-	variable socketmap
-	if {[info exists socketmap($state(socketinfo))]} {
-	    if {[catch {fconfigure $socketmap($state(socketinfo))}]} {
+	variable socketMapping
+	if {[info exists socketMapping($state(socketinfo))]} {
+	    if {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
 		Log "WARNING: socket for $state(socketinfo) was closed"
-		unset socketmap($state(socketinfo))
+		unset socketMapping($state(socketinfo))
 	    } else {
-		set sock $socketmap($state(socketinfo))
+		set sock $socketMapping($state(socketinfo))
 		Log "reusing socket $sock for $state(socketinfo)"
 		catch {fileevent $sock writable {}}
 		catch {fileevent $sock readable {}}
@@ -624,7 +624,7 @@ proc http::geturl {url args} {
     Log "Using $sock for $state(socketinfo)" \
 	[expr {$state(-keepalive)?"keepalive":""}]
     if {$state(-keepalive)} {
-	set socketmap($state(socketinfo)) $sock
+	set socketMapping($state(socketinfo)) $sock
     }
 
     if {![info exists phost]} {
@@ -1024,15 +1024,18 @@ proc http::Event {sock token} {
 	return
     }
     if {$state(state) eq "connecting"} {
-	if {[catch {gets $sock state(http)} n]} {
-	    return [Finish $token $n]
-	} elseif {$n >= 0} {
+	if {[catch {gets $sock state(http)} nsl]} {
+	    return [Finish $token $nsl]
+	} elseif {$nsl >= 0} {
 	    set state(state) "header"
+	} else {
+	    # nsl is -1 so either fblocked (OK) or eof.
+	    # Continue. Any eof is processed at the end of this proc.
 	}
     } elseif {$state(state) eq "header"} {
-	if {[catch {gets $sock line} n]} {
-	    return [Finish $token $n]
-	} elseif {$n == 0} {
+	if {[catch {gets $sock line} nhl]} {
+	    return [Finish $token $nhl]
+	} elseif {$nhl == 0} {
 	    # We have now read all headers
 	    # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
 	    if {    ($state(http) == "")
@@ -1046,7 +1049,7 @@ proc http::Event {sock token} {
 
 	    # If doing a HEAD, then we won't get any body
 	    if {$state(-validate)} {
-		Eof $token
+		Eot $token
 		return
 	    }
 
@@ -1072,7 +1075,7 @@ proc http::Event {sock token} {
 		 && ($state(totalsize) == 0)
 	    } {
 		Log "body size is 0 and no events likely - complete."
-		Eof $token
+		Eot $token
 		return
 	    }
 
@@ -1096,7 +1099,7 @@ proc http::Event {sock token} {
 		    return
 		}
 	    }
-	} elseif {$n > 0} {
+	} elseif {$nhl > 0} {
 	    # Process header lines
 	    if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 		switch -- [string tolower $key] {
@@ -1144,17 +1147,17 @@ proc http::Event {sock token} {
 		    append state(transfer_final) $line
 		} else {
 		    Log "final chunk part"
-		    Eof $token
+		    Eot $token
 		}
 	    } elseif {
 		[info exists state(transfer)]
 		&& $state(transfer) eq "chunked"
 	    } {
 		set size 0
-		set chunk [getTextLine $sock]
-		set n [string length $chunk]
-		if {[string trim $chunk] ne ""} {
-		    scan $chunk %x size
+		set hexLenChunk [getTextLine $sock]
+		set ntl [string length $hexLenChunk]
+		if {[string trim $hexLenChunk] ne ""} {
+		    scan $hexLenChunk %x size
 		    if {$size != 0} {
 			set bl [fconfigure $sock -blocking]
 			fconfigure $sock -blocking 1
@@ -1170,6 +1173,7 @@ proc http::Event {sock token} {
 			}
 			getTextLine $sock
 		    } else {
+			set n 0
 			set state(transfer_final) {}
 		    }
 		}
@@ -1190,7 +1194,7 @@ proc http::Event {sock token} {
 		    ($state(totalsize) > 0)
 		    && ($state(currentsize) >= $state(totalsize))
 		} {
-		    Eof $token
+		    Eot $token
 		}
 	    }
 	} err]} {
@@ -1203,11 +1207,11 @@ proc http::Event {sock token} {
 	}
     }
 
-    # catch as an Eof above may have closed the socket already
+    # catch as an Eot above may have closed the socket already
     if {![catch {eof $sock} eof] && $eof} {
 	if {[info exists $token]} {
 	    set state(connection) close
-	    Eof $token
+	    Eot $token
 	} else {
 	    # open connection closed on a token that has been cleaned up.
 	    CloseSocket $sock
@@ -1326,7 +1330,7 @@ proc http::CopyChunk {token chunk} {
 	    foreach stream $state(zlib) { $stream close }
 	    unset state(zlib)
 	}
-	Eof $token ;# FIX ME: pipelining.
+	Eot $token ;# FIX ME: pipelining.
     }
     return
 }
@@ -1355,24 +1359,34 @@ proc http::CopyDone {token count {error {}}} {
     if {[string length $error]} {
 	Finish $token $error
     } elseif {[catch {eof $sock} iseof] || $iseof} {
-	Eof $token
+	Eot $token
     } else {
 	CopyStart $sock $token 0
     }
     return
 }
 
-# http::Eof
+# http::Eot
+#
+#	Called when either:
+#	a. An eof condition is detected on the socket.
+#	b. The client decides that the response is complete.
+#	c. The client detects an inconsistency and aborts the transaction.
 #
-#	Handle eof on the socket
+#	Does:
+#	1. Set state(status)
+#	2. Reverse any Content-Encoding
+#	3. Convert charset encoding and line ends if necessary
+#	4. Call http::Finish
 #
 # Arguments
 #	token	The token returned from http::geturl
+#	force	optional, has no effect
 #
 # Side Effects
 #	Clean up the socket
 
-proc http::Eof {token {force 0}} {
+proc http::Eot {token {force 0}} {
     variable $token
     upvar 0 $token state
     if {$state(state) eq "header"} {
-- 
cgit v0.12


From 3b48db4a90ae3ec99e9c2e85d5a3610262d77707 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:12:47 +0000
Subject: Update some comments and a Log.

---
 library/http/http.tcl | 43 ++++++++++++++++++++++++++-----------------
 1 file changed, 26 insertions(+), 17 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index f22dc17..a6977f7 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -97,7 +97,11 @@ namespace eval http {
     }
 
     namespace export geturl config reset wait formatQuery register unregister
-    # Useful, but not exported: data size status code
+    # Useful, but not exported: data size status code cleanup error meta ncode
+    # Also mapReply.
+    #
+    # Not exported, probably should be upper-case initial letter as part
+    # of the internals: init getTextLine make-transformation-chunked
 }
 
 # http::Log --
@@ -199,7 +203,7 @@ proc http::config {args} {
 #		    reported to two places.
 #
 # Side Effects:
-#        Closes the socket
+#        May close the socket.
 
 proc http::Finish {token {errormsg ""} {skipCB 0}} {
     variable $token
@@ -235,7 +239,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 #	Close a socket and remove it from the persistent sockets table.  If
 #	possible an http token is included here but when we are called from a
 #	fileevent on remote closure we need to find the correct entry - hence
-#	the second section.
+#	the "else" block of the first "if" command.
 
 proc ::http::CloseSocket {s {token {}}} {
     variable socketMapping
@@ -600,7 +604,7 @@ proc http::geturl {url args} {
 		catch {fileevent $sock readable {}}
 	    }
 	}
-	# don't automatically close this connection socket
+	# Do not automatically close this connection socket.
 	set state(connection) {}
     }
     if {![info exists sock]} {
@@ -609,7 +613,7 @@ proc http::geturl {url args} {
 	    lappend sockopts -myaddr $state(-myaddr)
 	}
 	if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
-	    # something went wrong while trying to establish the connection.
+	    # 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.
@@ -677,7 +681,7 @@ proc http::Connected {token proto phost srvurl} {
     variable $token
     upvar 0 $token state
 
-    # Set back the variables needed here
+    # Set back the variables needed here.
     set sock $state(sock)
     set isQueryChannel [info exists state(-querychannel)]
     set isQuery [info exists state(-query)]
@@ -687,7 +691,7 @@ proc http::Connected {token proto phost srvurl} {
     set lower [string tolower $proto]
     set defport [lindex $urlTypes($lower) 0]
 
-    # Send data in cr-lf format, but accept any line terminators
+    # Send data in cr-lf format, but accept any line terminators.
 
     fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
 
@@ -827,8 +831,8 @@ proc http::Connected {token proto phost srvurl} {
 	# The socket probably was never connected, or the connection dropped
 	# later.
 
-	# if state(status) is error, it means someone's already called Finish
-	# to do the above-described clean up.
+	# if state(status) is error, it means someone's already called
+	# Finish to do the above-described clean up.
 	if {$state(status) ne "error"} {
 	    Finish $token $err
 	}
@@ -838,7 +842,7 @@ proc http::Connected {token proto phost srvurl} {
 
 # Data access functions:
 # Data - the URL data
-# Status - the transaction status: ok, reset, eof, timeout
+# Status - the transaction status: ok, reset, eof, timeout, error
 # Code - the HTTP transaction code, e.g., 200
 # Size - the size of the URL data
 
@@ -1085,7 +1089,7 @@ proc http::Event {sock token} {
 	    if {
 		$state(-binary) || [IsBinaryContentType $state(type)]
 	    } {
-		# Turn off conversions for non-text data
+		# Turn off conversions for non-text data.
 		set state(binary) 1
 	    }
 	    if {[info exists state(-channel)]} {
@@ -1093,19 +1097,19 @@ proc http::Event {sock token} {
 		    fconfigure $state(-channel) -translation binary
 		}
 		if {![info exists state(-handler)]} {
-		    # Initiate a sequence of background fcopies
+		    # Initiate a sequence of background fcopies.
 		    fileevent $sock readable {}
 		    CopyStart $sock $token
 		    return
 		}
 	    }
 	} elseif {$nhl > 0} {
-	    # Process header lines
+	    # Process header lines.
 	    if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 		switch -- [string tolower $key] {
 		    content-type {
 			set state(type) [string trim [string tolower $value]]
-			# grab the optional charset information
+			# Grab the optional charset information.
 			if {[regexp -nocase \
 				 {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \
 				 $state(type) -> cs]} {
@@ -1143,7 +1147,11 @@ proc http::Event {sock token} {
 		set line [getTextLine $sock]
 		set n [string length $line]
 		if {$n > 0} {
-		    Log "found $n bytes following final chunk"
+		    # - HTTP trailers (late response headers) are permitted by
+		    #   Chunked Transfer-Encoding, and can be safely ignored.
+		    # - Do not count these bytes in the total received for the
+		    #   response body.
+		    Log "trailer of $n bytes after final chunk - token $token"
 		    append state(transfer_final) $line
 		} else {
 		    Log "final chunk part"
@@ -1255,6 +1263,7 @@ proc http::IsBinaryContentType {type} {
 # http::getTextLine --
 #
 #	Get one line with the stream in blocking crlf mode
+#	Used if Transfer-Encoding is chunked
 #
 # Arguments
 #	sock	The socket receiving input.
@@ -1355,7 +1364,7 @@ proc http::CopyDone {token count {error {}}} {
 	eval $state(-progress) \
 	    [list $token $state(totalsize) $state(currentsize)]
     }
-    # At this point the token may have been reset
+    # At this point the token may have been reset.
     if {[string length $error]} {
 	Finish $token $error
     } elseif {[catch {eof $sock} iseof] || $iseof} {
@@ -1390,7 +1399,7 @@ proc http::Eot {token {force 0}} {
     variable $token
     upvar 0 $token state
     if {$state(state) eq "header"} {
-	# Premature eof
+	# Premature eof.
 	set state(status) eof
     } else {
 	set state(status) ok
-- 
cgit v0.12


From 25aad1ab18e6ac7d57e72db5af7ed702e0ea1dc0 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:15:26 +0000
Subject: Update some Log calls, mainly to specify token.

---
 library/http/http.tcl | 30 ++++++++++++++++++------------
 1 file changed, 18 insertions(+), 12 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index a6977f7..bfb2569 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -262,13 +262,13 @@ proc ::http::CloseSocket {s {token {}}} {
     if {$connId eq {} || ![info exists socketMapping($connId)]} {
 	Log "Closing socket $s (no connection info)"
 	if {[catch {close $s} err]} {
-	    Log "Error: $err"
+	    Log "Error closing socket: $err"
 	}
     } else {
 	if {[info exists socketMapping($connId)]} {
 	    Log "Closing connection $connId (sock $socketMapping($connId))"
 	    if {[catch {close $socketMapping($connId)} err]} {
-		Log "Error: $err"
+		Log "Error closing connection: $err"
 	    }
 	    unset socketMapping($connId)
 	} else {
@@ -595,11 +595,12 @@ proc http::geturl {url args} {
 	variable socketMapping
 	if {[info exists socketMapping($state(socketinfo))]} {
 	    if {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
-		Log "WARNING: socket for $state(socketinfo) was closed"
+		Log "WARNING: socket for $state(socketinfo) was closed\
+			 - token $token"
 		unset socketMapping($state(socketinfo))
 	    } else {
 		set sock $socketMapping($state(socketinfo))
-		Log "reusing socket $sock for $state(socketinfo)"
+		Log "reusing socket $sock for $state(socketinfo) - token $token"
 		catch {fileevent $sock writable {}}
 		catch {fileevent $sock readable {}}
 	    }
@@ -625,7 +626,7 @@ proc http::geturl {url args} {
 	}
     }
     set state(sock) $sock
-    Log "Using $sock for $state(socketinfo)" \
+    Log "Using $sock for $state(socketinfo) - token $token" \
 	[expr {$state(-keepalive)?"keepalive":""}]
     if {$state(-keepalive)} {
 	set socketMapping($state(socketinfo)) $sock
@@ -1021,7 +1022,8 @@ proc http::Event {sock token} {
 	Log "Event $sock with invalid token '$token' - remote close?"
 	if {![eof $sock]} {
 	    if {[set d [read $sock]] ne ""} {
-		Log "WARNING: additional data left on closed socket"
+		Log "WARNING: additional data left on closed socket\
+			- token $token"
 	    }
 	}
 	CloseSocket $sock
@@ -1078,7 +1080,8 @@ proc http::Event {sock token} {
 		 && (![info exists state(transfer)])
 		 && ($state(totalsize) == 0)
 	    } {
-		Log "body size is 0 and no events likely - complete."
+		set msg {body size is 0 and no events likely - complete}
+		Log "$msg - token $token"
 		Eot $token
 		return
 	    }
@@ -1154,7 +1157,7 @@ proc http::Event {sock token} {
 		    Log "trailer of $n bytes after final chunk - token $token"
 		    append state(transfer_final) $line
 		} else {
-		    Log "final chunk part"
+		    Log "final chunk part - token $token"
 		    Eot $token
 		}
 	    } elseif {
@@ -1177,7 +1180,8 @@ proc http::Event {sock token} {
 			}
 			if {$size != [string length $chunk]} {
 			    Log "WARNING: mis-sized chunk:\
-				was [string length $chunk], should be $size"
+				was [string length $chunk], should be $size -\
+				token $token"
 			}
 			getTextLine $sock
 		    } else {
@@ -1186,7 +1190,9 @@ proc http::Event {sock token} {
 		    }
 		}
 	    } else {
-		#Log "read non-chunk $state(currentsize) of $state(totalsize)"
+		set c $state(currentsize)
+		set t $state(totalsize)
+		##Log non-chunk currentsize $c of totalsize $t - token $token
 		set block [read $sock $state(-blocksize)]
 		set n [string length $block]
 		if {$n >= 0} {
@@ -1329,7 +1335,7 @@ proc http::CopyChunk {token chunk} {
 		      $token $state(totalsize) $state(currentsize)]
 	}
     } else {
-	Log "CopyChunk Finish $token"
+	Log "CopyChunk Finish - token $token"
 	if {[info exists state(zlib)]} {
 	    set excess ""
 	    foreach stream $state(zlib) {
@@ -1411,7 +1417,7 @@ proc http::Eot {token {force 0}} {
 		set state(body) [zlib $coding $state(body)]
 	    }
 	} err]} {
-	    Log "error doing decompression: $err"
+	    Log "error doing decompression for token $token: $err"
 	    return [Finish $token $err]
 	}
 
-- 
cgit v0.12


From 4f8b1772509919a3fae2017482774f3714a4d5b7 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:17:38 +0000
Subject: Tidying - add empty else clauses, omit :: at start of command name
 http::CloseSocket in proc definition, use two lines instead of "return
 [Finish ...]" because there is no return value!

---
 library/http/http.tcl | 18 +++++++++++++-----
 1 file changed, 13 insertions(+), 5 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index bfb2569..c429138 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -241,7 +241,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 #	fileevent on remote closure we need to find the correct entry - hence
 #	the "else" block of the first "if" command.
 
-proc ::http::CloseSocket {s {token {}}} {
+proc http::CloseSocket {s {token {}}} {
     variable socketMapping
     catch {fileevent $s readable {}}
     set connId {}
@@ -250,6 +250,7 @@ proc ::http::CloseSocket {s {token {}}} {
 	upvar 0 $token state
 	if {[info exists state(socketinfo)]} {
 	    set connId $state(socketinfo)
+	} else {
 	}
     } else {
 	set map [array get socketMapping]
@@ -257,18 +258,21 @@ proc ::http::CloseSocket {s {token {}}} {
 	if {$ndx != -1} {
 	    incr ndx -1
 	    set connId [lindex $map $ndx]
+	} else {
 	}
     }
     if {$connId eq {} || ![info exists socketMapping($connId)]} {
 	Log "Closing socket $s (no connection info)"
 	if {[catch {close $s} err]} {
 	    Log "Error closing socket: $err"
+	} else {
 	}
     } else {
 	if {[info exists socketMapping($connId)]} {
 	    Log "Closing connection $connId (sock $socketMapping($connId))"
 	    if {[catch {close $socketMapping($connId)} err]} {
 		Log "Error closing connection: $err"
+	    } else {
 	    }
 	    unset socketMapping($connId)
 	} else {
@@ -1031,7 +1035,8 @@ proc http::Event {sock token} {
     }
     if {$state(state) eq "connecting"} {
 	if {[catch {gets $sock state(http)} nsl]} {
-	    return [Finish $token $nsl]
+	    Finish $token $nsl
+	    return
 	} elseif {$nsl >= 0} {
 	    set state(state) "header"
 	} else {
@@ -1040,7 +1045,8 @@ proc http::Event {sock token} {
 	}
     } elseif {$state(state) eq "header"} {
 	if {[catch {gets $sock line} nhl]} {
-	    return [Finish $token $nhl]
+	    Finish $token $nhl
+	    return
 	} elseif {$nhl == 0} {
 	    # We have now read all headers
 	    # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
@@ -1212,7 +1218,8 @@ proc http::Event {sock token} {
 		}
 	    }
 	} err]} {
-	    return [Finish $token $err]
+	    Finish $token $err
+	    return
 	} else {
 	    if {[info exists state(-progress)]} {
 		eval $state(-progress) \
@@ -1418,7 +1425,8 @@ proc http::Eot {token {force 0}} {
 	    }
 	} err]} {
 	    Log "error doing decompression for token $token: $err"
-	    return [Finish $token $err]
+	    Finish $token $err
+	    return
 	}
 
 	if {!$state(binary)} {
-- 
cgit v0.12


From a8408767a49483d5bbca7cb51addc85b0d1ee9fd Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:20:14 +0000
Subject: Add "array unset socketMapping" in http::init. The sockets are closed
 and therefore do not belong in socketMapping, which should be unset.

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

diff --git a/library/http/http.tcl b/library/http/http.tcl
index c429138..77eae1b 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -62,11 +62,12 @@ namespace eval http {
 	# Create a map for HTTP/1.1 open sockets
 	variable socketMapping
 	if {[info exists socketMapping]} {
-	    # Close but don't remove open sockets on re-init
+	    # Close open sockets on re-init
 	    foreach {url sock} [array get socketMapping] {
 		catch {close $sock}
 	    }
 	}
+	array unset socketMapping
 	array set socketMapping {}
 	return
     }
-- 
cgit v0.12


From b00317d1742830de2509ee2020d19c46ff0dd665 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:25:14 +0000
Subject: Changes to response handling in Finish, Eot and Event. Carefully
 distinguish expected and premature eof. Stricter handling of errors, minor
 bugfixes.  Details in ticket 46b6edad51.

---
 library/http/http.tcl | 113 ++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 104 insertions(+), 9 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 77eae1b..5b9d03a 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -216,6 +216,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     }
     if {  ($state(status) eq "timeout")
        || ($state(status) eq "error")
+       || ($state(status) eq "eof")
        || ([info exists state(-keepalive)] && !$state(-keepalive))
        || ([info exists state(connection)] && ($state(connection) eq "close"))
     } {
@@ -1023,6 +1024,8 @@ proc http::Event {sock token} {
     variable $token
     upvar 0 $token state
 
+    ##Log Event call - token $token
+
     if {![info exists state]} {
 	Log "Event $sock with invalid token '$token' - remote close?"
 	if {![eof $sock]} {
@@ -1035,20 +1038,25 @@ proc http::Event {sock token} {
 	return
     }
     if {$state(state) eq "connecting"} {
+	##Log - connecting - token $token
 	if {[catch {gets $sock state(http)} nsl]} {
 	    Finish $token $nsl
 	    return
 	} elseif {$nsl >= 0} {
+	    ##Log - connecting 1 - token $token
 	    set state(state) "header"
 	} else {
+	    ##Log - connecting 2 - token $token
 	    # nsl is -1 so either fblocked (OK) or eof.
 	    # Continue. Any eof is processed at the end of this proc.
 	}
     } elseif {$state(state) eq "header"} {
 	if {[catch {gets $sock line} nhl]} {
+	    ##Log header failed - token $token
 	    Finish $token $nhl
 	    return
 	} elseif {$nhl == 0} {
+	    ##Log header done - token $token
 	    # We have now read all headers
 	    # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
 	    if {    ($state(http) == "")
@@ -1062,6 +1070,7 @@ proc http::Event {sock token} {
 
 	    # If doing a HEAD, then we won't get any body
 	    if {$state(-validate)} {
+		set state(state) complete
 		Eot $token
 		return
 	    }
@@ -1089,6 +1098,7 @@ proc http::Event {sock token} {
 	    } {
 		set msg {body size is 0 and no events likely - complete}
 		Log "$msg - token $token"
+		set state(state) complete
 		Eot $token
 		return
 	    }
@@ -1115,6 +1125,7 @@ proc http::Event {sock token} {
 	    }
 	} elseif {$nhl > 0} {
 	    # Process header lines.
+	    ##Log header - token $token - $line
 	    if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 		switch -- [string tolower $key] {
 		    content-type {
@@ -1150,12 +1161,46 @@ proc http::Event {sock token} {
 	}
     } else {
 	# Now reading body
+	##Log body - token $token
 	if {[catch {
 	    if {[info exists state(-handler)]} {
 		set n [eval $state(-handler) [list $sock $token]]
+		##Log handler $n - token $token
+		# N.B. the protocol has been set to 1.0 because the -handler
+		# logic is not expected to handle chunked encoding.
+		# FIXME allow -handler with 1.1 on dechunked stacked channel.
+		if {$state(totalsize) == 0} {
+		    # We know the transfer is complete only when the server
+		    # closes the connection - i.e. eof is not an error.
+		    set state(state) complete
+		}
+		if {![string is integer -strict $n]} {
+		    if 1 {
+			# Do not tolerate bad -handler - fail with error status.
+			set msg {the -handler command for http::geturl must\
+				return an integer (the number of bytes read)}
+			Eot $token $msg
+		    } else {
+			# Tolerate the bad -handler, and continue.  The penalty:
+			# (a) Because the handler returns nonsense, we know the
+			#     transfer is complete only when the server closes
+			#     the connection - i.e. eof is not an error.
+			# (b) http::size will not be accurate.
+			# (c) The transaction is already downgraded to 1.0 to
+			#     avoid chunked transfer encoding.  It MUST also be
+			#     forced to "Connection: close" or the HTTP/1.0
+			#     equivalent; or it MUST fail (as above) if the
+			#     server sends "Connection: keep-alive" or the
+			#     HTTP/1.0 equivalent.
+			set n 0
+			set state(state) complete
+		    }
+		} else {
+		}
 	    } elseif {[info exists state(transfer_final)]} {
 		set line [getTextLine $sock]
 		set n [string length $line]
+		set state(state) complete
 		if {$n > 0} {
 		    # - HTTP trailers (late response headers) are permitted by
 		    #   Chunked Transfer-Encoding, and can be safely ignored.
@@ -1163,20 +1208,22 @@ proc http::Event {sock token} {
 		    #   response body.
 		    Log "trailer of $n bytes after final chunk - token $token"
 		    append state(transfer_final) $line
+		    set n 0
 		} else {
 		    Log "final chunk part - token $token"
 		    Eot $token
 		}
-	    } elseif {
-		[info exists state(transfer)]
-		&& $state(transfer) eq "chunked"
+	    } elseif {    [info exists state(transfer)]
+		       && ($state(transfer) eq "chunked")
 	    } {
+		##Log chunked - token $token
 		set size 0
 		set hexLenChunk [getTextLine $sock]
-		set ntl [string length $hexLenChunk]
+		#set ntl [string length $hexLenChunk]
 		if {[string trim $hexLenChunk] ne ""} {
 		    scan $hexLenChunk %x size
 		    if {$size != 0} {
+			##Log chunk-measure $size - token $token
 			set bl [fconfigure $sock -blocking]
 			fconfigure $sock -blocking 1
 			set chunk [read $sock $size]
@@ -1184,19 +1231,39 @@ proc http::Event {sock token} {
 			set n [string length $chunk]
 			if {$n >= 0} {
 			    append state(body) $chunk
+			    incr state(log_size) [string length $chunk]
+			    ##Log chunk $n cumul $state(log_size) - token $token
 			}
 			if {$size != [string length $chunk]} {
 			    Log "WARNING: mis-sized chunk:\
 				was [string length $chunk], should be $size -\
 				token $token"
+			    set n 0
+			    set state(connection) close
+			    set msg {error in chunked encoding - fetch\
+				    terminated}
+			    Eot $token $msg
 			}
+			# CRLF that follows chunk:
 			getTextLine $sock
 		    } else {
 			set n 0
 			set state(transfer_final) {}
 		    }
+		} else {
+		    # Line expected to hold chunk length is empty.
+		    ##Log bad-chunk-measure - token $token
+		    set n 0
+		    set state(connection) close
+		    Eot $token {error in chunked encoding - fetch terminated}
 		}
 	    } else {
+		##Log unchunked - token $token
+		if {$state(totalsize) == 0} {
+		    # We know the transfer is complete only when the server
+		    # closes the connection.
+		    set state(state) complete
+		}
 		set c $state(currentsize)
 		set t $state(totalsize)
 		##Log non-chunk currentsize $c of totalsize $t - token $token
@@ -1204,17 +1271,24 @@ proc http::Event {sock token} {
 		set n [string length $block]
 		if {$n >= 0} {
 		    append state(body) $block
+		    ##Log non-chunk [string length $state(body)] - token $token
 		}
 	    }
+	    # This calculation uses n from the -handler, chunked, or unchunked
+	    # case as appropriate.
 	    if {[info exists state]} {
 		if {$n >= 0} {
 		    incr state(currentsize) $n
+		    set c $state(currentsize)
+		    set t $state(totalsize)
+		    ##Log chunk $n currentsize $c totalsize $t - token $token
 		}
 		# If Content-Length - check for end of data.
 		if {
 		    ($state(totalsize) > 0)
 		    && ($state(currentsize) >= $state(totalsize))
 		} {
+		    set state(state) complete
 		    Eot $token
 		}
 	    }
@@ -1230,10 +1304,21 @@ 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 {![catch {eof $sock} eof] && $eof} {
+	##Log eof - token $token
 	if {[info exists $token]} {
 	    set state(connection) close
-	    Eot $token
+	    if {$state(state) eq "complete"} {
+		# This includes all cases in which the transaction
+		# can be completed by eof.
+		# The value "complete" is set only in http::Event, and it is
+		# used only in the test above.
+		Eot $token
+	    } else {
+		# Premature eof.
+		Eot $token eof
+	    }
 	} else {
 	    # open connection closed on a token that has been cleaned up.
 	    CloseSocket $sock
@@ -1404,18 +1489,28 @@ proc http::CopyDone {token count {error {}}} {
 #
 # Arguments
 #	token	The token returned from http::geturl
-#	force	optional, has no effect
+#	force	(previously) optional, has no effect
+#	reason	- "eof" means premature EOF (not EOF as the natural end of
+#		  the response)
+#		- "" means completion of response, with or without EOF
+#		- anything else describes an error confition other than
+#		  premature EOF.
 #
 # Side Effects
 #	Clean up the socket
 
-proc http::Eot {token {force 0}} {
+proc http::Eot {token {reason {}}} {
     variable $token
     upvar 0 $token state
-    if {$state(state) eq "header"} {
+    if {$reason eq "eof"} {
 	# Premature eof.
 	set state(status) eof
+	set reason {}
+    } elseif {$reason ne ""} {
+	# Abort the transaction.
+	set state(status) $reason
     } else {
+	# The response is complete.
 	set state(status) ok
     }
 
@@ -1445,7 +1540,7 @@ proc http::Eot {token {force 0}} {
 	    set state(body) [string map {\r\n \n \r \n} $state(body)]
 	}
     }
-    Finish $token
+    Finish $token $reason
     return
 }
 
-- 
cgit v0.12


From 767cf6314a06f14d275746f66df21ef6ee324715 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:29:43 +0000
Subject: Workaround for bug with https and unchunked response.  A [read] does
 not deliver until the server closes the socket.  The workaround is to specify
 the buffer size as the precise length required.

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

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 5b9d03a..d67e217 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -1263,11 +1263,23 @@ proc http::Event {sock token} {
 		    # We know the transfer is complete only when the server
 		    # closes the connection.
 		    set state(state) complete
+		    set reqSize $state(-blocksize)
+		} else {
+		    # Ask for the whole of the unserved response-body.
+		    # This works around a problem with a tls::socket - for https
+		    # in keep-alive mode, and a request for $state(-blocksize)
+		    # bytes, the last part of the resource does not get read
+		    # until the server times out.
+		    set reqSize [expr {$state(totalsize) - $state(currentsize)}]
+
+		    # The workaround fails if reqSize is
+		    # capped at $state(-blocksize).
+		    # set reqSize [expr {min($reqSize, $state(-blocksize))}]
 		}
 		set c $state(currentsize)
 		set t $state(totalsize)
 		##Log non-chunk currentsize $c of totalsize $t - token $token
-		set block [read $sock $state(-blocksize)]
+		set block [read $sock $reqSize]
 		set n [string length $block]
 		if {$n >= 0} {
 		    append state(body) $block
@@ -1404,6 +1416,10 @@ proc http::CopyStart {sock token {initial 1}} {
 	    }
 	}
 	if {[catch {
+	    # FIXME Keep-Alive on https tls::socket with unchunked transfer
+	    # hangs until the server times out. A workaround is possible, as for
+	    # the case without -channel, but it does not use the neat "fcopy"
+	    # solution.
 	    fcopy $sock $state(-channel) -size $state(-blocksize) -command \
 		[list http::CopyDone $token]
 	} err]} {
-- 
cgit v0.12


From 731f40c6d954e4bb641cb336383eb4ea5d204b92 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:32:37 +0000
Subject: New http::config option -zip to control whether to send an
 "Accept-Encoding" request-header for a zipped response.  Default true for
 backward compatibility.

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

diff --git a/library/http/http.tcl b/library/http/http.tcl
index d67e217..9069291 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -24,6 +24,7 @@ namespace eval http {
 	    -proxyport {}
 	    -proxyfilter http::ProxyRequired
 	    -urlencoding utf-8
+	    -zip 1
 	}
 	# We need a useragent string of this style or various servers will
 	# refuse to send us compressed content even when we ask for it. This
@@ -787,7 +788,10 @@ proc http::Connected {token proto phost srvurl} {
 	if {!$accept_types_seen} {
 	    puts $sock "Accept: $state(accept-types)"
 	}
-	if {!$accept_encoding_seen && ![info exists state(-handler)]} {
+	if {    (!$accept_encoding_seen)
+	     && (![info exists state(-handler)])
+	     && $http(-zip)
+	} {
 	    puts $sock "Accept-Encoding: gzip,deflate,compress"
 	}
 	if {$isQueryChannel && ($state(querylength) == 0)} {
-- 
cgit v0.12


From e80e2146736e8176a0364b03fd8ad0fefe92e8d6 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:37:06 +0000
Subject: BUGFIX. Send "Connection: keep-alive" even if HTTP/1.1. Some servers
 (including Apache 2.2 on RHEL6) use the discretion granted by RFCs and will
 close the connection unless this header is sent.

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

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 9069291..485498a 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -749,7 +749,9 @@ proc http::Connected {token proto phost srvurl} {
 	    puts $sock "Host: $host:$port"
 	}
 	puts $sock "User-Agent: $http(-useragent)"
-	if {($state(-protocol) == 1.0) && $state(-keepalive)} {
+	if {($state(-protocol) >= 1.0) && $state(-keepalive)} {
+	    # Send this header, because a 1.1 server is not compelled to treat
+	    # this as the default.
 	    puts $sock "Connection: keep-alive"
 	}
 	if {($state(-protocol) > 1.0) && !$state(-keepalive)} {
-- 
cgit v0.12


From f35c0dc2edcc96ff38d150cd621cea7b771c9a4c Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:49:13 +0000
Subject: Revise tests/http11.test for use with commits from 78b23edb6b
 onwards.  Adjust proc "handler" to conform to http(n)

---
 tests/http11.test | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

diff --git a/tests/http11.test b/tests/http11.test
index c9ded0b..8483aa3 100644
--- a/tests/http11.test
+++ b/tests/http11.test
@@ -515,10 +515,7 @@ proc handler {var sock token} {
     set chunk [read $sock]
     append data $chunk
     #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
-    if {[eof $sock]} {
-        #::http::Log "handler eof $sock"
-	chan event $sock readable {}
-    }
+    return [string length $chunk]
 }
 
 test http11-3.0 "-handler,close,identity" -setup {
-- 
cgit v0.12


From e9bb0992b0f392798d2d978f2bdcbc62aa6ea602 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:52:40 +0000
Subject: First step for implementing concurrent requests using the same
 connection. Define namespace variables socket* and http where they will
 (eventually) be used. Leave them unused except in http::init where they are
 initialised.

---
 library/http/http.tcl | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 68 insertions(+)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 485498a..8b4d714 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -62,14 +62,35 @@ namespace eval http {
 
 	# Create a map for HTTP/1.1 open sockets
 	variable socketMapping
+	variable socketRdState
+	variable socketWrState
+	variable socketRdQueue
+	variable socketWrQueue
+	variable socketClosing
+	variable socketPlayCmd
 	if {[info exists socketMapping]} {
 	    # Close open sockets on re-init
 	    foreach {url sock} [array get socketMapping] {
 		catch {close $sock}
 	    }
 	}
+
+	# Traces on "unset socketRdState(*)" will cancel any queued responses.
+	# Traces on "unset socketWrState(*)" will cancel any queued requests.
 	array unset socketMapping
+	array unset socketRdState
+	array unset socketWrState
+	array unset socketRdQueue
+	array unset socketWrQueue
+	array unset socketClosing
+	array unset socketPlayCmd
 	array set socketMapping {}
+	array set socketRdState {}
+	array set socketWrState {}
+	array set socketRdQueue {}
+	array set socketWrQueue {}
+	array set socketClosing {}
+	array set socketPlayCmd {}
 	return
     }
     init
@@ -208,6 +229,14 @@ proc http::config {args} {
 #        May close the socket.
 
 proc http::Finish {token {errormsg ""} {skipCB 0}} {
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
     variable $token
     upvar 0 $token state
     global errorInfo errorCode
@@ -246,6 +275,13 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 
 proc http::CloseSocket {s {token {}}} {
     variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
     catch {fileevent $s readable {}}
     set connId {}
     if {$token ne ""} {
@@ -600,6 +636,13 @@ proc http::geturl {url args} {
     # See if we are supposed to use a previously opened channel.
     if {$state(-keepalive)} {
 	variable socketMapping
+	variable socketRdState
+	variable socketWrState
+	variable socketRdQueue
+	variable socketWrQueue
+	variable socketClosing
+	variable socketPlayCmd
+
 	if {[info exists socketMapping($state(socketinfo))]} {
 	    if {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
 		Log "WARNING: socket for $state(socketinfo) was closed\
@@ -685,6 +728,13 @@ proc http::geturl {url args} {
 proc http::Connected {token proto phost srvurl} {
     variable http
     variable urlTypes
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
 
     variable $token
     upvar 0 $token state
@@ -962,6 +1012,15 @@ proc http::Connect {token proto phost srvurl} {
 #	Write the socket and handle callbacks.
 
 proc http::Write {token} {
+    variable http
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
     variable $token
     upvar 0 $token state
     set sock $state(sock)
@@ -1027,6 +1086,15 @@ proc http::Write {token} {
 #	Read the socket and handle callbacks.
 
 proc http::Event {sock token} {
+    variable http
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
     variable $token
     upvar 0 $token state
 
-- 
cgit v0.12


From 0d887fa4657702c34d0b109df9e2634a563e5178 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:55:21 +0000
Subject: Define variable tk used in Log calls for testing.

---
 library/http/http.tcl | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 8b4d714..2a5bc24 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -282,6 +282,8 @@ proc http::CloseSocket {s {token {}}} {
     variable socketClosing
     variable socketPlayCmd
 
+    set tk [namespace tail $token]
+
     catch {fileevent $s readable {}}
     set connId {}
     if {$token ne ""} {
@@ -375,6 +377,7 @@ proc http::geturl {url args} {
     set token [namespace current]::[incr http(uid)]
     variable $token
     upvar 0 $token state
+    set tk [namespace tail $token]
     reset $token
 
     # Process command options.
@@ -738,6 +741,7 @@ proc http::Connected {token proto phost srvurl} {
 
     variable $token
     upvar 0 $token state
+    set tk [namespace tail $token]
 
     # Set back the variables needed here.
     set sock $state(sock)
@@ -988,6 +992,7 @@ proc http::cleanup {token} {
 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)] ||
@@ -1023,6 +1028,7 @@ proc http::Write {token} {
 
     variable $token
     upvar 0 $token state
+    set tk [namespace tail $token]
     set sock $state(sock)
 
     # Output a block.  Tcl will buffer this if the socket blocks
@@ -1097,6 +1103,7 @@ proc http::Event {sock token} {
 
     variable $token
     upvar 0 $token state
+    set tk [namespace tail $token]
 
     ##Log Event call - token $token
 
-- 
cgit v0.12


From d38ae8f97463f0a3fc07324aeae3de9508dbe9cc Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 08:56:16 +0000
Subject: Adapt fconfigure -translation for two-way pipelined operation.

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

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 2a5bc24..06f452d 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -676,8 +676,13 @@ proc http::geturl {url args} {
 	    Finish $token "" 1
 	    cleanup $token
 	    return -code error $sock
+	} else {
+	    # Initialisation of a new socket.
+	    fconfigure $sock -translation {auto crlf} \
+			     -buffersize $state(-blocksize)
 	}
     }
+
     set state(sock) $sock
     Log "Using $sock for $state(socketinfo) - token $token" \
 	[expr {$state(-keepalive)?"keepalive":""}]
@@ -754,8 +759,11 @@ proc http::Connected {token proto phost srvurl} {
     set defport [lindex $urlTypes($lower) 0]
 
     # Send data in cr-lf format, but accept any line terminators.
-
-    fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
+    # Initialisation to {auto *} now done in geturl.
+    # We are concerned here with the request (write) not the response (read).
+    lassign [fconfigure $sock -translation] trRead trWrite
+    fconfigure $sock -translation [list $trRead crlf] \
+		     -buffersize $state(-blocksize)
 
     # The following is disallowed in safe interpreters, but the socket is
     # already in non-blocking mode in that case.
@@ -778,7 +786,9 @@ proc http::Connected {token proto phost srvurl} {
 	set how POST
 	# The query channel must be blocking for the async Write to
 	# work properly.
-	fconfigure $state(-querychannel) -blocking 1 -translation binary
+	lassign [fconfigure $sock -translation] trRead trWrite
+	fconfigure $state(-querychannel) -blocking 1 \
+					 -translation [list $trRead binary]
 	set contDone 0
     }
     if {[info exists state(-method)] && ($state(-method) ne "")} {
@@ -886,7 +896,8 @@ proc http::Connected {token proto phost srvurl} {
 		puts $sock "Content-Length: $state(querylength)"
 	    }
 	    puts $sock ""
-	    fconfigure $sock -translation {auto binary}
+	    lassign [fconfigure $sock -translation] trRead trWrite
+	    fconfigure $sock -translation [list $trRead binary]
 	    fileevent $sock writable [list http::Write $token]
 	} else {
 	    puts $sock ""
@@ -1185,7 +1196,8 @@ proc http::Event {sock token} {
 	    }
 
 	    # We have to use binary translation to count bytes properly.
-	    fconfigure $sock -translation binary
+	    lassign [fconfigure $sock -translation] trRead trWrite
+	    fconfigure $sock -translation [list binary $trWrite]
 
 	    if {
 		$state(-binary) || [IsBinaryContentType $state(type)]
@@ -1465,8 +1477,9 @@ proc http::IsBinaryContentType {type} {
 
 proc http::getTextLine {sock} {
     set tr [fconfigure $sock -translation]
+    lassign $tr trRead trWrite
     set bl [fconfigure $sock -blocking]
-    fconfigure $sock -translation crlf -blocking 1
+    fconfigure $sock -translation [list crlf $trWrite] -blocking 1
     set r [gets $sock]
     fconfigure $sock -translation $tr -blocking $bl
     return $r
-- 
cgit v0.12


From 70af5c2b8260845974300e98c2e4c464b787d94e Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Tue, 27 Mar 2018 14:20:23 +0000
Subject: Implement queuing and pipelining for HTTP requests over a persistent
 connection.

---
 doc/http.n               |  159 ++++-
 library/http/http.tcl    | 1448 ++++++++++++++++++++++++++++++++++++++++++++--
 tests/httpPipeline.test  |  859 +++++++++++++++++++++++++++
 tests/httpTest.tcl       |  431 ++++++++++++++
 tests/httpTestScript.tcl |  509 ++++++++++++++++
 5 files changed, 3356 insertions(+), 50 deletions(-)
 create mode 100644 tests/httpPipeline.test
 create mode 100644 tests/httpTest.tcl
 create mode 100644 tests/httpTestScript.tcl

diff --git a/doc/http.n b/doc/http.n
index 40ced23..2dae77e 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -6,14 +6,14 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\"
-.TH "http" n 2.7 http "Tcl Bundled Packages"
+.TH "http" n 2.8 http "Tcl Bundled Packages"
 .so man.macros
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
 http \- Client-side implementation of the HTTP/1.1 protocol
 .SH SYNOPSIS
-\fBpackage require http ?2.7?\fR
+\fBpackage require http ?2.8?\fR
 .\" See Also -useragent option documentation in body!
 .sp
 \fB::http::config ?\fI\-option value\fR ...?
@@ -49,7 +49,7 @@ http \- Client-side implementation of the HTTP/1.1 protocol
 .SH DESCRIPTION
 .PP
 The \fBhttp\fR package provides the client side of the HTTP/1.1
-protocol, as defined in RFC 2616.
+protocol, as defined in RFC 7230 to RFC 7235, which supersede RFC 2616.
 The package implements the GET, POST, and HEAD operations
 of HTTP/1.1.  It allows configuration of a proxy host to get through
 firewalls.  The package is compatible with the \fBSafesock\fR security
@@ -95,6 +95,19 @@ comma-separated list of mime type patterns that you are
 willing to receive.  For example,
 .QW "image/gif, image/jpeg, text/*" .
 .TP
+\fB\-pipeline\fR \fIboolean\fR
+.
+Specifies whether HTTP/1.1 transactions on a persistent socket will be
+pipelined.  See the \fBPERSISTENT SOCKETS\fR section for details. The default
+is 1.
+.TP
+\fB\-postfresh\fR \fIboolean\fR
+.
+Specifies whether requests that use the \fBPOST\fR method will always use a
+fresh socket, overriding the \fB-keepalive\fR option of
+command \fBhttp::geturl\fR.  See the \fBPERSISTENT SOCKETS\fR section for details.
+The default is 0.
+.TP
 \fB\-proxyhost\fR \fIhostname\fR
 .
 The name of the proxy host, if any.  If this value is the
@@ -116,6 +129,18 @@ an empty list.  The default filter returns the values of the
 \fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are
 non-empty.
 .TP
+\fB\-repost\fR \fIboolean\fR
+.
+Specifies what to do if a POST request over a persistent connection fails
+because the server has half-closed the connection.  If boolean \fBtrue\fR, the
+request
+will be automatically retried; if boolean \fBfalse\fR it will not, and the
+application
+that uses \fBhttp::geturl\fR is expected to seek user confirmation before
+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\-urlencoding\fR \fIencoding\fR
 .
 The \fIencoding\fR used for creating the x-url-encoded URLs with
@@ -128,8 +153,22 @@ characters.
 .TP
 \fB\-useragent\fR \fIstring\fR
 .
-The value of the User-Agent header in the HTTP request.  The default is
-.QW "\fBTcl http client package 2.7\fR" .
+The value of the User-Agent header in the HTTP request.  In an unsafe
+interpreter, the default value depends upon the operating system, and
+the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example)
+.QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.8.12 Tcl/8.6.8\fR" .
+A safe interpreter cannot determine its operating system, and so the default
+in a safe interpreter is to use a Windows 10 value with the current version
+numbers of \fBhttp\fR and \fBTcl\fR.
+.TP
+\fB\-zip\fR \fIboolean\fR
+.
+If the value is boolean \fBtrue\fR, then by default requests will send a header
+.QW "\fBAccept-Encoding: gzip,deflate,compress\fR" .
+If the value is boolean \fBfalse\fR, then by default this header will not be sent.
+In either case the default can be overridden for an individual request by
+supplying a custom \fBAccept-Encoding\fR header in the \fB-headers\fR option
+of \fBhttp::geturl\fR. The default is 1.
 .RE
 .TP
 \fB::http::geturl\fR \fIurl\fR ?\fIoptions\fR?
@@ -227,7 +266,7 @@ Pragma: no-cache
 .TP
 \fB\-keepalive\fR \fIboolean\fR
 .
-If true, attempt to keep the connection open for servicing
+If boolean \fBtrue\fR, attempt to keep the connection open for servicing
 multiple requests.  Default is 0.
 .TP
 \fB\-method\fR \fItype\fR
@@ -504,6 +543,14 @@ The following elements of
 the array are supported:
 .RS
 .TP
+\fBbinary\fR
+.
+This is boolean \fBtrue\fR if (after decoding any compression specified
+by the
+.QW "Content-Encoding"
+response header) the HTTP response is binary.  It is boolean \fBfalse\fR
+if the HTTP response is text.
+.TP
 \fBbody\fR
 .
 The contents of the URL.  This will be empty if the \fB\-channel\fR
@@ -602,6 +649,106 @@ A copy of the \fBContent-Type\fR meta-data value.
 .
 The requested URL.
 .RE
+.SH "PERSISTENT CONNECTIONS"
+.PP
+.SS "BASICS"
+.PP
+See RFC 7230 Sec 6, which supersedes RFC 2616 Sec 8.1.
+.PP
+A persistent connection allows multiple HTTP/1.1 transactions to be
+carried over the same TCP connection.  Pipelining allows a
+client to make multiple requests over a persistent connection without
+waiting for each response.  The server sends responses in the same order
+that the requests were received.
+.PP
+If a POST request fails to complete, typically user confirmation is
+needed before sending the request again.  The user may wish to verify
+whether the server was modified by the failed POST request, before
+sending the same request again.
+.PP
+A HTTP request will use a persistent socket if the call to
+\fBhttp::geturl\fR has the option \fB-keepalive true\fR. It will use
+pipelining where permitted if the \fBhttp::config\fR option
+\fB-pipeline\fR is boolean \fBtrue\fR (its default value).
+.PP
+The http package maintains no more than one persistent connection to each
+server (i.e. each value of
+.QW "domain:port" ).
+If \fBhttp::geturl\fR is called to make a request over a persistent
+connection while the connection is busy with another request, the new
+request will be held in a queue until the connection is free.
+.PP
+The http package does not support HTTP/1.0 persistent connections
+controlled by the \fBKeep-Alive\fR header.
+.SS "SPECIAL CASES"
+.PP
+This subsection discusses issues related to closure of the
+persistent connection by the server, automatic retry of failed requests,
+the special treatment necessary for POST requests, and the options for
+dealing with these cases.
+.PP
+In accordance with RFC 7230, \fBhttp::geturl\fR does not pipeline
+requests that use the POST method.  If a POST uses a persistent
+connection and is not the first request on that connection,
+\fBhttp::geturl\fR waits until it has received the response for the previous
+request; or (if \fBhttp::config\fR option \fB-postfresh\fR is boolean \fBtrue\fR) it
+uses a new connection for each POST.
+.PP
+If the server is processing a number of pipelined requests, and sends a
+response header
+.QW "\fBConnection: close\fR"
+with one of the responses (other than the last), then subsequent responses
+are unfulfilled. \fBhttp::geturl\fR will send the unfulfilled requests again
+over a new connection.
+.PP
+A difficulty arises when a HTTP client sends a request over a persistent
+connection that has been idle for a while.  The HTTP server may
+half-close an apparently idle connection while the client is sending a
+request, but before the request arrives at the server: in this case (an
+.QW "asynchronous close event" )
+the request will fail.  The difficulty arises because the client cannot
+be certain whether the POST modified the state of the server.  For HEAD or
+GET requests, \fBhttp::geturl\fR opens another connection and retransmits
+the failed request. However, if the request was a POST, RFC 7230 forbids
+automatic retry by default, suggesting either user confirmation, or
+confirmation by user-agent software that has semantic understanding of
+the application.  The \fBhttp::config\fR option \fB-repost\fR allows for
+either possibility.
+.PP
+Asynchronous close events can occur only in a short interval of time.  The
+\fBhttp\fR package monitors each persistent connection for closure by the
+server.  Upon detection, the connection is also closed at the client end,
+and subsequent requests will use a fresh connection.
+.PP
+If the \fBhttp::geturl\fR command is called with option \fB-keepalive true\fR,
+then it will both try to use an existing persistent connection
+(if one is available), and it will send the server a
+.QW "\fBConnection: keep-alive\fR"
+request header asking to keep the connection open for future requests.
+.PP
+The \fBhttp::config\fR options \fB-pipeline\fR, \fB-postfresh\fR, and
+\fB-repost\fR relate to persistent connections.
+.PP
+Option \fB-pipeline\fR, if boolean \fBtrue\fR, will pipeline GET and HEAD requests
+made
+over a persistent connection.  POST requests will not be pipelined - if the
+POST is not the first transaction on the connection, its request will not
+be sent until the previous response has finished.  GET and HEAD requests
+made after a POST will not be sent until the POST response has been
+delivered, and will not be sent if the POST fails.
+.PP
+Option \fB-postfresh\fR, if boolean \fBtrue\fR, will override the \fBhttp::geturl\fR option
+\fB-keepalive\fR, and always open a fresh connection for a POST request.
+.PP
+Option \fB-repost\fR, if \fBtrue\fR, permits automatic retry of a POST request
+that fails because it uses a persistent connection that the server has
+half-closed (an 
+.QW "asynchronous close event" ).
+Subsequent GET and HEAD requests in a failed pipeline will also be retried.
+\fIThe -repost option should be used only if the application understands
+that the retry is appropriate\fR - specifically, the application must know
+that if the failed POST successfully modified the state of the server, a repeat POST
+would have no adverse effect.
 .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 06f452d..f4f83c6 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -20,9 +20,12 @@ namespace eval http {
     if {![info exists http]} {
 	array set http {
 	    -accept */*
+	    -pipeline 1
+	    -postfresh 0
 	    -proxyhost {}
 	    -proxyport {}
 	    -proxyfilter http::ProxyRequired
+	    -repost 0
 	    -urlencoding utf-8
 	    -zip 1
 	}
@@ -220,7 +223,7 @@ proc http::config {args} {
 # Arguments:
 #	token	    Connection token.
 #	errormsg    (optional) If set, forces status to error.
-#       skipCB      (optional) If set, don't call the -command callback. This
+#	skipCB      (optional) If set, don't call the -command callback. This
 #		    is useful when geturl wants to throw an exception instead
 #		    of calling the callback. That way, the same error isn't
 #		    reported to two places.
@@ -240,6 +243,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     variable $token
     upvar 0 $token state
     global errorInfo errorCode
+    set closeQueue 0
     if {$errormsg ne ""} {
 	set state(error) [list $errormsg $errorInfo $errorCode]
 	set state(status) "error"
@@ -251,6 +255,12 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
        || ([info exists state(connection)] && ($state(connection) eq "close"))
     } {
 	CloseSocket $state(sock) $token
+	set closeQueue 1
+    } elseif {
+	  ([info exists state(-keepalive)] && $state(-keepalive))
+       && ([info exists state(connection)] && ($state(connection) ne "close"))
+    } {
+	KeepSocket $token
     }
     if {[info exists state(after)]} {
 	after cancel $state(after)
@@ -263,6 +273,233 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	    set state(status) error
 	}
     }
+
+    if {    $closeQueue
+	 && [info exists state(socketinfo)]
+	 && [info exists socketMapping($state(socketinfo))]
+	 && ($socketMapping($state(socketinfo)) eq $state(sock))
+    } {
+	    http::CloseQueuedQueries $state(socketinfo) $token
+    }
+
+    return
+}
+
+# http::KeepSocket -
+#
+#	Keep a socket in the persistent sockets table and connect it to its next
+#	queued task if possible.  Otherwise leave it idle and ready for its next
+#	use.
+#
+# Arguments:
+#	token	    Connection token.
+
+proc http::KeepSocket {token} {
+    variable http
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
+    variable $token
+    upvar 0 $token state
+    set tk [namespace tail $token]
+
+    # Keep this socket open for another request ("Keep-Alive").
+    # React if the server half-closes the socket.
+    # Discussion is in http::geturl.
+    catch {fileevent $state(sock) readable [list http::CheckEof $state(sock)]}
+
+    # The line below should not be changed in production code.
+    # It is edited by the test suite.
+    set TEST_EOF 0
+    if {$TEST_EOF} {
+	# ONLY for testing reaction to server eof.
+	# No server timeouts will be caught.
+        catch {fileevent $state(sock) readable {}}
+    } else {
+        # Normal operation.
+        # Test constraint normalEof.
+    }
+
+    if {    [info exists state(socketinfo)]
+	 && [info exists socketMapping($state(socketinfo))]
+    } {
+	set connId $state(socketinfo)
+	# The value "Rready" is set only here.
+	set socketRdState($connId) Rready
+
+	if {    $state(-pipeline)
+	     && [info exists socketRdQueue($connId)]
+	     && [llength $socketRdQueue($connId)]
+	} {
+	    # The usual case for pipelined responses - if another response is
+	    # 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
+	    lassign [fconfigure $state3(sock) -translation] trRead trWrite
+	    fconfigure $state3(sock) -translation [list auto $trWrite] \
+				     -buffersize $state3(-blocksize)
+	    Log ^D$tk2 begin receiving response - token $token3
+	    fileevent $state3(sock) readable \
+		    [list http::Event $state3(sock) $token3]
+	    #Log ---- $state3(sock) >> conn to $token3 for HTTP response (a)
+
+	    # Other pipelined cases.
+	    # - The test above ensures that, for the pipelined cases in the two
+	    #   tests below, the read queue is empty.
+	    # - In those two tests, check whether the next write will be
+	    #   nonpipeline.
+	} elseif {
+		$state(-pipeline)
+	     && [info exists socketWrState($connId)]
+	     && ($socketWrState($connId) eq "peNding")
+
+	     && [info exists socketWrQueue($connId)]
+	     && [llength $socketWrQueue($connId)]
+	     && (![set token3 [lindex $socketWrQueue($connId) 0]
+		   set ${token3}(-pipeline)
+		  ]
+		)
+	} {
+	    # This case:
+	    # - Now it the time to run the "pending" request.
+	    # - The next token in the write queue is nonpipeline, and
+	    #   socketWrState has been marked "pending" (in
+	    #   http::NextPipelinedWrite or http::geturl) so a new pipelined
+	    #   request cannot jump the queue.
+	    #  
+	    # Tests:
+	    # - In this case the read queue (tested above) is empty and this
+	    #   "pending" write token is in front of the rest of the write
+	    #   queue.
+	    # - The write state is not Wready and therefore appears to be busy,
+	    #   but because it is "pending" we know that it is reserved for the
+	    #   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)]
+	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    set socketRdState($connId) $token3
+	    set socketWrState($connId) $token3
+	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+	    # Connect does its own fconfigure.
+	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+	    #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+
+	} elseif {
+		$state(-pipeline)
+	     && [info exists socketWrState($connId)]
+	     && ($socketWrState($connId) eq "peNding")
+
+	} {
+	    # Should not come here.  The second block in the previous "elseif"
+	    # test should be tautologous (but was needed in an earlier
+	    # implementation) and will be removed after testing.
+	    # If we get here, the value "pending" was assigned in error.
+	    # This error would block the queue for ever.
+	    Log ^X$tk <<<<< Error in queueing of requests >>>>> - token $token
+
+	} elseif {
+		$state(-pipeline)
+	     && [info exists socketWrState($connId)]
+	     && ($socketWrState($connId) eq "Wready")
+
+	     && [info exists socketWrQueue($connId)]
+	     && [llength $socketWrQueue($connId)]
+	     && (![set token3 [lindex $socketWrQueue($connId) 0]
+		   set ${token3}(-pipeline)
+		  ]
+		)
+	} {
+	    # This case:
+	    # - The next token in the write queue is nonpipeline, and
+	    #   socketWrState is Wready.  Get the next event from socketWrQueue.
+	    # Tests:
+	    # - In this case the read state (tested above) is Rready and the
+	    #   write state (tested here) is Wready - there is no "pending"
+	    #   request.
+	    # 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)]
+	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    set socketRdState($connId) $token3
+	    set socketWrState($connId) $token3
+	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+	    # Connect does its own fconfigure.
+	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+	    #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+
+	} elseif {
+		(!$state(-pipeline))
+	     && [info exists socketWrQueue($connId)]
+	     && [llength $socketWrQueue($connId)]
+	     && ($state(connection) ne "close")
+	} {
+	    # If not pipelined, (socketRdState eq Rready) tells us that we are
+	    # ready for the next write - there is no need to check
+	    # socketWrState. Write the next request, if one is waiting.
+	    # 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)]
+	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    set socketRdState($connId) $token3
+	    set socketWrState($connId) $token3
+	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+	    # Connect does its own fconfigure.
+	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+	    #Log ---- $state(sock) << conn to $token3 for HTTP request (d)
+
+	} elseif {(!$state(-pipeline))} {
+	    set socketWrState($connId) Wready
+	    # Rready and Wready and idle: nothing to do.
+	} else {
+	    # Rready and idle: nothing to do.
+	}
+
+    } else {
+	CloseSocket $state(sock) $token
+    }
+    return
+}
+
+# http::CheckEof -
+#
+#	Read from a socket and close it if eof.
+#	The command is bound to "fileevent readable" on an idle socket, and
+#	"eof" is the only event that should trigger the binding, occurring when
+#	the server times out and half-closes the socket.
+#
+#	A read is necessary so that [eof] gives a meaningful result.
+#	Any bytes sent are junk (or a bug).
+
+proc http::CheckEof {sock} {
+    set junk [read $sock]
+    set n [string length $junk]
+    if {$n} {
+	Log "WARNING: $n bytes received but no HTTP request sent"
+    }
+
+    if {[catch {eof $sock} res] || $res} {
+	# The server has half-closed the socket.
+	# If a new write has started, its transaction will fail and
+	# will then be error-handled.
+	CloseSocket $sock
+    }
     return
 }
 
@@ -302,23 +539,85 @@ proc http::CloseSocket {s {token {}}} {
 	} else {
 	}
     }
-    if {$connId eq {} || ![info exists socketMapping($connId)]} {
+    if {    ($connId ne {})
+	 && [info exists socketMapping($connId)]
+	 && ($socketMapping($connId) eq $s)
+    } {
+	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 $token
+	} else {
+	}
+    } else {
 	Log "Closing socket $s (no connection info)"
 	if {[catch {close $s} err]} {
 	    Log "Error closing socket: $err"
 	} else {
 	}
+    }
+    return
+}
+
+# http::CloseQueuedQueries
+#
+#	connId  - identifier "domain:port" for the connection
+#	token   - (optional) used only for logging
+#
+# Called from http::CloseSocket and http::Finish, after a connection is closed,
+# to clear the read and write queues if this has not already been done.
+
+proc http::CloseQueuedQueries {connId {token {}}} {
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
+    if {![info exists socketMapping($connId)]} {
+	# Command has already been called.
+	# Don't come here again - especially recursively.
+	return
+    }
+
+    # Used only for logging.
+    if {$token eq {}} {
+	set tk {}
     } else {
-	if {[info exists socketMapping($connId)]} {
-	    Log "Closing connection $connId (sock $socketMapping($connId))"
-	    if {[catch {close $socketMapping($connId)} err]} {
-		Log "Error closing connection: $err"
-	    } else {
-	    }
-	    unset socketMapping($connId)
-	} else {
-	    Log "Cannot close connection $connId - no socket in socket map"
-	}
+	set tk [namespace tail $token]
+    }
+
+    if {    [info exists socketPlayCmd($connId)]
+	 && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}})
+    } {
+	set unfinished $socketPlayCmd($connId)
+    } else {
+	set unfinished {}
+    }
+
+    # The trace on "unset socketRdState(*)" cancels any pipelined
+    # responses.
+    # The trace on "unset socketWrState(*)" cancels any pipelined
+    # requests.
+    unset socketMapping($connId)
+    unset socketRdState($connId)
+    unset socketWrState($connId)
+    unset -nocomplain socketRdQueue($connId)
+    unset -nocomplain socketWrQueue($connId)
+    unset -nocomplain socketClosing($connId)
+    unset -nocomplain socketPlayCmd($connId)
+
+    if {$unfinished ne {}} {
+	Log ^R$tk Any unfinished transactions (excluding $token) failed \
+		- token $token
+	{*}$unfinished
     }
     return
 }
@@ -332,7 +631,7 @@ proc http::CloseSocket {s {token {}}} {
 #	why	Status info.
 #
 # Side Effects:
-#       See Finish
+#        See Finish
 
 proc http::reset {token {why reset}} {
     variable $token
@@ -354,8 +653,8 @@ proc http::reset {token {why reset}} {
 #	Establishes a connection to a remote url via http.
 #
 # Arguments:
-#       url		The http URL to goget.
-#       args		Option value pairs. Valid options include:
+#	url		The http URL to goget.
+#	args		Option value pairs. Valid options include:
 #				-blocksize, -validate, -headers, -timeout
 # Results:
 #	Returns a token for this connection. This token is the name of an
@@ -375,10 +674,12 @@ proc http::geturl {url args} {
 	set http(uid) 0
     }
     set token [namespace current]::[incr http(uid)]
+    ##Log Starting http::geturl - token $token
     variable $token
     upvar 0 $token state
     set tk [namespace tail $token]
     reset $token
+    Log ^A$tk URL $url - token $token
 
     # Process command options.
 
@@ -393,8 +694,9 @@ proc http::geturl {url args} {
 	-queryprogress	{}
 	-protocol	1.1
 	binary		0
-	state		connecting
+	state		created
 	meta		{}
+	method		{}
 	coding		{}
 	currentsize	0
 	totalsize	0
@@ -611,14 +913,7 @@ proc http::geturl {url args} {
     # Don't append the fragment!
     set state(url) $url
 
-    # If a timeout is specified we set up the after event and arrange for an
-    # asynchronous socket connection.
-
     set sockopts [list -async]
-    if {$state(-timeout) > 0} {
-	set state(after) [after $state(-timeout) \
-		[list http::reset $token timeout]]
-    }
 
     # If we are using the proxy, we must pass in the full URL that includes
     # the server name.
@@ -636,7 +931,36 @@ proc http::geturl {url args} {
     # c11a51c482]
     set state(accept-types) $http(-accept)
 
+    if {$isQuery || $isQueryChannel} {
+	# It's a POST.
+	# A client wishing to send a non-idempotent request SHOULD wait to send
+	# that request until it has received the response status for the
+	# previous request.
+	if {$http(-postfresh)} {
+	    # Override -keepalive for a POST.  Use a new connection, and thus
+	    # avoid the small risk of a race against server timeout.
+	    set state(-keepalive) 0
+	} else {
+	    # Allow -keepalive but do not -pipeline - wait for the previous
+	    # transaction to finish.
+	    # There is a small risk of a race against server timeout.
+	    set state(-pipeline) 0
+	}
+    } else {
+	# It's a GET or HEAD.
+	set state(-pipeline) $http(-pipeline)
+    }
+
     # 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
+    #   request to leave the channel open AFTER completion of this call.
+    # - In fact, we try to use an existing channel only if -keepalive 1 -- this
+    #   means that at most one channel is left open for each value of
+    #   $state(socketinfo). This property simplifies the mapping of open
+    #   channels.
+    set reusing 0
+    set alreadyQueued 0
     if {$state(-keepalive)} {
 	variable socketMapping
 	variable socketRdState
@@ -647,20 +971,97 @@ proc http::geturl {url args} {
 	variable socketPlayCmd
 
 	if {[info exists socketMapping($state(socketinfo))]} {
+	    # - If the connection is idle, it has a "fileevent readable" binding
+	    #   to http::CheckEof, in case the server times out and half-closes
+	    #   the socket (http::CheckEof closes the other half).
+	    # - We leave this binding in place until just before the last
+	    #   puts+flush in http::Connected (GET/HEAD) or http::Write (POST),
+	    #   after which the HTTP response might be generated.
+	    # - Therefore we must be prepared for full closure of the socket,
+	    #   and catch errors on any socket operation.
+
 	    if {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
 		Log "WARNING: socket for $state(socketinfo) was closed\
-			 - token $token"
+			- token $token"
+
+		# The trace on "unset socketRdState(*)" cancels any pipelined
+		# responses.
+		# The trace on "`(*)" cancels any pipelined
+		# requests.
 		unset socketMapping($state(socketinfo))
+		unset socketRdState($state(socketinfo))
+		unset socketWrState($state(socketinfo))
+		unset -nocomplain socketRdQueue($state(socketinfo))
+		unset -nocomplain socketWrQueue($state(socketinfo))
+		unset -nocomplain socketClosing($state(socketinfo))
+		unset -nocomplain socketPlayCmd($state(socketinfo))
+
+		# Do not automatically close the eventual connection socket.
+		set state(connection) {}
+	    } elseif {    [info exists socketClosing($state(socketinfo))]
+		       && $socketClosing($state(socketinfo))
+	    } {
+		# The server has sent a "Connection: close" header.
+		# Do not use the persistent socket again.
+		# Since we have only one persistent socket per server, and the
+		# old socket is not yet dead, add the request to the write queue
+		# of the dying socket, which will be replayed by ReplayIfClose.
+		set reusing 1
+		set sock $socketMapping($state(socketinfo))
+		Log "reusing socket $sock for $state(socketinfo) - token $token"
+
+		# Do not automatically close this connection socket.
+		set state(connection) {}
+		set alreadyQueued 1
+		lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3
+		lappend com3 $token
+		set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3]
 	    } 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.
+		set reusing 1
 		set sock $socketMapping($state(socketinfo))
 		Log "reusing socket $sock for $state(socketinfo) - token $token"
-		catch {fileevent $sock writable {}}
-		catch {fileevent $sock readable {}}
+
+		# Do not automatically close this connection socket.
+		set state(connection) {}
 	    }
 	}
-	# Do not automatically close this connection socket.
-	set state(connection) {}
     }
+
+    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]
+
+	# Pass -myaddr directly to the socket command
+	if {[info exists state(-myaddr)]} {
+	    lappend sockopts -myaddr $state(-myaddr)
+	}
+
+	set state(tmpOpenCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr]
+    }
+
+    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
+
+    # See comments above re the start of this timeout in other cases.
+    if {(!$state(reusing)) && ($state(-timeout) > 0)} {
+	set state(after) [after $state(-timeout) \
+		[list http::reset $token timeout]]
+    }
+
     if {![info exists sock]} {
 	# Pass -myaddr directly to the socket command
 	if {[info exists state(-myaddr)]} {
@@ -686,14 +1087,126 @@ proc http::geturl {url args} {
     set state(sock) $sock
     Log "Using $sock for $state(socketinfo) - token $token" \
 	[expr {$state(-keepalive)?"keepalive":""}]
-    if {$state(-keepalive)} {
+
+    if {    $state(-keepalive)
+	 && (![info exists socketMapping($state(socketinfo))])
+    } {
+	# Freshly-opened socket that we would like to become persistent.
 	set socketMapping($state(socketinfo)) $sock
+	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
+	}
+
+	if {![info exists socketRdQueue($state(socketinfo))]} {
+	    set socketRdQueue($state(socketinfo)) {}
+	    set varName ::http::socketRdState($state(socketinfo))
+	    trace add variable $varName unset ::http::CancelReadPipeline
+	}
+	if {![info exists socketWrQueue($state(socketinfo))]} {
+	    set socketWrQueue($state(socketinfo)) {}
+	    set varName ::http::socketWrState($state(socketinfo))
+	    trace add variable $varName unset ::http::CancelWritePipeline
+	}
     }
 
     if {![info exists phost]} {
 	set phost ""
     }
-    fileevent $sock writable [list http::Connect $token $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]
+    }
+
+    # 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.
+
+    if {$alreadyQueued} {
+	# 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
+	# will close after the current read, and its
+	# socketClosing($connId) is 1.
+	##Log "HTTP request for token $token is queued"
+
+    } elseif {    $reusing
+	       && $state(-pipeline)
+	       && ($socketWrState($state(socketinfo)) ne "Wready")
+    } {
+	##Log "HTTP request for token $token is queued for pipelined use"
+	lappend socketWrQueue($state(socketinfo)) $token
+
+    } elseif {    $reusing
+	       && (!$state(-pipeline))
+	       && ($socketWrState($state(socketinfo)) ne "Wready")
+    } {
+	# A write is queued or in progress.  Lappend to the write queue.
+	##Log "HTTP request for token $token is queued for nonpipeline use"
+	lappend socketWrQueue($state(socketinfo)) $token
+
+    } elseif {    $reusing
+	       && (!$state(-pipeline))
+	       && ($socketWrState($state(socketinfo)) eq "Wready")
+	       && ($socketRdState($state(socketinfo)) ne "Rready")
+    } {
+	# A read is queued or in progress, but not a write.  Cannot start the
+	# nonpipeline transaction, but must set socketWrState to prevent a
+	# 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
+
+	} else {
+	    # (!$reusing)
+	}
+
+	# All (!$reusing) cases come here, and also some $reusing cases if the
+	# connection is ready.
+	#Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
+	# Connect does its own fconfigure.
+	fileevent $sock writable \
+		[list http::Connect $token $proto $phost $srvurl]
+    }
 
     # Wait for the connection to complete.
     if {![info exists state(-command)]} {
@@ -716,7 +1229,7 @@ proc http::geturl {url args} {
 	    return -code error $err
 	}
     }
-
+    ##Log Leaving http::geturl - token $token
     return $token
 }
 
@@ -726,8 +1239,8 @@ proc http::geturl {url args} {
 #	established.
 #
 # Arguments:
-#       token	State token.
-#       proto	What protocol (http, https, etc.) was used to connect.
+#	token	State token.
+#	proto	What protocol (http, https, etc.) was used to connect.
 #	phost	Are we using keep-alive? Non-empty if yes.
 #	srvurl	Service-local URL that we're requesting
 # Results:
@@ -748,6 +1261,11 @@ proc http::Connected {token proto phost srvurl} {
     upvar 0 $token state
     set tk [namespace tail $token]
 
+    if {$state(reusing) && (!$state(-pipeline)) && ($state(-timeout) > 0)} {
+	set state(after) [after $state(-timeout) \
+		[list http::reset $token timeout]]
+    }
+
     # Set back the variables needed here.
     set sock $state(sock)
     set isQueryChannel [info exists state(-querychannel)]
@@ -759,7 +1277,7 @@ proc http::Connected {token proto phost srvurl} {
     set defport [lindex $urlTypes($lower) 0]
 
     # Send data in cr-lf format, but accept any line terminators.
-    # Initialisation to {auto *} now done in geturl.
+    # Initialisation to {auto *} now done in geturl, KeepSocket and DoneRequest.
     # We are concerned here with the request (write) not the response (read).
     lassign [fconfigure $sock -translation] trRead trWrite
     fconfigure $sock -translation [list $trRead crlf] \
@@ -800,7 +1318,11 @@ proc http::Connected {token proto phost srvurl} {
 	set state(-protocol) 1.0
     }
     set accept_types_seen 0
+
+    Log ^B$tk begin sending request - token $token
+
     if {[catch {
+	set state(method) $how
 	puts $sock "$how $srvurl HTTP/$state(-protocol)"
 	if {[dict exists $state(-headers) Host]} {
 	    # Allow Host spoofing. [Bug 928154]
@@ -889,6 +1411,7 @@ proc http::Connected {token proto phost srvurl} {
 	# response.
 
 	if {$isQuery || $isQueryChannel} {
+	    # POST method.
 	    if {!$content_type_seen} {
 		puts $sock "Content-Type: $state(-type)"
 	    }
@@ -899,25 +1422,624 @@ proc http::Connected {token proto phost srvurl} {
 	    lassign [fconfigure $sock -translation] trRead trWrite
 	    fconfigure $sock -translation [list $trRead binary]
 	    fileevent $sock writable [list http::Write $token]
+	    # The http::Write command decides when to make the socket readable,
+	    # using the same test as the GET/HEAD case below.
 	} else {
+	    # GET or HEAD method.
+	    if {    (![catch {fileevent $sock readable} binding])
+		 && ($binding eq [list http::CheckEof $sock])
+	    } {
+		# Remove the "fileevent readable" binding of an idle persistent
+		# socket to http::CheckEof.  We can no longer treat bytes
+		# received as junk. The server might still time out and
+		# half-close the socket if it has not yet received the first
+		# "puts".
+		fileevent $sock readable {}
+	    }
 	    puts $sock ""
 	    flush $sock
-	    fileevent $sock readable [list http::Event $sock $token]
+	    Log ^C$tk end sending request - token $token
+	    # End of writing (GET/HEAD methods).  The request has been sent.
+
+	    DoneRequest $token
 	}
 
     } err]} {
 	# The socket probably was never connected, or the connection dropped
 	# later.
+	if {[info exists state(reusing)] && $state(reusing)} {
+	    # The socket was closed at the server end, and closed at
+	    # this end by http::CheckEof.
+    	    if {[TestForReplay $token write $err a]} {
+		return
+	    } else {
+		Finish $token {failed to re-use socket}
+	    }
 
-	# if state(status) is error, it means someone's already called
-	# Finish to do the above-described clean up.
-	if {$state(status) ne "error"} {
+	    # else:
+	    # This is NOT a persistent socket that has been closed since its
+	    # last use.
+	    # If any other requests are in flight or pipelined/queued, they will
+	    # be discarded.
+	} elseif {$state(status) eq ""} {
+	    Finish $token {failed to re-use socket}
+	} elseif {$state(status) ne "error"} {
 	    Finish $token $err
+	} else {
+	    # if state(status) is error, it means someone's already called
+	    # Finish to do the above-described clean up.
 	}
     }
     return
 }
 
+# http::DoneRequest --
+#
+#	Command called when a request has been sent.  It will arrange the
+#	next request and/or response as appropriate.
+
+proc http::DoneRequest {token} {
+    variable http
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
+    variable $token
+    upvar 0 $token state
+    set tk [namespace tail $token]
+    set sock $state(sock)
+
+    # If pipelined, connect the next HTTP request to the socket.
+    if {$state(reusing) && $state(-pipeline)} {
+	# Enable next token (if any) to write.
+	# The value "Wready" is set only here, and
+	# in http::Event after reading the response-headers of a
+	# non-reusing transaction.
+	# Previous value is $token. It cannot be pending.
+	set socketWrState($state(socketinfo)) Wready
+
+	# Now ready to write the next pipelined request (if any).
+	http::NextPipelinedWrite $token
+    } else {
+	# If pipelined, this is the first transaction on this socket.  We wait
+	# for the response headers to discover whether the connection is
+	# persistent.  (If this is not done and the connection is not
+	# persistent, we SHOULD retry and then MUST NOT pipeline before knowing
+	# that we have a persistent connection
+	# (rfc2616 8.1.2.2)).
+    }
+
+    # Connect to receive the response, unless the socket is pipelined
+    # and another response is being sent.
+    # This code block is separate from the code below because there are
+    # cases where socketRdState already has the value $token.
+    if {    $state(-keepalive)
+	 && $state(-pipeline)
+	 && [info exists socketRdState($state(socketinfo))]
+	 && ($socketRdState($state(socketinfo)) eq "Rready")
+    } {
+	#Log pipelined, GRANT read access to $token in Connected
+	set socketRdState($state(socketinfo)) $token
+    }
+
+    if {    $state(-keepalive)
+	 && $state(-pipeline)
+	 && [info exists socketRdState($state(socketinfo))]
+	 && ($socketRdState($state(socketinfo)) ne $token)
+    } {
+	# Do not read from the socket until it is ready.
+	##Log "HTTP response for token $token is queued for pipelined use"
+	lappend socketRdQueue($state(socketinfo)) $token
+    } else {
+	# In the pipelined case, connection for reading depends on the
+	# value of socketRdState.
+	# In the nonpipeline case, connection for reading always occurs.
+	#Log ---- $state(socketinfo) >> conn to $token for HTTP response (b)
+	lassign [fconfigure $sock -translation] trRead trWrite
+	fconfigure $sock -translation [list auto $trWrite] \
+			 -buffersize $state(-blocksize)
+	Log ^D$tk begin receiving response - token $token
+	fileevent $sock readable [list http::Event $sock $token]
+    }
+    return
+}
+
+# http::NextPipelinedWrite
+#
+# - Connecting a socket to a token for writing is done by this command and by
+#   command KeepSocket.
+# - If another request has a pipelined write scheduled for $token's socket,
+#   and if the socket is ready to accept it, connect the write and update
+#   the queue accordingly.
+# - This command is called from http::DoneRequest and http::Event,
+#   IF $state(-pipeline) AND (the current transfer has reached the point at
+#   which the socket is ready for the next request to be written).
+# - This command is called when a token has write access and is pipelined and
+#   keep-alive, and sets socketWrState to Wready.
+# - The command need not consider the case where socketWrState is set to a token
+#   that does not yet have write access.  Such a token is waiting for Rready,
+#   and the assignment of the connection to the token will be done elsewhere (in
+#   http::KeepSocket).
+# - This command cannot be called after socketWrState has been set to a
+#   "pending" token value (that is then overwritten by the caller), because that
+#   value is set by this command when it is called by an earlier token when it
+#   relinquishes its write access, and the pending token is always the next in
+#   line to write.
+
+proc http::NextPipelinedWrite {token} {
+    variable http
+    variable socketRdState
+    variable socketWrState
+    variable socketWrQueue
+
+    variable $token
+    upvar 0 $token state
+    set connId $state(socketinfo)
+
+    if {    $state(-pipeline)
+	 && [info exists socketWrState($connId)]
+	 && ($socketWrState($connId) eq "Wready")
+
+	 && [info exists socketWrQueue($connId)]
+	 && [llength $socketWrQueue($connId)]
+	 && ([set token2 [lindex $socketWrQueue($connId) 0]
+	      set ${token2}(-pipeline)
+	     ]
+	    )
+    } {
+	# - 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 socketWrState($connId) $token2
+	set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+	# Connect does its own fconfigure.
+	fileevent $state(sock) writable [list http::Connect $token2 {*}$conn]
+	#Log ---- $connId << conn to $token2 for HTTP request (b)
+
+	# In the tests below, the next request will be nonpipeline.
+    } elseif {    $state(-pipeline)
+	       && [info exists socketWrState($connId)]
+	       && ($socketWrState($connId) eq "Wready")
+
+	       && [info exists socketWrQueue($connId)]
+	       && [llength $socketWrQueue($connId)]
+	       && (![ set token3 [lindex $socketWrQueue($connId) 0]
+		      set ${token3}(-pipeline)
+		    ]
+		  )
+
+	       && [info exists socketRdState($connId)]
+	       && ($socketRdState($connId) eq "Rready")
+    } {
+	# 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)]
+	#Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
+	set socketRdState($connId) $token3
+	set socketWrState($connId) $token3
+	set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+	# Connect does its own fconfigure.
+	fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+	#Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+
+    } elseif {    $state(-pipeline)
+	 && [info exists socketWrState($connId)]
+	 && ($socketWrState($connId) eq "Wready")
+
+	 && [info exists socketWrQueue($connId)]
+	 && [llength $socketWrQueue($connId)]
+	 && (![set token2 [lindex $socketWrQueue($connId) 0]
+	      set ${token2}(-pipeline)
+	     ]
+	    )
+    } {
+	# - The case in which the next request will be non-pipelined, but the
+	#   read queue is NOT ready.
+	# - A read is queued or in progress, but not a write.  Cannot start the
+	#   nonpipeline transaction, but must set socketWrState to prevent a new
+	#   pipelined request (in http::geturl) jumping the queue.
+	# - Because socketWrState($connId) is not set to Wready, the assignment
+	#   of the connection to $token2 will be done elsewhere - by command
+	#   http::KeepSocket when $socketRdState($connId) is set to "Rready".
+
+	#Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
+	set socketWrState($connId) peNding
+
+    } else {
+	# No requests in socketWrQueue.  Nothing to do.
+    }
+
+    return
+}
+
+# http::CancelReadPipeline
+#
+#	Cancel pipelined responses on a closing "Keep-Alive" socket.
+#
+#	- Called by a trace when the variable ::http::socketRdState($connId) is
+#	  unset (the trace itself is automatically removed).
+#	- The variable relates to a Keep-Alive socket, which has been closed.
+#	- Cancels all pipelined responses. The requests have been sent,
+#	  the responses have not yet been received.
+#	- N.B. Always delete ::http::socketRdState($connId) before deleting
+#	  ::http::socketRdQueue($connId), or this command will do nothing.
+#
+# Arguments
+#	As for a trace command on a variable.
+
+proc http::CancelReadPipeline {name1 connId op} {
+    variable socketRdQueue
+
+    ##Log CancelReadPipeline $name1 $connId $op
+    if {[info exists socketRdQueue($connId)]} {
+	set msg {the connection was Closed}
+	foreach token $socketRdQueue($connId) {
+	    set tk [namespace tail $token]
+	    Log ^X$tk end of response "($msg)" - token $token
+	    set ${token}(status) eof
+	    Finish $token ;#$msg
+	}
+	set socketRdQueue($connId) {}
+    }
+    return
+}
+
+# http::CancelWritePipeline
+#
+#	Cancel queued events on a closing "Keep-Alive" socket.
+#
+#	- Called by a trace when the variable ::http::socketWrState($connId) is
+#	  unset (the trace itself is automatically removed).
+#	- The variable relates to a Keep-Alive socket, which has been closed.
+#	- In pipelined or nonpipeline case: cancels all queued requests.  The
+#	  requests have not yet been sent, the responses are not due and have
+#	  no data to cancel.
+#	- N.B. Always delete ::http::socketWrState($connId) before deleting
+#	  ::http::socketWrQueue($connId), or this command will do nothing.
+#
+# Arguments
+#	As for a trace command on a variable.
+
+proc http::CancelWritePipeline {name1 connId op} {
+    variable socketWrQueue
+
+    ##Log CancelWritePipeline $name1 $connId $op
+    if {[info exists socketWrQueue($connId)]} {
+	set msg {the connection was Closed}
+	foreach token $socketWrQueue($connId) {
+	    set tk [namespace tail $token]
+	    Log ^X$tk end of response "($msg)" - token $token
+	    set ${token}(status) eof
+	    Finish $token ;#$msg
+	}
+	set socketWrQueue($connId) {}
+    }
+    return
+}
+
+# http::ReplayIfDead --
+#
+# - A query on a re-used persistent socket failed at the earliest opportunity,
+#   because the socket had been closed by the server.  Keep the token, tidy up,
+#   and try to connect on a fresh socket.
+# - The connection is monitored for eof by the command http::CheckEof.  Thus
+#   http::ReplayIfDead is needed only when a server event (half-closing an
+#   apparently idle connection), and a client event (sending a request) occur at
+#   almost the same time, and neither client nor server detects the other's
+#   action before performing its own (an "asynchronous close event").
+# - To simplify testing of http::ReplayIfDead, set TEST_EOF 1 in
+#   http::KeepSocket, and then http::ReplayIfDead will be called if http::geturl
+#   is called at any time after the server timeout.
+#
+# Arguments:
+#	token	Connection token.
+#
+# Side Effects:
+#	Use the same token, but try to open a new socket.
+
+proc http::ReplayIfDead {tokenArg doing} {
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
+    variable $tokenArg
+    upvar 0 $tokenArg stateArg
+
+    Log running http::ReplayIfDead for $tokenArg $doing
+
+    # 1. Merge the tokens for transactions in flight, the read (response) queue,
+    #    and the write (request) queue.
+
+    set InFlightR {}
+    set InFlightW {}
+
+    # Obtain the tokens for transactions in flight.
+    if {$stateArg(-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")
+	} {
+	    lappend InFlightR $socketRdState($stateArg(socketinfo))
+	} elseif {($doing eq "read")} {
+	    lappend InFlightR $tokenArg
+	} else {
+	}
+
+	if {    [info exists socketWrState($stateArg(socketinfo))]
+	     && $socketWrState($stateArg(socketinfo)) ni {Wready peNding}
+	} {
+	    lappend InFlightW $socketWrState($stateArg(socketinfo))
+	} elseif {($doing eq "write")} {
+	    lappend InFlightW $tokenArg
+	} else {
+	}
+
+	# Report any inconsistency of $tokenArg with socket*state.
+	if {    ($doing eq "read")
+	     && [info exists socketRdState($stateArg(socketinfo))]
+	     && ($tokenArg ne $socketRdState($stateArg(socketinfo)))
+	} {
+	    Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \
+		    ne socketRdState($stateArg(socketinfo)) \
+		      $socketRdState($stateArg(socketinfo))
+
+	} elseif {
+		($doing eq "write")
+	     && [info exists socketWrState($stateArg(socketinfo))]
+	     && ($tokenArg ne $socketWrState($stateArg(socketinfo)))
+	} {
+	    Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \
+		    ne socketWrState($stateArg(socketinfo)) \
+		      $socketWrState($stateArg(socketinfo))
+	} else {
+	}
+    } 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))
+	} else {
+	}
+
+	# Report the inconsistency that socketRdQueue is non-empty.
+	if {    [info exists socketRdQueue($stateArg(socketinfo))]
+	     && ($socketRdQueue($stateArg(socketinfo)) ne {})
+	} {
+	    Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \
+		    has read queue socketRdQueue($stateArg(socketinfo)) \
+		    $socketRdQueue($stateArg(socketinfo)) ne {}
+	} else {
+	}
+
+	lappend InFlightW $socketRdState($stateArg(socketinfo))
+	set socketRdQueue($stateArg(socketinfo)) {}
+    }
+
+    set newQueue {}
+    lappend newQueue {*}$InFlightR
+    lappend newQueue {*}$socketRdQueue($stateArg(socketinfo))
+    lappend newQueue {*}$InFlightW
+    lappend newQueue {*}$socketWrQueue($stateArg(socketinfo))
+
+
+    # 2. Tidy up tokenArg.  This is a cut-down form of Finish/CloseSocket.
+    #    CloseSocket cancels file events, closes the socket, and unsets the
+    #    socketMapping.
+    #    Finish calls CloseSocket, if called as below.
+    #    Don't want Eot.
+    #    Do not change state(status).
+    #    Want to not unset socketWrState(*).
+
+    if {[info exists stateArg(after)]} {
+	after cancel $stateArg(after)
+    }
+    catch {close $stateArg(sock)}
+
+    # The relevant element of socketMapping, socketRdState, socketWrState,
+    # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set to
+    # new values in ReplayCore.
+    # The trace on "unset socketRdState(*)" cancels any pipelined responses.
+    # It also clears socketRdQueue(*).
+    # Transactions, if any, that are awaiting responses cannot be completed.
+    # They are listed for re-sending in newQueue.
+    # There is no need to unset socketWrState - the write queue transactions
+    # have not yet been sent, nor the state(-timeout) events.
+    # All tokens are preserved for re-use by ReplayCore.
+
+    unset socketRdState($stateArg(socketinfo))
+
+    ReplayCore $newQueue
+    return
+}
+
+# http::ReplayIfClose --
+#
+#	A request on a socket that was previously "Connection: keep-alive" has
+#	received a "Connection: close" response header.  The server supplies
+#	that response correctly, but any later requests already queued on this
+#	connection will be lost when the socket closes.
+#
+#	This command takes arguments that represent the socketWrState,
+#	socketRdQueue and socketWrQueue for this connection.  The socketRdState
+#	is not needed because the server responds in full to the request that
+#	received the "Connection: close" response header.
+#
+#	Existing request tokens $token (::http::$n) are preserved.  The caller
+#	will be unaware that the request was processed this way.
+
+proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
+    Log running http::ReplayIfClose for $Wstate $Rqueue $Wqueue
+
+    if {$Wstate in $Rqueue || $Wstate in $Wqueue} {
+	Log WARNING duplicate token in http::ReplayIfClose - token $Wstate
+	set Wstate Wready
+    }
+
+    # 1. Create newQueue
+    set InFlightW {}
+    if {$Wstate ni {Wready peNding}} {
+	lappend InFlightW $Wstate
+    }
+
+    set newQueue {}
+    lappend newQueue {*}$Rqueue
+    lappend newQueue {*}$InFlightW
+    lappend newQueue {*}$Wqueue
+
+    # 2. Cleanup - none needed, done by the caller.
+
+    ReplayCore $newQueue
+    return
+}
+
+# http::ReplayCore --
+#
+#	Command to replay a list of requests, using existing connection tokens.
+#
+#	Abstracted from http::geturl which stores extra state in state(tmp*) so
+#	we don't need to do the argument processing again.
+#
+# Arguments:
+#	newQueue	List of connection tokens.
+#
+# Side Effects:
+#	Use existing tokens, but try to open a new socket.
+
+proc http::ReplayCore {newQueue} {
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
+    if {[llength $newQueue] == 0} {
+	# Nothing to do.
+	return
+    }
+
+    ##Log running ReplayCore for {*}$newQueue
+    set newToken [lindex $newQueue 0]
+    set newQueue [lrange $newQueue 1 end]
+
+    # 3. Use newToken, and restore its values of state(*).  Do not restore
+    #    elements tmp* - we try again only once.
+
+    set token $newToken
+    variable $token
+    upvar 0 $token state
+
+    if {!(
+	      [info exists state(tmpState)]
+	   && [info exists state(tmpOpenCmd)]
+	   && [info exists state(tmpConnArgs)]
+	 )
+    } {
+	Log FAILED in http::ReplayCore - NO tmp vars
+	Finish $token error 1
+	return
+    }
+
+    # Don't alter state(status) - this would trigger http::wait if it is in use.
+    set tmpState    $state(tmpState)
+    set tmpOpenCmd  $state(tmpOpenCmd)
+    set tmpConnArgs $state(tmpConnArgs)
+    foreach name [array names state] {
+	if {$name ne "status"} {
+	    unset state($name)
+	}
+    }
+
+    # Don't alter state(status).
+    dict unset tmpState status
+    array set state $tmpState
+    set state(reusing) 0
+
+    if {$state(-timeout) > 0} {
+	set resetCmd [list http::reset $token timeout]
+	set state(after) [after $state(-timeout) $resetCmd]
+    }
+
+    # 4. Open a socket.
+    if {[catch {eval $tmpOpenCmd} sock]} {
+	# Something went wrong while trying to establish the connection.
+	Log FAILED - $tmpOpenCmd
+	set state(sock) $sock
+	Finish $token error 1
+	return
+    }
+
+    # 5. Configure the persistent socket data.
+    if {$state(-keepalive)} {
+	set socketMapping($state(socketinfo)) $sock
+	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
+	}
+
+	if {![info exists socketRdQueue($state(socketinfo))]} {
+	    set socketRdQueue($state(socketinfo)) {}
+	    set varName ::http::socketRdState($state(socketinfo))
+	    trace add variable $varName unset ::http::CancelReadPipeline
+	}
+	set socketRdQueue($state(socketinfo)) {}
+
+	if {![info exists socketWrQueue($state(socketinfo))]} {
+	    set socketWrQueue($state(socketinfo)) {}
+	    set varName ::http::socketWrState($state(socketinfo))
+	    trace add variable $varName unset ::http::CancelWritePipeline
+	}
+	set socketWrQueue($state(socketinfo)) $newQueue
+	set socketClosing($state(socketinfo)) 0
+	set socketPlayCmd($state(socketinfo)) {}
+    }
+
+    # 6. Configure sockets in the queue.
+    foreach tok $newQueue {
+	set ${tok}(sock) $sock
+    }
+
+    # 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":""}]
+
+    # Initialisation of a new socket.
+    fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
+
+    # 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:
 # Data - the URL data
 # Status - the transaction status: ok, reset, eof, timeout, error
@@ -1009,8 +2131,22 @@ proc http::Connect {token proto phost srvurl} {
 	[eof $state(sock)] ||
 	[set err [fconfigure $state(sock) -error]] ne ""
     } {
+	if {[info exists state(reusing)] && $state(reusing)} {
+	    # The socket was closed at the server end, and closed at
+	    # this end by http::CheckEof.
+	    if {[TestForReplay $token write $err b]} {
+		return
+	    }
+
+	    # else:
+	    # This is NOT a persistent socket that has been closed since its
+	    # last use.
+	    # If any other requests are in flight or pipelined/queued, they will
+	    # be discarded.
+	}
 	Finish $token "connect failed $err"
     } else {
+	set state(state) connecting
 	fileevent $state(sock) writable {}
 	::http::Connected $token $proto $phost $srvurl
     }
@@ -1050,7 +2186,21 @@ proc http::Write {token} {
 	if {[info exists state(-query)]} {
 	    # Chop up large query strings so queryprogress callback can give
 	    # smooth feedback.
-
+	    if {    $state(queryoffset) + $state(-queryblocksize)
+		 >= $state(querylength)
+	    } {
+		# This will be the last puts for the request-body.
+		if {    (![catch {fileevent $sock readable} binding])
+		     && ($binding eq [list http::CheckEof $sock])
+		} {
+		    # Remove the "fileevent readable" binding of an idle
+		    # persistent socket to http::CheckEof.  We can no longer
+		    # treat bytes received as junk. The server might still time
+		    # out and half-close the socket if it has not yet received
+		    # the first "puts".
+		    fileevent $sock readable {}
+		}
+	    }
 	    puts -nonewline $sock \
 		[string range $state(-query) $state(queryoffset) \
 		     [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
@@ -1063,6 +2213,19 @@ proc http::Write {token} {
 	    # Copy blocks from the query channel
 
 	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
+	    if {[eof $state(-querychannel)]} {
+		# This will be the last puts for the request-body.
+		if {    (![catch {fileevent $sock readable} binding])
+		     && ($binding eq [list http::CheckEof $sock])
+		} {
+		    # Remove the "fileevent readable" binding of an idle
+		    # persistent socket to http::CheckEof.  We can no longer
+		    # treat bytes received as junk. The server might still time
+		    # out and half-close the socket if it has not yet received
+		    # the first "puts".
+		    fileevent $sock readable {}
+		}
+	    }
 	    puts -nonewline $sock $outStr
 	    incr state(queryoffset) [string length $outStr]
 	    if {[eof $state(-querychannel)]} {
@@ -1076,10 +2239,14 @@ proc http::Write {token} {
 	set state(posterror) $err
 	set done 1
     }
+
     if {$done} {
 	catch {flush $sock}
 	fileevent $sock writable {}
-	fileevent $sock readable [list http::Event $sock $token]
+	Log ^C$tk end sending request - token $token
+	# End of writing (POST method).  The request has been sent.
+
+	DoneRequest $token
     }
 
     # Callback to the client after we've completely handled everything.
@@ -1126,29 +2293,74 @@ proc http::Event {sock token} {
 			- token $token"
 	    }
 	}
+	Log ^X$tk end of response (token error) - token $token
 	CloseSocket $sock
 	return
     }
     if {$state(state) eq "connecting"} {
 	##Log - connecting - token $token
+	if {    $state(reusing)
+	     && $state(-pipeline)
+	     && ($state(-timeout) > 0)
+	     && (![info exists state(after)])
+	} {
+	    set state(after) [after $state(-timeout) \
+		    [list http::reset $token timeout]]
+	}
+
 	if {[catch {gets $sock state(http)} nsl]} {
-	    Finish $token $nsl
-	    return
+	    if {[info exists state(reusing)] && $state(reusing)} {
+		# The socket was closed at the server end, and closed at
+		# this end by http::CheckEof.
+
+		if {[TestForReplay $token read $nsl c]} {
+		    return
+		}
+
+		# else:
+		# This is NOT a persistent socket that has been closed since its
+		# last use.
+		# If any other requests are in flight or pipelined/queued, they
+		# will be discarded.
+	    } else {
+		Log ^X$tk end of response (error) - token $token
+		Finish $token $nsl
+		return
+	    }
 	} elseif {$nsl >= 0} {
 	    ##Log - connecting 1 - token $token
 	    set state(state) "header"
+	} elseif {    [eof $sock]
+		   && [info exists state(reusing)]
+		   && $state(reusing)
+	} {
+	    # The socket was closed at the server end, and we didn't notice.
+	    # This is the first read - where the closure is usually first
+	    # detected.
+
+	    if {[TestForReplay $token read {} d]} {
+		return
+	    }
+
+	    # else:
+	    # This is NOT a persistent socket that has been closed since its
+	    # last use.
+	    # If any other requests are in flight or pipelined/queued, they will
+	    # be discarded.
 	} else {
 	    ##Log - connecting 2 - token $token
-	    # nsl is -1 so either fblocked (OK) or eof.
+	    # nsl is -1 so either fblocked (OK) or (eof and not reusing).
 	    # Continue. Any eof is processed at the end of this proc.
 	}
     } elseif {$state(state) eq "header"} {
 	if {[catch {gets $sock line} nhl]} {
 	    ##Log header failed - token $token
+	    Log ^X$tk end of response (error) - token $token
 	    Finish $token $nhl
 	    return
 	} elseif {$nhl == 0} {
 	    ##Log header done - token $token
+	    Log ^E$tk end of response headers - token $token
 	    # We have now read all headers
 	    # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
 	    if {    ($state(http) == "")
@@ -1158,10 +2370,89 @@ proc http::Event {sock token} {
 		return
 	    }
 
+	    if {    ([info exists state(connection)])
+		 && ([info exists socketMapping($state(socketinfo))])
+		 && ($state(connection) eq "keep-alive")
+		 && ($state(-keepalive))
+		 && (!$state(reusing))
+		 && ($state(-pipeline))
+	    } {
+		# Response headers received for first request on a persistent
+		# socket.  Now ready for pipelined writes (if any).
+		# Previous value is $token. It cannot be pending.
+		set socketWrState($state(socketinfo)) Wready
+		http::NextPipelinedWrite $token
+	    }
+
+	    # Once a "close" has been signaled, the client MUST NOT send any
+	    # more requests on that connection.
+	    #
+	    # If either the client or the server sends the "close" token in the
+	    # Connection header, that request becomes the last one for the
+	    # connection.
+
+	    if {    ([info exists state(connection)])
+		 && ([info exists socketMapping($state(socketinfo))])
+		 && ($state(connection) eq "close")
+		 && ($state(-keepalive))
+	    } {
+		# The server warns that it will close the socket after this
+		# response.
+		##Log WARNING - socket will close after response for $token
+		# Prepare data for a call to ReplayIfClose.
+		if {    ($socketRdQueue($state(socketinfo)) ne {})
+		     || ($socketWrQueue($state(socketinfo)) ne {})
+		     || ($socketWrState($state(socketinfo)) ni
+						[list Wready peNding $token])
+		} {
+		    set InFlightW $socketWrState($state(socketinfo))
+		    if {$InFlightW in [list Wready peNding $token]} {
+			set InFlightW Wready
+		    } else {
+			set msg "token ${InFlightW} is InFlightW"
+			##Log $msg - token $token
+		    }
+
+		    set socketPlayCmd($state(socketinfo)) \
+			    [list ReplayIfClose $InFlightW \
+			    $socketRdQueue($state(socketinfo)) \
+			    $socketWrQueue($state(socketinfo))]
+
+		    # See discussion below.
+		    foreach tokenElement $socketRdQueue($state(socketinfo)) {
+			if {[info exists ${tokenElement}(after)]} {
+			    after cancel [set ${tokenElement}(after)]
+			}
+		    }
+
+		    # - Clear the queues.  By doing this here, the code for
+		    #   connecting the next token to the socket needs no
+		    #   modification.
+		    # - Do not unset socketRdState and socketWrState and trigger
+		    #   their traces, because this will close the socket, which
+		    #   is still needed for the current read.
+		    # - The only other thing that the traces would have done is
+		    #   cancel the state(after) timeout events.  This is now
+		    #   done above.
+		    # - All tokens are preserved for re-use by ReplayCore.
+
+		    set socketRdQueue($state(socketinfo)) {}
+		    set socketWrQueue($state(socketinfo)) {}
+
+		} else {
+		    set socketPlayCmd($state(socketinfo)) \
+			    {ReplayIfClose Wready {} {}}
+		}
+
+		# Do not allow further connections on this socket.
+		set socketClosing($state(socketinfo)) 1
+	    }
+
 	    set state(state) body
 
 	    # If doing a HEAD, then we won't get any body
 	    if {$state(-validate)} {
+		Log ^F$tk end of response for HEAD request - token $token
 		set state(state) complete
 		Eot $token
 		return
@@ -1190,6 +2481,8 @@ proc http::Event {sock token} {
 	    } {
 		set msg {body size is 0 and no events likely - complete}
 		Log "$msg - token $token"
+		set msg {(length unknown, set to 0)}
+		Log ^F$tk end of response body {*}$msg - token $token
 		set state(state) complete
 		Eot $token
 		return
@@ -1272,6 +2565,7 @@ proc http::Event {sock token} {
 			# Do not tolerate bad -handler - fail with error status.
 			set msg {the -handler command for http::geturl must\
 				return an integer (the number of bytes read)}
+			Log ^X$tk end of response (handler error) - token $token
 			Eot $token $msg
 		    } else {
 			# Tolerate the bad -handler, and continue.  The penalty:
@@ -1303,6 +2597,7 @@ proc http::Event {sock token} {
 		    append state(transfer_final) $line
 		    set n 0
 		} else {
+		    Log ^F$tk end of response body (chunked) - token $token
 		    Log "final chunk part - token $token"
 		    Eot $token
 		}
@@ -1333,6 +2628,8 @@ proc http::Event {sock token} {
 				token $token"
 			    set n 0
 			    set state(connection) close
+			    Log ^X$tk end of response (chunk error) \
+				    - token $token
 			    set msg {error in chunked encoding - fetch\
 				    terminated}
 			    Eot $token $msg
@@ -1348,6 +2645,7 @@ proc http::Event {sock token} {
 		    ##Log bad-chunk-measure - token $token
 		    set n 0
 		    set state(connection) close
+		    Log ^X$tk end of response (chunk error) - token $token
 		    Eot $token {error in chunked encoding - fetch terminated}
 		}
 	    } else {
@@ -1393,11 +2691,13 @@ proc http::Event {sock token} {
 		    ($state(totalsize) > 0)
 		    && ($state(currentsize) >= $state(totalsize))
 		} {
+		    Log ^F$tk end of response body (unchunked) - token $token
 		    set state(state) complete
 		    Eot $token
 		}
 	    }
 	} err]} {
+	    Log ^X$tk end of response (error ${err}) - token $token
 	    Finish $token $err
 	    return
 	} else {
@@ -1419,19 +2719,77 @@ proc http::Event {sock token} {
 		# can be completed by eof.
 		# The value "complete" is set only in http::Event, and it is
 		# used only in the test above.
+		Log ^F$tk end of response body (unchunked, eof) - token $token
 		Eot $token
 	    } else {
 		# Premature eof.
+		Log ^X$tk end of response (unexpected eof) - token $token
 		Eot $token eof
 	    }
 	} else {
 	    # open connection closed on a token that has been cleaned up.
+	    Log ^X$tk end of response (token error) - token $token
 	    CloseSocket $sock
 	}
     }
     return
 }
 
+# http::TestForReplay
+#
+#	Command called if eof is discovered when a socket is first used for a
+#	new transaction.  Typically this occurs if a persistent socket is used
+#	after a period of idleness and the server has half-closed the socket.
+#
+# token  - the connection token returned by http::geturl
+# doing  - "read" or "write"
+# err    - error message, if any
+# caller - code to identify the caller - used only in logging
+#
+# Return Value: boolean, true iff the command calls http::ReplayIfDead.
+
+proc http::TestForReplay {token doing err caller} {
+    variable http
+    variable $token
+    upvar 0 $token state
+    set tk [namespace tail $token]
+    if {$doing eq "read"} {
+	set code Q
+	set action response
+	set ing reading
+    } else {
+	set code P
+	set action request
+	set ing writing
+    }
+
+    if {$err eq {}} {
+	set err "detect eof when $ing (server timed out?)"
+    }
+
+    if {$state(method) eq "POST" && !$http(-repost)} {
+	# No Replay.
+	# The present transaction will end when Finish is called.
+	# That call to Finish will abort any other transactions
+	# currently in the write queue.
+	# For calls from http::Event this occurs when execution
+	# reaches the code block at the end of that proc.
+	set msg {no retry for POST with http::config -repost 0}
+	Log reusing socket failed "($caller)" - $msg - token $token
+	Log error - $err - token $token
+	Log ^X$tk end of $action (error) - token $token
+	return 0
+    } else {
+	# Replay.
+	set msg {try a new socket}
+	Log reusing socket failed "($caller)" - $msg - token $token
+	Log error - $err - token $token
+	Log ^$code$tk Any unfinished (incl this one) failed - token $token
+	ReplayIfDead $token $doing
+	return 1
+    }
+}
+
 # http::IsBinaryContentType --
 #
 #	Determine if the content-type means that we should definitely transfer
@@ -1475,6 +2833,8 @@ proc http::IsBinaryContentType {type} {
 # Results:
 #	The line of text, without trailing newline
 
+# FIXME get rid of blocking
+
 proc http::getTextLine {sock} {
     set tr [fconfigure $sock -translation]
     lassign $tr trRead trWrite
@@ -1662,7 +3022,7 @@ proc http::Eot {token {reason {}}} {
 #	token	Connection token.
 #
 # Results:
-#        The status after the wait.
+#	The status after the wait.
 
 proc http::wait {token} {
     variable $token
diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
new file mode 100644
index 0000000..017661d
--- /dev/null
+++ b/tests/httpPipeline.test
@@ -0,0 +1,859 @@
+# httpPipeline.test
+#
+#	Test HTTP/1.1 concurrent requests including
+#	queueing, pipelining and retries.
+#
+# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+package require http 2.8
+
+set sourcedir [file normalize [file dirname [info script]]]
+source [file join $sourcedir httpTest.tcl]
+source [file join $sourcedir httpTestScript.tcl]
+
+# ------------------------------------------------------------------------------
+# (1) Define the test scripts that will be used to generate logs for analysis -
+#     and also define the "correct" results.
+# ------------------------------------------------------------------------------
+
+proc ReturnTestScriptAndResult {ca cb delay te} {
+
+    switch -- $ca {
+	1     {set start {
+	    START
+	    KEEPALIVE 0
+	    PIPELINE  0
+	}}
+
+	2     {set start {
+	    START
+	    KEEPALIVE 0
+	    PIPELINE  1
+	}}
+
+	3     {set start {
+	    START
+	    KEEPALIVE 1
+	    PIPELINE  0
+	}}
+
+	4     {set start {
+	    START
+	    KEEPALIVE 1
+	    PIPELINE  1
+	}}
+
+	default {
+	    return -code error {no matching script}
+	}
+    }
+
+    set middle "
+	    [list DELAY $delay]
+    "
+
+    switch -- $cb {
+	1     {set end {
+	    GET a
+	    GET b
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 ? ? ?}
+	    set resLong  {1 2 3 4}
+	}
+
+	2     {set end {
+	    GET a
+	    HEAD b
+	    GET c
+	    HEAD a
+	    HEAD c
+	    STOP
+	    }
+	    set resShort {1 ? ? ? ?}
+	    set resLong  {1 2 3 4 5}
+	}
+
+	3     {set end {
+	    HEAD a
+	    GET b
+	    HEAD c
+	    HEAD b
+	    GET a
+	    GET b
+	    STOP
+	    }
+	    set resShort {1 ? ? ? ? ?}
+	    set resLong  {1 2 3 4 5 6}
+	}
+
+	4     {set end {
+	    GET a
+	    GET b
+	    GET c
+	    GET a
+	    POST b address=home code=brief paid=yes
+	    GET c
+	    GET a
+	    GET b
+	    GET c
+	    STOP
+	    }
+	    set resShort {1 ? ? ? 5 ? ? ? ?}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	5     {set end {
+	    POST a address=home code=brief paid=yes
+	    POST b address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes
+	    POST a address=home code=brief paid=yes
+	    POST b address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes
+	    POST a address=home code=brief paid=yes
+	    POST b address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes
+	    STOP
+	    }
+	    set resShort {1 2 3 4 5 6 7 8 9}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	6     {set end {
+	    POST a address=home code=brief paid=yes
+	    GET b address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes
+	    GET a address=home code=brief paid=yes
+	    GET b address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes
+	    POST a address=home code=brief paid=yes
+	    HEAD b address=home code=brief paid=yes
+	    GET c address=home code=brief paid=yes
+	    STOP
+	    }
+	    set resShort {1 ? 3 ? ? 6 7 ? ?}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	7     {set end {
+	    GET b address=home code=brief paid=yes
+	    POST a address=home code=brief paid=yes
+	    GET a address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes
+	    GET b address=home code=brief paid=yes
+	    HEAD b address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes
+	    POST a address=home code=brief paid=yes
+	    GET c address=home code=brief paid=yes
+	    STOP
+	    }
+	    set resShort {1 2 ? 4 ? ? 7 8 ?}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	8     {set end {
+	    # Telling the server to close the connection.
+	    GET a
+	    GET b close=y
+	    GET c
+	    GET a
+	    GET b
+	    GET c
+	    GET a
+	    GET b
+	    GET c
+	    STOP
+	    }
+	    set resShort {1 ? 3 ? ? ? ? ? ?}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	9     {set end {
+	    # Telling the server to close the connection.
+	    GET a
+	    POST b close=y address=home code=brief paid=yes
+	    GET c
+	    GET a
+	    GET b
+	    GET c
+	    GET a
+	    GET b
+	    GET c
+	    STOP
+	    }
+	    set resShort {1 2 3 ? ? ? ? ? ?}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	10     {set end {
+	    # Telling the server to close the connection.
+	    GET a
+	    GET b close=y
+	    POST c address=home code=brief paid=yes
+	    GET a
+	    GET b
+	    GET c
+	    GET a
+	    GET b
+	    GET c
+	    STOP
+	    }
+	    set resShort {1 ? 3 ? ? ? ? ? ?}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	11    {set end {
+	    # Telling the server to close the connection twice.
+	    GET a
+	    GET b close=y
+	    GET c
+	    GET a
+	    GET b close=y
+	    GET c
+	    GET a
+	    GET b
+	    GET c
+	    STOP
+	    }
+	    set resShort {1 ? 3 ? ? 6 ? ? ?}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	12    {set end {
+	    # Telling the server to delay before sending the response.
+	    GET a
+	    GET b delay=1
+	    GET c
+	    GET a
+	    GET b
+	    STOP
+	    }
+	    set resShort {1 ? ? ? ?}
+	    set resLong  {1 2 3 4 5}
+	}
+
+	13    {set end {
+	    # Making the server close the connection (time out).
+	    GET a
+	    WAIT 2000
+	    GET b
+	    GET c
+	    GET a
+	    GET b
+	    STOP
+	    }
+	    set resShort {1 2 ? ? ?}
+	    set resLong  {1 2 3 4 5}
+	}
+
+	14    {set end {
+	    # Making the server close the connection (time out) twice.
+	    GET a
+	    WAIT 2000
+	    GET b
+	    GET c
+	    GET a
+	    WAIT 2000
+	    GET b
+	    GET c
+	    GET a
+	    GET b
+	    GET c
+	    STOP
+	    }
+	    set resShort {1 2 ? ? 5 ? ? ? ?}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	15    {set end {
+	    POST a address=home code=brief paid=yes
+	    POST b address=home code=brief paid=yes close=y delay=1
+	    POST c address=home code=brief paid=yes delay=1
+	    POST a address=home code=brief paid=yes close=y
+	    WAIT 2000
+	    POST b address=home code=brief paid=yes delay=1
+	    POST c address=home code=brief paid=yes close=y
+	    POST a address=home code=brief paid=yes
+	    POST b address=home code=brief paid=yes close=y
+	    POST c address=home code=brief paid=yes
+	    STOP
+	    }
+	    set resShort {1 2 3 4 5 6 7 8 9}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	16    {set end {
+	    POST a address=home code=brief paid=yes
+	    GET b address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes close=y
+	    GET a address=home code=brief paid=yes
+	    GET b address=home code=brief paid=yes close=y
+	    POST c address=home code=brief paid=yes
+	    WAIT 2000
+	    POST a address=home code=brief paid=yes
+	    HEAD b address=home code=brief paid=yes close=y
+	    GET c address=home code=brief paid=yes
+	    STOP
+	    }
+	    set resShort {1 ? 3 4 ? 6 7 ? 9}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+	17    {set end {
+	    GET b address=home code=brief paid=yes
+	    POST a address=home code=brief paid=yes
+	    GET a address=home code=brief paid=yes
+	    POST c address=home code=brief paid=yes close=y
+	    GET b address=home code=brief paid=yes
+	    HEAD b address=home code=brief paid=yes close=y
+	    POST c address=home code=brief paid=yes
+	    WAIT 2000
+	    POST a address=home code=brief paid=yes
+	    WAIT 2000
+	    GET c address=home code=brief paid=yes
+	    STOP
+	    }
+	    set resShort {1 2 3 4 5 ? 7 8 9}
+	    set resLong  {1 2 3 4 5 6 7 8 9}
+	}
+
+
+	18    {set end {
+	    REPOST 0
+	    GET a
+	    WAIT 2000
+	    POST b address=home code=brief paid=yes
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 2 ? ?}
+	    set resLong  {1 2 3 4}
+	    # resShort is overwritten below for the case ($te == 1).
+	}
+
+
+	19    {set end {
+	    REPOST 0
+	    GET a
+	    WAIT 2000
+	    GET b address=home code=brief paid=yes
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 2 ? ?}
+	    set resLong  {1 2 3 4}
+	}
+
+
+	20    {set end {
+	    POSTFRESH 1
+	    GET a
+	    WAIT 2000
+	    POST b address=home code=brief paid=yes
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 3 ?}
+	    set resLong  {1 3 4}
+	}
+
+
+	21    {set end {
+	    POSTFRESH 1
+	    GET a
+	    WAIT 2000
+	    GET b address=home code=brief paid=yes
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 2 ? ?}
+	    set resLong  {1 2 3 4}
+	}
+
+	22    {set end {
+	    GET a
+	    WAIT 2000
+	    KEEPALIVE 0
+	    POST b address=home code=brief paid=yes
+	    KEEPALIVE 1
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 3 ?}
+	    set resLong  {1 3 4}
+	}
+
+
+	23    {set end {
+	    GET a
+	    WAIT 2000
+	    KEEPALIVE 0
+	    GET b address=home code=brief paid=yes
+	    KEEPALIVE 1
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 3 ?}
+	    set resLong  {1 3 4}
+	}
+
+	24    {set end {
+	    GET a
+	    KEEPALIVE 0
+	    POST b address=home code=brief paid=yes
+	    KEEPALIVE 1
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 ? ?}
+	    set resLong  {1 3 4}
+	}
+
+
+	25    {set end {
+	    GET a
+	    KEEPALIVE 0
+	    GET b address=home code=brief paid=yes
+	    KEEPALIVE 1
+	    GET c
+	    GET a
+	    STOP
+	    }
+	    set resShort {1 ? ?}
+	    set resLong  {1 3 4}
+	}
+
+	default {
+	    return -code error {no matching script}
+	}
+    }
+
+
+    if {$ca < 3} {
+	# Not Keep-Alive.
+        set result "Passed all sanity checks."
+
+    } elseif {$ca == 3} {
+        # Keep-Alive, not pipelined.
+        set result {}
+        append result "Passed all sanity checks.\n"
+        append result "Have overlaps including response body:\n"
+
+    } else {
+        # Keep-Alive, pipelined: ($ca == 4)
+        set result {}
+        append result "Passed all sanity checks.\n"
+        append result "Overlap-free without response body:\n"
+        append result "$resShort"
+    }
+
+    # - The special case of test *.18*-testEof needs test results to be
+    #   individually written.
+    # - These test -repost 0 when there is a POST to apply it to, and the server
+    #   timeout has not been detected.
+    if {($cb == 18) && ($te == 1)} {
+        if {$ca < 3} {
+	    # Not Keep-Alive.
+	    set result "Passed all sanity checks."
+
+	} elseif {$ca == 3 && $delay == 0} {
+	    # Keep-Alive, not pipelined.
+            set result [MakeMessage {
+		|Problems with sanity checks:
+		|Wrong sequence for token ::http::2 - {A B C D X X X}
+		|- and error(s) X
+		|Wrong sequence for token ::http::3 - {A X X}
+		|- and error(s) X
+		|Wrong sequence for token ::http::4 - {A X X X}
+		|- and error(s) X
+		|
+		|Have overlaps including response body:
+		|
+	    }]
+
+	} elseif {$ca == 3} {
+	    # Keep-Alive, not pipelined.
+            set result [MakeMessage {
+		|Problems with sanity checks:
+		|Wrong sequence for token ::http::2 - {A B C D X X X}
+		|- and error(s) X
+		|
+		|Have overlaps including response body:
+		|
+	    }]
+
+	} elseif {$delay == 0} {
+	    # Keep-Alive, pipelined: ($ca == 4)
+            set result [MakeMessage {
+		|Problems with sanity checks:
+		|Wrong sequence for token ::http::2 - {A B C D X X X}
+		|- and error(s) X
+		|Wrong sequence for token ::http::3 - {A X X}
+		|- and error(s) X
+		|Wrong sequence for token ::http::4 - {A X X X}
+		|- and error(s) X
+		|
+		|Overlap-free without response body:
+		|
+	    }]
+
+	} else {
+            set result [MakeMessage {
+		|Problems with sanity checks:
+		|Wrong sequence for token ::http::2 - {A B C D X X X}
+		|- and error(s) X
+		|
+		|Overlap-free without response body:
+		|
+	    }]
+
+        }
+    }
+
+    return [list "$start$middle$end" $result]
+}
+
+# ------------------------------------------------------------------------------
+#  Proc MakeMessage
+# ------------------------------------------------------------------------------
+# WHD's one-line command to generate multi-line strings from readable code.
+# 
+# Example:
+#   set blurb [MakeMessage {
+#            |This command allows multi-line strings to be created with readable
+#            |code, and without breaking the rules for indentation.
+#            |
+#            |The command shifts the entire block of text to the left, omitting
+#            |the pipe character and the spaces to its left.
+#   }]
+# ------------------------------------------------------------------------------
+
+proc MakeMessage {in} {
+    regsub -all -line {^\s*\|} [string trim $in] {}
+    # N.B. Implicit Return.
+}
+
+
+proc ReturnTestScript {ca cb delay te} {
+    lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result
+    return $script
+}
+
+proc ReturnTestResult {ca cb delay te} {
+    lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result
+    return $result
+}
+
+
+# ------------------------------------------------------------------------------
+# (2) Command to run a test script and use httpTest to analyse the logs.
+# ------------------------------------------------------------------------------
+
+namespace import httpTestScript::runHttpTestScript
+namespace import httpTestScript::cleanupHttpTestScript
+
+proc RunTest {header footer delay te} {
+    set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]]
+    set skipOverlaps 0
+    set notIncluded {}
+
+    # --------------------------------------------------------------------------
+    # Custom code for specific tests
+    # --------------------------------------------------------------------------
+    if {$header < 3} {
+        set skipOverlaps 1
+        for {set i 1} {$i <= $num} {incr i} {
+	    lappend notIncluded $i
+        }
+    } elseif {$header > 2 && $footer == 18 && $te == 1} {
+        set skipOverlaps 1
+        if {$delay == 0} {
+	    # Transaction 1 is conventional.
+	    # Check that transactions 2,3,4 are cancelled.
+	    set notIncluded {1}
+        } else {
+	    # Transaction 1 is conventional.
+	    # Check that transaction 2 is cancelled.
+	    # The timing of transactions 3 and 4 is uncertain.
+	    set notIncluded {1 3 4}
+	}
+    } elseif {$footer in {20 22 23 24 25}} {
+	# Transaction 2 uses its own socket.
+	set notIncluded 2
+    } else {
+    }
+    # --------------------------------------------------------------------------
+    # End of custom code for specific tests
+    # --------------------------------------------------------------------------
+
+
+    set Results [httpTest::LogAnalyse $num $skipOverlaps $notIncluded $notIncluded]
+    lassign $Results msg cleanE cleanF dirtyE dirtyF
+    if {$msg eq {}} {
+        set msg "Passed all sanity checks."
+    } else {
+        set msg "Problems with sanity checks:\n$msg"
+    }
+
+    if 0 {
+        puts $msg
+        puts "Overlap-free including response body:\n$cleanF"
+        puts "Have overlaps including response body:\n$dirtyF"
+        puts "Overlap-free without response body:\n$cleanE"
+        puts "Have overlaps without response body:\n$dirtyE"
+    }
+
+    if {$header < 3} {
+        # No ordering, just check that transactions all finish
+        set result $msg
+    } elseif {$header == 3} {
+        # Not pipelined - check overlaps with response body.
+        set result "$msg\nHave overlaps including response body:\n$dirtyF"
+    } else {
+        # Pipelined - check overlaps without response body.  Check that the
+        # first request, the first requests after replay, and POSTs are clean.
+        set result "$msg\nOverlap-free without response body:\n$cleanE"
+    }
+    set ::nTokens $num
+    return $result
+}
+
+
+# ------------------------------------------------------------------------------
+# (3) VERBOSITY CONTROL
+# ------------------------------------------------------------------------------
+# If tests fail, run an individual test with -verbose 1 or 2 for diagnosis.
+# If still obscure, uncomment #Log and ##Log lines in the http package.
+# ------------------------------------------------------------------------------
+
+set ::httpTest::testOptions(-verbose) 0
+
+
+# ------------------------------------------------------------------------------
+# (4) Define the base URLs used for testing.  Each must have a query string.
+# ------------------------------------------------------------------------------
+# - A HTTP/1.1 server is required.  It should be configured to provide
+#   persistent connections when requested to do so, and to close these
+#   connections if they are idle for one second.
+# - The resource must be served with status 200 in response to a valid GET or
+#   POST.
+# - The value of "page" is always specified in the query-string. Different
+#   resources for the three values of "page" allow testing of both chunked and
+#   unchunked transfer encoding.
+# - The variables "close" and "delay" may be specified in the query-string (for
+#   a GET) or the request body (for a POST).
+#   - "delay" is a numerical value in seconds, and causes the server to delay
+#     the response, including headers.
+#   - "close", if it has the value "y", instructs the server to close the
+#     connection ater the current request.
+# - Any other variables should be ignored.
+# ------------------------------------------------------------------------------
+
+namespace eval ::httpTestScript {
+    variable URL
+    array set URL {
+        a  http://test-tcl-http.kerlin.org/index.html?page=privacy
+        b  http://test-tcl-http.kerlin.org/index.html?page=conditions
+        c  http://test-tcl-http.kerlin.org/index.html?page=welcome
+    }
+}
+
+
+# ------------------------------------------------------------------------------
+# (5) Define the tests
+# ------------------------------------------------------------------------------
+# Constraints:
+# - serverNeeded - the URLs defined at (4) must be available, and must have the
+#                  properties specified there.
+# - duplicate    - the value of -pipeline does not matter if -keepalive 0
+# - timeout1s    - tests that work correctly only if the server closes
+#                  persistent connections after one second.
+#
+# Server timeout of persistent connections should be 1s.  Delays of 2s are
+# intended to cause timeout.
+# Servers are usually configured to use a longer timeout: this will cause the
+# tests to fail.  The "2000" could be replaced with a larger number, but the
+# tests will then be inconveniently slow.
+# ------------------------------------------------------------------------------
+
+#testConstraint serverNeeded 1
+#testConstraint timeout1s 1
+#testConstraint duplicate 1
+
+# ------------------------------------------------------------------------------
+#  Proc SetTestEof - to edit the command ::http::KeepSocket
+# ------------------------------------------------------------------------------
+# The usual line in command ::http::KeepSocket is "    set TEST_EOF 0".
+# Whether the value set in the file is 0 or 1, change it here to the value
+# specified by the argument.
+#
+# It is worth doing all tests for both values of the argument.
+#
+# test 0  - ::http::KeepSocket is unchanged, detects server eof where possible
+#           and closes the connection.
+# test 1  - ::http::KeepSocket is edited, does not detect server eof, so the
+#           reaction to finding server eof can be tested without the difficulty
+#           of testing in the few milliseconds of an asynchronous close event.
+# ------------------------------------------------------------------------------
+
+proc SetTestEof {test} {
+    set body [info body ::http::KeepSocket]
+    set subs "    set TEST_EOF $test"
+    set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody]
+    if {$count != 1} {
+        return -code error {proc ::http::KeepSocket has unexpected form}
+    }
+    proc ::http::KeepSocket {token} $newBody
+    return
+}
+
+for {set header 1} {$header <= 4} {incr header} {
+    if {$header == 4} {
+	set ::httpTest::testOptions(-dotted) 1
+	set match glob
+    } else {
+	set ::httpTest::testOptions(-dotted) 0
+	set match exact
+    }
+
+    if {$header == 2} {
+        set cons0 {serverNeeded duplicate}
+    } else {
+        set cons0 serverNeeded
+    }
+
+    for {set footer 1} {$footer <= 25} {incr footer} {
+        foreach {delay label} {
+	       0 a
+	       1 b
+	       2 c
+	       3 d
+	       5 e
+	       8 f
+	      12 g
+	     100 h
+	     500 i
+	    2000 j
+	} {
+	  foreach te {0 1} {
+	    if {$te} {
+	        set tag testEof
+	    } else {
+	        set tag normal
+	    }
+	    set suffix {}
+	    set cons $cons0
+
+	    # ------------------------------------------------------------------
+	    # Custom code for individual tests
+	    # ------------------------------------------------------------------
+	    if {$footer in {18}} {
+		# Custom code:
+		if {($label eq "j") && ($te == 1)} {
+		    continue
+		}
+		if {$te == 1} {
+		    # The test (of REPOST 0) is useful if tag is "testEof"
+		    # (server timeout without client reaction).  The same test
+		    # has a different result if tag is "normal".
+
+		    set suffix " - extra test for -repost 0 - ::http::2 must be"
+		    append suffix " cancelled"
+		    if {($delay == 0)} {
+			append suffix ", along with  ::http::3  ::http::4 if"
+			append suffix " the test creates these before ::http::2"
+			append suffix " is cancelled"
+		    }
+		} else {
+		}
+	    } elseif {$footer in {19}} {
+		set suffix " - extra test for -repost 0"
+	    } elseif {$footer in {20 21}} {
+		set suffix " - extra test for -postfresh 1"
+		if {($footer == 20)} {
+		    append suffix " - ::http::2 uses a separate socket"
+		    append suffix ", other requests use a persistent connection"
+		}
+	    } elseif {$footer in {22 23 24 25}} {
+		append suffix " - ::http::2 uses a separate socket"
+		append suffix ", other requests use a persistent connection"
+	    } else {
+	    }
+
+	    if {($footer >= 13 && $footer <= 23)} {
+		# Test use WAIT and depend on server timeout before this time.
+		lappend cons timeout1s
+	    }
+	    # ------------------------------------------------------------------
+	    # End of custom code.
+	    # ------------------------------------------------------------------
+
+            set name "pipeline test header $header footer $footer delay $delay $tag$suffix"
+
+
+	    # Here's the test:
+            test http11-${header}.${footer}${label}-${tag} $name -constraints $cons \
+            -setup [string map [list TE $te] {
+                http::init
+                set http::http(uid) 0
+		# Restore default values for tests:
+		http::config -pipeline 1 -postfresh 0 -repost 1
+		SetTestEof {TE}
+	    }] -body [list RunTest $header $footer $delay $te] -cleanup {
+		# Restore default values for tests:
+		http::config -pipeline 1 -postfresh 0 -repost 1
+		cleanupHttpTestScript
+		SetTestEof 0
+		set ::httpTest::testResults {}
+		after 2000
+		# Wait for persistent sockets on the server to time out.
+	    } -result [ReturnTestResult $header $footer $delay $te] -match $match
+
+
+	  }
+
+	}
+    }
+}
+
+# ------------------------------------------------------------------------------
+# (*) Notes on tests *.18*-testEof, *.19*-testEof - these test -repost 0
+# ------------------------------------------------------------------------------
+# These tests are a bit awkward because the main test kit analyses whether all
+# requests are satisfied, with retries if necessary, and it has result analysis
+# for processing retry logs.
+# - *.18*-testEof tests that certain requests are NOT satisfied, so the analysis
+#   is a one-off.
+# - Tests *.18a-testEof depend on client/server timing - the test needs to call
+#   http::geturl for all requests before the POST (request 2) is cancelled.
+#   We test that requests 2, 3, 4 are all cancelled.
+# - Other tests *.18*-testEof may not request 3 and 4 in time for the to be
+#   added to the write queue before request 2 is completed. We simply check that
+#   request 2 is cancelled.
+# - The behaviour is different if all connections are allowed to time out
+#   (label "j").  This case is not needed to test -repost 0, and is omitted.
+# - Tests *.18*-normal and *.19* are conventional (-repost 0 should have no
+#   effect).
+# ------------------------------------------------------------------------------
+
+
+unset header footer delay label suffix match cons name te
+namespace delete ::httpTest
+namespace delete ::httpTestScript
+
+::tcltest::cleanupTests
diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl
new file mode 100644
index 0000000..ad08048
--- /dev/null
+++ b/tests/httpTest.tcl
@@ -0,0 +1,431 @@
+# httpTest.tcl
+#
+#	Test HTTP/1.1 concurrent requests including
+#	queueing, pipelining and retries.
+#
+# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# ------------------------------------------------------------------------------
+# "Package" httpTest for analysis of Log output of http requests.
+# ------------------------------------------------------------------------------
+# This is a specialised test kit for examining the presence, ordering, and
+# overlap of multiple HTTP transactions over a persistent ("Keep-Alive")
+# connection; and also for testing reconnection in accordance with RFC 7230 when
+# the connection is lost.
+#
+# This kit is probably not useful for other purposes.  It depends on the
+# presence of specific Log commands in the http library, and it interprets the
+# logs that these commands create.
+# ------------------------------------------------------------------------------
+
+package require http
+
+namespace eval ::http {
+    variable TestStartTimeInMs [clock milliseconds]
+}
+
+namespace eval ::httpTest {
+    variable testResults {}
+    variable testOptions
+    array set testOptions {
+        -verbose 0
+        -dotted  1
+    }
+    # -verbose - 0 quiet 1 write to stderr 2 write more
+    # -dotted  - (boolean) use dots for absences in lists of transactions
+}
+
+proc httpTest::Puts {txt} {
+    variable testOptions
+    if {$testOptions(-verbose) > 0} {
+        puts stderr $txt
+        flush stderr
+    }
+    return
+}
+
+# http::Log
+#
+# A special-purpose logger used for running tests.
+# - Processes Log calls that have "^" in their arguments, and records them in
+#   variable ::httpTest::testResults.
+# - Also writes them to stderr (using Puts) if ($testOptions(-verbose) > 0).
+# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1).
+
+proc http::Log {args} {
+    variable TestStartTimeInMs
+    set time [expr {[clock milliseconds] - $TestStartTimeInMs}]
+    set txt [list $time {*}$args]
+    if {[string first ^ $txt] != -1} {
+        ::httpTest::LogRecord $txt
+        ::httpTest::Puts $txt
+    } elseif {$::httpTest::testOptions(-verbose) > 1} {
+        ::httpTest::Puts $txt
+    }
+    return
+}
+
+
+# Called by http::Log (the "testing" version) to record logs for later analysis.
+
+proc httpTest::LogRecord {txt} {
+    variable testResults
+
+    set pos [string first ^ $txt]
+    set len [string length  $txt]
+    if {$pos > $len - 3} {
+        puts stderr "Logging Error: $txt"
+        puts stderr "Fix this call to Log in http-*.tm so it has ^ then\
+		a letter then a numeral."
+        flush stderr
+    } elseif {$pos == -1} {
+        # Called by mistake.
+    } else {
+        set letter [string index $txt [incr pos]]
+        set number [string index $txt [incr pos]]
+        # Max 9 requests!
+        lappend testResults [list $letter $number]
+    }
+
+    return
+}
+
+
+# ------------------------------------------------------------------------------
+# Commands for analysing the logs recorded when calling http::geturl.
+# ------------------------------------------------------------------------------
+
+# httpTest::TestOverlaps --
+#
+# The main test for correct behaviour of pipelined and sequential
+# (non-pipelined) transactions.  Other tests should be run first to detect
+# any inconsistencies in the data (e.g. absence of the elements that are
+# examined here).
+#
+# Examine the sequence $someResults for each transaction from 1 to $n,
+# ignoring any that are listed in $badTrans.
+# Determine whether the elements "B" to $term for one transaction overlap
+# elements "B" to $term for the previous and following transactions.
+#
+# Transactions in the list $badTrans are not included in "clean" or
+# "dirty", but their possible overlap with other transactions is noted.
+# Transactions in the list $notPiped are a subset of $badTrans, and
+# their possible overlap with other transactions is NOT noted.
+#
+# Arguments:
+# someResults - list of results, each of the form {letter numeral}
+# n           - number of HTTP transactions
+# term        - letter that indicated end of search range. "E" for testing
+#               overlaps from start of request to end of response headers.
+#               "F" to extend to the end of the response body.
+# msg         - the cumulative message from sanity checks.  Append to it only
+#               to report a test failure.
+# badTrans    - list of transaction numbers not to be assessed as "clean" or
+#               "dirty"
+# notPiped    - subset of badTrans.  List of transaction numbers that cannot
+#               taint another transaction by overlapping with it, because it
+#               used a different socket.
+#
+# Return value: [list $msg $clean $dirty]
+# msg   - warning messages: nothing will be appended to argument $msg if there
+#         is an error with the test.
+# clean - list of transactions that have no overlap with other transactions
+# dirty - list of transactions that have YES overlap with other transactions
+
+proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} {
+    variable testOptions
+
+    # Check whether transactions overlap:
+    set clean {}
+    set dirty {}
+    for {set i 1} {$i <= $n} {incr i} {
+        if {$i in $badTrans} {
+            continue
+        }
+        set myStart   [lsearch -exact $someResults [list B $i]]
+        set myEnd     [lsearch -exact $someResults [list $term $i]]
+
+        if {($myStart == -1 || $myEnd == -1)} {
+            set res "Cannot find positions of transaction $i"
+	    append msg $res \n
+	    Puts $res
+        }
+
+	set overlaps {}
+	for {set j $myStart} {$j <= $myEnd} {incr j} {
+	    lassign [lindex $someResults $j] letter number
+	    if {$number != $i && $letter ne "A" && $number ni $notPiped} {
+		lappend overlaps $number
+	    }
+	}
+
+        if {[llength $overlaps] == 0} {
+	    set res "Transaction $i has no overlaps"
+	    Puts $res
+	    lappend clean $i
+	    if {$testOptions(-dotted)} {
+		# N.B. results from different segments are concatenated.
+		lappend dirty .
+	    } else {
+	    }
+        } else {
+	    set res "Transaction $i overlaps with [join $overlaps { }]"
+	    Puts $res
+	    lappend dirty $i
+	    if {$testOptions(-dotted)} {
+		# N.B. results from different segments are concatenated.
+		lappend clean .
+	    } else {
+	    }
+        }
+    }
+    return [list $msg $clean $dirty]
+}
+
+# httpTest::PipelineNext --
+#
+# Test whether prevPair, pair are valid as consecutive elements of a pipelined
+# sequence (Start 1), (End 1), (Start 2), (End 2) ...
+# Numbers are integers increasing (by 1 if argument "any" is false), and need
+# not begin with 1.
+# The first element of the sequence has prevPair {} and is always passed as
+# valid.
+#
+# Arguments;
+# Start        - string that labels the start of a segment
+# End          - string that labels the end of a segment
+# prevPair     - previous "pair" (list of string and number) element of a
+#                sequence, or {} if argument "pair" is the first in the
+#                sequence.
+# pair         - current "pair" (list of string and number) element of a
+#                sequence
+# any          - (boolean) iff true, accept any increasing sequence of integers.
+#                If false, integers must increase by 1.
+#
+# Return value - boolean, true iff the two pairs are valid consecutive elements.
+
+proc httpTest::PipelineNext {Start End prevPair pair any} {
+    if {$prevPair eq {}} {
+        return 1
+    }
+
+    lassign $prevPair letter number
+    lassign $pair newLetter newNumber
+    if {$letter eq $Start} {
+	return [expr {($newLetter eq $End) && ($newNumber == $number)}]
+    } elseif {$any} {
+        set nxt [list $Start [expr {$number + 1}]]
+	return [expr {($newLetter eq $Start) && ($newNumber > $number)}]
+    } else {
+        set nxt [list $Start [expr {$number + 1}]]
+	return [expr {($newLetter eq $Start) && ($newNumber == $number + 1)}]
+    }
+}
+
+# httpTest::TestPipeline --
+#
+# Given a sequence of "pair" elements, check that the elements whose string is
+# $Start or $End form a valid pipeline. Ignore other elements.
+#
+# Return value: {} if valid pipeline, otherwise a non-empty error message.
+
+proc httpTest::TestPipeline {someResults n Start End msg desc badTrans} {
+    set sequence {}
+    set prevPair {}
+    set ok 1
+    set any [llength $badTrans]
+    foreach pair $someResults {
+        lassign $pair letter number
+        if {($letter in [list $Start $End]) && ($number ni $badTrans)} {
+            lappend sequence $pair
+            if {![PipelineNext $Start $End $prevPair $pair $any]} {
+		set ok 0
+		break
+            }
+            set prevPair $pair
+        }
+    }
+
+    if {!$ok} {
+        set res "$desc are not pipelined: {$sequence}"
+        append msg $res \n
+        Puts $res
+    }
+    return $msg
+}
+
+# httpTest::TestSequence --
+#
+# Examine each transaction from 1 to $n, ignoring any that are listed
+# in $badTrans.
+# Check that each transaction has elements A to F, in alphabetical order.
+
+proc httpTest::TestSequence {someResults n msg badTrans} {
+    variable testOptions
+
+    for {set i 1} {$i <= $n} {incr i} {
+        if {$i in $badTrans} {
+	    continue
+        }
+        set sequence {}
+        foreach pair $someResults {
+            lassign $pair letter number
+            if {$number == $i} {
+                lappend sequence $letter
+            }
+        }
+        if {$sequence eq {A B C D E F}} {
+        } else {
+            set res "Wrong sequence for token ::http::$i - {$sequence}"
+	    append msg $res \n
+	    Puts $res
+            if {"X" in $sequence} {
+                set res "- and error(s) X"
+		append msg $res \n
+		Puts $res
+            }
+            if {"Y" in $sequence} {
+                set res "- and warnings(s) Y"
+		append msg $res \n
+		Puts $res
+            }
+        }
+    }
+    return $msg
+}
+
+proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} {
+    variable testOptions
+
+    # Check that stages for "good" transactions are all present and correct:
+    set msg [TestSequence $someResults $n $msg $badTrans]
+
+    # Check that requests are pipelined:
+    set msg [TestPipeline $someResults $n B C $msg Requests $notPiped]
+
+    # Check that responses are pipelined:
+    set msg [TestPipeline $someResults $n D F $msg Responses $notPiped]
+
+    if {$skipOverlaps} {
+	set cleanE {}
+	set dirtyE {}
+	set cleanF {}
+	set dirtyF {}
+    } else {
+	Puts "Overlaps including response body (test for non-pipelined case)"
+	lassign [TestOverlaps $someResults $n F $msg $badTrans $notPiped] msg cleanF dirtyF
+
+	Puts "Overlaps without response body (test for pipelined case)"
+	lassign [TestOverlaps $someResults $n E $msg $badTrans $notPiped] msg cleanE dirtyE
+    }
+
+    return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
+}
+
+# httpTest::ProcessRetries --
+#
+# Command to examine results for socket-changing records [PQR],
+# divide the results into segments for each connection, and analyse each segment
+# individually.
+# (Could add $sock to the logging to simplify this, but never mind.)
+#
+# In each segment, identify any transactions that are not included, and
+# any that are aborted, to assist subsequent testing.
+#
+# Prepend A records (socket-independent) to each segment for transactions that
+# were scheduled (by A) but not completed (by F).  Pass each segment to
+# MostAnalysis for processing.
+
+proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
+    variable testOptions
+
+    set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
+    if {$nextRetry == -1} {
+        return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped]
+    }
+    set badTrans $notIncluded
+    set tryCount 0
+    set try $nextRetry
+    incr tryCount
+    lassign [lindex $someResults $try] letter number
+    Puts "Processing retry [lindex $someResults $try]"
+    set beforeTry [lrange $someResults 0 $try-1]
+    Puts [join $beforeTry \n]
+    set afterTry [lrange $someResults $try+1 end]
+
+    set dummyTry   {}
+    for {set i 1} {$i <= $n} {incr i} {
+        set first [lsearch -exact $beforeTry [list A $i]]
+        set last  [lsearch -exact $beforeTry [list F $i]]
+        if {$first == -1} {
+	    set res "Transaction $i was not started in connection number $tryCount"
+	    # append msg $res \n
+	    Puts $res
+	    if {$i ni $badTrans} {
+		lappend badTrans $i
+	    } else {
+	    }
+        } elseif {$last == -1} {
+	    set res "Transaction $i was started but unfinished in connection number $tryCount"
+	    # append msg $res \n
+	    Puts $res
+	    lappend badTrans $i
+	    lappend dummyTry [list A $i]
+        } else {
+	    set res "Transaction $i was started and finished in connection number $tryCount"
+	    # append msg $res \n
+	    Puts $res
+	    lappend notIncluded $i
+        }
+    }
+
+    # Analyse the part of the results before the first replay:
+    set HeadResults [MostAnalysis $beforeTry $n $msg $skipOverlaps $badTrans $notPiped]
+    lassign $HeadResults msg cleanE1 cleanF1 dirtyE1 dirtyF1
+
+    # Pass the rest of the results to be processed recursively.
+    set afterTry [concat $dummyTry $afterTry]
+    set TailResults [ProcessRetries $afterTry $n $msg $skipOverlaps $notIncluded $notPiped]
+    lassign $TailResults msg cleanE2 cleanF2 dirtyE2 dirtyF2
+
+    set cleanE [concat $cleanE1 $cleanE2]
+    set cleanF [concat $cleanF1 $cleanF2]
+    set dirtyE [concat $dirtyE1 $dirtyE2]
+    set dirtyF [concat $dirtyF1 $dirtyF2]
+    return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
+}
+
+proc httpTest::LogAnalyse {n skipOverlaps notIncluded notPiped} {
+    variable testResults
+    variable testOptions
+
+    # Check that each data item has the correct form {letter numeral}.
+    set ii 0
+    set ok 1
+    foreach pair $testResults {
+	lassign $pair letter number
+	if {    [string match {[A-Z]} $letter]
+	     && [string match {[0-9]} $number]
+	} {
+	    # OK
+	} else {
+	    set ok 0
+	    set res "Error: testResults has bad element {$pair} at position $ii"
+	    append msg $res \n
+	    Puts $res
+	}
+	incr ii
+    }
+
+    if {!$ok} {
+	return $msg
+    }
+    set msg {}
+
+    Puts [join $testResults \n]
+    ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped
+    # N.B. Implicit Return.
+}
diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl
new file mode 100644
index 0000000..a826c81
--- /dev/null
+++ b/tests/httpTestScript.tcl
@@ -0,0 +1,509 @@
+# httpTestScript.tcl
+#
+#	Test HTTP/1.1 concurrent requests including
+#	queueing, pipelining and retries.
+#
+# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# ------------------------------------------------------------------------------
+# "Package" httpTestScript for executing test scripts written in a convenient
+# shorthand.
+# ------------------------------------------------------------------------------
+
+# ------------------------------------------------------------------------------
+# Documentation for "package" httpTestScript.
+# ------------------------------------------------------------------------------
+# To use the package:
+# (a) define URLs as the values of elements in the array ::httpTestScript
+# (b) define a script in terms of the commands
+#         START STOP DELAY KEEPALIVE WAIT PIPELINE GET HEAD POST
+#     referring to URLs by the name of the corresponding array element.  The
+#     script can include any other Tcl commands, and evaluates in the
+#     httpTestScript namespace.
+# (c) Use the command httpTestScript::runHttpTestScript to evaluate the script.
+# (d) For tcltest tests, wrap the runHttpTestScript call in a suitable "test"
+#     command.
+# ------------------------------------------------------------------------------
+# START
+# Must be the first command of the script.
+#
+# STOP
+# Must be present in the script to avoid waiting for client timeout.
+# Usually the last command, but can be elsewhere to end a script prematurely.
+# Subsequent httpTestScript commands will have no effect.
+#
+# DELAY ms
+# If there are no WAIT commands, this sets the delay in ms between subsequent
+# calls to http::geturl.  Default 500ms.
+#
+# KEEPALIVE
+# Set the value passed to http::geturl for the -keepalive option.  The command
+# applies to subsequent requests in the script. Default 1.
+#
+# WAIT ms
+# Pause for a time in ms before sending subsequent requests.
+#
+# PIPELINE boolean
+# Set the value of -pipeline using http::config.  The last PIPELINE command
+# in the script applies to every request. Default 1.
+#
+# POSTFRESH boolean
+# Set the value of -postfresh using http::config.  The last POSTFRESH command
+# in the script applies to every request. Default 0.
+#
+# REPOST boolean
+# Set the value of -repost using http::config.  The last REPOST command
+# in the script applies to every request. Default 1 for httpTestScript.
+# (Default value in http is 0).
+#
+# GET uriCode ?arg ...?
+# Send a HTTP request using the GET method.
+# Arguments:
+# uriCode - the code for the base URI - the value must be stored in
+#           ::httpTestScript::URL($uriCode).
+# args    - strings that will be joined by "&" and appended to the query
+#           string with a preceding "&".
+#
+# HEAD uriCode ?arg ...?
+# Send a HTTP request using the HEAD method.
+# Arguments: as for GET
+#
+# POST uriCode ?arg ...?
+# Send a HTTP request using the POST method.
+# Arguments:
+# uriCode - the code for the base URI - the value must be stored in
+#           ::httpTestScript::URL($uriCode).
+# args    - strings that will be joined by "&" and used as the request body.
+# ------------------------------------------------------------------------------
+
+namespace eval ::httpTestScript {
+    namespace export runHttpTestScript cleanupHttpTestScript
+}
+
+# httpTestScript::START --
+# Initialise, and create a long-stop timeout.
+
+proc httpTestScript::START {} {
+    variable CountRequestedSoFar
+    variable RequestsWhenStopped
+    variable KeepAlive
+    variable Delay
+    variable TimeOutCode
+    variable TimeOutDone
+    variable StartDone
+    variable StopDone
+    variable CountFinishedSoFar
+    variable RequestList
+    variable RequestsMade
+    variable ExtraTime
+    variable ActualKeepAlive
+
+    if {[info exists StartDone] && ($StartDone == 1)} {
+        set msg {START has been called twice without an intervening STOP}
+        return -code error $msg
+    }
+
+    set StartDone 1
+    set StopDone 0
+    set TimeOutDone 0
+    set CountFinishedSoFar 0
+    set CountRequestedSoFar 0
+    set RequestList {}
+    set RequestsMade {}
+    set ExtraTime 0
+    set ActualKeepAlive 1
+
+    # Undefined until a STOP command:
+    unset -nocomplain RequestsWhenStopped
+
+    # Default values:
+    set KeepAlive 1
+    set Delay 500
+
+    # Default values for tests:
+    KEEPALIVE 1
+    PIPELINE  1
+    POSTFRESH 0
+    REPOST    1
+
+    set TimeOutCode [after 30000 httpTestScript::TimeOutNow]
+#    set TimeOutCode [after 4000 httpTestScript::TimeOutNow]
+    return
+}
+
+# httpTestScript::STOP --
+# Do not process any more commands.  The commands will be executed but will
+# silently do nothing.
+
+proc httpTestScript::STOP {} {
+    variable CountRequestedSoFar
+    variable CountFinishedSoFar
+    variable RequestsWhenStopped
+    variable TimeOutCode
+    variable StartDone
+    variable StopDone
+    variable RequestsMade
+
+    if {$StopDone} {
+        # Don't do anything on a second call.
+        return
+    }
+
+    if {![info exists StartDone]} {
+        return -code error {initialise the script by calling command START}
+    }
+
+    set StopDone 1
+    set StartDone 0
+    set RequestsWhenStopped $CountRequestedSoFar
+    unset -nocomplain StartDone
+
+    if {$CountFinishedSoFar == $RequestsWhenStopped} {
+        if {[info exists TimeOutCode]} {
+            after cancel $TimeOutCode
+        }
+        set ::httpTestScript::FOREVER 0
+    }
+    return
+}
+
+# httpTestScript::DELAY --
+# If there are no WAIT commands, this sets the delay in ms between subsequent
+# calls to http::geturl.  Default 500ms.
+
+proc httpTestScript::DELAY {t} {
+    variable StartDone
+    variable StopDone
+
+    if {$StopDone} {
+        return
+    }
+
+    if {![info exists StartDone]} {
+        return -code error {initialise the script by calling command START}
+    }
+
+    variable Delay
+
+    set Delay $t
+    return
+}
+
+# httpTestScript::KEEPALIVE --
+# Set the value passed to http::geturl for the -keepalive option.  Default 1.
+
+proc httpTestScript::KEEPALIVE {b} {
+    variable StartDone
+    variable StopDone
+
+    if {$StopDone} {
+        return
+    }
+
+    if {![info exists StartDone]} {
+        return -code error {initialise the script by calling command START}
+    }
+
+    variable KeepAlive
+    set KeepAlive $b
+    return
+}
+
+# httpTestScript::WAIT --
+# Pause for a time in ms before processing any more commands.
+
+proc httpTestScript::WAIT {t} {
+    variable StartDone
+    variable StopDone
+    variable ExtraTime
+
+    if {$StopDone} {
+        return
+    }
+
+    if {![info exists StartDone]} {
+        return -code error {initialise the script by calling command START}
+    }
+
+    if {(![string is integer -strict $t]) || $t < 0} {
+        return -code error {argument to WAIT must be a non-negative integer}
+    }
+
+    incr ExtraTime $t
+
+    return
+}
+
+# httpTestScript::PIPELINE --
+# Pass a value to http::config -pipeline.
+
+proc httpTestScript::PIPELINE {b} {
+    variable StartDone
+    variable StopDone
+
+    if {$StopDone} {
+        return
+    }
+
+    if {![info exists StartDone]} {
+        return -code error {initialise the script by calling command START}
+    }
+
+    ::http::config -pipeline $b
+    ::http::Log http(-pipeline) is now [::http::config -pipeline]
+    return
+}
+
+# httpTestScript::POSTFRESH --
+# Pass a value to http::config -postfresh.
+
+proc httpTestScript::POSTFRESH {b} {
+    variable StartDone
+    variable StopDone
+
+    if {$StopDone} {
+        return
+    }
+
+    if {![info exists StartDone]} {
+        return -code error {initialise the script by calling command START}
+    }
+
+    ::http::config -postfresh $b
+    ::http::Log http(-postfresh) is now [::http::config -postfresh]
+    return
+}
+
+# httpTestScript::REPOST --
+# Pass a value to http::config -repost.
+
+proc httpTestScript::REPOST {b} {
+    variable StartDone
+    variable StopDone
+
+    if {$StopDone} {
+        return
+    }
+
+    if {![info exists StartDone]} {
+        return -code error {initialise the script by calling command START}
+    }
+
+    ::http::config -repost $b
+    ::http::Log http(-repost) is now [::http::config -repost]
+    return
+}
+
+# httpTestScript::GET --
+# Send a HTTP request using the GET method.
+# Arguments:
+# uriCode - the code for the base URI - the value must be stored in
+#           ::httpTestScript::URL($uriCode).
+# args    - strings that will each be preceded by "&" and appended to the query
+#           string.
+
+proc httpTestScript::GET {uriCode args} {
+    variable RequestList
+    lappend RequestList GET
+    RequestAfter $uriCode 0 {} {*}$args
+    return
+}
+
+# httpTestScript::HEAD --
+# Send a HTTP request using the HEAD method.
+# Arguments: as for GET
+
+proc httpTestScript::HEAD {uriCode args} {
+    variable RequestList
+    lappend RequestList HEAD
+    RequestAfter $uriCode 1 {} {*}$args
+    return
+}
+
+# httpTestScript::POST --
+# Send a HTTP request using the POST method.
+# Arguments:
+# uriCode - the code for the base URI - the value must be stored in
+#           ::httpTestScript::URL($uriCode).
+# args    - strings that will be joined by "&" and used as the request body.
+
+proc httpTestScript::POST {uriCode args} {
+    variable RequestList
+    lappend RequestList POST
+    RequestAfter $uriCode 0 {use} {*}$args
+    return
+}
+
+
+proc httpTestScript::RequestAfter {uriCode validate query args} {
+    variable CountRequestedSoFar
+    variable Delay
+    variable ExtraTime
+    variable StartDone
+    variable StopDone
+    variable KeepAlive
+
+    if {$StopDone} {
+        return
+    }
+
+    if {![info exists StartDone]} {
+        return -code error {initialise the script by calling command START}
+    }
+
+    incr CountRequestedSoFar
+    set idelay [expr {($CountRequestedSoFar - 1) * $Delay + 10 + $ExtraTime}]
+
+    # Could pass values of -pipeline, -postfresh, -repost if it were
+    # useful to change these mid-script.
+    after $idelay [list httpTestScript::Requester $uriCode $KeepAlive $validate $query {*}$args]
+    return
+}
+
+proc httpTestScript::Requester {uriCode keepAlive validate query args} {
+    variable URL
+
+    ::http::config -accept {*/*}
+
+    set absUrl $URL($uriCode)
+    if {$query eq {}} {
+	if {$args ne {}} {
+	    append absUrl & [join $args &]
+	}
+	set queryArgs {}
+    } elseif {$validate} {
+        return -code error {cannot have both -validate (HEAD) and -query (POST)}
+    } else {
+	set queryArgs [list -query [join $args &]]
+    }
+
+    if {[catch {
+        ::http::geturl     $absUrl        \
+                -validate  $validate      \
+                -timeout   5000           \
+                {*}$queryArgs             \
+                -keepalive $keepAlive     \
+                -command   ::httpTestScript::WhenFinished
+    } token]} {
+        set msg $token
+        catch {puts stderr "Error: $msg"}
+        return
+    } else {
+        # Request will begin.
+    }
+
+    return
+
+}
+
+proc httpTestScript::TimeOutNow {} {
+    variable TimeOutDone
+
+    set TimeOutDone 1
+    set ::httpTestScript::FOREVER 0
+    return
+}
+
+proc httpTestScript::WhenFinished {hToken} {
+    variable CountFinishedSoFar
+    variable RequestsWhenStopped
+    variable TimeOutCode
+    variable StopDone
+    variable RequestList
+    variable RequestsMade
+    variable ActualKeepAlive
+
+    upvar #0 $hToken state
+
+    if {[catch {
+	if {    [info exists state(transfer)]
+	     && ($state(transfer) eq "chunked")
+	} {
+	    set Trans chunked
+	} else {
+	    set Trans unchunked
+	}
+
+	if {    [info exists ::httpTest::testOptions(-verbose)]
+	     && ($::httpTest::testOptions(-verbose) > 0)
+	} {
+	    puts "Token    $hToken
+Response $state(http)
+Status   $state(status)
+Method   $state(method)
+Transfer $Trans
+Size     $state(currentsize)
+URL      $state(url)
+"
+	}
+
+	if {!$state(-keepalive)} {
+	    set ActualKeepAlive 0
+	}
+
+	if {[info exists state(method)]} {
+	    lappend RequestsMade $state(method)
+	} else {
+	    lappend RequestsMade UNKNOWN
+	}
+	set tk [namespace tail $hToken]
+
+	if {    ($state(http) != {HTTP/1.1 200 OK})
+	     || ($state(status) != {ok})
+	     || (($state(currentsize) == 0) && ($state(method) ne "HEAD"))
+	} {
+	    ::http::Log ^X$tk unexpected result Response $state(http) Status $state(status) Size $state(currentsize) - token $hToken
+	}
+    } err]} {
+	::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken
+    }
+
+    incr CountFinishedSoFar
+    if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} {
+        if {[info exists TimeOutCode]} {
+            after cancel $TimeOutCode
+        }
+        if {$RequestsMade ne $RequestList && $ActualKeepAlive} {
+	    ::http::Log ^X$tk unexpected result - Script asked for "{$RequestList}" but got "{$RequestsMade}" - token $hToken
+        }
+        set ::httpTestScript::FOREVER 0
+    }
+
+    return
+}
+
+
+proc httpTestScript::runHttpTestScript {scr} {
+    variable TimeOutDone
+    variable RequestsWhenStopped
+
+    after idle [list namespace eval ::httpTestScript $scr]
+    vwait ::httpTestScript::FOREVER
+    # N.B. does not automatically execute in this namespace, unlike some other events.
+    # Release when all requests have been served or have timed out.
+
+    if {$TimeOutDone} {
+        return -code error {test script timed out}
+    }
+
+    return $RequestsWhenStopped
+}
+
+
+proc httpTestScript::cleanupHttpTestScript {} {
+    variable TimeOutDone
+    variable RequestsWhenStopped
+    
+    if {![info exists RequestsWhenStopped]} {
+	return -code error {Cleanup Failed: RequestsWhenStopped is undefined}
+    }
+
+    for {set i 1} {$i <= $RequestsWhenStopped} {incr i} {
+        http::cleanup ::http::$i
+    }
+
+    return
+}
-- 
cgit v0.12


From a0e1b18138fb42f0dee9353735aa7938a1c19951 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Thu, 29 Mar 2018 18:20:56 +0000
Subject: Adapt tests/httpPipeline.test for test without installation.  Comment
 out some Log calls from tests/httpTestScript.tcl

---
 tests/httpPipeline.test  | 4 ++--
 tests/httpTestScript.tcl | 6 +++---
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
index 017661d..33462c05 100644
--- a/tests/httpPipeline.test
+++ b/tests/httpPipeline.test
@@ -809,10 +809,10 @@ for {set header 1} {$header <= 4} {incr header} {
 	    # Here's the test:
             test http11-${header}.${footer}${label}-${tag} $name -constraints $cons \
             -setup [string map [list TE $te] {
-                http::init
-                set http::http(uid) 0
 		# Restore default values for tests:
 		http::config -pipeline 1 -postfresh 0 -repost 1
+                http::init
+                set http::http(uid) 0
 		SetTestEof {TE}
 	    }] -body [list RunTest $header $footer $delay $te] -cleanup {
 		# Restore default values for tests:
diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl
index a826c81..048cb4f 100644
--- a/tests/httpTestScript.tcl
+++ b/tests/httpTestScript.tcl
@@ -253,7 +253,7 @@ proc httpTestScript::PIPELINE {b} {
     }
 
     ::http::config -pipeline $b
-    ::http::Log http(-pipeline) is now [::http::config -pipeline]
+    ##::http::Log http(-pipeline) is now [::http::config -pipeline]
     return
 }
 
@@ -273,7 +273,7 @@ proc httpTestScript::POSTFRESH {b} {
     }
 
     ::http::config -postfresh $b
-    ::http::Log http(-postfresh) is now [::http::config -postfresh]
+    ##::http::Log http(-postfresh) is now [::http::config -postfresh]
     return
 }
 
@@ -293,7 +293,7 @@ proc httpTestScript::REPOST {b} {
     }
 
     ::http::config -repost $b
-    ::http::Log http(-repost) is now [::http::config -repost]
+    ##::http::Log http(-repost) is now [::http::config -repost]
     return
 }
 
-- 
cgit v0.12


From 3117af219fe5b0c4374266fd7f781223f3036eb9 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Fri, 30 Mar 2018 10:02:44 +0000
Subject: Bugfixes.  Details in ticket 46b6edad51.

---
 library/http/http.tcl   | 372 +++++++++++++++++++++++++++++++-----------------
 tests/httpPipeline.test |   3 +-
 2 files changed, 241 insertions(+), 134 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index f4f83c6..a268e87 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -72,14 +72,20 @@ namespace eval http {
 	variable socketClosing
 	variable socketPlayCmd
 	if {[info exists socketMapping]} {
-	    # Close open sockets on re-init
+	    # Close open sockets on re-init.  Do not permit retries.
 	    foreach {url sock} [array get socketMapping] {
-		catch {close $sock}
+		unset -nocomplain socketClosing($url)
+		unset -nocomplain socketPlayCmd($url)
+		CloseSocket $sock
 	    }
 	}
 
-	# Traces on "unset socketRdState(*)" will cancel any queued responses.
-	# Traces on "unset socketWrState(*)" will cancel any queued requests.
+	# CloseSocket should have unset the socket* arrays, one element at
+	# a time.  Now unset anything that was overlooked.
+	# Traces on "unset socketRdState(*)" will call CancelReadPipeline and
+	# cancel any queued responses.
+	# Traces on "unset socketWrState(*)" will call CancelWritePipeline and
+	# cancel any queued requests.
 	array unset socketMapping
 	array unset socketRdState
 	array unset socketWrState
@@ -123,11 +129,12 @@ namespace eval http {
     }
 
     namespace export geturl config reset wait formatQuery register unregister
-    # Useful, but not exported: data size status code cleanup error meta ncode
-    # Also mapReply.
+    # Useful, but not exported: data size status code cleanup error meta ncode,
+    # mapReply, init.  Comments suggest that "init" can be used for
+    # re-initialisation, although it is undocumented.
     #
     # Not exported, probably should be upper-case initial letter as part
-    # of the internals: init getTextLine make-transformation-chunked
+    # of the internals: getTextLine make-transformation-chunked
 }
 
 # http::Log --
@@ -264,6 +271,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     }
     if {[info exists state(after)]} {
 	after cancel $state(after)
+	unset state(after)
     }
     if {[info exists state(-command)] && (!$skipCB)
 	    && (![info exists state(done-command-cb)])} {
@@ -291,6 +299,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 #	queued task if possible.  Otherwise leave it idle and ready for its next
 #	use.
 #
+#	If $socketClosing(*), then ($state(connection) eq "close") and therefore
+#	this command will not be called by Finish.
+#
 # Arguments:
 #	token	    Connection token.
 
@@ -473,6 +484,8 @@ proc http::KeepSocket {token} {
 
     } else {
 	CloseSocket $state(sock) $token
+	# There is no socketMapping($state(socketinfo)), so it does not matter
+	# that CloseQueuedQueries is not called.
     }
     return
 }
@@ -551,7 +564,7 @@ proc http::CloseSocket {s {token {}}} {
 	if {$token eq {}} {
 	    # Cases with a non-empty token are handled by Finish, so the tokens
 	    # are finished in connection order.
-	    http::CloseQueuedQueries $connId $token
+	    http::CloseQueuedQueries $connId
 	} else {
 	}
     } else {
@@ -597,15 +610,46 @@ proc http::CloseQueuedQueries {connId {token {}}} {
     if {    [info exists socketPlayCmd($connId)]
 	 && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}})
     } {
+	# Before unsetting, there is some unfinished business.
+	# - If the server sent "Connection: close", we have stored the command
+	#   for retrying any queued requests in socketPlayCmd, so copy that
+	#   value for execution below.  socketClosing(*) was also set.
+	# - 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".
 	set unfinished $socketPlayCmd($connId)
+	set socketRdQueue($connId) {}
+	set socketWrQueue($connId) {}
     } else {
 	set unfinished {}
     }
 
-    # The trace on "unset socketRdState(*)" cancels any pipelined
-    # responses.
-    # The trace on "unset socketWrState(*)" cancels any pipelined
-    # requests.
+    Unset $connId
+
+    if {$unfinished ne {}} {
+	Log ^R$tk Any unfinished transactions (excluding $token) failed \
+		- token $token
+	{*}$unfinished
+    }
+    return
+}
+
+# http::Unset
+#
+#	The trace on "unset socketRdState(*)" will call CancelReadPipeline
+#	and cancel any queued responses.
+#	The trace on "unset socketWrState(*)" will call CancelWritePipeline
+#	and cancel any queued requests.
+
+proc http::Unset {connId} {
+    variable socketMapping
+    variable socketRdState
+    variable socketWrState
+    variable socketRdQueue
+    variable socketWrQueue
+    variable socketClosing
+    variable socketPlayCmd
+
     unset socketMapping($connId)
     unset socketRdState($connId)
     unset socketWrState($connId)
@@ -614,11 +658,6 @@ proc http::CloseQueuedQueries {connId {token {}}} {
     unset -nocomplain socketClosing($connId)
     unset -nocomplain socketPlayCmd($connId)
 
-    if {$unfinished ne {}} {
-	Log ^R$tk Any unfinished transactions (excluding $token) failed \
-		- token $token
-	{*}$unfinished
-    }
     return
 }
 
@@ -977,45 +1016,39 @@ proc http::geturl {url args} {
 	    # - We leave this binding in place until just before the last
 	    #   puts+flush in http::Connected (GET/HEAD) or http::Write (POST),
 	    #   after which the HTTP response might be generated.
-	    # - Therefore we must be prepared for full closure of the socket,
-	    #   and catch errors on any socket operation.
-
-	    if {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
-		Log "WARNING: socket for $state(socketinfo) was closed\
-			- token $token"
 
-		# The trace on "unset socketRdState(*)" cancels any pipelined
-		# responses.
-		# The trace on "`(*)" cancels any pipelined
-		# requests.
-		unset socketMapping($state(socketinfo))
-		unset socketRdState($state(socketinfo))
-		unset socketWrState($state(socketinfo))
-		unset -nocomplain socketRdQueue($state(socketinfo))
-		unset -nocomplain socketWrQueue($state(socketinfo))
-		unset -nocomplain socketClosing($state(socketinfo))
-		unset -nocomplain socketPlayCmd($state(socketinfo))
-
-		# Do not automatically close the eventual connection socket.
-		set state(connection) {}
-	    } elseif {    [info exists socketClosing($state(socketinfo))]
+	    if {    [info exists socketClosing($state(socketinfo))]
 		       && $socketClosing($state(socketinfo))
 	    } {
-		# The server has sent a "Connection: close" header.
+		# socketClosing(*) is set because the server has sent a
+		# "Connection: close" header.
 		# Do not use the persistent socket again.
 		# Since we have only one persistent socket per server, and the
 		# old socket is not yet dead, add the request to the write queue
 		# of the dying socket, which will be replayed by ReplayIfClose.
+		# Also add it to socketWrQueue(*) which is used only if an error
+		# causes a call to Finish.
 		set reusing 1
 		set sock $socketMapping($state(socketinfo))
 		Log "reusing socket $sock for $state(socketinfo) - token $token"
 
-		# Do not automatically close this connection socket.
-		set state(connection) {}
 		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
+	    } elseif {[catch {fconfigure $socketMapping($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.
+		Log "WARNING: socket for $state(socketinfo) was closed\
+			- token $token"
+		Log "WARNING - if testing, pay special attention to this\
+			case (GH) which is seldom executed - token $token"
+
+		# This will call CancelReadPipeline, CancelWritePipeline, and
+		# cancel any queued requests, responses.
+		Unset $state(socketinfo)
 	    } else {
 		# Use the persistent socket.
 		# The socket may not be ready to write: an earlier request might
@@ -1026,9 +1059,9 @@ proc http::geturl {url args} {
 		set sock $socketMapping($state(socketinfo))
 		Log "reusing socket $sock for $state(socketinfo) - token $token"
 
-		# Do not automatically close this connection socket.
-		set state(connection) {}
 	    }
+	    # Do not automatically close the connection socket.
+	    set state(connection) {}
 	}
     }
 
@@ -1073,8 +1106,8 @@ proc http::geturl {url args} {
 	    # callback (if available) because we're going to throw an
 	    # exception from here instead.
 
-	    set state(sock) $sock
-	    Finish $token "" 1
+	    set state(sock) NONE
+	    Finish $token $sock 1
 	    cleanup $token
 	    return -code error $sock
 	} else {
@@ -1093,6 +1126,18 @@ proc http::geturl {url args} {
     } {
 	# Freshly-opened socket that we would like to become persistent.
 	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 access to $token in geturl
 	    # Also grant premature read access to the socket. This is OK.
@@ -1108,16 +1153,10 @@ proc http::geturl {url args} {
 	    set socketWrState($state(socketinfo)) $token
 	}
 
-	if {![info exists socketRdQueue($state(socketinfo))]} {
-	    set socketRdQueue($state(socketinfo)) {}
-	    set varName ::http::socketRdState($state(socketinfo))
-	    trace add variable $varName unset ::http::CancelReadPipeline
-	}
-	if {![info exists socketWrQueue($state(socketinfo))]} {
-	    set socketWrQueue($state(socketinfo)) {}
-	    set varName ::http::socketWrState($state(socketinfo))
-	    trace add variable $varName unset ::http::CancelWritePipeline
-	}
+	set socketRdQueue($state(socketinfo)) {}
+	set socketWrQueue($state(socketinfo)) {}
+	set socketClosing($state(socketinfo)) 0
+	set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
     }
 
     if {![info exists phost]} {
@@ -1447,6 +1486,8 @@ proc http::Connected {token proto phost srvurl} {
     } err]} {
 	# The socket probably was never connected, or the connection dropped
 	# later.
+	Log "WARNING - if testing, pay special attention to this\
+		case (GI) which is seldom executed - token $token"
 	if {[info exists state(reusing)] && $state(reusing)} {
 	    # The socket was closed at the server end, and closed at
 	    # this end by http::CheckEof.
@@ -1477,6 +1518,9 @@ proc http::Connected {token proto phost srvurl} {
 #
 #	Command called when a request has been sent.  It will arrange the
 #	next request and/or response as appropriate.
+#
+#	If this command is called when $socketClosing(*), the request $token
+#	that calls it must be pipelined and destined to fail.
 
 proc http::DoneRequest {token} {
     variable http
@@ -1533,6 +1577,11 @@ proc http::DoneRequest {token} {
     } {
 	# Do not read from the socket until it is ready.
 	##Log "HTTP response for token $token is queued for pipelined use"
+	# If $socketClosing(*), then the caller will be a pipelined write and
+	# execution will come here.
+	# This token has already been recorded as "in flight" for writing.
+	# When the socket is closed, the read queue will be cleared in
+	# CloseQueuedQueries and so the "lappend" here has no effect.
 	lappend socketRdQueue($state(socketinfo)) $token
     } else {
 	# In the pipelined case, connection for reading depends on the
@@ -1575,12 +1624,18 @@ proc http::NextPipelinedWrite {token} {
     variable socketRdState
     variable socketWrState
     variable socketWrQueue
-
+    variable socketClosing
     variable $token
     upvar 0 $token state
     set connId $state(socketinfo)
 
-    if {    $state(-pipeline)
+    if {    [info exists socketClosing($connId)]
+	 && $socketClosing($connId)
+    } {
+	# socketClosing(*) is set because the server has sent a
+	# "Connection: close" header.
+	# Behave as if the queues are empty - so do nothing.
+    } elseif {    $state(-pipeline)
 	 && [info exists socketWrState($connId)]
 	 && ($socketWrState($connId) eq "Wready")
 
@@ -1663,11 +1718,13 @@ proc http::NextPipelinedWrite {token} {
 #
 #	Cancel pipelined responses on a closing "Keep-Alive" socket.
 #
-#	- Called by a trace when the variable ::http::socketRdState($connId) is
-#	  unset (the trace itself is automatically removed).
+#	- Called by a variable trace on "unset socketRdState($connId)".
 #	- The variable relates to a Keep-Alive socket, which has been closed.
 #	- Cancels all pipelined responses. The requests have been sent,
 #	  the responses have not yet been received.
+#	- This is a hard cancel that ends each transaction with error status,
+#	  and closes the connection. Do not use it if you want to replay failed
+#	  transactions.
 #	- N.B. Always delete ::http::socketRdState($connId) before deleting
 #	  ::http::socketRdQueue($connId), or this command will do nothing.
 #
@@ -1676,10 +1733,9 @@ proc http::NextPipelinedWrite {token} {
 
 proc http::CancelReadPipeline {name1 connId op} {
     variable socketRdQueue
-
     ##Log CancelReadPipeline $name1 $connId $op
     if {[info exists socketRdQueue($connId)]} {
-	set msg {the connection was Closed}
+	set msg {the connection was closed by CancelReadPipeline}
 	foreach token $socketRdQueue($connId) {
 	    set tk [namespace tail $token]
 	    Log ^X$tk end of response "($msg)" - token $token
@@ -1695,12 +1751,13 @@ proc http::CancelReadPipeline {name1 connId op} {
 #
 #	Cancel queued events on a closing "Keep-Alive" socket.
 #
-#	- Called by a trace when the variable ::http::socketWrState($connId) is
-#	  unset (the trace itself is automatically removed).
+#	- Called by a variable trace on "unset socketWrState($connId)".
 #	- The variable relates to a Keep-Alive socket, which has been closed.
 #	- In pipelined or nonpipeline case: cancels all queued requests.  The
-#	  requests have not yet been sent, the responses are not due and have
-#	  no data to cancel.
+#	  requests have not yet been sent, the responses are not due.
+#	- This is a hard cancel that ends each transaction with error status,
+#	  and closes the connection. Do not use it if you want to replay failed
+#	  transactions.
 #	- N.B. Always delete ::http::socketWrState($connId) before deleting
 #	  ::http::socketWrQueue($connId), or this command will do nothing.
 #
@@ -1712,7 +1769,7 @@ proc http::CancelWritePipeline {name1 connId op} {
 
     ##Log CancelWritePipeline $name1 $connId $op
     if {[info exists socketWrQueue($connId)]} {
-	set msg {the connection was Closed}
+	set msg {the connection was closed by CancelWritePipeline}
 	foreach token $socketWrQueue($connId) {
 	    set tk [namespace tail $token]
 	    Log ^X$tk end of response "($msg)" - token $token
@@ -1844,30 +1901,20 @@ proc http::ReplayIfDead {tokenArg doing} {
 
 
     # 2. Tidy up tokenArg.  This is a cut-down form of Finish/CloseSocket.
-    #    CloseSocket cancels file events, closes the socket, and unsets the
-    #    socketMapping.
-    #    Finish calls CloseSocket, if called as below.
-    #    Don't want Eot.
     #    Do not change state(status).
-    #    Want to not unset socketWrState(*).
+    #    No need to after cancel stateArg(after) - either this is done in
+    #    ReplayCore/ReInit, or Finish is called.
 
-    if {[info exists stateArg(after)]} {
-	after cancel $stateArg(after)
-    }
     catch {close $stateArg(sock)}
 
-    # The relevant element of socketMapping, socketRdState, socketWrState,
-    # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set to
-    # new values in ReplayCore.
-    # The trace on "unset socketRdState(*)" cancels any pipelined responses.
-    # It also clears socketRdQueue(*).
-    # Transactions, if any, that are awaiting responses cannot be completed.
-    # They are listed for re-sending in newQueue.
-    # There is no need to unset socketWrState - the write queue transactions
-    # have not yet been sent, nor the state(-timeout) events.
-    # All tokens are preserved for re-use by ReplayCore.
-
-    unset socketRdState($stateArg(socketinfo))
+    # 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit.
+    # - Transactions, if any, that are awaiting responses cannot be completed.
+    #   They are listed for re-sending in newQueue.
+    # - All tokens are preserved for re-use by ReplayCore, and their variables
+    #   will be re-initialised by calls to ReInit.
+    # - The relevant element of socketMapping, socketRdState, socketWrState,
+    #   socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set
+    #   to new values in ReplayCore.
 
     ReplayCore $newQueue
     return
@@ -1913,6 +1960,72 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
     return
 }
 
+# http::ReInit --
+#
+#	Command to restore a token's state to a condition that
+#	makes it ready to replay a request.
+#
+#	Command http::geturl stores extra state in state(tmp*) so
+#	we don't need to do the argument processing again.
+#
+#	The caller must:
+#	- Set state(reusing) and state(sock) to their new values after calling
+#	  this command.
+#	- Unset state(tmpState), state(tmpOpenCmd) if future calls to ReplayCore
+#	  or ReInit are inappropriate for this token. Typically only one retry
+#	  is allowed.
+#	The caller may also unset state(tmpConnArgs) if this value (and the
+#	token) will be used immediately.  The value is needed by tokens that
+#	will be stored in a queue.
+#
+# Arguments:
+#	token	Connection token.
+#
+# Return Value: (boolean) true iff the re-initialisation was successful.
+
+proc http::ReInit {token} {
+    variable $token
+    upvar 0 $token state
+
+    if {!(
+	      [info exists state(tmpState)]
+	   && [info exists state(tmpOpenCmd)]
+	   && [info exists state(tmpConnArgs)]
+	 )
+    } {
+	Log FAILED in http::ReInit via ReplayCore - NO tmp vars for $token
+	return 0
+    }
+
+    if {[info exists state(after)]} {
+	after cancel $state(after)
+	unset state(after)
+    }
+
+    # Don't alter state(status) - this would trigger http::wait if it is in use.
+    set tmpState    $state(tmpState)
+    set tmpOpenCmd  $state(tmpOpenCmd)
+    set tmpConnArgs $state(tmpConnArgs)
+    foreach name [array names state] {
+	if {$name ne "status"} {
+	    unset state($name)
+	}
+    }
+
+    # Don't alter state(status).
+    # Restore state(tmp*) - the caller may decide to unset them.
+    # Restore state(tmpConnArgs) which is needed for connection.
+    # state(tmpState), state(tmpOpenCmd) are needed only for retries.
+
+    dict unset tmpState status
+    array set state $tmpState
+    set state(tmpState)    $tmpState
+    set state(tmpOpenCmd)  $tmpOpenCmd
+    set state(tmpConnArgs) $tmpConnArgs
+
+    return 1
+}
+
 # http::ReplayCore --
 #
 #	Command to replay a list of requests, using existing connection tokens.
@@ -1951,30 +2064,19 @@ proc http::ReplayCore {newQueue} {
     variable $token
     upvar 0 $token state
 
-    if {!(
-	      [info exists state(tmpState)]
-	   && [info exists state(tmpOpenCmd)]
-	   && [info exists state(tmpConnArgs)]
-	 )
-    } {
+    if {![ReInit $token]} {
 	Log FAILED in http::ReplayCore - NO tmp vars
-	Finish $token error 1
+	Finish $token {cannot send this request again}
 	return
     }
 
-    # Don't alter state(status) - this would trigger http::wait if it is in use.
     set tmpState    $state(tmpState)
     set tmpOpenCmd  $state(tmpOpenCmd)
     set tmpConnArgs $state(tmpConnArgs)
-    foreach name [array names state] {
-	if {$name ne "status"} {
-	    unset state($name)
-	}
-    }
+    unset state(tmpState)
+    unset state(tmpOpenCmd)
+    unset state(tmpConnArgs)
 
-    # Don't alter state(status).
-    dict unset tmpState status
-    array set state $tmpState
     set state(reusing) 0
 
     if {$state(-timeout) > 0} {
@@ -1985,15 +2087,28 @@ proc http::ReplayCore {newQueue} {
     # 4. Open a socket.
     if {[catch {eval $tmpOpenCmd} sock]} {
 	# Something went wrong while trying to establish the connection.
-	Log FAILED - $tmpOpenCmd
-	set state(sock) $sock
-	Finish $token error 1
+	Log FAILED - $sock
+	set state(sock) NONE
+	Finish $token $sock
 	return
     }
 
     # 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
@@ -2004,26 +2119,22 @@ proc http::ReplayCore {newQueue} {
 	    set socketWrState($state(socketinfo)) $token
 	}
 
-	if {![info exists socketRdQueue($state(socketinfo))]} {
-	    set socketRdQueue($state(socketinfo)) {}
-	    set varName ::http::socketRdState($state(socketinfo))
-	    trace add variable $varName unset ::http::CancelReadPipeline
-	}
 	set socketRdQueue($state(socketinfo)) {}
-
-	if {![info exists socketWrQueue($state(socketinfo))]} {
-	    set socketWrQueue($state(socketinfo)) {}
-	    set varName ::http::socketWrState($state(socketinfo))
-	    trace add variable $varName unset ::http::CancelWritePipeline
-	}
 	set socketWrQueue($state(socketinfo)) $newQueue
 	set socketClosing($state(socketinfo)) 0
-	set socketPlayCmd($state(socketinfo)) {}
+	set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
     }
 
     # 6. Configure sockets in the queue.
     foreach tok $newQueue {
-	set ${tok}(sock) $sock
+	if {[ReInit $tok]} {
+	    set ${tok}(reusing) 1
+	    set ${tok}(sock) $sock
+	} else {
+	    set ${tok}(reusing) 1
+	    set ${tok}(sock) NONE
+	    Finish $token {cannot send this request again}
+	}
     }
 
     # 7. Configure the socket for newToken to send a request.
@@ -2131,6 +2242,8 @@ proc http::Connect {token proto phost srvurl} {
 	[eof $state(sock)] ||
 	[set err [fconfigure $state(sock) -error]] ne ""
     } {
+	Log "WARNING - if testing, pay special attention to this\
+		case (GJ) which is seldom executed - token $token"
 	if {[info exists state(reusing)] && $state(reusing)} {
 	    # The socket was closed at the server end, and closed at
 	    # this end by http::CheckEof.
@@ -2309,6 +2422,8 @@ proc http::Event {sock token} {
 	}
 
 	if {[catch {gets $sock state(http)} nsl]} {
+	    Log "WARNING - if testing, pay special attention to this\
+		    case (GK) which is seldom executed - token $token"
 	    if {[info exists state(reusing)] && $state(reusing)} {
 		# The socket was closed at the server end, and closed at
 		# this end by http::CheckEof.
@@ -2418,27 +2533,18 @@ proc http::Event {sock token} {
 			    $socketRdQueue($state(socketinfo)) \
 			    $socketWrQueue($state(socketinfo))]
 
-		    # See discussion below.
+		    # - All tokens are preserved for re-use by ReplayCore.
+		    # - Queues are preserved in case of Finish with error, but
+		    #   are not used for anything else because socketClosing(*)
+		    #   is set below.
+		    # - Cancel the state(after) timeout events.
 		    foreach tokenElement $socketRdQueue($state(socketinfo)) {
 			if {[info exists ${tokenElement}(after)]} {
 			    after cancel [set ${tokenElement}(after)]
+			    unset ${tokenElement}(after)
 			}
 		    }
 
-		    # - Clear the queues.  By doing this here, the code for
-		    #   connecting the next token to the socket needs no
-		    #   modification.
-		    # - Do not unset socketRdState and socketWrState and trigger
-		    #   their traces, because this will close the socket, which
-		    #   is still needed for the current read.
-		    # - The only other thing that the traces would have done is
-		    #   cancel the state(after) timeout events.  This is now
-		    #   done above.
-		    # - All tokens are preserved for re-use by ReplayCore.
-
-		    set socketRdQueue($state(socketinfo)) {}
-		    set socketWrQueue($state(socketinfo)) {}
-
 		} else {
 		    set socketPlayCmd($state(socketinfo)) \
 			    {ReplayIfClose Wready {} {}}
diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
index 33462c05..cab36b2 100644
--- a/tests/httpPipeline.test
+++ b/tests/httpPipeline.test
@@ -807,7 +807,8 @@ for {set header 1} {$header <= 4} {incr header} {
 
 
 	    # Here's the test:
-            test http11-${header}.${footer}${label}-${tag} $name -constraints $cons \
+            test httpPipeline-${header}.${footer}${label}-${tag} $name \
+            -constraints $cons \
             -setup [string map [list TE $te] {
 		# Restore default values for tests:
 		http::config -pipeline 1 -postfresh 0 -repost 1
-- 
cgit v0.12


From 441e4f6796e1e3cecba7872500d68d0ebbf3a943 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Fri, 30 Mar 2018 10:13:57 +0000
Subject: For thorough testing, set test file to verbose, and uncomment Log
 calls in http.tcl.

---
 library/http/http.tcl   | 108 ++++++++++++++++++++++++------------------------
 tests/httpPipeline.test |   2 +-
 2 files changed, 55 insertions(+), 55 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index a268e87..ac51370 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -355,7 +355,7 @@ proc http::KeepSocket {token} {
 	    upvar 0 $token3 state3
 	    set tk2 [namespace tail $token3]
 
-	    #Log pipelined, GRANT read access to $token3 in KeepSocket
+	    Log #Log pipelined, GRANT read access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    lassign [fconfigure $state3(sock) -translation] trRead trWrite
 	    fconfigure $state3(sock) -translation [list auto $trWrite] \
@@ -363,7 +363,7 @@ proc http::KeepSocket {token} {
 	    Log ^D$tk2 begin receiving response - token $token3
 	    fileevent $state3(sock) readable \
 		    [list http::Event $state3(sock) $token3]
-	    #Log ---- $state3(sock) >> conn to $token3 for HTTP response (a)
+	    Log #Log ---- $state3(sock) >> conn to $token3 for HTTP response (a)
 
 	    # Other pipelined cases.
 	    # - The test above ensures that, for the pipelined cases in the two
@@ -400,13 +400,13 @@ proc http::KeepSocket {token} {
 	    #   give that request read and write access.
 	    variable $token3
 	    set conn [set ${token3}(tmpConnArgs)]
-	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
 	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	    # Connect does its own fconfigure.
 	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
-	    #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+	    Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
 
 	} elseif {
 		$state(-pipeline)
@@ -445,13 +445,13 @@ proc http::KeepSocket {token} {
 	    #   case with a queued request.
 	    variable $token3
 	    set conn [set ${token3}(tmpConnArgs)]
-	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
 	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	    # Connect does its own fconfigure.
 	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
-	    #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+	    Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
 
 	} elseif {
 		(!$state(-pipeline))
@@ -467,13 +467,13 @@ proc http::KeepSocket {token} {
 	    set token3 [lindex $socketWrQueue($connId) 0]
 	    variable $token3
 	    set conn [set ${token3}(tmpConnArgs)]
-	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
 	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	    # Connect does its own fconfigure.
 	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
-	    #Log ---- $state(sock) << conn to $token3 for HTTP request (d)
+	    Log #Log ---- $state(sock) << conn to $token3 for HTTP request (d)
 
 	} elseif {(!$state(-pipeline))} {
 	    set socketWrState($connId) Wready
@@ -713,7 +713,7 @@ proc http::geturl {url args} {
 	set http(uid) 0
     }
     set token [namespace current]::[incr http(uid)]
-    ##Log Starting http::geturl - token $token
+    Log ##Log Starting http::geturl - token $token
     variable $token
     upvar 0 $token state
     set tk [namespace tail $token]
@@ -1139,7 +1139,7 @@ proc http::geturl {url args} {
 	}
 
 	if {$state(-pipeline)} {
-	    #Log new, init for pipelined, GRANT write access to $token in geturl
+	    Log #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
@@ -1148,7 +1148,7 @@ proc http::geturl {url args} {
 	    # 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
+	    Log #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
 	    set socketRdState($state(socketinfo)) $token
 	    set socketWrState($state(socketinfo)) $token
 	}
@@ -1193,13 +1193,13 @@ proc http::geturl {url args} {
 	# subsequent calls on this socket will come here because the socket
 	# will close after the current read, and its
 	# socketClosing($connId) is 1.
-	##Log "HTTP request for token $token is queued"
+	Log ##Log "HTTP request for token $token is queued"
 
     } elseif {    $reusing
 	       && $state(-pipeline)
 	       && ($socketWrState($state(socketinfo)) ne "Wready")
     } {
-	##Log "HTTP request for token $token is queued for pipelined use"
+	Log ##Log "HTTP request for token $token is queued for pipelined use"
 	lappend socketWrQueue($state(socketinfo)) $token
 
     } elseif {    $reusing
@@ -1207,7 +1207,7 @@ proc http::geturl {url args} {
 	       && ($socketWrState($state(socketinfo)) ne "Wready")
     } {
 	# A write is queued or in progress.  Lappend to the write queue.
-	##Log "HTTP request for token $token is queued for nonpipeline use"
+	Log ##Log "HTTP request for token $token is queued for nonpipeline use"
 	lappend socketWrQueue($state(socketinfo)) $token
 
     } elseif {    $reusing
@@ -1218,20 +1218,20 @@ proc http::geturl {url args} {
 	# A read is queued or in progress, but not a write.  Cannot start the
 	# nonpipeline transaction, but must set socketWrState to prevent a
 	# 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
+	Log ##Log "HTTP request for token $token is queued for nonpipeline use"
+	Log #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
+	    Log #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
+	    Log #Log re-use nonpipeline, GRANT r/w access to $token in geturl
 	    set socketRdState($state(socketinfo)) $token
 	    set socketWrState($state(socketinfo)) $token
 
@@ -1241,7 +1241,7 @@ proc http::geturl {url args} {
 
 	# All (!$reusing) cases come here, and also some $reusing cases if the
 	# connection is ready.
-	#Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
+	Log #Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
 	# Connect does its own fconfigure.
 	fileevent $sock writable \
 		[list http::Connect $token $proto $phost $srvurl]
@@ -1268,7 +1268,7 @@ proc http::geturl {url args} {
 	    return -code error $err
 	}
     }
-    ##Log Leaving http::geturl - token $token
+    Log ##Log Leaving http::geturl - token $token
     return $token
 }
 
@@ -1566,7 +1566,7 @@ proc http::DoneRequest {token} {
 	 && [info exists socketRdState($state(socketinfo))]
 	 && ($socketRdState($state(socketinfo)) eq "Rready")
     } {
-	#Log pipelined, GRANT read access to $token in Connected
+	Log #Log pipelined, GRANT read access to $token in Connected
 	set socketRdState($state(socketinfo)) $token
     }
 
@@ -1576,7 +1576,7 @@ proc http::DoneRequest {token} {
 	 && ($socketRdState($state(socketinfo)) ne $token)
     } {
 	# Do not read from the socket until it is ready.
-	##Log "HTTP response for token $token is queued for pipelined use"
+	Log ##Log "HTTP response for token $token is queued for pipelined use"
 	# If $socketClosing(*), then the caller will be a pipelined write and
 	# execution will come here.
 	# This token has already been recorded as "in flight" for writing.
@@ -1587,7 +1587,7 @@ proc http::DoneRequest {token} {
 	# In the pipelined case, connection for reading depends on the
 	# value of socketRdState.
 	# In the nonpipeline case, connection for reading always occurs.
-	#Log ---- $state(socketinfo) >> conn to $token for HTTP response (b)
+	Log #Log ---- $state(socketinfo) >> conn to $token for HTTP response (b)
 	lassign [fconfigure $sock -translation] trRead trWrite
 	fconfigure $sock -translation [list auto $trWrite] \
 			 -buffersize $state(-blocksize)
@@ -1647,13 +1647,13 @@ 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
+	Log #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite
 	set conn [set ${token2}(tmpConnArgs)]
 	set socketWrState($connId) $token2
 	set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	# Connect does its own fconfigure.
 	fileevent $state(sock) writable [list http::Connect $token2 {*}$conn]
-	#Log ---- $connId << conn to $token2 for HTTP request (b)
+	Log #Log ---- $connId << conn to $token2 for HTTP request (b)
 
 	# In the tests below, the next request will be nonpipeline.
     } elseif {    $state(-pipeline)
@@ -1676,13 +1676,13 @@ proc http::NextPipelinedWrite {token} {
 	variable $token3
 	upvar 0 $token3 state3
 	set conn [set ${token3}(tmpConnArgs)]
-	#Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
+	Log #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
 	set socketRdState($connId) $token3
 	set socketWrState($connId) $token3
 	set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	# Connect does its own fconfigure.
 	fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
-	#Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+	Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
 
     } elseif {    $state(-pipeline)
 	 && [info exists socketWrState($connId)]
@@ -1704,7 +1704,7 @@ proc http::NextPipelinedWrite {token} {
 	#   of the connection to $token2 will be done elsewhere - by command
 	#   http::KeepSocket when $socketRdState($connId) is set to "Rready".
 
-	#Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
+	Log #Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
 	set socketWrState($connId) peNding
 
     } else {
@@ -1733,7 +1733,7 @@ proc http::NextPipelinedWrite {token} {
 
 proc http::CancelReadPipeline {name1 connId op} {
     variable socketRdQueue
-    ##Log CancelReadPipeline $name1 $connId $op
+    Log ##Log CancelReadPipeline $name1 $connId $op
     if {[info exists socketRdQueue($connId)]} {
 	set msg {the connection was closed by CancelReadPipeline}
 	foreach token $socketRdQueue($connId) {
@@ -1767,7 +1767,7 @@ proc http::CancelReadPipeline {name1 connId op} {
 proc http::CancelWritePipeline {name1 connId op} {
     variable socketWrQueue
 
-    ##Log CancelWritePipeline $name1 $connId $op
+    Log ##Log CancelWritePipeline $name1 $connId $op
     if {[info exists socketWrQueue($connId)]} {
 	set msg {the connection was closed by CancelWritePipeline}
 	foreach token $socketWrQueue($connId) {
@@ -2053,7 +2053,7 @@ proc http::ReplayCore {newQueue} {
 	return
     }
 
-    ##Log running ReplayCore for {*}$newQueue
+    Log ##Log running ReplayCore for {*}$newQueue
     set newToken [lindex $newQueue 0]
     set newQueue [lrange $newQueue 1 end]
 
@@ -2110,11 +2110,11 @@ proc http::ReplayCore {newQueue} {
 	}
 
 	if {$state(-pipeline)} {
-	    #Log new, init for pipelined, GRANT write acc to $token ReplayCore
+	    Log #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
+	    Log #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore
 	    set socketRdState($state(socketinfo)) $token
 	    set socketWrState($state(socketinfo)) $token
 	}
@@ -2147,7 +2147,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)
+    Log #Log ---- $sock << conn to $token for HTTP request (e)
     return
 }
 
@@ -2396,7 +2396,7 @@ proc http::Event {sock token} {
     upvar 0 $token state
     set tk [namespace tail $token]
 
-    ##Log Event call - token $token
+    Log ##Log Event call - token $token
 
     if {![info exists state]} {
 	Log "Event $sock with invalid token '$token' - remote close?"
@@ -2411,7 +2411,7 @@ proc http::Event {sock token} {
 	return
     }
     if {$state(state) eq "connecting"} {
-	##Log - connecting - token $token
+	Log ##Log - connecting - token $token
 	if {    $state(reusing)
 	     && $state(-pipeline)
 	     && ($state(-timeout) > 0)
@@ -2443,7 +2443,7 @@ proc http::Event {sock token} {
 		return
 	    }
 	} elseif {$nsl >= 0} {
-	    ##Log - connecting 1 - token $token
+	    Log ##Log - connecting 1 - token $token
 	    set state(state) "header"
 	} elseif {    [eof $sock]
 		   && [info exists state(reusing)]
@@ -2463,18 +2463,18 @@ proc http::Event {sock token} {
 	    # If any other requests are in flight or pipelined/queued, they will
 	    # be discarded.
 	} else {
-	    ##Log - connecting 2 - token $token
+	    Log ##Log - connecting 2 - token $token
 	    # nsl is -1 so either fblocked (OK) or (eof and not reusing).
 	    # Continue. Any eof is processed at the end of this proc.
 	}
     } elseif {$state(state) eq "header"} {
 	if {[catch {gets $sock line} nhl]} {
-	    ##Log header failed - token $token
+	    Log ##Log header failed - token $token
 	    Log ^X$tk end of response (error) - token $token
 	    Finish $token $nhl
 	    return
 	} elseif {$nhl == 0} {
-	    ##Log header done - token $token
+	    Log ##Log header done - token $token
 	    Log ^E$tk end of response headers - token $token
 	    # We have now read all headers
 	    # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
@@ -2513,7 +2513,7 @@ proc http::Event {sock token} {
 	    } {
 		# The server warns that it will close the socket after this
 		# response.
-		##Log WARNING - socket will close after response for $token
+		Log ##Log WARNING - socket will close after response for $token
 		# Prepare data for a call to ReplayIfClose.
 		if {    ($socketRdQueue($state(socketinfo)) ne {})
 		     || ($socketWrQueue($state(socketinfo)) ne {})
@@ -2525,7 +2525,7 @@ proc http::Event {sock token} {
 			set InFlightW Wready
 		    } else {
 			set msg "token ${InFlightW} is InFlightW"
-			##Log $msg - token $token
+			Log ##Log $msg - token $token
 		    }
 
 		    set socketPlayCmd($state(socketinfo)) \
@@ -2617,7 +2617,7 @@ proc http::Event {sock token} {
 	    }
 	} elseif {$nhl > 0} {
 	    # Process header lines.
-	    ##Log header - token $token - $line
+	    Log ##Log header - token $token - $line
 	    if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 		switch -- [string tolower $key] {
 		    content-type {
@@ -2653,11 +2653,11 @@ proc http::Event {sock token} {
 	}
     } else {
 	# Now reading body
-	##Log body - token $token
+	Log ##Log body - token $token
 	if {[catch {
 	    if {[info exists state(-handler)]} {
 		set n [eval $state(-handler) [list $sock $token]]
-		##Log handler $n - token $token
+		Log ##Log handler $n - token $token
 		# N.B. the protocol has been set to 1.0 because the -handler
 		# logic is not expected to handle chunked encoding.
 		# FIXME allow -handler with 1.1 on dechunked stacked channel.
@@ -2710,14 +2710,14 @@ proc http::Event {sock token} {
 	    } elseif {    [info exists state(transfer)]
 		       && ($state(transfer) eq "chunked")
 	    } {
-		##Log chunked - token $token
+		Log ##Log chunked - token $token
 		set size 0
 		set hexLenChunk [getTextLine $sock]
 		#set ntl [string length $hexLenChunk]
 		if {[string trim $hexLenChunk] ne ""} {
 		    scan $hexLenChunk %x size
 		    if {$size != 0} {
-			##Log chunk-measure $size - token $token
+			Log ##Log chunk-measure $size - token $token
 			set bl [fconfigure $sock -blocking]
 			fconfigure $sock -blocking 1
 			set chunk [read $sock $size]
@@ -2726,7 +2726,7 @@ proc http::Event {sock token} {
 			if {$n >= 0} {
 			    append state(body) $chunk
 			    incr state(log_size) [string length $chunk]
-			    ##Log chunk $n cumul $state(log_size) - token $token
+			    Log ##Log chunk $n cumul $state(log_size) - token $token
 			}
 			if {$size != [string length $chunk]} {
 			    Log "WARNING: mis-sized chunk:\
@@ -2748,14 +2748,14 @@ proc http::Event {sock token} {
 		    }
 		} else {
 		    # Line expected to hold chunk length is empty.
-		    ##Log bad-chunk-measure - token $token
+		    Log ##Log bad-chunk-measure - token $token
 		    set n 0
 		    set state(connection) close
 		    Log ^X$tk end of response (chunk error) - token $token
 		    Eot $token {error in chunked encoding - fetch terminated}
 		}
 	    } else {
-		##Log unchunked - token $token
+		Log ##Log unchunked - token $token
 		if {$state(totalsize) == 0} {
 		    # We know the transfer is complete only when the server
 		    # closes the connection.
@@ -2775,12 +2775,12 @@ proc http::Event {sock token} {
 		}
 		set c $state(currentsize)
 		set t $state(totalsize)
-		##Log non-chunk currentsize $c of totalsize $t - token $token
+		Log ##Log non-chunk currentsize $c of totalsize $t - token $token
 		set block [read $sock $reqSize]
 		set n [string length $block]
 		if {$n >= 0} {
 		    append state(body) $block
-		    ##Log non-chunk [string length $state(body)] - token $token
+		    Log ##Log non-chunk [string length $state(body)] - token $token
 		}
 	    }
 	    # This calculation uses n from the -handler, chunked, or unchunked
@@ -2790,7 +2790,7 @@ proc http::Event {sock token} {
 		    incr state(currentsize) $n
 		    set c $state(currentsize)
 		    set t $state(totalsize)
-		    ##Log chunk $n currentsize $c totalsize $t - token $token
+		    Log ##Log chunk $n currentsize $c totalsize $t - token $token
 		}
 		# If Content-Length - check for end of data.
 		if {
@@ -2817,7 +2817,7 @@ 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 {![catch {eof $sock} eof] && $eof} {
-	##Log eof - token $token
+	Log ##Log eof - token $token
 	if {[info exists $token]} {
 	    set state(connection) close
 	    if {$state(state) eq "complete"} {
diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
index cab36b2..08eb076 100644
--- a/tests/httpPipeline.test
+++ b/tests/httpPipeline.test
@@ -641,7 +641,7 @@ proc RunTest {header footer delay te} {
 # If still obscure, uncomment #Log and ##Log lines in the http package.
 # ------------------------------------------------------------------------------
 
-set ::httpTest::testOptions(-verbose) 0
+set ::httpTest::testOptions(-verbose) 2
 
 
 # ------------------------------------------------------------------------------
-- 
cgit v0.12


From 466fd1d9304f60660938226a59e6ed8156a0d02e Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Sat, 31 Mar 2018 15:27:52 +0000
Subject: Chasing timeout bug: reduce client timeout to 4s in tests; more
 sanity checking in non-keep-alive tests; tidying; more logging in http.tcl.

---
 library/http/http.tcl    | 29 ++++++++++++++++--
 tests/httpPipeline.test  | 26 ++++++++++-------
 tests/httpTest.tcl       | 76 +++++++++++++++++++++++++++++++++++++++++++++++-
 tests/httpTestScript.tcl |  2 +-
 4 files changed, 119 insertions(+), 14 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index ac51370..49898db 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -1086,7 +1086,7 @@ proc http::geturl {url args} {
     # - 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
+    # - Event       - if (not reusing) and pipelined, send the next pipelined
     #                 write
 
     # See comments above re the start of this timeout in other cases.
@@ -1100,6 +1100,9 @@ proc http::geturl {url args} {
 	if {[info exists state(-myaddr)]} {
 	    lappend sockopts -myaddr $state(-myaddr)
 	}
+	set pre [clock milliseconds]
+	Log ##Log pre socket opened, - token $token
+	Log ##Log [concat $defcmd $sockopts $targetAddr] - token $token
 	if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
 	    # Something went wrong while trying to establish the connection.
 	    # Clean up after events and such, but DON'T call the command
@@ -1112,10 +1115,19 @@ proc http::geturl {url args} {
 	    return -code error $sock
 	} else {
 	    # Initialisation of a new socket.
+	    Log ##Log post socket opened, - token $token
+	    Log ##Log socket opened, now fconfigure - token $token
+	    set delay [expr {[clock milliseconds] - $pre}]
+	    if {$delay > 3000} {
+		Log ##Log socket delay $delay - token $token
+	    }
 	    fconfigure $sock -translation {auto crlf} \
 			     -buffersize $state(-blocksize)
+	    Log ##Log socket opened, DONE fconfigure - token $token
 	}
     }
+    # Command [socket] is called with -async, but occasionally takes seconds to return.
+    # It returns after 5s, and the request times out when this command returns.
 
     set state(sock) $sock
     Log "Using $sock for $state(socketinfo) - token $token" \
@@ -2084,6 +2096,9 @@ proc http::ReplayCore {newQueue} {
 	set state(after) [after $state(-timeout) $resetCmd]
     }
 
+    set pre [clock milliseconds]
+    Log ##Log pre socket opened, - token $token
+    Log ##Log $tmpOpenCmd - token $token
     # 4. Open a socket.
     if {[catch {eval $tmpOpenCmd} sock]} {
 	# Something went wrong while trying to establish the connection.
@@ -2092,6 +2107,13 @@ proc http::ReplayCore {newQueue} {
 	Finish $token $sock
 	return
     }
+    Log ##Log post socket opened, - token $token
+    set delay [expr {[clock milliseconds] - $pre}]
+    if {$delay > 3000} {
+	Log ##Log socket delay $delay - token $token
+    }
+    # Command [socket] is called with -async, but occasionally takes seconds to return.
+    # It returns after 5s, and the request times out when this command returns.
 
     # 5. Configure the persistent socket data.
     if {$state(-keepalive)} {
@@ -2125,6 +2147,7 @@ proc http::ReplayCore {newQueue} {
 	set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
     }
 
+    Log ##Log pre newQueue ReInit, - token $token
     # 6. Configure sockets in the queue.
     foreach tok $newQueue {
 	if {[ReInit $tok]} {
@@ -2143,7 +2166,9 @@ proc http::ReplayCore {newQueue} {
 	[expr {$state(-keepalive)?"keepalive":""}]
 
     # Initialisation of a new socket.
+    Log ##Log socket opened, now fconfigure - token $token
     fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
+    Log ##Log socket opened, DONE fconfigure - token $token
 
     # Connect does its own fconfigure.
     fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs]
@@ -2790,7 +2815,7 @@ proc http::Event {sock token} {
 		    incr state(currentsize) $n
 		    set c $state(currentsize)
 		    set t $state(totalsize)
-		    Log ##Log chunk $n currentsize $c totalsize $t - token $token
+		    Log ##Log another $n currentsize $c totalsize $t - token $token
 		}
 		# If Content-Length - check for end of data.
 		if {
diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
index 08eb076..4823d19 100644
--- a/tests/httpPipeline.test
+++ b/tests/httpPipeline.test
@@ -566,10 +566,14 @@ proc ReturnTestResult {ca cb delay te} {
 
 namespace import httpTestScript::runHttpTestScript
 namespace import httpTestScript::cleanupHttpTestScript
+namespace import httpTest::cleanupHttpTest
+namespace import httpTest::logAnalyse
+namespace import httpTest::setHttpTestOptions
 
 proc RunTest {header footer delay te} {
     set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]]
     set skipOverlaps 0
+    set notPiped    {}
     set notIncluded {}
 
     # --------------------------------------------------------------------------
@@ -578,23 +582,26 @@ proc RunTest {header footer delay te} {
     if {$header < 3} {
         set skipOverlaps 1
         for {set i 1} {$i <= $num} {incr i} {
-	    lappend notIncluded $i
+	    lappend notPiped $i
         }
     } elseif {$header > 2 && $footer == 18 && $te == 1} {
         set skipOverlaps 1
         if {$delay == 0} {
 	    # Transaction 1 is conventional.
 	    # Check that transactions 2,3,4 are cancelled.
-	    set notIncluded {1}
+	    set notPiped {1}
+	    set notIncluded $notPiped
         } else {
 	    # Transaction 1 is conventional.
 	    # Check that transaction 2 is cancelled.
 	    # The timing of transactions 3 and 4 is uncertain.
-	    set notIncluded {1 3 4}
+	    set notPiped {1 3 4}
+	    set notIncluded $notPiped
 	}
     } elseif {$footer in {20 22 23 24 25}} {
 	# Transaction 2 uses its own socket.
-	set notIncluded 2
+	set notPiped    2
+	set notIncluded $notPiped
     } else {
     }
     # --------------------------------------------------------------------------
@@ -602,7 +609,7 @@ proc RunTest {header footer delay te} {
     # --------------------------------------------------------------------------
 
 
-    set Results [httpTest::LogAnalyse $num $skipOverlaps $notIncluded $notIncluded]
+    set Results [logAnalyse $num $skipOverlaps $notIncluded $notPiped]
     lassign $Results msg cleanE cleanF dirtyE dirtyF
     if {$msg eq {}} {
         set msg "Passed all sanity checks."
@@ -641,8 +648,7 @@ proc RunTest {header footer delay te} {
 # If still obscure, uncomment #Log and ##Log lines in the http package.
 # ------------------------------------------------------------------------------
 
-set ::httpTest::testOptions(-verbose) 2
-
+setHttpTestOptions -verbose 2
 
 # ------------------------------------------------------------------------------
 # (4) Define the base URLs used for testing.  Each must have a query string.
@@ -724,10 +730,10 @@ proc SetTestEof {test} {
 
 for {set header 1} {$header <= 4} {incr header} {
     if {$header == 4} {
-	set ::httpTest::testOptions(-dotted) 1
+	setHttpTestOptions -dotted 1
 	set match glob
     } else {
-	set ::httpTest::testOptions(-dotted) 0
+	setHttpTestOptions -dotted 0
 	set match exact
     }
 
@@ -820,7 +826,7 @@ for {set header 1} {$header <= 4} {incr header} {
 		http::config -pipeline 1 -postfresh 0 -repost 1
 		cleanupHttpTestScript
 		SetTestEof 0
-		set ::httpTest::testResults {}
+		cleanupHttpTest
 		after 2000
 		# Wait for persistent sockets on the server to time out.
 	    } -result [ReturnTestResult $header $footer $delay $te] -match $match
diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl
index ad08048..38ba43f 100644
--- a/tests/httpTest.tcl
+++ b/tests/httpTest.tcl
@@ -25,6 +25,7 @@ package require http
 
 namespace eval ::http {
     variable TestStartTimeInMs [clock milliseconds]
+    catch {puts stderr "Start time (zero ms) is $TestStartTimeInMs"}
 }
 
 namespace eval ::httpTest {
@@ -297,6 +298,32 @@ proc httpTest::TestSequence {someResults n msg badTrans} {
     return $msg
 }
 
+#
+# Arguments:
+# someResults  - list of elements, each a list of a letter and a number
+# n            - (positive integer) the number of HTTP requests
+# msg          - accumulated warning messages
+# skipOverlaps - (boolean) whether to skip testing of transaction overlaps
+# badTrans     - list of transaction numbers not to be assessed as "clean" or
+#                "dirty" by their overlaps
+#   for 1/2 includes all transactions
+#   for 3/4 includes an increasing (with recursion) set that will not be included in the list because they are already handled.
+# notPiped     - subset of badTrans.  List of transaction numbers that cannot
+#                taint another transaction by overlapping with it, because it
+#                used a different socket.
+#
+# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF]
+# msg    - warning messages: nothing will be appended to argument $msg if there
+#          is no error with the test.
+# cleanE - list of transactions that have no overlap with other transactions
+#          (not considering response body)
+# dirtyE - list of transactions that have YES overlap with other transactions
+#          (not considering response body)
+# cleanF - list of transactions that have no overlap with other transactions
+#          (including response body)
+# dirtyF - list of transactions that have YES overlap with other transactions
+#          (including response body)
+
 proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} {
     variable testOptions
 
@@ -362,6 +389,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip
         set last  [lsearch -exact $beforeTry [list F $i]]
         if {$first == -1} {
 	    set res "Transaction $i was not started in connection number $tryCount"
+	    # So lappend it to badTrans and don't include it in the call below of MostAnalysis.
 	    # append msg $res \n
 	    Puts $res
 	    if {$i ni $badTrans} {
@@ -370,12 +398,16 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip
 	    }
         } elseif {$last == -1} {
 	    set res "Transaction $i was started but unfinished in connection number $tryCount"
+	    # So lappend it to badTrans and don't include it in the call below of MostAnalysis.
 	    # append msg $res \n
 	    Puts $res
 	    lappend badTrans $i
 	    lappend dummyTry [list A $i]
         } else {
 	    set res "Transaction $i was started and finished in connection number $tryCount"
+	    # So include it in the call below of MostAnalysis.
+	    # So lappend it to notIncluded and don't include it in the recursive call of
+	    # ProcessRetries which handles the later connections.
 	    # append msg $res \n
 	    Puts $res
 	    lappend notIncluded $i
@@ -398,7 +430,31 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip
     return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
 }
 
-proc httpTest::LogAnalyse {n skipOverlaps notIncluded notPiped} {
+# httpTest::logAnalyse --
+#
+#	The main command called to analyse logs for a single test.
+#
+# Arguments:
+# n            - (positive integer) the number of HTTP requests
+# skipOverlaps - (boolean) whether to skip testing of transaction overlaps
+# notIncluded  - list of transaction numbers not to be assessed as "clean" or
+#                "dirty" by their overlaps
+# notPiped     - subset of notIncluded.  List of transaction numbers that cannot
+#                taint another transaction by overlapping with it, because it
+#                used a different socket.
+#
+# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF]
+# msg    - warning messages: {} if there is no error with the test.
+# cleanE - list of transactions that have no overlap with other transactions
+#          (not considering response body)
+# dirtyE - list of transactions that have YES overlap with other transactions
+#          (not considering response body)
+# cleanF - list of transactions that have no overlap with other transactions
+#          (including response body)
+# dirtyF - list of transactions that have YES overlap with other transactions
+#          (including response body)
+
+proc httpTest::logAnalyse {n skipOverlaps notIncluded notPiped} {
     variable testResults
     variable testOptions
 
@@ -429,3 +485,21 @@ proc httpTest::LogAnalyse {n skipOverlaps notIncluded notPiped} {
     ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped
     # N.B. Implicit Return.
 }
+
+proc httpTest::cleanupHttpTest {} {
+    variable testResults
+    set testResults {}
+    return
+}
+
+proc httpTest::setHttpTestOptions {key args} {
+    variable testOptions
+    if {$key ni {-dotted -verbose}} {
+        return -code error {valid options are -dotted, -verbose}
+    }
+    set testOptions($key) {*}$args
+}
+
+namespace eval httpTest {
+    namespace export cleanupHttpTest logAnalyse setHttpTestOptions
+}
diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl
index 048cb4f..68b3474 100644
--- a/tests/httpTestScript.tcl
+++ b/tests/httpTestScript.tcl
@@ -383,7 +383,7 @@ proc httpTestScript::Requester {uriCode keepAlive validate query args} {
     if {[catch {
         ::http::geturl     $absUrl        \
                 -validate  $validate      \
-                -timeout   5000           \
+                -timeout   4000           \
                 {*}$queryArgs             \
                 -keepalive $keepAlive     \
                 -command   ::httpTestScript::WhenFinished
-- 
cgit v0.12


From 13571723674678c9c380ee2e6f2f5bc44777f58f Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Sun, 1 Apr 2018 01:09:57 +0000
Subject: Increase test timeout to 10s. Remove commenting from Log calls that
 report long delay for [socket].

---
 library/http/http.tcl    | 18 ++++++++++++------
 tests/httpTestScript.tcl |  2 +-
 2 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 49898db..83a4665 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -1119,15 +1119,18 @@ proc http::geturl {url args} {
 	    Log ##Log socket opened, now fconfigure - token $token
 	    set delay [expr {[clock milliseconds] - $pre}]
 	    if {$delay > 3000} {
-		Log ##Log socket delay $delay - token $token
+		Log socket delay $delay - token $token
 	    }
 	    fconfigure $sock -translation {auto crlf} \
 			     -buffersize $state(-blocksize)
 	    Log ##Log socket opened, DONE fconfigure - token $token
 	}
     }
-    # Command [socket] is called with -async, but occasionally takes seconds to return.
-    # It returns after 5s, and the request times out when this command returns.
+    # 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" \
@@ -2110,10 +2113,13 @@ proc http::ReplayCore {newQueue} {
     Log ##Log post socket opened, - token $token
     set delay [expr {[clock milliseconds] - $pre}]
     if {$delay > 3000} {
-	Log ##Log socket delay $delay - token $token
+	Log socket delay $delay - token $token
     }
-    # Command [socket] is called with -async, but occasionally takes seconds to return.
-    # It returns after 5s, and the request times out when this command returns.
+    # 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)} {
diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl
index 68b3474..4046c7a 100644
--- a/tests/httpTestScript.tcl
+++ b/tests/httpTestScript.tcl
@@ -383,7 +383,7 @@ proc httpTestScript::Requester {uriCode keepAlive validate query args} {
     if {[catch {
         ::http::geturl     $absUrl        \
                 -validate  $validate      \
-                -timeout   4000           \
+                -timeout   10000          \
                 {*}$queryArgs             \
                 -keepalive $keepAlive     \
                 -command   ::httpTestScript::WhenFinished
-- 
cgit v0.12


From 6a58a0cab24668a9c1feda011147c87f3ba34801 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Wed, 4 Apr 2018 12:00:03 +0000
Subject: Use coroutines to remove blocking on HTTP connections

---
 library/http/http.tcl | 874 +++++++++++++++++++++++++++-----------------------
 1 file changed, 466 insertions(+), 408 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 83a4665..77a2a43 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -255,6 +255,9 @@ 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 {  ($state(status) eq "timeout")
        || ($state(status) eq "error")
        || ($state(status) eq "eof")
@@ -357,13 +360,7 @@ proc http::KeepSocket {token} {
 
 	    Log #Log pipelined, GRANT read access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
-	    lassign [fconfigure $state3(sock) -translation] trRead trWrite
-	    fconfigure $state3(sock) -translation [list auto $trWrite] \
-				     -buffersize $state3(-blocksize)
-	    Log ^D$tk2 begin receiving response - token $token3
-	    fileevent $state3(sock) readable \
-		    [list http::Event $state3(sock) $token3]
-	    Log #Log ---- $state3(sock) >> conn to $token3 for HTTP response (a)
+	    ReceiveResponse $token3
 
 	    # Other pipelined cases.
 	    # - The test above ensures that, for the pipelined cases in the two
@@ -1602,16 +1599,32 @@ proc http::DoneRequest {token} {
 	# In the pipelined case, connection for reading depends on the
 	# value of socketRdState.
 	# In the nonpipeline case, connection for reading always occurs.
-	Log #Log ---- $state(socketinfo) >> conn to $token for HTTP response (b)
-	lassign [fconfigure $sock -translation] trRead trWrite
-	fconfigure $sock -translation [list auto $trWrite] \
-			 -buffersize $state(-blocksize)
-	Log ^D$tk begin receiving response - token $token
-	fileevent $sock readable [list http::Event $sock $token]
+	ReceiveResponse $token
     }
     return
 }
 
+# http::ReceiveResponse
+#
+#	Connects token to its socket for reading.
+
+proc http::ReceiveResponse {token} {
+    variable $token
+    upvar 0 $token state
+    set tk [namespace tail $token]
+    set sock $state(sock)
+
+    Log #Log ---- $state(socketinfo) >> conn to $token for HTTP response
+    lassign [fconfigure $sock -translation] trRead trWrite
+    fconfigure $sock -translation [list auto $trWrite] \
+		     -buffersize $state(-blocksize)
+    Log ^D$tk begin receiving response - token $token
+
+    coroutine ${token}EventCoroutine http::Event $sock $token
+    fileevent $sock readable ${token}EventCoroutine
+    return
+}
+
 # http::NextPipelinedWrite
 #
 # - Connecting a socket to a token for writing is done by this command and by
@@ -2247,6 +2260,9 @@ 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 exists state]} {
 	unset state
     }
@@ -2426,447 +2442,452 @@ proc http::Event {sock token} {
     variable $token
     upvar 0 $token state
     set tk [namespace tail $token]
+    while 1 {
+	yield
+	Log ##Log Event call - token $token
 
-    Log ##Log Event call - token $token
-
-    if {![info exists state]} {
-	Log "Event $sock with invalid token '$token' - remote close?"
-	if {![eof $sock]} {
-	    if {[set d [read $sock]] ne ""} {
-		Log "WARNING: additional data left on closed socket\
-			- token $token"
+	if {![info exists state]} {
+	    Log "Event $sock with invalid token '$token' - remote close?"
+	    if {![eof $sock]} {
+		if {[set d [read $sock]] ne ""} {
+		    Log "WARNING: additional data left on closed socket\
+			    - token $token"
+		}
 	    }
+	    Log ^X$tk end of response (token error) - token $token
+	    CloseSocket $sock
+	    return
 	}
-	Log ^X$tk end of response (token error) - token $token
-	CloseSocket $sock
-	return
-    }
-    if {$state(state) eq "connecting"} {
-	Log ##Log - connecting - token $token
-	if {    $state(reusing)
-	     && $state(-pipeline)
-	     && ($state(-timeout) > 0)
-	     && (![info exists state(after)])
-	} {
-	    set state(after) [after $state(-timeout) \
-		    [list http::reset $token timeout]]
-	}
+	if {$state(state) eq "connecting"} {
+	    Log ##Log - connecting - token $token
+	    if {    $state(reusing)
+		 && $state(-pipeline)
+		 && ($state(-timeout) > 0)
+		 && (![info exists state(after)])
+	    } {
+		set state(after) [after $state(-timeout) \
+			[list http::reset $token timeout]]
+	    }
+
+	    if {[catch {gets $sock state(http)} nsl]} {
+		Log "WARNING - if testing, pay special attention to this\
+			case (GK) which is seldom executed - token $token"
+		if {[info exists state(reusing)] && $state(reusing)} {
+		    # The socket was closed at the server end, and closed at
+		    # this end by http::CheckEof.
 
-	if {[catch {gets $sock state(http)} nsl]} {
-	    Log "WARNING - if testing, pay special attention to this\
-		    case (GK) which is seldom executed - token $token"
-	    if {[info exists state(reusing)] && $state(reusing)} {
-		# The socket was closed at the server end, and closed at
-		# this end by http::CheckEof.
+		    if {[TestForReplay $token read $nsl c]} {
+			return
+		    }
 
-		if {[TestForReplay $token read $nsl c]} {
+		    # else:
+		    # This is NOT a persistent socket that has been closed since its
+		    # last use.
+		    # If any other requests are in flight or pipelined/queued, they
+		    # will be discarded.
+		} else {
+		    Log ^X$tk end of response (error) - token $token
+		    Finish $token $nsl
+		    return
+		}
+	    } elseif {$nsl >= 0} {
+		Log ##Log - connecting 1 - token $token
+		set state(state) "header"
+	    } elseif {    [eof $sock]
+		       && [info exists state(reusing)]
+		       && $state(reusing)
+	    } {
+		# The socket was closed at the server end, and we didn't notice.
+		# This is the first read - where the closure is usually first
+		# detected.
+
+		if {[TestForReplay $token read {} d]} {
 		    return
 		}
 
 		# else:
 		# This is NOT a persistent socket that has been closed since its
 		# last use.
-		# If any other requests are in flight or pipelined/queued, they
-		# will be discarded.
+		# If any other requests are in flight or pipelined/queued, they will
+		# be discarded.
 	    } else {
-		Log ^X$tk end of response (error) - token $token
-		Finish $token $nsl
-		return
+		Log ##Log - connecting 2 - token $token
+		# nsl is -1 so either fblocked (OK) or (eof and not reusing).
+		# Continue. Any eof is processed at the end of this proc.
 	    }
-	} elseif {$nsl >= 0} {
-	    Log ##Log - connecting 1 - token $token
-	    set state(state) "header"
-	} elseif {    [eof $sock]
-		   && [info exists state(reusing)]
-		   && $state(reusing)
-	} {
-	    # The socket was closed at the server end, and we didn't notice.
-	    # This is the first read - where the closure is usually first
-	    # detected.
-
-	    if {[TestForReplay $token read {} d]} {
-		return
-	    }
-
-	    # else:
-	    # This is NOT a persistent socket that has been closed since its
-	    # last use.
-	    # If any other requests are in flight or pipelined/queued, they will
-	    # be discarded.
-	} else {
-	    Log ##Log - connecting 2 - token $token
-	    # nsl is -1 so either fblocked (OK) or (eof and not reusing).
-	    # Continue. Any eof is processed at the end of this proc.
-	}
-    } elseif {$state(state) eq "header"} {
-	if {[catch {gets $sock line} nhl]} {
-	    Log ##Log header failed - token $token
-	    Log ^X$tk end of response (error) - token $token
-	    Finish $token $nhl
-	    return
-	} elseif {$nhl == 0} {
-	    Log ##Log header done - token $token
-	    Log ^E$tk end of response headers - token $token
-	    # We have now read all headers
-	    # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
-	    if {    ($state(http) == "")
-		 || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)
-	    } {
-		set state(state) "connecting"
+	} elseif {$state(state) eq "header"} {
+	    if {[catch {gets $sock line} nhl]} {
+		Log ##Log header failed - token $token
+		Log ^X$tk end of response (error) - token $token
+		Finish $token $nhl
 		return
-	    }
+	    } elseif {$nhl == 0} {
+		Log ##Log header done - token $token
+		Log ^E$tk end of response headers - token $token
+		# We have now read all headers
+		# We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
+		if {    ($state(http) == "")
+		     || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)
+		} {
+		    set state(state) "connecting"
+		    continue
+		    # This was a "return" in the pre-coroutine code.
+		}
 
-	    if {    ([info exists state(connection)])
-		 && ([info exists socketMapping($state(socketinfo))])
-		 && ($state(connection) eq "keep-alive")
-		 && ($state(-keepalive))
-		 && (!$state(reusing))
-		 && ($state(-pipeline))
-	    } {
-		# Response headers received for first request on a persistent
-		# socket.  Now ready for pipelined writes (if any).
-		# Previous value is $token. It cannot be pending.
-		set socketWrState($state(socketinfo)) Wready
-		http::NextPipelinedWrite $token
-	    }
+		if {    ([info exists state(connection)])
+		     && ([info exists socketMapping($state(socketinfo))])
+		     && ($state(connection) eq "keep-alive")
+		     && ($state(-keepalive))
+		     && (!$state(reusing))
+		     && ($state(-pipeline))
+		} {
+		    # Response headers received for first request on a persistent
+		    # socket.  Now ready for pipelined writes (if any).
+		    # Previous value is $token. It cannot be pending.
+		    set socketWrState($state(socketinfo)) Wready
+		    http::NextPipelinedWrite $token
+		}
 
-	    # Once a "close" has been signaled, the client MUST NOT send any
-	    # more requests on that connection.
-	    #
-	    # If either the client or the server sends the "close" token in the
-	    # Connection header, that request becomes the last one for the
-	    # connection.
-
-	    if {    ([info exists state(connection)])
-		 && ([info exists socketMapping($state(socketinfo))])
-		 && ($state(connection) eq "close")
-		 && ($state(-keepalive))
-	    } {
-		# The server warns that it will close the socket after this
-		# response.
-		Log ##Log WARNING - socket will close after response for $token
-		# Prepare data for a call to ReplayIfClose.
-		if {    ($socketRdQueue($state(socketinfo)) ne {})
-		     || ($socketWrQueue($state(socketinfo)) ne {})
-		     || ($socketWrState($state(socketinfo)) ni
-						[list Wready peNding $token])
+		# Once a "close" has been signaled, the client MUST NOT send any
+		# more requests on that connection.
+		#
+		# If either the client or the server sends the "close" token in the
+		# Connection header, that request becomes the last one for the
+		# connection.
+
+		if {    ([info exists state(connection)])
+		     && ([info exists socketMapping($state(socketinfo))])
+		     && ($state(connection) eq "close")
+		     && ($state(-keepalive))
 		} {
-		    set InFlightW $socketWrState($state(socketinfo))
-		    if {$InFlightW in [list Wready peNding $token]} {
-			set InFlightW Wready
-		    } else {
-			set msg "token ${InFlightW} is InFlightW"
-			Log ##Log $msg - token $token
-		    }
+		    # The server warns that it will close the socket after this
+		    # response.
+		    Log ##Log WARNING - socket will close after response for $token
+		    # Prepare data for a call to ReplayIfClose.
+		    if {    ($socketRdQueue($state(socketinfo)) ne {})
+			 || ($socketWrQueue($state(socketinfo)) ne {})
+			 || ($socketWrState($state(socketinfo)) ni
+						[list Wready peNding $token])
+		    } {
+			set InFlightW $socketWrState($state(socketinfo))
+			if {$InFlightW in [list Wready peNding $token]} {
+			    set InFlightW Wready
+			} else {
+			    set msg "token ${InFlightW} is InFlightW"
+			    Log ##Log $msg - token $token
+			}
 
-		    set socketPlayCmd($state(socketinfo)) \
-			    [list ReplayIfClose $InFlightW \
-			    $socketRdQueue($state(socketinfo)) \
-			    $socketWrQueue($state(socketinfo))]
-
-		    # - All tokens are preserved for re-use by ReplayCore.
-		    # - Queues are preserved in case of Finish with error, but
-		    #   are not used for anything else because socketClosing(*)
-		    #   is set below.
-		    # - Cancel the state(after) timeout events.
-		    foreach tokenElement $socketRdQueue($state(socketinfo)) {
-			if {[info exists ${tokenElement}(after)]} {
-			    after cancel [set ${tokenElement}(after)]
-			    unset ${tokenElement}(after)
+			set socketPlayCmd($state(socketinfo)) \
+				[list ReplayIfClose $InFlightW \
+				$socketRdQueue($state(socketinfo)) \
+				$socketWrQueue($state(socketinfo))]
+
+			# - All tokens are preserved for re-use by ReplayCore.
+			# - Queues are preserved in case of Finish with error, but
+			#   are not used for anything else because socketClosing(*)
+			#   is set below.
+			# - Cancel the state(after) timeout events.
+			foreach tokenElement $socketRdQueue($state(socketinfo)) {
+			    if {[info exists ${tokenElement}(after)]} {
+				after cancel [set ${tokenElement}(after)]
+				unset ${tokenElement}(after)
+			    }
 			}
+
+		    } else {
+			set socketPlayCmd($state(socketinfo)) \
+				{ReplayIfClose Wready {} {}}
 		    }
 
-		} else {
-		    set socketPlayCmd($state(socketinfo)) \
-			    {ReplayIfClose Wready {} {}}
+		    # Do not allow further connections on this socket.
+		    set socketClosing($state(socketinfo)) 1
 		}
 
-		# Do not allow further connections on this socket.
-		set socketClosing($state(socketinfo)) 1
-	    }
-
-	    set state(state) body
+		set state(state) body
 
-	    # If doing a HEAD, then we won't get any body
-	    if {$state(-validate)} {
-		Log ^F$tk end of response for HEAD request - token $token
-		set state(state) complete
-		Eot $token
-		return
-	    }
+		# If doing a HEAD, then we won't get any body
+		if {$state(-validate)} {
+		    Log ^F$tk end of response for HEAD request - token $token
+		    set state(state) complete
+		    Eot $token
+		    return
+		}
 
-	    # - For non-chunked transfer we may have no body - in this case we
-	    #   may get no further file event if the connection doesn't close
-	    #   and no more data is sent. We can tell and must finish up now -
-	    #   not later - the alternative would be to wait until the server
-	    #   times out.
-	    # - In this case, the server has NOT told the client it will close
-	    #   the connection, AND it has NOT indicated the resource length
-	    #   EITHER by setting the Content-Length (totalsize) OR by using
-	    #   chunked Transer-Encoding.
-	    # - Do not worry here about the case (Connection: close) because
-	    #   the server should close the connection.
-	    # - IF (NOT Connection: close) AND (NOT chunked encoding) AND
-	    #      (totalsize == 0).
-
-	    if {    (!(    [info exists state(connection)]
-			&& ($state(connection) eq "close")
-		      )
-		    )
-		 && (![info exists state(transfer)])
-		 && ($state(totalsize) == 0)
-	    } {
-		set msg {body size is 0 and no events likely - complete}
-		Log "$msg - token $token"
-		set msg {(length unknown, set to 0)}
-		Log ^F$tk end of response body {*}$msg - token $token
-		set state(state) complete
-		Eot $token
-		return
-	    }
+		# - For non-chunked transfer we may have no body - in this case we
+		#   may get no further file event if the connection doesn't close
+		#   and no more data is sent. We can tell and must finish up now -
+		#   not later - the alternative would be to wait until the server
+		#   times out.
+		# - In this case, the server has NOT told the client it will close
+		#   the connection, AND it has NOT indicated the resource length
+		#   EITHER by setting the Content-Length (totalsize) OR by using
+		#   chunked Transer-Encoding.
+		# - Do not worry here about the case (Connection: close) because
+		#   the server should close the connection.
+		# - IF (NOT Connection: close) AND (NOT chunked encoding) AND
+		#      (totalsize == 0).
+
+		if {    (!(    [info exists state(connection)]
+			    && ($state(connection) eq "close")
+			  )
+			)
+		     && (![info exists state(transfer)])
+		     && ($state(totalsize) == 0)
+		} {
+		    set msg {body size is 0 and no events likely - complete}
+		    Log "$msg - token $token"
+		    set msg {(length unknown, set to 0)}
+		    Log ^F$tk end of response body {*}$msg - token $token
+		    set state(state) complete
+		    Eot $token
+		    return
+		}
 
-	    # We have to use binary translation to count bytes properly.
-	    lassign [fconfigure $sock -translation] trRead trWrite
-	    fconfigure $sock -translation [list binary $trWrite]
+		# We have to use binary translation to count bytes properly.
+		lassign [fconfigure $sock -translation] trRead trWrite
+		fconfigure $sock -translation [list binary $trWrite]
 
-	    if {
-		$state(-binary) || [IsBinaryContentType $state(type)]
-	    } {
-		# Turn off conversions for non-text data.
-		set state(binary) 1
-	    }
-	    if {[info exists state(-channel)]} {
-		if {$state(binary) || [llength [ContentEncoding $token]]} {
-		    fconfigure $state(-channel) -translation binary
-		}
-		if {![info exists state(-handler)]} {
-		    # Initiate a sequence of background fcopies.
-		    fileevent $sock readable {}
-		    CopyStart $sock $token
-		    return
+		if {
+		    $state(-binary) || [IsBinaryContentType $state(type)]
+		} {
+		    # Turn off conversions for non-text data.
+		    set state(binary) 1
 		}
-	    }
-	} elseif {$nhl > 0} {
-	    # Process header lines.
-	    Log ##Log header - token $token - $line
-	    if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
-		switch -- [string tolower $key] {
-		    content-type {
-			set state(type) [string trim [string tolower $value]]
-			# Grab the optional charset information.
-			if {[regexp -nocase \
-				 {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \
-				 $state(type) -> cs]} {
-			    set state(charset) [string map {{\"} \"} $cs]
-			} else {
-			    regexp -nocase {charset\s*=\s*(\S+?);?} \
-				$state(type) -> state(charset)
-			}
+		if {[info exists state(-channel)]} {
+		    if {$state(binary) || [llength [ContentEncoding $token]]} {
+			fconfigure $state(-channel) -translation binary
 		    }
-		    content-length {
-			set state(totalsize) [string trim $value]
+		    if {![info exists state(-handler)]} {
+			# Initiate a sequence of background fcopies.
+			fileevent $sock readable {}
+			rename ${token}EventCoroutine {}
+			CopyStart $sock $token
+			return
 		    }
-		    content-encoding {
-			set state(coding) [string trim $value]
-		    }
-		    transfer-encoding {
-			set state(transfer) \
-			    [string trim [string tolower $value]]
-		    }
-		    proxy-connection -
-		    connection {
-			set state(connection) \
-			    [string trim [string tolower $value]]
+		}
+	    } elseif {$nhl > 0} {
+		# Process header lines.
+		Log ##Log header - token $token - $line
+		if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
+		    switch -- [string tolower $key] {
+			content-type {
+			    set state(type) [string trim [string tolower $value]]
+			    # Grab the optional charset information.
+			    if {[regexp -nocase \
+				    {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \
+				    $state(type) -> cs]} {
+				set state(charset) [string map {{\"} \"} $cs]
+			    } else {
+				regexp -nocase {charset\s*=\s*(\S+?);?} \
+					$state(type) -> state(charset)
+			    }
+			}
+			content-length {
+			    set state(totalsize) [string trim $value]
+			}
+			content-encoding {
+			    set state(coding) [string trim $value]
+			}
+			transfer-encoding {
+			    set state(transfer) \
+				    [string trim [string tolower $value]]
+			}
+			proxy-connection -
+			connection {
+			    set state(connection) \
+				    [string trim [string tolower $value]]
+			}
 		    }
+		    lappend state(meta) $key [string trim $value]
 		}
-		lappend state(meta) $key [string trim $value]
 	    }
-	}
-    } else {
-	# Now reading body
-	Log ##Log body - token $token
-	if {[catch {
-	    if {[info exists state(-handler)]} {
-		set n [eval $state(-handler) [list $sock $token]]
-		Log ##Log handler $n - token $token
-		# N.B. the protocol has been set to 1.0 because the -handler
-		# logic is not expected to handle chunked encoding.
-		# FIXME allow -handler with 1.1 on dechunked stacked channel.
-		if {$state(totalsize) == 0} {
-		    # We know the transfer is complete only when the server
-		    # closes the connection - i.e. eof is not an error.
-		    set state(state) complete
-		}
-		if {![string is integer -strict $n]} {
-		    if 1 {
-			# Do not tolerate bad -handler - fail with error status.
-			set msg {the -handler command for http::geturl must\
-				return an integer (the number of bytes read)}
-			Log ^X$tk end of response (handler error) - token $token
-			Eot $token $msg
-		    } else {
-			# Tolerate the bad -handler, and continue.  The penalty:
-			# (a) Because the handler returns nonsense, we know the
-			#     transfer is complete only when the server closes
-			#     the connection - i.e. eof is not an error.
-			# (b) http::size will not be accurate.
-			# (c) The transaction is already downgraded to 1.0 to
-			#     avoid chunked transfer encoding.  It MUST also be
-			#     forced to "Connection: close" or the HTTP/1.0
-			#     equivalent; or it MUST fail (as above) if the
-			#     server sends "Connection: keep-alive" or the
-			#     HTTP/1.0 equivalent.
-			set n 0
+	} else {
+	    # Now reading body
+	    Log ##Log body - token $token
+	    if {[catch {
+		if {[info exists state(-handler)]} {
+		    set n [eval $state(-handler) [list $sock $token]]
+		    Log ##Log handler $n - token $token
+		    # N.B. the protocol has been set to 1.0 because the -handler
+		    # logic is not expected to handle chunked encoding.
+		    # FIXME allow -handler with 1.1 on dechunked stacked channel.
+		    if {$state(totalsize) == 0} {
+			# We know the transfer is complete only when the server
+			# closes the connection - i.e. eof is not an error.
 			set state(state) complete
 		    }
-		} else {
-		}
-	    } elseif {[info exists state(transfer_final)]} {
-		set line [getTextLine $sock]
-		set n [string length $line]
-		set state(state) complete
-		if {$n > 0} {
-		    # - HTTP trailers (late response headers) are permitted by
-		    #   Chunked Transfer-Encoding, and can be safely ignored.
-		    # - Do not count these bytes in the total received for the
-		    #   response body.
-		    Log "trailer of $n bytes after final chunk - token $token"
-		    append state(transfer_final) $line
-		    set n 0
-		} else {
-		    Log ^F$tk end of response body (chunked) - token $token
-		    Log "final chunk part - token $token"
-		    Eot $token
-		}
-	    } elseif {    [info exists state(transfer)]
-		       && ($state(transfer) eq "chunked")
-	    } {
-		Log ##Log chunked - token $token
-		set size 0
-		set hexLenChunk [getTextLine $sock]
-		#set ntl [string length $hexLenChunk]
-		if {[string trim $hexLenChunk] ne ""} {
-		    scan $hexLenChunk %x size
-		    if {$size != 0} {
-			Log ##Log chunk-measure $size - token $token
-			set bl [fconfigure $sock -blocking]
-			fconfigure $sock -blocking 1
-			set chunk [read $sock $size]
-			fconfigure $sock -blocking $bl
-			set n [string length $chunk]
-			if {$n >= 0} {
-			    append state(body) $chunk
-			    incr state(log_size) [string length $chunk]
-			    Log ##Log chunk $n cumul $state(log_size) - token $token
+		    if {![string is integer -strict $n]} {
+			if 1 {
+			    # Do not tolerate bad -handler - fail with error status.
+			    set msg {the -handler command for http::geturl must\
+				    return an integer (the number of bytes read)}
+			    Log ^X$tk end of response (handler error) - token $token
+			    Eot $token $msg
+			} else {
+			    # Tolerate the bad -handler, and continue.  The penalty:
+			    # (a) Because the handler returns nonsense, we know the
+			    #     transfer is complete only when the server closes
+			    #     the connection - i.e. eof is not an error.
+			    # (b) http::size will not be accurate.
+			    # (c) The transaction is already downgraded to 1.0 to
+			    #     avoid chunked transfer encoding.  It MUST also be
+			    #     forced to "Connection: close" or the HTTP/1.0
+			    #     equivalent; or it MUST fail (as above) if the
+			    #     server sends "Connection: keep-alive" or the
+			    #     HTTP/1.0 equivalent.
+			    set n 0
+			    set state(state) complete
 			}
-			if {$size != [string length $chunk]} {
-			    Log "WARNING: mis-sized chunk:\
-				was [string length $chunk], should be $size -\
-				token $token"
+		    } else {
+		    }
+		} elseif {[info exists state(transfer_final)]} {
+		    set line [getTextLine $sock]
+		    set n [string length $line]
+		    set state(state) complete
+		    if {$n > 0} {
+			# - HTTP trailers (late response headers) are permitted by
+			#   Chunked Transfer-Encoding, and can be safely ignored.
+			# - Do not count these bytes in the total received for the
+			#   response body.
+			Log "trailer of $n bytes after final chunk - token $token"
+			append state(transfer_final) $line
+			set n 0
+		    } else {
+			Log ^F$tk end of response body (chunked) - token $token
+			Log "final chunk part - token $token"
+			Eot $token
+		    }
+		} elseif {    [info exists state(transfer)]
+			   && ($state(transfer) eq "chunked")
+		} {
+		    Log ##Log chunked - token $token
+		    set size 0
+		    set hexLenChunk [getTextLine $sock]
+		    #set ntl [string length $hexLenChunk]
+		    if {[string trim $hexLenChunk] ne ""} {
+			scan $hexLenChunk %x size
+			if {$size != 0} {
+			    Log ##Log chunk-measure $size - token $token
+			    set chunk [BlockingRead $sock $size]
+			    set n [string length $chunk]
+			    if {$n >= 0} {
+				append state(body) $chunk
+				incr state(log_size) [string length $chunk]
+				Log ##Log chunk $n cumul $state(log_size) - token $token
+			    }
+			    if {$size != [string length $chunk]} {
+				Log "WARNING: mis-sized chunk:\
+				    was [string length $chunk], should be $size -\
+				    token $token"
+				set n 0
+				set state(connection) close
+				Log ^X$tk end of response (chunk error) \
+					- token $token
+				set msg {error in chunked encoding - fetch\
+					terminated}
+				Eot $token $msg
+			    }
+			    # CRLF that follows chunk:
+			    getTextLine $sock
+			} else {
 			    set n 0
-			    set state(connection) close
-			    Log ^X$tk end of response (chunk error) \
-				    - token $token
-			    set msg {error in chunked encoding - fetch\
-				    terminated}
-			    Eot $token $msg
+			    set state(transfer_final) {}
 			}
-			# CRLF that follows chunk:
-			getTextLine $sock
 		    } else {
+			# Line expected to hold chunk length is empty.
+			Log ##Log bad-chunk-measure - token $token
 			set n 0
-			set state(transfer_final) {}
+			set state(connection) close
+			Log ^X$tk end of response (chunk error) - token $token
+			Eot $token {error in chunked encoding - fetch terminated}
 		    }
 		} else {
-		    # Line expected to hold chunk length is empty.
-		    Log ##Log bad-chunk-measure - token $token
-		    set n 0
-		    set state(connection) close
-		    Log ^X$tk end of response (chunk error) - token $token
-		    Eot $token {error in chunked encoding - fetch terminated}
-		}
-	    } else {
-		Log ##Log unchunked - token $token
-		if {$state(totalsize) == 0} {
-		    # We know the transfer is complete only when the server
-		    # closes the connection.
-		    set state(state) complete
-		    set reqSize $state(-blocksize)
-		} else {
-		    # Ask for the whole of the unserved response-body.
-		    # This works around a problem with a tls::socket - for https
-		    # in keep-alive mode, and a request for $state(-blocksize)
-		    # bytes, the last part of the resource does not get read
-		    # until the server times out.
-		    set reqSize [expr {$state(totalsize) - $state(currentsize)}]
-
-		    # The workaround fails if reqSize is
-		    # capped at $state(-blocksize).
-		    # set reqSize [expr {min($reqSize, $state(-blocksize))}]
-		}
-		set c $state(currentsize)
-		set t $state(totalsize)
-		Log ##Log non-chunk currentsize $c of totalsize $t - token $token
-		set block [read $sock $reqSize]
-		set n [string length $block]
-		if {$n >= 0} {
-		    append state(body) $block
-		    Log ##Log non-chunk [string length $state(body)] - token $token
-		}
-	    }
-	    # This calculation uses n from the -handler, chunked, or unchunked
-	    # case as appropriate.
-	    if {[info exists state]} {
-		if {$n >= 0} {
-		    incr state(currentsize) $n
+		    Log ##Log unchunked - token $token
+		    if {$state(totalsize) == 0} {
+			# We know the transfer is complete only when the server
+			# closes the connection.
+			set state(state) complete
+			set reqSize $state(-blocksize)
+		    } else {
+			# Ask for the whole of the unserved response-body.
+			# This works around a problem with a tls::socket - for https
+			# in keep-alive mode, and a request for $state(-blocksize)
+			# bytes, the last part of the resource does not get read
+			# until the server times out.
+			set reqSize [expr {$state(totalsize) - $state(currentsize)}]
+
+			# The workaround fails if reqSize is
+			# capped at $state(-blocksize).
+			# set reqSize [expr {min($reqSize, $state(-blocksize))}]
+		    }
 		    set c $state(currentsize)
 		    set t $state(totalsize)
-		    Log ##Log another $n currentsize $c totalsize $t - token $token
+		    Log ##Log non-chunk currentsize $c of totalsize $t - token $token
+		    set block [read $sock $reqSize]
+		    set n [string length $block]
+		    if {$n >= 0} {
+			append state(body) $block
+			Log ##Log non-chunk [string length $state(body)] - token $token
+		    }
 		}
-		# If Content-Length - check for end of data.
-		if {
-		    ($state(totalsize) > 0)
-		    && ($state(currentsize) >= $state(totalsize))
-		} {
-		    Log ^F$tk end of response body (unchunked) - token $token
-		    set state(state) complete
-		    Eot $token
+		# This calculation uses n from the -handler, chunked, or unchunked
+		# case as appropriate.
+		if {[info exists state]} {
+		    if {$n >= 0} {
+			incr state(currentsize) $n
+			set c $state(currentsize)
+			set t $state(totalsize)
+			Log ##Log another $n currentsize $c totalsize $t - token $token
+		    }
+		    # If Content-Length - check for end of data.
+		    if {
+			   ($state(totalsize) > 0)
+			&& ($state(currentsize) >= $state(totalsize))
+		    } {
+			Log ^F$tk end of response body (unchunked) - token $token
+			set state(state) complete
+			Eot $token
+		    }
+		}
+	    } err]} {
+		Log ^X$tk end of response (error ${err}) - token $token
+		Finish $token $err
+		return
+	    } else {
+		if {[info exists state(-progress)]} {
+		    eval $state(-progress) \
+			[list $token $state(totalsize) $state(currentsize)]
 		}
-	    }
-	} err]} {
-	    Log ^X$tk end of response (error ${err}) - token $token
-	    Finish $token $err
-	    return
-	} else {
-	    if {[info exists state(-progress)]} {
-		eval $state(-progress) \
-		    [list $token $state(totalsize) $state(currentsize)]
 	    }
 	}
-    }
 
-    # catch as an Eot above may have closed the socket already
-    # $state(state) may be connecting, header, body, or complete
-    if {![catch {eof $sock} eof] && $eof} {
-	Log ##Log eof - token $token
-	if {[info exists $token]} {
-	    set state(connection) close
-	    if {$state(state) eq "complete"} {
-		# This includes all cases in which the transaction
-		# can be completed by eof.
-		# The value "complete" is set only in http::Event, and it is
-		# used only in the test above.
-		Log ^F$tk end of response body (unchunked, eof) - token $token
-		Eot $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} {
+	    Log ##Log eof - token $token
+	    if {[info exists $token]} {
+		set state(connection) close
+		if {$state(state) eq "complete"} {
+		    # This includes all cases in which the transaction
+		    # can be completed by eof.
+		    # The value "complete" is set only in http::Event, and it is
+		    # used only in the test above.
+		    Log ^F$tk end of response body (unchunked, eof) - token $token
+		    Eot $token
+		} else {
+		    # Premature eof.
+		    Log ^X$tk end of response (unexpected eof) - token $token
+		    Eot $token eof
+		}
 	    } else {
-		# Premature eof.
-		Log ^X$tk end of response (unexpected eof) - token $token
-		Eot $token eof
+		# open connection closed on a token that has been cleaned up.
+		Log ^X$tk end of response (token error) - token $token
+		CloseSocket $sock
 	    }
+	} elseif {$cc} {
+	    return
 	} else {
-	    # open connection closed on a token that has been cleaned up.
-	    Log ^X$tk end of response (token error) - token $token
-	    CloseSocket $sock
+	    # Not eof, continue and yield.
 	}
     }
     return
@@ -2970,18 +2991,55 @@ proc http::IsBinaryContentType {type} {
 # Results:
 #	The line of text, without trailing newline
 
-# FIXME get rid of blocking
-
 proc http::getTextLine {sock} {
     set tr [fconfigure $sock -translation]
     lassign $tr trRead trWrite
-    set bl [fconfigure $sock -blocking]
-    fconfigure $sock -translation [list crlf $trWrite] -blocking 1
-    set r [gets $sock]
-    fconfigure $sock -translation $tr -blocking $bl
+    fconfigure $sock -translation [list crlf $trWrite]
+    set r [BlockingGets $sock]
+    fconfigure $sock -translation $tr
     return $r
 }
 
+# http::BlockingRead
+#
+#	Replacement for a blocking read.
+#	The caller must be a coroutine.
+
+proc http::BlockingRead {sock size} {
+    if {$size < 1} {
+        return
+    }
+    set result {}
+    while 1 {
+        set need [expr {$size - [string length $result]}]
+        set block [read $sock $need]
+        set eof [eof $sock]
+        append result $block
+        if {[string length $result] >= $size || $eof} {
+            return $result
+        } else {
+            yield
+        }
+    }
+}
+
+# http::BlockingGets
+#
+#	Replacement for a blocking gets.
+#	The caller must be a coroutine.
+
+proc http::BlockingGets {sock} {
+    while 1 {
+        set count [gets $sock line]
+        set eof [eof $sock]
+        if {$count > -1 || $eof} {
+            return $line
+        } else {
+            yield
+        }
+    }
+}
+
 # http::CopyStart
 #
 #	Error handling wrapper around fcopy
-- 
cgit v0.12


From 6bc8c27b7f2b94c8b35b1a7533fb19cb2f788fbd Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Wed, 4 Apr 2018 13:37:37 +0000
Subject: Restore most lines to 80 columns

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

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 77a2a43..28bb13d 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -2420,7 +2420,9 @@ proc http::Write {token} {
 
 # http::Event
 #
-#	Handle input on the socket
+#	Handle input on the socket. This command is the core of
+#	the coroutine commands ${token}EventCoroutine that are
+#	bound to "fileevent $sock readable" and process input.
 #
 # Arguments
 #	sock	The socket receiving input.
@@ -2481,10 +2483,10 @@ proc http::Event {sock token} {
 		    }
 
 		    # else:
-		    # This is NOT a persistent socket that has been closed since its
-		    # last use.
-		    # If any other requests are in flight or pipelined/queued, they
-		    # will be discarded.
+		    # This is NOT a persistent socket that has been closed since
+		    # its last use.
+		    # If any other requests are in flight or pipelined/queued,
+		    # they will be discarded.
 		} else {
 		    Log ^X$tk end of response (error) - token $token
 		    Finish $token $nsl
@@ -2508,8 +2510,8 @@ proc http::Event {sock token} {
 		# else:
 		# This is NOT a persistent socket that has been closed since its
 		# last use.
-		# If any other requests are in flight or pipelined/queued, they will
-		# be discarded.
+		# If any other requests are in flight or pipelined/queued, they
+		# will be discarded.
 	    } else {
 		Log ##Log - connecting 2 - token $token
 		# nsl is -1 so either fblocked (OK) or (eof and not reusing).
@@ -2541,9 +2543,10 @@ proc http::Event {sock token} {
 		     && (!$state(reusing))
 		     && ($state(-pipeline))
 		} {
-		    # Response headers received for first request on a persistent
-		    # socket.  Now ready for pipelined writes (if any).
-		    # Previous value is $token. It cannot be pending.
+		    # Response headers received for first request on a
+		    # persistent socket.  Now ready for pipelined writes (if
+		    # any).
+		    # Previous value is $token. It cannot be "pending".
 		    set socketWrState($state(socketinfo)) Wready
 		    http::NextPipelinedWrite $token
 		}
@@ -2551,9 +2554,9 @@ proc http::Event {sock token} {
 		# Once a "close" has been signaled, the client MUST NOT send any
 		# more requests on that connection.
 		#
-		# If either the client or the server sends the "close" token in the
-		# Connection header, that request becomes the last one for the
-		# connection.
+		# If either the client or the server sends the "close" token in
+		# the Connection header, that request becomes the last one for
+		# the connection.
 
 		if {    ([info exists state(connection)])
 		     && ([info exists socketMapping($state(socketinfo))])
@@ -2583,14 +2586,14 @@ proc http::Event {sock token} {
 				$socketWrQueue($state(socketinfo))]
 
 			# - All tokens are preserved for re-use by ReplayCore.
-			# - Queues are preserved in case of Finish with error, but
-			#   are not used for anything else because socketClosing(*)
-			#   is set below.
+			# - Queues are preserved in case of Finish with error,
+			#   but are not used for anything else because
+			#   socketClosing(*) is set below.
 			# - Cancel the state(after) timeout events.
-			foreach tokenElement $socketRdQueue($state(socketinfo)) {
-			    if {[info exists ${tokenElement}(after)]} {
-				after cancel [set ${tokenElement}(after)]
-				unset ${tokenElement}(after)
+			foreach tokenVal $socketRdQueue($state(socketinfo)) {
+			    if {[info exists ${tokenVal}(after)]} {
+				after cancel [set ${tokenVal}(after)]
+				unset ${tokenVal}(after)
 			    }
 			}
 
@@ -2613,15 +2616,15 @@ proc http::Event {sock token} {
 		    return
 		}
 
-		# - For non-chunked transfer we may have no body - in this case we
-		#   may get no further file event if the connection doesn't close
-		#   and no more data is sent. We can tell and must finish up now -
-		#   not later - the alternative would be to wait until the server
-		#   times out.
-		# - In this case, the server has NOT told the client it will close
-		#   the connection, AND it has NOT indicated the resource length
-		#   EITHER by setting the Content-Length (totalsize) OR by using
-		#   chunked Transer-Encoding.
+		# - For non-chunked transfer we may have no body - in this case
+		#   we may get no further file event if the connection doesn't
+		#   close and no more data is sent. We can tell and must finish
+		#   up now - not later - the alternative would be to wait until
+		#   the server times out.
+		# - In this case, the server has NOT told the client it will
+		#   close the connection, AND it has NOT indicated the resource
+		#   length EITHER by setting the Content-Length (totalsize) OR
+		#   by using chunked Transfer-Encoding.
 		# - Do not worry here about the case (Connection: close) because
 		#   the server should close the connection.
 		# - IF (NOT Connection: close) AND (NOT chunked encoding) AND
@@ -2710,7 +2713,7 @@ proc http::Event {sock token} {
 		    Log ##Log handler $n - token $token
 		    # N.B. the protocol has been set to 1.0 because the -handler
 		    # logic is not expected to handle chunked encoding.
-		    # FIXME allow -handler with 1.1 on dechunked stacked channel.
+		    # FIXME Allow -handler with 1.1 on dechunked stacked chan.
 		    if {$state(totalsize) == 0} {
 			# We know the transfer is complete only when the server
 			# closes the connection - i.e. eof is not an error.
@@ -2718,23 +2721,29 @@ proc http::Event {sock token} {
 		    }
 		    if {![string is integer -strict $n]} {
 			if 1 {
-			    # Do not tolerate bad -handler - fail with error status.
+			    # Do not tolerate bad -handler - fail with error
+			    # status.
 			    set msg {the -handler command for http::geturl must\
-				    return an integer (the number of bytes read)}
-			    Log ^X$tk end of response (handler error) - token $token
+				    return an integer (the number of bytes\
+				    read)}
+			    Log ^X$tk end of response (handler error) -\
+				    token $token
 			    Eot $token $msg
 			} else {
-			    # Tolerate the bad -handler, and continue.  The penalty:
-			    # (a) Because the handler returns nonsense, we know the
-			    #     transfer is complete only when the server closes
-			    #     the connection - i.e. eof is not an error.
+			    # Tolerate the bad -handler, and continue.  The
+			    # penalty:
+			    # (a) Because the handler returns nonsense, we know
+			    #     the transfer is complete only when the server
+			    #     closes the connection - i.e. eof is not an
+			    #     error.
 			    # (b) http::size will not be accurate.
-			    # (c) The transaction is already downgraded to 1.0 to
-			    #     avoid chunked transfer encoding.  It MUST also be
-			    #     forced to "Connection: close" or the HTTP/1.0
-			    #     equivalent; or it MUST fail (as above) if the
-			    #     server sends "Connection: keep-alive" or the
-			    #     HTTP/1.0 equivalent.
+			    # (c) The transaction is already downgraded to 1.0
+			    #     to avoid chunked transfer encoding.  It MUST
+			    #     also be forced to "Connection: close" or the
+			    #     HTTP/1.0 equivalent; or it MUST fail (as
+			    #     above) if the server sends
+			    #     "Connection: keep-alive" or the HTTP/1.0
+			    #     equivalent.
 			    set n 0
 			    set state(state) complete
 			}
@@ -2745,11 +2754,13 @@ proc http::Event {sock token} {
 		    set n [string length $line]
 		    set state(state) complete
 		    if {$n > 0} {
-			# - HTTP trailers (late response headers) are permitted by
-			#   Chunked Transfer-Encoding, and can be safely ignored.
-			# - Do not count these bytes in the total received for the
-			#   response body.
-			Log "trailer of $n bytes after final chunk - token $token"
+			# - HTTP trailers (late response headers) are permitted
+			#   by Chunked Transfer-Encoding, and can be safely
+			#   ignored.
+			# - Do not count these bytes in the total received for
+			#   the response body.
+			Log "trailer of $n bytes after final chunk -\
+				token $token"
 			append state(transfer_final) $line
 			set n 0
 		    } else {
@@ -2773,12 +2784,13 @@ proc http::Event {sock token} {
 			    if {$n >= 0} {
 				append state(body) $chunk
 				incr state(log_size) [string length $chunk]
-				Log ##Log chunk $n cumul $state(log_size) - token $token
+				Log ##Log chunk $n cumul $state(log_size) -\
+					token $token
 			    }
 			    if {$size != [string length $chunk]} {
 				Log "WARNING: mis-sized chunk:\
-				    was [string length $chunk], should be $size -\
-				    token $token"
+				    was [string length $chunk], should be\
+				    $size - token $token"
 				set n 0
 				set state(connection) close
 				Log ^X$tk end of response (chunk error) \
@@ -2799,7 +2811,8 @@ proc http::Event {sock token} {
 			set n 0
 			set state(connection) close
 			Log ^X$tk end of response (chunk error) - token $token
-			Eot $token {error in chunked encoding - fetch terminated}
+			Eot $token {error in chunked encoding -\
+				fetch terminated}
 		    }
 		} else {
 		    Log ##Log unchunked - token $token
@@ -2810,11 +2823,12 @@ proc http::Event {sock token} {
 			set reqSize $state(-blocksize)
 		    } else {
 			# Ask for the whole of the unserved response-body.
-			# This works around a problem with a tls::socket - for https
-			# in keep-alive mode, and a request for $state(-blocksize)
-			# bytes, the last part of the resource does not get read
-			# until the server times out.
-			set reqSize [expr {$state(totalsize) - $state(currentsize)}]
+			# This works around a problem with a tls::socket - for
+			# https in keep-alive mode, and a request for
+			# $state(-blocksize) bytes, the last part of the
+			# resource does not get read until the server times out.
+			set reqSize [expr {  $state(totalsize)
+			                   - $state(currentsize)}]
 
 			# The workaround fails if reqSize is
 			# capped at $state(-blocksize).
@@ -2822,29 +2836,33 @@ proc http::Event {sock token} {
 		    }
 		    set c $state(currentsize)
 		    set t $state(totalsize)
-		    Log ##Log non-chunk currentsize $c of totalsize $t - token $token
+		    Log ##Log non-chunk currentsize $c of totalsize $t -\
+			    token $token
 		    set block [read $sock $reqSize]
 		    set n [string length $block]
 		    if {$n >= 0} {
 			append state(body) $block
-			Log ##Log non-chunk [string length $state(body)] - token $token
+			Log ##Log non-chunk [string length $state(body)] -\
+				token $token
 		    }
 		}
-		# This calculation uses n from the -handler, chunked, or unchunked
-		# case as appropriate.
+		# This calculation uses n from the -handler, chunked, or
+		# unchunked case as appropriate.
 		if {[info exists state]} {
 		    if {$n >= 0} {
 			incr state(currentsize) $n
 			set c $state(currentsize)
 			set t $state(totalsize)
-			Log ##Log another $n currentsize $c totalsize $t - token $token
+			Log ##Log another $n currentsize $c totalsize $t -\
+				token $token
 		    }
 		    # If Content-Length - check for end of data.
 		    if {
 			   ($state(totalsize) > 0)
 			&& ($state(currentsize) >= $state(totalsize))
 		    } {
-			Log ^F$tk end of response body (unchunked) - token $token
+			Log ^F$tk end of response body (unchunked) -\
+				token $token
 			set state(state) complete
 			Eot $token
 		    }
@@ -2872,7 +2890,8 @@ proc http::Event {sock token} {
 		    # can be completed by eof.
 		    # The value "complete" is set only in http::Event, and it is
 		    # used only in the test above.
-		    Log ^F$tk end of response body (unchunked, eof) - token $token
+		    Log ^F$tk end of response body (unchunked, eof) -\
+			    token $token
 		    Eot $token
 		} else {
 		    # Premature eof.
-- 
cgit v0.12


From d690b847384c4c4ea77254292ac7e36a71b4867d Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Fri, 13 Apr 2018 15:41:00 +0000
Subject: Improve detection and reporting of TLS errors.  New command
 http::registerError to assist the latter.  Ensure that http::cleanup cancels
 any timeout event if not already done.  Add comments on non-blocking
 read/gets.

---
 library/http/http.tcl | 80 ++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 66 insertions(+), 14 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 28bb13d..e0382e7 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -128,13 +128,13 @@ namespace eval http {
 	set defaultKeepalive 0
     }
 
-    namespace export geturl config reset wait formatQuery register unregister
-    # Useful, but not exported: data size status code cleanup error meta ncode,
-    # mapReply, init.  Comments suggest that "init" can be used for
-    # re-initialisation, although it is undocumented.
-    #
-    # Not exported, probably should be upper-case initial letter as part
-    # of the internals: getTextLine make-transformation-chunked
+    namespace export geturl config reset wait formatQuery
+    namespace export register unregister registerError
+    # - Useful, but not exported: data, size, status, code, cleanup, error,
+    #   meta, ncode, mapReply, init.  Comments suggest that "init" can be used
+    #   for re-initialisation, although the command is undocumented.
+    # - Not exported, probably should be upper-case initial letter as part
+    #   of the internals: getTextLine, make-transformation-chunked.
 }
 
 # http::Log --
@@ -1470,6 +1470,11 @@ proc http::Connected {token proto phost srvurl} {
 		puts $sock "Content-Length: $state(querylength)"
 	    }
 	    puts $sock ""
+	    flush $sock
+	    # Flush flushes the error in the https case with a bad handshake:
+	    # else the socket never becomes writable again, and hangs until
+	    # timeout (if any).
+
 	    lassign [fconfigure $sock -translation] trRead trWrite
 	    fconfigure $sock -translation [list $trRead binary]
 	    fileevent $sock writable [list http::Write $token]
@@ -1496,8 +1501,9 @@ proc http::Connected {token proto phost srvurl} {
 	}
 
     } err]} {
-	# The socket probably was never connected, or the connection dropped
-	# later.
+	# The socket probably was never connected, OR the connection dropped
+	# later, OR https handshake error, which may be discovered as late as
+	# the "flush" command above...
 	Log "WARNING - if testing, pay special attention to this\
 		case (GI) which is seldom executed - token $token"
 	if {[info exists state(reusing)] && $state(reusing)} {
@@ -1515,7 +1521,14 @@ proc http::Connected {token proto phost srvurl} {
 	    # If any other requests are in flight or pipelined/queued, they will
 	    # be discarded.
 	} elseif {$state(status) eq ""} {
-	    Finish $token {failed to re-use socket}
+	    # ...https handshake errors come here.
+	    set msg [registerError $sock]
+	    registerError $sock {}
+	    if {$msg eq {}} {
+		set msg {failed to use socket}
+	    } else {
+	    }
+	    Finish $token $msg
 	} elseif {$state(status) ne "error"} {
 	    Finish $token $err
 	} else {
@@ -1526,6 +1539,35 @@ proc http::Connected {token proto phost srvurl} {
     return
 }
 
+# http::registerError
+#
+#	Called (for example when processing TclTLS activity) to register
+#	an error for a connection on a specific socket.  This helps
+#	http::Connected to deliver meaningful error messages, e.g. when a TLS
+#	certificate fails verification.
+#
+#	Usage: http::registerError socket ?newValue?
+#
+#	"set" semantics, except that a "get" (a call without a new value) for a
+#	non-existent socket returns {}, not an error.
+
+proc http::registerError {sock args} {
+    variable registeredErrors
+
+    if {    ([llength $args] == 0)
+         && (![info exists registeredErrors($sock)])
+    } {
+        return
+    } elseif {    ([llength $args] == 1)
+               && ([lindex $args 0] eq {})
+    } {
+        unset -nocomplain registeredErrors($sock)
+        return
+    }
+    set registeredErrors($sock) {*}$args
+    # N.B. Implicit Return
+}
+
 # http::DoneRequest --
 #
 #	Command called when a request has been sent.  It will arrange the
@@ -2263,6 +2305,10 @@ proc http::cleanup {token} {
     if {[info commands ${token}EventCoroutine] ne {}} {
         rename ${token}EventCoroutine {}
     }
+    if {[info exists state(after)]} {
+	after cancel $state(after)
+	unset state(after)
+    }
     if {[info exists state]} {
 	unset state
     }
@@ -2750,6 +2796,7 @@ proc http::Event {sock token} {
 		    } else {
 		    }
 		} elseif {[info exists state(transfer_final)]} {
+		    # This code forgives EOF in place of the final CRLF.
 		    set line [getTextLine $sock]
 		    set n [string length $line]
 		    set state(state) complete
@@ -2799,14 +2846,15 @@ proc http::Event {sock token} {
 					terminated}
 				Eot $token $msg
 			    }
-			    # CRLF that follows chunk:
+			    # CRLF that follows chunk.
+			    # If eof, this is handled at the end of this proc.
 			    getTextLine $sock
 			} else {
 			    set n 0
 			    set state(transfer_final) {}
 			}
 		    } else {
-			# Line expected to hold chunk length is empty.
+			# Line expected to hold chunk length is empty, or eof.
 			Log ##Log bad-chunk-measure - token $token
 			set n 0
 			set state(connection) close
@@ -3001,8 +3049,10 @@ proc http::IsBinaryContentType {type} {
 
 # http::getTextLine --
 #
-#	Get one line with the stream in blocking crlf mode
-#	Used if Transfer-Encoding is chunked
+#	Get one line with the stream in crlf mode.
+#	Used if Transfer-Encoding is chunked.
+#	Empty line is not distinguished from eof.  The caller must
+#	be able to handle this.
 #
 # Arguments
 #	sock	The socket receiving input.
@@ -3046,6 +3096,8 @@ proc http::BlockingRead {sock size} {
 #
 #	Replacement for a blocking gets.
 #	The caller must be a coroutine.
+#	Empty line is not distinguished from eof.  The caller must
+#	be able to handle this.
 
 proc http::BlockingGets {sock} {
     while 1 {
-- 
cgit v0.12


From 4588d7300e53e7403a693eedb0d10d54efccb972 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Fri, 13 Apr 2018 15:48:13 +0000
Subject: Restore Tcl 8+4 tab convention

---
 library/http/http.tcl | 56 +++++++++++++++++++++++++--------------------------
 1 file changed, 28 insertions(+), 28 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index e0382e7..30b69e6 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -256,7 +256,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	set state(status) "error"
     }
     if {[info commands ${token}EventCoroutine] ne {}} {
-        rename ${token}EventCoroutine {}
+	rename ${token}EventCoroutine {}
     }
     if {  ($state(status) eq "timeout")
        || ($state(status) eq "error")
@@ -333,10 +333,10 @@ proc http::KeepSocket {token} {
     if {$TEST_EOF} {
 	# ONLY for testing reaction to server eof.
 	# No server timeouts will be caught.
-        catch {fileevent $state(sock) readable {}}
+	catch {fileevent $state(sock) readable {}}
     } else {
-        # Normal operation.
-        # Test constraint normalEof.
+	# Normal operation.
+	# Test constraint normalEof.
     }
 
     if {    [info exists state(socketinfo)]
@@ -1555,14 +1555,14 @@ proc http::registerError {sock args} {
     variable registeredErrors
 
     if {    ([llength $args] == 0)
-         && (![info exists registeredErrors($sock)])
+	 && (![info exists registeredErrors($sock)])
     } {
-        return
+	return
     } elseif {    ([llength $args] == 1)
-               && ([lindex $args 0] eq {})
+	       && ([lindex $args 0] eq {})
     } {
-        unset -nocomplain registeredErrors($sock)
-        return
+	unset -nocomplain registeredErrors($sock)
+	return
     }
     set registeredErrors($sock) {*}$args
     # N.B. Implicit Return
@@ -2303,7 +2303,7 @@ proc http::cleanup {token} {
     variable $token
     upvar 0 $token state
     if {[info commands ${token}EventCoroutine] ne {}} {
-        rename ${token}EventCoroutine {}
+	rename ${token}EventCoroutine {}
     }
     if {[info exists state(after)]} {
 	after cancel $state(after)
@@ -2876,7 +2876,7 @@ proc http::Event {sock token} {
 			# $state(-blocksize) bytes, the last part of the
 			# resource does not get read until the server times out.
 			set reqSize [expr {  $state(totalsize)
-			                   - $state(currentsize)}]
+					   - $state(currentsize)}]
 
 			# The workaround fails if reqSize is
 			# capped at $state(-blocksize).
@@ -3076,19 +3076,19 @@ proc http::getTextLine {sock} {
 
 proc http::BlockingRead {sock size} {
     if {$size < 1} {
-        return
+	return
     }
     set result {}
     while 1 {
-        set need [expr {$size - [string length $result]}]
-        set block [read $sock $need]
-        set eof [eof $sock]
-        append result $block
-        if {[string length $result] >= $size || $eof} {
-            return $result
-        } else {
-            yield
-        }
+	set need [expr {$size - [string length $result]}]
+	set block [read $sock $need]
+	set eof [eof $sock]
+	append result $block
+	if {[string length $result] >= $size || $eof} {
+	    return $result
+	} else {
+	    yield
+	}
     }
 }
 
@@ -3101,13 +3101,13 @@ proc http::BlockingRead {sock size} {
 
 proc http::BlockingGets {sock} {
     while 1 {
-        set count [gets $sock line]
-        set eof [eof $sock]
-        if {$count > -1 || $eof} {
-            return $line
-        } else {
-            yield
-        }
+	set count [gets $sock line]
+	set eof [eof $sock]
+	if {$count > -1 || $eof} {
+	    return $line
+	} else {
+	    yield
+	}
     }
 }
 
-- 
cgit v0.12


From 3771e638b05a4c75d1222ee7653e01cd2289643e Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Fri, 20 Apr 2018 20:06:30 +0000
Subject: Document the new proc http::registerError in http.n

---
 doc/http.n | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/doc/http.n b/doc/http.n
index 2dae77e..e788022 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -44,6 +44,8 @@ http \- Client-side implementation of the HTTP/1.1 protocol
 .sp
 \fB::http::register \fIproto port command\fR
 .sp
+\fB::http::registerError \fIport\fR ?\fImessage\fR?
+.sp
 \fB::http::unregister \fIproto\fR
 .BE
 .SH DESCRIPTION
@@ -454,6 +456,17 @@ set token [::http::geturl https://my.secure.site/]
 .CE
 .RE
 .TP
+\fB::http::registerError\fR \fIport\fR ?\fImessage\fR?
+.
+This procedure allows a registered protocol handler to deliver an error
+message for use by \fBhttp\fR.  Calling this command does not raise an
+error. The command is useful when a registered protocol detects an problem
+(for example, an invalid TLS certificate) that will cause an error to
+propagate to \fBhttp\fR.  The command allows \fBhttp\fR to provide a
+precise error message rather than a general one.  The command returns the
+value provided by the last call with argument \fImessage\fR, or the empty
+string if no such call has been made.
+.TP
 \fB::http::unregister\fR \fIproto\fR
 .
 This procedure unregisters a protocol handler that was previously
-- 
cgit v0.12


From b169c964e611847319cc92875f653466939bcb43 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Sat, 21 Apr 2018 13:31:16 +0000
Subject: Amend httpPipeline.test tests to use stdout not stderr, and thus
 avoid the report {Test files exiting with errors} even when all tests pass.

---
 tests/httpTest.tcl       | 16 ++++++++--------
 tests/httpTestScript.tcl |  2 +-
 2 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl
index 38ba43f..9cd7a5d 100644
--- a/tests/httpTest.tcl
+++ b/tests/httpTest.tcl
@@ -25,7 +25,7 @@ package require http
 
 namespace eval ::http {
     variable TestStartTimeInMs [clock milliseconds]
-    catch {puts stderr "Start time (zero ms) is $TestStartTimeInMs"}
+    catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"}
 }
 
 namespace eval ::httpTest {
@@ -35,15 +35,15 @@ namespace eval ::httpTest {
         -verbose 0
         -dotted  1
     }
-    # -verbose - 0 quiet 1 write to stderr 2 write more
+    # -verbose - 0 quiet 1 write to stdout 2 write more
     # -dotted  - (boolean) use dots for absences in lists of transactions
 }
 
 proc httpTest::Puts {txt} {
     variable testOptions
     if {$testOptions(-verbose) > 0} {
-        puts stderr $txt
-        flush stderr
+        puts stdout $txt
+        flush stdout
     }
     return
 }
@@ -53,7 +53,7 @@ proc httpTest::Puts {txt} {
 # A special-purpose logger used for running tests.
 # - Processes Log calls that have "^" in their arguments, and records them in
 #   variable ::httpTest::testResults.
-# - Also writes them to stderr (using Puts) if ($testOptions(-verbose) > 0).
+# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0).
 # - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1).
 
 proc http::Log {args} {
@@ -78,10 +78,10 @@ proc httpTest::LogRecord {txt} {
     set pos [string first ^ $txt]
     set len [string length  $txt]
     if {$pos > $len - 3} {
-        puts stderr "Logging Error: $txt"
-        puts stderr "Fix this call to Log in http-*.tm so it has ^ then\
+        puts stdout "Logging Error: $txt"
+        puts stdout "Fix this call to Log in http-*.tm so it has ^ then\
 		a letter then a numeral."
-        flush stderr
+        flush stdout
     } elseif {$pos == -1} {
         # Called by mistake.
     } else {
diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl
index 4046c7a..a8ef9c8 100644
--- a/tests/httpTestScript.tcl
+++ b/tests/httpTestScript.tcl
@@ -389,7 +389,7 @@ proc httpTestScript::Requester {uriCode keepAlive validate query args} {
                 -command   ::httpTestScript::WhenFinished
     } token]} {
         set msg $token
-        catch {puts stderr "Error: $msg"}
+        catch {puts stdout "Error: $msg"}
         return
     } else {
         # Request will begin.
-- 
cgit v0.12


From 227db01958097c4aac9a9b57569db68002ab1187 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Sat, 21 Apr 2018 14:22:35 +0000
Subject: Restore production test settings: set tests/httpPipeline.test to
 non-verbose, and comment out most Log calls in library/http/http.tcl

---
 library/http/http.tcl   | 128 ++++++++++++++++++++++++------------------------
 tests/httpPipeline.test |   2 +-
 2 files changed, 65 insertions(+), 65 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 4bde573..d16a8d9 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -358,7 +358,7 @@ proc http::KeepSocket {token} {
 	    upvar 0 $token3 state3
 	    set tk2 [namespace tail $token3]
 
-	    Log #Log pipelined, GRANT read access to $token3 in KeepSocket
+	    #Log pipelined, GRANT read access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    ReceiveResponse $token3
 
@@ -397,13 +397,13 @@ proc http::KeepSocket {token} {
 	    #   give that request read and write access.
 	    variable $token3
 	    set conn [set ${token3}(tmpConnArgs)]
-	    Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
 	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	    # Connect does its own fconfigure.
 	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
-	    Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+	    #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
 
 	} elseif {
 		$state(-pipeline)
@@ -442,13 +442,13 @@ proc http::KeepSocket {token} {
 	    #   case with a queued request.
 	    variable $token3
 	    set conn [set ${token3}(tmpConnArgs)]
-	    Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
 	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	    # Connect does its own fconfigure.
 	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
-	    Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+	    #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
 
 	} elseif {
 		(!$state(-pipeline))
@@ -464,13 +464,13 @@ proc http::KeepSocket {token} {
 	    set token3 [lindex $socketWrQueue($connId) 0]
 	    variable $token3
 	    set conn [set ${token3}(tmpConnArgs)]
-	    Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+	    #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
 	    set socketRdState($connId) $token3
 	    set socketWrState($connId) $token3
 	    set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	    # Connect does its own fconfigure.
 	    fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
-	    Log #Log ---- $state(sock) << conn to $token3 for HTTP request (d)
+	    #Log ---- $state(sock) << conn to $token3 for HTTP request (d)
 
 	} elseif {(!$state(-pipeline))} {
 	    set socketWrState($connId) Wready
@@ -710,7 +710,7 @@ proc http::geturl {url args} {
 	set http(uid) 0
     }
     set token [namespace current]::[incr http(uid)]
-    Log ##Log Starting http::geturl - token $token
+    ##Log Starting http::geturl - token $token
     variable $token
     upvar 0 $token state
     set tk [namespace tail $token]
@@ -1098,8 +1098,8 @@ proc http::geturl {url args} {
 	    lappend sockopts -myaddr $state(-myaddr)
 	}
 	set pre [clock milliseconds]
-	Log ##Log pre socket opened, - token $token
-	Log ##Log [concat $defcmd $sockopts $targetAddr] - token $token
+	##Log pre socket opened, - token $token
+	##Log [concat $defcmd $sockopts $targetAddr] - token $token
 	if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} {
 	    # Something went wrong while trying to establish the connection.
 	    # Clean up after events and such, but DON'T call the command
@@ -1113,15 +1113,15 @@ proc http::geturl {url args} {
 	    return -options $errdict $sock
 	} else {
 	    # Initialisation of a new socket.
-	    Log ##Log post socket opened, - token $token
-	    Log ##Log socket opened, now fconfigure - token $token
+	    ##Log post socket opened, - token $token
+	    ##Log socket opened, now fconfigure - token $token
 	    set delay [expr {[clock milliseconds] - $pre}]
 	    if {$delay > 3000} {
 		Log socket delay $delay - token $token
 	    }
 	    fconfigure $sock -translation {auto crlf} \
 			     -buffersize $state(-blocksize)
-	    Log ##Log socket opened, DONE fconfigure - token $token
+	    ##Log socket opened, DONE fconfigure - token $token
 	}
     }
     # Command [socket] is called with -async, but takes 5s to 5.1s to return,
@@ -1152,7 +1152,7 @@ proc http::geturl {url args} {
 	}
 
 	if {$state(-pipeline)} {
-	    Log #Log new, init for pipelined, GRANT write access to $token in geturl
+	    #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
@@ -1161,7 +1161,7 @@ proc http::geturl {url args} {
 	    # 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 #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
+	    #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
 	    set socketRdState($state(socketinfo)) $token
 	    set socketWrState($state(socketinfo)) $token
 	}
@@ -1206,13 +1206,13 @@ proc http::geturl {url args} {
 	# subsequent calls on this socket will come here because the socket
 	# will close after the current read, and its
 	# socketClosing($connId) is 1.
-	Log ##Log "HTTP request for token $token is queued"
+	##Log "HTTP request for token $token is queued"
 
     } elseif {    $reusing
 	       && $state(-pipeline)
 	       && ($socketWrState($state(socketinfo)) ne "Wready")
     } {
-	Log ##Log "HTTP request for token $token is queued for pipelined use"
+	##Log "HTTP request for token $token is queued for pipelined use"
 	lappend socketWrQueue($state(socketinfo)) $token
 
     } elseif {    $reusing
@@ -1220,7 +1220,7 @@ proc http::geturl {url args} {
 	       && ($socketWrState($state(socketinfo)) ne "Wready")
     } {
 	# A write is queued or in progress.  Lappend to the write queue.
-	Log ##Log "HTTP request for token $token is queued for nonpipeline use"
+	##Log "HTTP request for token $token is queued for nonpipeline use"
 	lappend socketWrQueue($state(socketinfo)) $token
 
     } elseif {    $reusing
@@ -1231,20 +1231,20 @@ proc http::geturl {url args} {
 	# A read is queued or in progress, but not a write.  Cannot start the
 	# nonpipeline transaction, but must set socketWrState to prevent a
 	# pipelined request jumping the queue.
-	Log ##Log "HTTP request for token $token is queued for nonpipeline use"
-	Log #Log re-use nonpipeline, GRANT delayed write access to $token in geturl
+	##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 #Log re-use pipelined, GRANT write access to $token in geturl
+	    #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 #Log re-use nonpipeline, GRANT r/w access to $token in geturl
+	    #Log re-use nonpipeline, GRANT r/w access to $token in geturl
 	    set socketRdState($state(socketinfo)) $token
 	    set socketWrState($state(socketinfo)) $token
 
@@ -1254,7 +1254,7 @@ proc http::geturl {url args} {
 
 	# All (!$reusing) cases come here, and also some $reusing cases if the
 	# connection is ready.
-	Log #Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
+	#Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
 	# Connect does its own fconfigure.
 	fileevent $sock writable \
 		[list http::Connect $token $proto $phost $srvurl]
@@ -1281,7 +1281,7 @@ proc http::geturl {url args} {
 	    return -code error $err
 	}
     }
-    Log ##Log Leaving http::geturl - token $token
+    ##Log Leaving http::geturl - token $token
     return $token
 }
 
@@ -1621,7 +1621,7 @@ proc http::DoneRequest {token} {
 	 && [info exists socketRdState($state(socketinfo))]
 	 && ($socketRdState($state(socketinfo)) eq "Rready")
     } {
-	Log #Log pipelined, GRANT read access to $token in Connected
+	#Log pipelined, GRANT read access to $token in Connected
 	set socketRdState($state(socketinfo)) $token
     }
 
@@ -1631,7 +1631,7 @@ proc http::DoneRequest {token} {
 	 && ($socketRdState($state(socketinfo)) ne $token)
     } {
 	# Do not read from the socket until it is ready.
-	Log ##Log "HTTP response for token $token is queued for pipelined use"
+	##Log "HTTP response for token $token is queued for pipelined use"
 	# If $socketClosing(*), then the caller will be a pipelined write and
 	# execution will come here.
 	# This token has already been recorded as "in flight" for writing.
@@ -1657,7 +1657,7 @@ proc http::ReceiveResponse {token} {
     set tk [namespace tail $token]
     set sock $state(sock)
 
-    Log #Log ---- $state(socketinfo) >> conn to $token for HTTP response
+    #Log ---- $state(socketinfo) >> conn to $token for HTTP response
     lassign [fconfigure $sock -translation] trRead trWrite
     fconfigure $sock -translation [list auto $trWrite] \
 		     -buffersize $state(-blocksize)
@@ -1718,13 +1718,13 @@ proc http::NextPipelinedWrite {token} {
 	    )
     } {
 	# - The usual case for a pipelined connection, ready for a new request.
-	Log #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite
+	#Log pipelined, GRANT write access to $token2 in NextPipelinedWrite
 	set conn [set ${token2}(tmpConnArgs)]
 	set socketWrState($connId) $token2
 	set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	# Connect does its own fconfigure.
 	fileevent $state(sock) writable [list http::Connect $token2 {*}$conn]
-	Log #Log ---- $connId << conn to $token2 for HTTP request (b)
+	#Log ---- $connId << conn to $token2 for HTTP request (b)
 
 	# In the tests below, the next request will be nonpipeline.
     } elseif {    $state(-pipeline)
@@ -1747,13 +1747,13 @@ proc http::NextPipelinedWrite {token} {
 	variable $token3
 	upvar 0 $token3 state3
 	set conn [set ${token3}(tmpConnArgs)]
-	Log #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
+	#Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
 	set socketRdState($connId) $token3
 	set socketWrState($connId) $token3
 	set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
 	# Connect does its own fconfigure.
 	fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
-	Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+	#Log ---- $state(sock) << conn to $token3 for HTTP request (c)
 
     } elseif {    $state(-pipeline)
 	 && [info exists socketWrState($connId)]
@@ -1775,7 +1775,7 @@ proc http::NextPipelinedWrite {token} {
 	#   of the connection to $token2 will be done elsewhere - by command
 	#   http::KeepSocket when $socketRdState($connId) is set to "Rready".
 
-	Log #Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
+	#Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
 	set socketWrState($connId) peNding
 
     } else {
@@ -1804,7 +1804,7 @@ proc http::NextPipelinedWrite {token} {
 
 proc http::CancelReadPipeline {name1 connId op} {
     variable socketRdQueue
-    Log ##Log CancelReadPipeline $name1 $connId $op
+    ##Log CancelReadPipeline $name1 $connId $op
     if {[info exists socketRdQueue($connId)]} {
 	set msg {the connection was closed by CancelReadPipeline}
 	foreach token $socketRdQueue($connId) {
@@ -1838,7 +1838,7 @@ proc http::CancelReadPipeline {name1 connId op} {
 proc http::CancelWritePipeline {name1 connId op} {
     variable socketWrQueue
 
-    Log ##Log CancelWritePipeline $name1 $connId $op
+    ##Log CancelWritePipeline $name1 $connId $op
     if {[info exists socketWrQueue($connId)]} {
 	set msg {the connection was closed by CancelWritePipeline}
 	foreach token $socketWrQueue($connId) {
@@ -2124,7 +2124,7 @@ proc http::ReplayCore {newQueue} {
 	return
     }
 
-    Log ##Log running ReplayCore for {*}$newQueue
+    ##Log running ReplayCore for {*}$newQueue
     set newToken [lindex $newQueue 0]
     set newQueue [lrange $newQueue 1 end]
 
@@ -2156,8 +2156,8 @@ proc http::ReplayCore {newQueue} {
     }
 
     set pre [clock milliseconds]
-    Log ##Log pre socket opened, - token $token
-    Log ##Log $tmpOpenCmd - token $token
+    ##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.
@@ -2166,7 +2166,7 @@ proc http::ReplayCore {newQueue} {
 	Finish $token $sock
 	return
     }
-    Log ##Log post socket opened, - token $token
+    ##Log post socket opened, - token $token
     set delay [expr {[clock milliseconds] - $pre}]
     if {$delay > 3000} {
 	Log socket delay $delay - token $token
@@ -2194,11 +2194,11 @@ proc http::ReplayCore {newQueue} {
 	}
 
 	if {$state(-pipeline)} {
-	    Log #Log new, init for pipelined, GRANT write acc to $token ReplayCore
+	    #Log new, init for pipelined, GRANT write acc to $token ReplayCore
 	    set socketRdState($state(socketinfo)) $token
 	    set socketWrState($state(socketinfo)) $token
 	} else {
-	    Log #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore
+	    #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore
 	    set socketRdState($state(socketinfo)) $token
 	    set socketWrState($state(socketinfo)) $token
 	}
@@ -2209,7 +2209,7 @@ proc http::ReplayCore {newQueue} {
 	set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
     }
 
-    Log ##Log pre newQueue ReInit, - token $token
+    ##Log pre newQueue ReInit, - token $token
     # 6. Configure sockets in the queue.
     foreach tok $newQueue {
 	if {[ReInit $tok]} {
@@ -2228,13 +2228,13 @@ proc http::ReplayCore {newQueue} {
 	[expr {$state(-keepalive)?"keepalive":""}]
 
     # Initialisation of a new socket.
-    Log ##Log socket opened, now fconfigure - token $token
+    ##Log socket opened, now fconfigure - token $token
     fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
-    Log ##Log socket opened, DONE fconfigure - token $token
+    ##Log socket opened, DONE fconfigure - token $token
 
     # Connect does its own fconfigure.
     fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs]
-    Log #Log ---- $sock << conn to $token for HTTP request (e)
+    #Log ---- $sock << conn to $token for HTTP request (e)
     return
 }
 
@@ -2493,7 +2493,7 @@ proc http::Event {sock token} {
     set tk [namespace tail $token]
     while 1 {
 	yield
-	Log ##Log Event call - token $token
+	##Log Event call - token $token
 
 	if {![info exists state]} {
 	    Log "Event $sock with invalid token '$token' - remote close?"
@@ -2508,7 +2508,7 @@ proc http::Event {sock token} {
 	    return
 	}
 	if {$state(state) eq "connecting"} {
-	    Log ##Log - connecting - token $token
+	    ##Log - connecting - token $token
 	    if {    $state(reusing)
 		 && $state(-pipeline)
 		 && ($state(-timeout) > 0)
@@ -2540,7 +2540,7 @@ proc http::Event {sock token} {
 		    return
 		}
 	    } elseif {$nsl >= 0} {
-		Log ##Log - connecting 1 - token $token
+		##Log - connecting 1 - token $token
 		set state(state) "header"
 	    } elseif {    [eof $sock]
 		       && [info exists state(reusing)]
@@ -2560,18 +2560,18 @@ proc http::Event {sock token} {
 		# If any other requests are in flight or pipelined/queued, they
 		# will be discarded.
 	    } else {
-		Log ##Log - connecting 2 - token $token
+		##Log - connecting 2 - token $token
 		# nsl is -1 so either fblocked (OK) or (eof and not reusing).
 		# Continue. Any eof is processed at the end of this proc.
 	    }
 	} elseif {$state(state) eq "header"} {
 	    if {[catch {gets $sock line} nhl]} {
-		Log ##Log header failed - token $token
+		##Log header failed - token $token
 		Log ^X$tk end of response (error) - token $token
 		Finish $token $nhl
 		return
 	    } elseif {$nhl == 0} {
-		Log ##Log header done - token $token
+		##Log header done - token $token
 		Log ^E$tk end of response headers - token $token
 		# We have now read all headers
 		# We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
@@ -2612,7 +2612,7 @@ proc http::Event {sock token} {
 		} {
 		    # The server warns that it will close the socket after this
 		    # response.
-		    Log ##Log WARNING - socket will close after response for $token
+		    ##Log WARNING - socket will close after response for $token
 		    # Prepare data for a call to ReplayIfClose.
 		    if {    ($socketRdQueue($state(socketinfo)) ne {})
 			 || ($socketWrQueue($state(socketinfo)) ne {})
@@ -2624,7 +2624,7 @@ proc http::Event {sock token} {
 			    set InFlightW Wready
 			} else {
 			    set msg "token ${InFlightW} is InFlightW"
-			    Log ##Log $msg - token $token
+			    ##Log $msg - token $token
 			}
 
 			set socketPlayCmd($state(socketinfo)) \
@@ -2717,7 +2717,7 @@ proc http::Event {sock token} {
 		}
 	    } elseif {$nhl > 0} {
 		# Process header lines.
-		Log ##Log header - token $token - $line
+		##Log header - token $token - $line
 		if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 		    switch -- [string tolower $key] {
 			content-type {
@@ -2753,11 +2753,11 @@ proc http::Event {sock token} {
 	    }
 	} else {
 	    # Now reading body
-	    Log ##Log body - token $token
+	    ##Log body - token $token
 	    if {[catch {
 		if {[info exists state(-handler)]} {
 		    set n [eval $state(-handler) [list $sock $token]]
-		    Log ##Log handler $n - token $token
+		    ##Log handler $n - token $token
 		    # N.B. the protocol has been set to 1.0 because the -handler
 		    # logic is not expected to handle chunked encoding.
 		    # FIXME Allow -handler with 1.1 on dechunked stacked chan.
@@ -2819,20 +2819,20 @@ proc http::Event {sock token} {
 		} elseif {    [info exists state(transfer)]
 			   && ($state(transfer) eq "chunked")
 		} {
-		    Log ##Log chunked - token $token
+		    ##Log chunked - token $token
 		    set size 0
 		    set hexLenChunk [getTextLine $sock]
 		    #set ntl [string length $hexLenChunk]
 		    if {[string trim $hexLenChunk] ne ""} {
 			scan $hexLenChunk %x size
 			if {$size != 0} {
-			    Log ##Log chunk-measure $size - token $token
+			    ##Log chunk-measure $size - token $token
 			    set chunk [BlockingRead $sock $size]
 			    set n [string length $chunk]
 			    if {$n >= 0} {
 				append state(body) $chunk
 				incr state(log_size) [string length $chunk]
-				Log ##Log chunk $n cumul $state(log_size) -\
+				##Log chunk $n cumul $state(log_size) -\
 					token $token
 			    }
 			    if {$size != [string length $chunk]} {
@@ -2856,7 +2856,7 @@ proc http::Event {sock token} {
 			}
 		    } else {
 			# Line expected to hold chunk length is empty, or eof.
-			Log ##Log bad-chunk-measure - token $token
+			##Log bad-chunk-measure - token $token
 			set n 0
 			set state(connection) close
 			Log ^X$tk end of response (chunk error) - token $token
@@ -2864,7 +2864,7 @@ proc http::Event {sock token} {
 				fetch terminated}
 		    }
 		} else {
-		    Log ##Log unchunked - token $token
+		    ##Log unchunked - token $token
 		    if {$state(totalsize) == 0} {
 			# We know the transfer is complete only when the server
 			# closes the connection.
@@ -2885,13 +2885,13 @@ proc http::Event {sock token} {
 		    }
 		    set c $state(currentsize)
 		    set t $state(totalsize)
-		    Log ##Log non-chunk currentsize $c of totalsize $t -\
+		    ##Log non-chunk currentsize $c of totalsize $t -\
 			    token $token
 		    set block [read $sock $reqSize]
 		    set n [string length $block]
 		    if {$n >= 0} {
 			append state(body) $block
-			Log ##Log non-chunk [string length $state(body)] -\
+			##Log non-chunk [string length $state(body)] -\
 				token $token
 		    }
 		}
@@ -2902,7 +2902,7 @@ proc http::Event {sock token} {
 			incr state(currentsize) $n
 			set c $state(currentsize)
 			set t $state(totalsize)
-			Log ##Log another $n currentsize $c totalsize $t -\
+			##Log another $n currentsize $c totalsize $t -\
 				token $token
 		    }
 		    # If Content-Length - check for end of data.
@@ -2931,7 +2931,7 @@ 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} {
-	    Log ##Log eof - token $token
+	    ##Log eof - token $token
 	    if {[info exists $token]} {
 		set state(connection) close
 		if {$state(state) eq "complete"} {
diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
index 4823d19..5eb02d3 100644
--- a/tests/httpPipeline.test
+++ b/tests/httpPipeline.test
@@ -648,7 +648,7 @@ proc RunTest {header footer delay te} {
 # If still obscure, uncomment #Log and ##Log lines in the http package.
 # ------------------------------------------------------------------------------
 
-setHttpTestOptions -verbose 2
+setHttpTestOptions -verbose 0
 
 # ------------------------------------------------------------------------------
 # (4) Define the base URLs used for testing.  Each must have a query string.
-- 
cgit v0.12


From 754bb107b4100f394d445d589dddc94e59dd2d04 Mon Sep 17 00:00:00 2001
From: kjnash <k.j.nash@usa.net>
Date: Fri, 1 Jun 2018 18:34:07 +0000
Subject: Bugfix - always cleanup persistent socket.

---
 library/http/http.tcl | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index d16a8d9..c177374 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -264,8 +264,10 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
        || ([info exists state(-keepalive)] && !$state(-keepalive))
        || ([info exists state(connection)] && ($state(connection) eq "close"))
     } {
-	CloseSocket $state(sock) $token
 	set closeQueue 1
+	set connId $state(socketinfo)
+	set sock $state(sock)
+	CloseSocket $state(sock) $token
     } elseif {
 	  ([info exists state(-keepalive)] && $state(-keepalive))
        && ([info exists state(connection)] && ($state(connection) ne "close"))
@@ -286,11 +288,10 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     }
 
     if {    $closeQueue
-	 && [info exists state(socketinfo)]
-	 && [info exists socketMapping($state(socketinfo))]
-	 && ($socketMapping($state(socketinfo)) eq $state(sock))
+	 && [info exists socketMapping($connId)]
+	 && ($socketMapping($connId) eq $sock)
     } {
-	    http::CloseQueuedQueries $state(socketinfo) $token
+	http::CloseQueuedQueries $connId $token
     }
 
     return
-- 
cgit v0.12