Merge 8.7

3 files changed, 44 insertions, 21 deletions

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 326aede..88685ec 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -1260,6 +1260,7 @@ proc http::CreateToken {url args} {
 			   [GetFieldValue $state(-headers) Upgrade]]
     set state(upgradeRequest) [expr {    "upgrade" in $connectionValues
 				      && [llength $upgradeValues] >= 1}]
+    set state(connectionValues) $connectionValues
 
     if {$isQuery || $isQueryChannel} {
 	# It's a POST.
@@ -2104,24 +2105,25 @@ proc http::Connected {token proto phost srvurl} {
 	if {($state(-protocol) > 1.0) && $state(-keepalive)} {
 	    # Send this header, because a 1.1 server is not compelled to treat
 	    # this as the default.
-	    SendHeader $token Connection keep-alive
-	}
-	if {($state(-protocol) > 1.0) && !$state(-keepalive)} {
-	    SendHeader $token Connection close ;# RFC2616 sec 8.1.2.1
-	}
-	if {($state(-protocol) < 1.1)} {
+	    set ConnVal keep-alive
+	} elseif {($state(-protocol) > 1.0)} {
+	    # RFC2616 sec 8.1.2.1
+	    set ConnVal close
+	} else {
+	    # ($state(-protocol) <= 1.0)
 	    # RFC7230 A.1
 	    # Some server implementations of HTTP/1.0 have a faulty
 	    # implementation of RFC 2068 Keep-Alive.
 	    # Don't leave this to chance.
 	    # For HTTP/1.0 we have already "set state(connection) close"
 	    # and "state(-keepalive) 0".
-	    SendHeader $token Connection close
+	    set ConnVal close
 	}
 	# RFC7230 A.1 - "clients are encouraged not to send the
 	# Proxy-Connection header field in any requests"
 	set accept_encoding_seen 0
 	set content_type_seen 0
+	set connection_seen 0
 	foreach {key value} $state(-headers) {
 	    set value [string map [list \n "" \r ""] $value]
 	    set key [string map {" " -} [string trim $key]]
@@ -2141,6 +2143,24 @@ proc http::Connected {token proto phost srvurl} {
 		set contDone 1
 		set state(querylength) $value
 	    }
+	    if {[string equal -nocase $key "connection"]} {
+		# Remove "close" or "keep-alive" and use our own value.
+		# In an upgrade request, the upgrade is not guaranteed.
+		# Value "close" or "keep-alive" tells the server what to do
+		# if it refuses the upgrade.  We send a single "Connection"
+		# header because some websocket servers, e.g. civetweb, reject
+		# multiple headers. Bug [d01de3281f] of tcllib/websocket.
+		set connection_seen 1
+		set listVal $state(connectionValues)
+		if {[set pos [lsearch $listVal close]] != -1} {
+		    set listVal [lreplace $listVal $pos $pos]
+		}
+		if {[set pos [lsearch $listVal keep-alive]] != -1} {
+		    set listVal [lreplace $listVal $pos $pos]
+		}
+		lappend listVal $ConnVal
+		set value [join $listVal {, }]
+	    }
 	    if {[string length $key]} {
 		SendHeader $token $key $value
 	    }
@@ -2159,6 +2179,9 @@ proc http::Connected {token proto phost srvurl} {
 	    SendHeader $token Accept-Encoding identity
 	} else {
 	}
+	if {!$connection_seen} {
+	    SendHeader $token Connection $ConnVal
+	}
 	if {$isQueryChannel && ($state(querylength) == 0)} {
 	    # Try to determine size of data in channel. If we cannot seek, the
 	    # surrounding catch will trap us
diff --git a/tests/http.test b/tests/http.test
index c5aa2f5..11bf0f9 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -408,10 +408,10 @@ test http-3.27 {http::geturl: -headers override -type} -body {
     http::cleanup $token
 } -match regexp -result {(?n)Host .*
 User-Agent .*
-Connection close
 Content-Type {text/plain;charset=utf-8}
 Accept \*/\*
 Accept-Encoding .*
+Connection close
 Content-Length 5}
 test http-3.28 {http::geturl: -headers override -type default} -body {
     set token [http::geturl $url/headers -query dummy \
@@ -421,10 +421,10 @@ test http-3.28 {http::geturl: -headers override -type default} -body {
     http::cleanup $token
 } -match regexp -result {(?n)Host .*
 User-Agent .*
-Connection close
 Content-Type {text/plain;charset=utf-8}
 Accept \*/\*
 Accept-Encoding .*
+Connection close
 Content-Length 5}
 test http-3.29 {http::geturl IPv6 address} -body {
     # We only want to see if the URL gets parsed correctly. This is
@@ -461,9 +461,9 @@ test http-3.32 {http::geturl: -headers override -accept default} -body {
     http::cleanup $token
 } -match regexp -result {(?n)Host .*
 User-Agent .*
-Connection close
 Accept text/plain,application/tcl-test-value
 Accept-Encoding .*
+Connection close
 Content-Type application/x-www-form-urlencoded
 Content-Length 5}
 # Bug 838e99a76d
diff --git a/tests/io.test b/tests/io.test
index 4fd1a6b..3241625 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -9146,7 +9146,7 @@ test io-75.10 {incomplete shiftjis encoding read is ignored} -setup {
 
 
 
-test io-75.0 {channel modes} -setup {
+test io-76.0 {channel modes} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile r]
 } -constraints testchannel -body {
@@ -9156,7 +9156,7 @@ test io-75.0 {channel modes} -setup {
     removeFile dummy
 } -result {read {}}
 
-test io-75.1 {channel modes} -setup {
+test io-76.1 {channel modes} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile w]
 } -constraints testchannel -body {
@@ -9166,7 +9166,7 @@ test io-75.1 {channel modes} -setup {
     removeFile dummy
 } -result {{} write}
 
-test io-75.2 {channel modes} -setup {
+test io-76.2 {channel modes} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile r+]
 } -constraints testchannel -body {
@@ -9176,7 +9176,7 @@ test io-75.2 {channel modes} -setup {
     removeFile dummy
 } -result {read write}
 
-test io-75.3 {channel mode dropping} -setup {
+test io-76.3 {channel mode dropping} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile r]
 } -constraints testchannel -body {
@@ -9187,7 +9187,7 @@ test io-75.3 {channel mode dropping} -setup {
     removeFile dummy
 } -result {{read {}} {read {}}}
 
-test io-75.4 {channel mode dropping} -setup {
+test io-76.4 {channel mode dropping} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile r]
 } -constraints testchannel -body {
@@ -9197,7 +9197,7 @@ test io-75.4 {channel mode dropping} -setup {
     removeFile dummy
 } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"}
 
-test io-75.5 {channel mode dropping} -setup {
+test io-76.5 {channel mode dropping} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile w]
 } -constraints testchannel -body {
@@ -9208,7 +9208,7 @@ test io-75.5 {channel mode dropping} -setup {
     removeFile dummy
 } -result {{{} write} {{} write}}
 
-test io-75.6 {channel mode dropping} -setup {
+test io-76.6 {channel mode dropping} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile w]
 } -constraints testchannel -body {
@@ -9218,7 +9218,7 @@ test io-75.6 {channel mode dropping} -setup {
     removeFile dummy
 } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"}
 
-test io-75.7 {channel mode dropping} -setup {
+test io-76.7 {channel mode dropping} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile r+]
 } -constraints testchannel -body {
@@ -9229,7 +9229,7 @@ test io-75.7 {channel mode dropping} -setup {
     removeFile dummy
 } -result {{{} write} {read write}}
 
-test io-75.8 {channel mode dropping} -setup {
+test io-76.8 {channel mode dropping} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile r+]
 } -constraints testchannel -body {
@@ -9240,7 +9240,7 @@ test io-75.8 {channel mode dropping} -setup {
     removeFile dummy
 } -result {{read {}} {read write}}
 
-test io-75.9 {channel mode dropping} -setup {
+test io-76.9 {channel mode dropping} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile r+]
 } -constraints testchannel -body {
@@ -9251,7 +9251,7 @@ test io-75.9 {channel mode dropping} -setup {
     removeFile dummy
 } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"}
 
-test io-75.10 {channel mode dropping} -setup {
+test io-76.10 {channel mode dropping} -setup {
     set datafile [makeFile {some characters} dummy]
     set f [open $datafile r+]
 } -constraints testchannel -body {