Merge 8.6

6 files changed, 111 insertions, 75 deletions

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 87003e4..48e1b4b 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -11,7 +11,7 @@
 package require Tcl 8.6-
 # Keep this in sync with pkgIndex.tcl and with the install directories in
 # Makefiles
-package provide http 2.10a3
+package provide http 2.10a4
 
 namespace eval http {
     # Allow resourcing to not clobber existing data
@@ -270,26 +270,11 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
     }
 
     # Is this an upgrade request/response?
-    set upgradeResponse 0
-    if {    [info exists state(upgradeRequest)]
-         && [info exists state(http)]
-         && $state(upgradeRequest)
-         && ([ncode $token] eq {101})
-    } {
-        # An upgrade must be requested by the client.
-        # If 101 response, test server response headers for an upgrade.
-        set connectionHd {}
-        set upgradeHd {}
-        if {[dict exists $state(meta) connection]} {
-            set connectionHd [string tolower [dict get $state(meta) connection]]
-        }
-        if {[dict exists $state(meta) upgrade]} {
-            set upgradeHd [string tolower [dict get $state(meta) upgrade]]
-        }
-        if {($connectionHd eq {upgrade}) && ($upgradeHd ne {})} {
-            set upgradeResponse 1
-        }
-    }
+    set upgradeResponse \
+	[expr {    [info exists state(upgradeRequest)] && $state(upgradeRequest)
+		&& [info exists state(http)] && [ncode $token] eq {101}
+		&& [info exists state(connection)] && "upgrade" in $state(connection)
+		&& [info exists state(upgrade)] && "" ne $state(upgrade)}]
 
     if {  ($state(status) eq "timeout")
        || ($state(status) eq "error")
@@ -311,7 +296,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	catch {fileevent $state(sock) writable {}}
     } elseif {
           ([info exists state(-keepalive)] && !$state(-keepalive))
-       || ([info exists state(connection)] && ($state(connection) eq "close"))
+       || ([info exists state(connection)] && ("close" in $state(connection)))
     } {
 	set closeQueue 1
 	set connId $state(socketinfo)
@@ -319,7 +304,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
 	CloseSocket $state(sock) $token
     } elseif {
 	  ([info exists state(-keepalive)] && $state(-keepalive))
-       && ([info exists state(connection)] && ($state(connection) ne "close"))
+       && ([info exists state(connection)] && ("close" ni $state(connection)))
     } {
 	KeepSocket $token
     }
@@ -350,7 +335,7 @@ 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
+#	If $socketClosing(*), then ("close" in $state(connection)) and therefore
 #	this command will not be called by Finish.
 #
 # Arguments:
@@ -499,7 +484,7 @@ proc http::KeepSocket {token} {
 		(!$state(-pipeline))
 	     && [info exists socketWrQueue($connId)]
 	     && [llength $socketWrQueue($connId)]
-	     && ($state(connection) ne "close")
+	     && ("close" ni $state(connection))
 	} {
 	    # If not pipelined, (socketRdState eq Rready) tells us that we are
 	    # ready for the next write - there is no need to check
@@ -785,7 +770,7 @@ proc http::geturl {url args} {
 	-strict		boolean
 	-timeout	integer
 	-validate	boolean
-	-headers	dict
+	-headers	list
     }
     set state(charset)	$defaultCharset
     set options {
@@ -799,13 +784,18 @@ proc http::geturl {url args} {
     foreach {flag value} $args {
 	if {[regexp -- $pat $flag]} {
 	    # Validate numbers
-	    if {($flag eq "-headers") ? [catch {dict size $value}] :
-		([info exists type($flag)] && ![string is $type($flag) -strict $value])
+	    if {    [info exists type($flag)]
+	        && (![string is $type($flag) -strict $value])
 	    } {
 		unset $token
 		return -code error \
 		    "Bad value for $flag ($value), must be $type($flag)"
 	    }
+	    if {($flag eq "-headers") && ([llength $value] % 2 != 0)} {
+		unset $token
+		return -code error \
+		    "Bad value for $flag ($value), number of list elements must be even"
+	    }
 	    set state($flag) $value
 	} else {
 	    unset $token
@@ -1002,12 +992,14 @@ proc http::geturl {url args} {
     # c11a51c482]
     set state(accept-types) $http(-accept)
 
-    set state(upgradeRequest) [expr {
-           [dict exists $state(-headers) Upgrade]
-        && [dict exists $state(-headers) Connection]
-        && ([dict get $state(-headers) Connection] eq {Upgrade})
-        && ([dict get $state(-headers) Upgrade] ne {})
-    }]
+    # Check whether this is an Upgrade request.
+    set connectionValues [SplitCommaSeparatedFieldValue \
+			      [GetFieldValue $state(-headers) Connection]]
+    set connectionValues [string tolower $connectionValues]
+    set upgradeValues [SplitCommaSeparatedFieldValue \
+			   [GetFieldValue $state(-headers) Upgrade]]
+    set state(upgradeRequest) [expr {    "upgrade" in $connectionValues
+				      && [llength $upgradeValues] >= 1}]
 
     if {$isQuery || $isQueryChannel} {
 	# It's a POST.
@@ -1424,11 +1416,11 @@ proc http::Connected {token proto phost srvurl} {
     if {[catch {
 	set state(method) $how
 	puts $sock "$how $srvurl HTTP/$state(-protocol)"
-	if {[dict exists $state(-headers) Host]} {
+	set hostValue [GetFieldValue $state(-headers) Host]
+	if {$hostValue ne {}} {
 	    # Allow Host spoofing. [Bug 928154]
-	    set hostHdr [dict get $state(-headers) Host]
-	    regexp {^[^:]+} $hostHdr state(host)
-	    puts $sock "Host: $hostHdr"
+	    regexp {^[^:]+} $hostValue state(host)
+	    puts $sock "Host: $hostValue"
 	} elseif {$port == $defport} {
 	    # Don't add port in this case, to handle broken servers. [Bug
 	    # #504508]
@@ -1460,7 +1452,7 @@ proc http::Connected {token proto phost srvurl} {
 	# Proxy-Connection header field in any requests"
 	set accept_encoding_seen 0
 	set content_type_seen 0
-	dict for {key value} $state(-headers) {
+	foreach {key value} $state(-headers) {
 	    set value [string map [list \n "" \r ""] $value]
 	    set key [string map {" " -} [string trim $key]]
 	    if {[string equal -nocase $key "host"]} {
@@ -2673,7 +2665,7 @@ proc http::Event {sock token} {
 
 		if {    ([info exists state(connection)])
 		     && ([info exists socketMapping($state(socketinfo))])
-		     && ($state(connection) eq "keep-alive")
+		     && ("keep-alive" in $state(connection))
 		     && ($state(-keepalive))
 		     && (!$state(reusing))
 		     && ($state(-pipeline))
@@ -2695,7 +2687,7 @@ proc http::Event {sock token} {
 
 		if {    ([info exists state(connection)])
 		     && ([info exists socketMapping($state(socketinfo))])
-		     && ($state(connection) eq "close")
+		     && ("close" in $state(connection))
 		     && ($state(-keepalive))
 		} {
 		    # The server warns that it will close the socket after this
@@ -2743,6 +2735,19 @@ proc http::Event {sock token} {
 
 		set state(state) body
 
+		# According to
+		# https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
+		# any comma-separated "Connection:" list implies keep-alive, but I
+		# don't see this in the RFC so we'll play safe and
+		# scan any list for "close".
+		# Done here to support combining duplicate header field's values.
+		if {   [info exists state(connection)]
+		    && ("close" ni $state(connection))
+		    && ("keep-alive" ni $state(connection))
+		} {
+		    lappend state(connection) "keep-alive"
+		}
+
 		# 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
@@ -2766,7 +2771,7 @@ proc http::Event {sock token} {
 		#      (totalsize == 0).
 
 		if {    (!(    [info exists state(connection)]
-			    && ($state(connection) eq "close")
+			    && ("close" in $state(connection))
 			  )
 			)
 		     && (![info exists state(transfer)])
@@ -2832,32 +2837,14 @@ proc http::Event {sock token} {
 			}
 			proxy-connection -
 			connection {
-			    set tmpHeader [string trim [string tolower $value]]
 			    # RFC 7230 Section 6.1 states that a comma-separated
-			    # list is an acceptable value.  According to
-			    # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
-			    # any comma-separated list implies keep-alive, but I
-			    # don't see this in the RFC so we'll play safe and
-			    # scan any list for "close".
-			    if {$tmpHeader in {close keep-alive}} {
-				# The common cases, continue.
-			    } elseif {[string first , $tmpHeader] < 0} {
-				# Not a comma-separated list, not "close",
-				# therefore "keep-alive".
-				set tmpHeader keep-alive
-			    } else {
-				set tmpResult keep-alive
-				set tmpCsl [split $tmpHeader ,]
-				# Optional whitespace either side of separator.
-				foreach el $tmpCsl {
-				    if {[string trim $el] eq {close}} {
-					set tmpResult close
-					break
-				    }
-			        }
-				set tmpHeader $tmpResult
+			    # list is an acceptable value.
+			    foreach el [SplitCommaSeparatedFieldValue $value] {
+				lappend state(connection) [string tolower $el]
 			    }
-			    set state(connection) $tmpHeader
+			}
+			upgrade {
+			    set state(upgrade) [string trim $value]
 			}
 			set-cookie {
 			    if {$http(-cookiejar) ne ""} {
@@ -3662,6 +3649,52 @@ proc http::ReceiveChunked {chan command} {
     }
 }
 
+# http::SplitCommaSeparatedFieldValue --
+# 	Return the individual values of a comma-separated field value.
+#
+# Arguments:
+#	fieldValue	Comma-separated header field value.
+#
+# Results:
+#       List of values.
+proc http::SplitCommaSeparatedFieldValue {fieldValue} {
+    set r {}
+    foreach el [split $fieldValue ,] {
+	lappend r [string trim $el]
+    }
+    return $r
+}
+
+
+# http::GetFieldValue --
+# 	Return the value of a header field.
+#
+# Arguments:
+#	headers	Headers key-value list
+#	fieldName	Name of header field whose value to return.
+#
+# Results:
+#       The value of the fieldName header field
+#
+# Field names are matched case-insensitively (RFC 7230 Section 3.2).
+#
+# If the field is present multiple times, it is assumed that the field is
+# defined as a comma-separated list and the values are combined (by separating
+# them with commas, see RFC 7230 Section 3.2.2) and returned at once.
+proc http::GetFieldValue {headers fieldName} {
+    set r {}
+    foreach {field value} $headers {
+	if {[string equal -nocase $fieldName $field]} {
+	    if {$r eq {}} {
+		set r $value
+	    } else {
+		append r ", $value"
+	    }
+	}
+    }
+    return $r
+}
+
 proc http::make-transformation-chunked {chan command} {
     coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command
     chan event $chan readable [namespace current]::dechunk$chan
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index aaa37f9..5437859 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,2 @@
 if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
-package ifneeded http 2.10a3 [list tclPkgSetup $dir http 2.10a3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.10a4 [list tclPkgSetup $dir http 2.10a4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/library/manifest.txt b/library/manifest.txt
index 1cf251d..6b70b24 100644
--- a/library/manifest.txt
+++ b/library/manifest.txt
@@ -5,7 +5,7 @@ apply {{dir} {
   set ::test [info script]
   set isafe [interp issafe]
   foreach {safe package version file} {
-    0 http            2.10a3  {http http.tcl}
+    0 http            2.10a4  {http http.tcl}
     1 msgcat          1.7.1  {msgcat msgcat.tcl}
     1 opt             0.4.8  {opt optparse.tcl}
     0 cookiejar       0.2.0  {cookiejar cookiejar.tcl}
diff --git a/tests/http.test b/tests/http.test
index e8f8405..a6f1ce6 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -463,9 +463,12 @@ test http-3.33 {http::geturl application/xml is text} -body {
 } -cleanup {
     catch { http::cleanup $token }
 } -result {test 4660 /test}
-test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body {
-    http::geturl http://test/t -headers NoDict
-} -result {Bad value for -headers (NoDict), must be dict}
+test http-3.34 {http::geturl -headers not a list} -returnCodes error -body {
+    http::geturl http://test/t -headers \"
+} -result {Bad value for -headers ("), must be list}
+test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body {
+    http::geturl http://test/t -headers {List Length 3}
+} -result {Bad value for -headers (List Length 3), number of list elements must be even}
 
 test http-4.1 {http::Event} -body {
     set token [http::geturl $url -keepalive 0]
diff --git a/unix/Makefile.in b/unix/Makefile.in
index f6e442f..d0a9d86 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -1039,9 +1039,9 @@ install-libraries: libraries
 	    do \
 	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
 	    done
-	@echo "Installing package http 2.10a3 as a Tcl Module"
+	@echo "Installing package http 2.10a4 as a Tcl Module"
 	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
-		"$(MODULE_INSTALL_DIR)/8.6/http-2.10a3.tm"
+		"$(MODULE_INSTALL_DIR)/8.6/http-2.10a4.tm"
 	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"
 	@for i in $(TOP_DIR)/library/opt/*.tcl; do \
 	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
diff --git a/win/Makefile.in b/win/Makefile.in
index edeb46f..8fef0cc 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -878,8 +878,8 @@ install-libraries: libraries install-tzdata install-msgs
 	          $(ROOT_DIR)/library/cookiejar/*.gz; do \
 	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
 	    done;
-	@echo "Installing package http 2.10a3 as a Tcl Module";
-	@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10a3.tm";
+	@echo "Installing package http 2.10a4 as a Tcl Module";
+	@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10a4.tm";
 	@echo "Installing package opt 0.4.7";
 	@for j in $(ROOT_DIR)/library/opt/*.tcl; do \
 	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \