Merge bug-c2dc1da315-for-8-6

6 files changed, 231 insertions, 7 deletions

diff --git a/doc/http.n b/doc/http.n
index e8c8c90..26bf943 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -250,6 +250,10 @@ proc httpHandlerCallback {socket token} {
     return $nbytes
 }
 .CE
+.PP
+The \fBhttp::geturl\fR code for the \fB-handler\fR option is not compatible with either compression or chunked transfer-encoding.  If \fB-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR").
+.PP
+If options \fB-handler\fR and \fB-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel.  The name of the channel is available to the handler as element \fB-channel\fR of the token array.
 .RE
 .TP
 \fB\-headers\fR \fIkeyvaluelist\fR
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 8b5d686..9d3e5ca 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.9.4
+package provide http 2.9.5
 
 namespace eval http {
     # Allow resourcing to not clobber existing data
@@ -1646,9 +1646,51 @@ proc http::ReceiveResponse {token} {
     Log ^D$tk begin receiving response - token $token
 
     coroutine ${token}EventCoroutine http::Event $sock $token
-    fileevent $sock readable ${token}EventCoroutine
+    if {[info exists state(-handler)] || [info exists state(-progress)]} {
+        fileevent $sock readable [list http::EventGateway $sock $token]
+    } else {
+        fileevent $sock readable ${token}EventCoroutine
+    }
+    return
 }
 
+
+# http::EventGateway
+#
+#	Bug [c2dc1da315].
+#	- Recursive launch of the coroutine can occur if a -handler or -progress
+#	  callback is used, and the callback command enters the event loop.
+#	- To prevent this, the fileevent "binding" is disabled while the
+#	  coroutine is in flight.
+#	- If a recursive call occurs despite these precautions, it is not
+#	  trapped and discarded here, because it is better to report it as a
+#	  bug.
+#	- Although this solution is believed to be sufficiently general, it is
+#	  used only if -handler or -progress is specified.  In other cases,
+#	  the coroutine is called directly.
+
+proc http::EventGateway {sock token} {
+    variable $token
+    upvar 0 $token state
+    fileevent $sock readable {}
+    catch {${token}EventCoroutine} res opts
+    if {[info commands ${token}EventCoroutine] ne {}} {
+        # The coroutine can be deleted by completion (a non-yield return), by
+        # http::Finish (when there is a premature end to the transaction), by
+        # http::reset or http::cleanup, or if the caller set option -channel
+        # but not option -handler: in the last case reading from the socket is
+        # now managed by commands ::http::Copy*, http::ReceiveChunked, and
+        # http::make-transformation-chunked.
+        #
+        # Catch in case the coroutine has closed the socket.
+        catch {fileevent $sock readable [list http::EventGateway $sock $token]}
+    }
+
+    # If there was an error, re-throw it.
+    return -options $opts $res
+}
+
+
 # http::NextPipelinedWrite
 #
 # - Connecting a socket to a token for writing is done by this command and by
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index 1cc8f46..74c4841 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.9.4 [list tclPkgSetup $dir http 2.9.4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.9.5 [list tclPkgSetup $dir http 2.9.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/tests/http11.test b/tests/http11.test
index 240bfef..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 ""
@@ -653,6 +729,108 @@ test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connecti
     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/unix/Makefile.in b/unix/Makefile.in
index 07ce3b7..87f0844 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -944,8 +944,8 @@ install-libraries: libraries
 	    do \
 	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \
 	    done;
-	@echo "Installing package http 2.9.4 as a Tcl Module";
-	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.4.tm";
+	@echo "Installing package http 2.9.5 as a Tcl Module";
+	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.5.tm";
 	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
 	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
 	    do \
diff --git a/win/Makefile.in b/win/Makefile.in
index 110f7bf..dee6656 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -719,8 +719,8 @@ install-libraries: libraries install-tzdata install-msgs
 	    do \
 	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
 	    done;
-	@echo "Installing package http 2.9.4 as a Tcl Module";
-	@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.4.tm";
+	@echo "Installing package http 2.9.5 as a Tcl Module";
+	@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.5.tm";
 	@echo "Installing library opt0.4 directory";
 	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
 	    do \