Merge old 8.7 9a14272d20

4 files changed, 230 insertions, 2 deletions

diff --git a/tests/http11.test b/tests/http11.test
index 762788e..989b00f 100644
--- a/tests/http11.test
+++ b/tests/http11.test
@@ -280,6 +280,20 @@ test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup {
 
 # -------------------------------------------------------------------------
 
+proc progress {var token total current} {
+    upvar #0 $var log
+    set log [list $current $total]
+    return
+}
+
+proc progressPause {var token total current} {
+    upvar #0 $var log
+    set log [list $current $total]
+    after 100 set ::WaitHere 0
+    vwait ::WaitHere
+    return
+}
+
 test http11-2.0 "-channel" -setup {
     variable httpd [create_httpd]
     set chan [open [makeFile {} testfile.tmp] wb+]
@@ -376,6 +390,58 @@ test http11-2.4 "-channel,encoding identity" -setup {
     halt_httpd
 } -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
 
+test http11-2.4.1 "-channel,encoding identity with -progress" -setup {
+    variable httpd [create_httpd]
+    set chan [open [makeFile {} testfile.tmp] wb+]
+    set logdata ""
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
+                 -timeout 5000 -channel $chan \
+                 -headers {accept-encoding identity} \
+                 -progress [namespace code [list progress logdata]]]
+
+    http::wait $tok
+    seek $chan 0
+    set data [read $chan]
+    list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+        [meta $tok connection] [meta $tok content-encoding]\
+        [meta $tok transfer-encoding] \
+        [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \
+        [expr {[lindex $logdata 0] - [string length $data]}]
+} -cleanup {
+    http::cleanup $tok
+    close $chan
+    removeFile testfile.tmp
+    halt_httpd
+    unset -nocomplain logdata data
+} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0}
+
+test http11-2.4.2 "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup {
+    variable httpd [create_httpd]
+    set chan [open [makeFile {} testfile.tmp] wb+]
+    set logdata ""
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
+                 -timeout 5000 -channel $chan \
+                 -headers {accept-encoding identity} \
+                 -progress [namespace code [list progressPause logdata]]]
+
+    http::wait $tok
+    seek $chan 0
+    set data [read $chan]
+    list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+        [meta $tok connection] [meta $tok content-encoding]\
+        [meta $tok transfer-encoding] \
+        [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \
+        [expr {[lindex $logdata 0] - [string length $data]}]
+} -cleanup {
+    http::cleanup $tok
+    close $chan
+    removeFile testfile.tmp
+    halt_httpd
+    unset -nocomplain logdata data ::WaitHere
+} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0}
+
 test http11-2.5 "-channel,encoding unsupported" -setup {
     variable httpd [create_httpd]
     set chan [open [makeFile {} testfile.tmp] wb+]
@@ -555,6 +621,16 @@ proc handler {var sock token} {
     return [string length $chunk]
 }
 
+proc handlerPause {var sock token} {
+    upvar #0 $var data
+    set chunk [read $sock]
+    append data $chunk
+    #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
+    after 100 set ::WaitHere 0
+    vwait ::WaitHere
+    return [string length $chunk]
+}
+
 test http11-3.0 "-handler,close,identity" -setup {
     variable httpd [create_httpd]
     set testdata ""
@@ -626,6 +702,135 @@ test http11-3.3 "-handler,keepalive,chunked" -setup {
     halt_httpd
 } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
 
+# http11-3.4
+# This test is a blatant attempt to confuse the client by instructing the server
+# to send neither "Connection: close" nor "Content-Length" when in non-chunked
+# mode.
+# The client has no way to know the response-body is complete unless the
+# server signals this by closing the connection.
+# In an HTTP/1.1 response the absence of "Connection: close" means
+# "Connection: keep-alive", i.e. the server will keep the connection
+# open.  In HTTP/1.0 this is not the case, and this is a test that
+# the Tcl client assumes "Connection: close" by default in HTTP/1.0.
+test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup {
+    variable httpd [create_httpd]
+    set testdata ""
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&nosendclose=any \
+                 -timeout 10000 -handler [namespace code [list handler testdata]]]
+    http::wait $tok
+    list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
+        [meta $tok connection] [meta $tok content-encoding] \
+        [meta $tok transfer-encoding] \
+        [expr {[file size testdoc.html]-[string length $testdata]}]
+} -cleanup {
+    http::cleanup $tok
+    unset -nocomplain testdata
+    halt_httpd
+} -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0}
+
+# It is not forbidden for a handler to enter the event loop.
+test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup {
+    variable httpd [create_httpd]
+    set testdata ""
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
+                 -timeout 10000 -handler [namespace code [list handlerPause testdata]]]
+    http::wait $tok
+    list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
+        [meta $tok connection] [meta $tok content-encoding] \
+        [meta $tok transfer-encoding] \
+        [expr {[file size testdoc.html]-[string length $testdata]}]
+} -cleanup {
+    http::cleanup $tok
+    unset -nocomplain testdata ::WaitHere
+    halt_httpd
+} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
+
+test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setup {
+    variable httpd [create_httpd]
+    set testdata ""
+    set logdata ""
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
+                 -timeout 10000 -handler [namespace code [list handler testdata]] \
+                 -progress [namespace code [list progress logdata]]]
+    http::wait $tok
+    list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
+        [meta $tok connection] [meta $tok content-encoding] \
+        [meta $tok transfer-encoding] \
+        [expr {[file size testdoc.html]-[string length $testdata]}] \
+        [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \
+        [expr {[lindex $logdata 0] - [string length $testdata]}]
+} -cleanup {
+    http::cleanup $tok
+    unset -nocomplain testdata logdata ::WaitHere
+    halt_httpd
+} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0}
+
+test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup {
+    variable httpd [create_httpd]
+    set testdata ""
+    set logdata ""
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
+                 -timeout 10000 -handler [namespace code [list handler testdata]] \
+                 -progress [namespace code [list progressPause logdata]]]
+    http::wait $tok
+    list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
+        [meta $tok connection] [meta $tok content-encoding] \
+        [meta $tok transfer-encoding] \
+        [expr {[file size testdoc.html]-[string length $testdata]}] \
+        [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \
+        [expr {[lindex $logdata 0] - [string length $testdata]}]
+} -cleanup {
+    http::cleanup $tok
+    unset -nocomplain testdata logdata ::WaitHere
+    halt_httpd
+} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0}
+
+test http11-3.8 "close,identity no -handler but with -progress" -setup {
+    variable httpd [create_httpd]
+    set logdata ""
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
+                 -timeout 10000 \
+                 -progress [namespace code [list progress logdata]] \
+                 -headers {accept-encoding {}}]
+    http::wait $tok
+    list [http::status $tok] [http::code $tok] [check_crc $tok]\
+        [meta $tok connection] [meta $tok content-encoding] \
+        [meta $tok transfer-encoding] \
+        [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \
+        [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \
+        [expr {[lindex $logdata 0] - [string length [http::data $tok]]}]
+} -cleanup {
+    http::cleanup $tok
+    unset -nocomplain logdata ::WaitHere
+    halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0}
+
+test http11-3.9 "close,identity no -handler but with -progress progressPause enters event loop" -setup {
+    variable httpd [create_httpd]
+    set logdata ""
+} -body {
+    set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
+                 -timeout 10000 \
+                 -progress [namespace code [list progressPause logdata]] \
+                 -headers {accept-encoding {}}]
+    http::wait $tok
+    list [http::status $tok] [http::code $tok] [check_crc $tok]\
+        [meta $tok connection] [meta $tok content-encoding] \
+        [meta $tok transfer-encoding] \
+        [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \
+        [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \
+        [expr {[lindex $logdata 0] - [string length [http::data $tok]]}]
+} -cleanup {
+    http::cleanup $tok
+    unset -nocomplain logdata ::WaitHere
+    halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0}
+
 test http11-4.0 "normal post request" -setup {
     variable httpd [create_httpd]
 } -body {
diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
index 7880494..0b02319 100644
--- a/tests/httpd11.tcl
+++ b/tests/httpd11.tcl
@@ -170,14 +170,19 @@ proc Service {chan addr port} {
             set close 1
         }
 
+        set nosendclose 0
         foreach pair [split $query &] {
             if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
             switch -exact -- $key {
+                nosendclose  {set nosendclose 1}
                 close        {set close 1 ; set transfer 0}
                 transfer     {set transfer $val}
                 content-type {set type $val}
             }
         }
+        if {$protocol eq "HTTP/1.1"} {
+            set nosendclose 0
+        }
 
         chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
         Puts $chan "$protocol $code"
@@ -186,12 +191,16 @@ proc Service {chan addr port} {
         if {$req eq "POST"} {
             Puts $chan [format "x-query-length: %d" [string length $query]]
         }
-        if {$close} {
+        if {$close && (!$nosendclose)} {
             Puts $chan "connection: close"
         }
 	Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
-        if {$encoding eq "identity"} {
+        if {$encoding eq "identity" && (!$nosendclose)} {
             Puts $chan "content-length: [string length $data]"
+        } elseif {$encoding eq "identity"} {
+            # This is a blatant attempt to confuse the client by sending neither
+            # "Connection: close" nor "Content-Length" when in non-chunked mode.
+            # See test http11-3.4.
         } else {
             Puts $chan "content-encoding: $encoding"
         }
diff --git a/tests/regexp.test b/tests/regexp.test
index bae1217..ee92a35 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -192,6 +192,17 @@ test regexp-3.7 {getting substrings back from regexp} {
     set foo 1; set f2 1; set f3 1; set f4 1
     list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
 } {1 {1 2} {1 1} {-1 -1} {2 2}}
+test regexp-3.8a {-indices by multi-byte utf-8} {
+    regexp -inline -indices {(\w+)-(\w+)} \
+	"gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"
+} {{0 10} {0 3} {5 10}}
+test regexp-3.8b {-indices by multi-byte utf-8, from -start position} {
+    list\
+	[regexp -inline -indices -start 3 {(\w+)-(\w+)} \
+	"gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \
+	[regexp -inline -indices -start 4 {(\w+)-(\w+)} \
+	"gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"]
+} {{{3 10} {3 3} {5 10}} {}}
 
 test regexp-4.1 {-nocase option to regexp} {
     regexp -nocase foo abcFOo
diff --git a/tests/socket.test b/tests/socket.test
index 1c1a89d..66a1bf1 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -291,6 +291,9 @@ proc getPort sock {
     lindex [fconfigure $sock -sockname] 2
 }
 
+# Some tests in this file are known to hang *occasionally* on OSX; stop the
+# worst offenders.
+testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
 
 # ----------------------------------------------------------------------