diff options
| author | kjnash <k.j.nash@usa.net> | 2022-09-11 16:32:30 (GMT) |
|---|---|---|
| committer | kjnash <k.j.nash@usa.net> | 2022-09-11 16:32:30 (GMT) |
| commit | e681ade127e237c8ebf20bbaf02f6c5757671b71 (patch) | |
| tree | 05241f1daceb328a12bea3d21ea0fc87cb358089 | |
| parent | b34f06a4afa5f57846efbe55f8dccb29e4611e2b (diff) | |
| download | tcl-e681ade127e237c8ebf20bbaf02f6c5757671b71.zip tcl-e681ade127e237c8ebf20bbaf02f6c5757671b71.tar.gz tcl-e681ade127e237c8ebf20bbaf02f6c5757671b71.tar.bz2 | |
Fix bug [3610253] - apply the patch supplied with the ticket, and add a test. REVIEW REQUESTED! Also fix -zip 0 so it sends "Accept-Encoding: identity".
| -rw-r--r-- | library/http/http.tcl | 10 | ||||
| -rw-r--r-- | tests/http11.test | 32 | ||||
| -rw-r--r-- | tests/httpd11.tcl | 4 |
3 files changed, 41 insertions, 5 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl index 691355c..551b323 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -2129,6 +2129,9 @@ proc http::Connected {token proto phost srvurl} { && $http(-zip) } { puts $sock "Accept-Encoding: gzip,deflate" + } elseif {!$accept_encoding_seen} { + puts $sock "Accept-Encoding: identity" + } else { } if {$isQueryChannel && ($state(querylength) == 0)} { # Try to determine size of data in channel. If we cannot seek, the @@ -4064,7 +4067,12 @@ proc http::CopyChunk {token chunk} { if {[info exists state(zlib)]} { set excess "" foreach stream $state(zlib) { - catch {set excess [$stream add -finalize $excess]} + catch { + $stream put -finalize $excess + set excess "" + set overflood "" + while {[set overflood [$stream get]] ne ""} { append excess $overflood } + } } puts -nonewline $state(-channel) $excess foreach stream $state(zlib) { $stream close } diff --git a/tests/http11.test b/tests/http11.test index b3d9edb..71ef4c7 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -84,6 +84,8 @@ proc check_crc {tok args} { makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html +makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 5000]\n</body></html>" largedoc.html + if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} @@ -371,15 +373,40 @@ test http11-2.1 "-channel, encoding gzip" -setup { http::wait $tok seek $chan 0 set data [read $chan] + set diff [expr {[file size testdoc.html] - [file size testfile.tmp]}] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ - [meta $tok transfer-encoding] + [meta $tok transfer-encoding] -- $diff bytes lost +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost} + +# Cf. Bug [3610253] "CopyChunk does not drain decompressor(s)" +# This test failed before the bugfix. +# The pass/fail depended on file size. +test http11-2.1.1 "-channel, encoding gzip" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set fileName largedoc.html +} -body { + set tok [http::geturl http://localhost:$httpd_port/$fileName \ + -timeout 5000 -channel $chan -headers {accept-encoding gzip}] + http::wait $tok + seek $chan 0 + set data [read $chan] + set diff [expr {[file size $fileName] - [file size testfile.tmp]}] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] -- $diff bytes lost } -cleanup { http::cleanup $tok close $chan removeFile testfile.tmp halt_httpd -} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked} +} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost} test http11-2.2 "-channel, encoding deflate" -setup { variable httpd [create_httpd] @@ -1033,6 +1060,7 @@ foreach p {create_httpd httpd_read halt_httpd meta check_crc} { if {[llength [info proc $p]]} {rename $p {}} } removeFile testdoc.html +removeFile largedoc.html unset -nocomplain httpd_port httpd p ::tcltest::cleanupTests diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 6570ee9..55b52fd 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -46,7 +46,7 @@ proc get-chunks {data {compression gzip}} { } set data "" - set chunker [make-chunk-generator $data 512] + set chunker [make-chunk-generator $data 671] while {[string length [set chunk [$chunker]]]} { append data $chunk } @@ -60,7 +60,7 @@ proc blow-chunks {data {ochan stdout} {compression gzip}} { compress { set data [zlib compress $data] } } - set chunker [make-chunk-generator $data 512] + set chunker [make-chunk-generator $data 671] while {[string length [set chunk [$chunker]]]} { puts -nonewline $ochan $chunk } |