diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/cmdAH.test | 4 | ||||
| -rw-r--r-- | tests/fCmd.test | 126 | ||||
| -rw-r--r-- | tests/http.test | 10 | ||||
| -rw-r--r-- | tests/http11.test | 161 | ||||
| -rw-r--r-- | tests/httpd11.tcl | 31 | ||||
| -rw-r--r-- | tests/proc.test | 7 |
6 files changed, 308 insertions, 31 deletions
diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 64991af..38ca521 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -355,7 +355,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -1686,7 +1686,7 @@ test cmdAH-29.6.1 { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} diff --git a/tests/fCmd.test b/tests/fCmd.test index 13f3720..73118f4 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -2556,6 +2556,132 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} - } return $r } -result {exists 1 readable 0 stat 0 {}} + +test fCmd-31.1 {file home} -body { + file home +} -result [file join $::env(HOME)] +test fCmd-31.2 {file home - obeys env} -setup { + set ::env(HOME) $::env(HOME)/xxx +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + file home +} -result [file join $::env(HOME) xxx] +test fCmd-31.3 {file home - \ -> /} -constraints win -setup { + set saved $::env(HOME) + set ::env(HOME) C:\\backslash\\path +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -result C:/backslash/path +test fCmd-31.4 {file home - error} -setup { + set saved $::env(HOME) + unset ::env(HOME) +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -returnCodes error -result {couldn't find HOME environment variable to expand path} +test fCmd-31.5 { + file home - relative path. Following 8.x ~ expansion behavior, relative + paths are not made absolute +} -setup { + set saved $::env(HOME) + set ::env(HOME) relative/path +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -result relative/path +test fCmd-31.6 {file home USER} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + file home $::tcl_platform(user) +} -match glob -result "*$::tcl_platform(user)*" +test fCmd-31.7 {file home UNKNOWNUSER} -body { + file home nosuchuser +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-31.8 {file home extra arg} -body { + file home $::tcl_platform(user) arg +} -returnCodes error -result {wrong # args: should be "file home ?user?"} + +test fCmd-32.1 {file tildeexpand ~} -body { + file tildeexpand ~ +} -result [file join $::env(HOME)] +test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup { + set ::env(HOME) $::env(HOME)/xxx +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + file tildeexpand ~ +} -result [file join $::env(HOME) xxx] +test fCmd-32.3 {file tildeexpand ~ - error} -setup { + set saved $::env(HOME) + unset ::env(HOME) +} -cleanup { + set ::env(HOME) $saved +} -body { + file tildeexpand ~ +} -returnCodes error -result {couldn't find HOME environment variable to expand path} +test fCmd-32.4 { + file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative + paths are not made absolute +} -setup { + set saved $::env(HOME) + set ::env(HOME) relative/path +} -cleanup { + set ::env(HOME) $saved +} -body { + file tildeexpand ~ +} -result relative/path +test fCmd-32.5 {file tildeexpand ~USER} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + file tildeexpand ~$::tcl_platform(user) +} -match glob -result "*$::tcl_platform(user)*" +test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body { + file tildeexpand ~nosuchuser +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-32.7 {file tildeexpand ~extra arg} -body { + file tildeexpand ~ arg +} -returnCodes error -result {wrong # args: should be "file tildeexpand path"} +test fCmd-32.8 {file tildeexpand ~/path} -body { + file tildeexpand ~/foo +} -result [file join $::env(HOME)/foo] +test fCmd-32.9 {file tildeexpand ~USER/bar} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + file tildeexpand ~$::tcl_platform(user)/bar +} -match glob -result "*$::tcl_platform(user)*/bar" +test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body { + file tildeexpand ~nosuchuser/foo +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-32.11 {file tildeexpand /~/path} -body { + file tildeexpand /~/foo +} -result /~/foo +test fCmd-32.12 {file tildeexpand /~user/path} -body { + file tildeexpand /~$::tcl_platform(user)/foo +} -result /~$::tcl_platform(user)/foo +test fCmd-32.13 {file tildeexpand ./~} -body { + file tildeexpand ./~ +} -result ./~ +test fCmd-32.14 {file tildeexpand relative/path} -body { + file tildeexpand relative/path +} -result relative/path +test fCmd-32.15 {file tildeexpand ~\\path} -body { + file tildeexpand ~\\foo +} -constraints win -result [file join $::env(HOME)/foo] +test fCmd-32.16 {file tildeexpand ~USER\\bar} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + file tildeexpand ~$::tcl_platform(user)\\bar +} -constraints win -match glob -result "*$::tcl_platform(user)*/bar" + # cleanup cleanup diff --git a/tests/http.test b/tests/http.test index 26ba710..e88210a 100644 --- a/tests/http.test +++ b/tests/http.test @@ -145,7 +145,7 @@ test http-2.8 {http::CharsetToEncoding} { test http-3.1 {http::geturl} -returnCodes error -body { http::geturl -bogus flag -} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate} +} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -guesstype, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate} test http-3.2 {http::geturl} -returnCodes error -body { http::geturl http:junk @@ -390,7 +390,7 @@ test http-3.25 {http::meta} -setup { } -cleanup { http::cleanup $token unset -nocomplain m token -} -result {Content-Length Content-Type Date} +} -result {content-length content-type date} test http-3.26 {http::meta} -setup { unset -nocomplain m token } -body { @@ -400,7 +400,7 @@ test http-3.26 {http::meta} -setup { } -cleanup { http::cleanup $token unset -nocomplain m token -} -result {Content-Length Content-Type Date X-Check} +} -result {content-length content-type date x-check} test http-3.27 {http::geturl: -headers override -type} -body { set token [http::geturl $url/headers -type "text/plain" -query dummy \ -headers [list "Content-Type" "text/plain;charset=utf-8"]] @@ -485,7 +485,7 @@ test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] upvar #0 $token data array set meta $data(meta) - expr {($data(totalsize) == $meta(Content-Length))} + expr {($data(totalsize) == $meta(content-length))} } -cleanup { http::cleanup $token } -result 1 @@ -493,7 +493,7 @@ test http-4.2 {http::Event} -body { set token [http::geturl $url] upvar #0 $token data array set meta $data(meta) - string compare $data(type) [string trim $meta(Content-Type)] + string compare $data(type) [string trim $meta(content-type)] } -cleanup { http::cleanup $token } -result 0 diff --git a/tests/http11.test b/tests/http11.test index 346e334..71ef4c7 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -51,15 +51,11 @@ proc halt_httpd {} { } proc meta {tok {key ""}} { - set meta [http::meta $tok] - if {$key ne ""} { - if {[dict exists $meta $key]} { - return [dict get $meta $key] - } else { - return "" - } + if {$key eq ""} { + return [http::meta $tok] + } else { + return [http::metaValue $tok $key] } - return $meta } proc state {tok {key ""}} { @@ -88,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} @@ -128,11 +126,12 @@ test http11-1.1 "normal,gzip,non-chunked" -setup { -timeout 10000 -headers {accept-encoding gzip}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ - [meta $tok content-encoding] [meta $tok transfer-encoding] + [meta $tok content-encoding] [meta $tok transfer-encoding] \ + [http::meta $tok content-encoding] [http::meta $tok transfer-encoding] } -cleanup { http::cleanup $tok halt_httpd -} -result {ok {HTTP/1.1 200 OK} ok gzip {}} +} -result {ok {HTTP/1.1 200 OK} ok gzip {} {content-encoding gzip} {}} test http11-1.2 "normal,deflated,non-chunked" -setup { variable httpd [create_httpd] @@ -147,7 +146,22 @@ test http11-1.2 "normal,deflated,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate {}} -test http11-1.3 "normal,compressed,non-chunked" -setup { +test http11-1.2.1 "normal,deflated,non-chunked,msdeflate" -setup { + variable httpd [create_httpd] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \ + -timeout 10000 -headers {accept-encoding deflate}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok] \ + [meta $tok content-encoding] [meta $tok transfer-encoding] +} -cleanup { + http::cleanup $tok + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok deflate {}} + +test http11-1.3 "normal,compressed,non-chunked" -constraints badCompress -setup { + # The Tcl "compress" algorithm appears to be incorrect and has been removed. + # Bug [a13b9d0ce1]. variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -193,11 +207,12 @@ test http11-1.6 "normal, specify 1.1 " -setup { -protocol 1.1 -timeout 10000] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ - [meta $tok connection] [meta $tok transfer-encoding] + [meta $tok connection] [meta $tok transfer-encoding] \ + [http::meta $tok connection] [http::meta $tok transfer-encoding] } -cleanup { http::cleanup $tok halt_httpd -} -result {ok {HTTP/1.1 200 OK} ok close chunked} +} -result {ok {HTTP/1.1 200 OK} ok close chunked {connection close} {transfer-encoding chunked}} test http11-1.7 "normal, 1.1 and keepalive " -setup { variable httpd [create_httpd] @@ -251,7 +266,22 @@ test http11-1.10 "normal,deflate,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate chunked} -test http11-1.11 "normal,compress,chunked" -setup { +test http11-1.10.1 "normal,deflate,chunked,msdeflate" -setup { + variable httpd [create_httpd] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ + -timeout 10000 -headers {accept-encoding deflate}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok] \ + [meta $tok content-encoding] [meta $tok transfer-encoding] +} -cleanup { + http::cleanup $tok + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok deflate chunked} + +test http11-1.11 "normal,compress,chunked" -constraints badCompress -setup { + # The Tcl "compress" algorithm appears to be incorrect and has been removed. + # Bug [a13b9d0ce1]. variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -343,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} +} -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 -- 0 bytes lost} test http11-2.2 "-channel, encoding deflate" -setup { variable httpd [create_httpd] @@ -372,7 +427,28 @@ test http11-2.2 "-channel, encoding deflate" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate chunked} -test http11-2.3 "-channel,encoding compress" -setup { +test http11-2.2.1 "-channel, encoding deflate,msdeflate" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ + -timeout 5000 -channel $chan -headers {accept-encoding deflate}] + 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] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked} + +test http11-2.3 "-channel,encoding compress" -constraints badCompress -setup { + # The Tcl "compress" algorithm appears to be incorrect and has been removed. + # Bug [a13b9d0ce1]. variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -524,7 +600,32 @@ test http11-2.7 "-channel,encoding deflate,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0} -test http11-2.8 "-channel,encoding compress,non-chunked" -setup { +test http11-2.7.1 "-channel,encoding deflate,non-chunked,msdeflate" -constraints knownBug -setup { + # Test fails because a -channel can only try one un-deflate algorithm, and the + # compliant "decompress" is tried, not the non-compliant "inflate" of + # the MS browser implementation. + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \ + -timeout 5000 -channel $chan -headers {accept-encoding deflate}] + 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 {[file size testdoc.html]-[file size testfile.tmp]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0} + +test http11-2.8 "-channel,encoding compress,non-chunked" -constraints badCompress -setup { + # The Tcl "compress" algorithm appears to be incorrect and has been removed. + # Bug [a13b9d0ce1]. variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -585,6 +686,27 @@ test http11-2.10 "-channel,deflate,keepalive" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0} +test http11-2.10.1 "-channel,deflate,keepalive,msdeflate" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ + -timeout 5000 -channel $chan -keepalive 1 \ + -headers {accept-encoding deflate}] + 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 {[file size testdoc.html]-[file size testfile.tmp]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0} + test http11-2.11 "-channel,identity,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -623,7 +745,7 @@ test http11-2.12 "-channel,negotiate,keepalive" -setup { close $chan removeFile testfile.tmp halt_httpd -} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0} +} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate 0} # ------------------------------------------------------------------------- @@ -938,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 d0624f8..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 } @@ -160,6 +160,12 @@ proc Service {chan addr port} { if {$protocol eq "HTTP/1.1"} { foreach enc [split [dict get? $meta accept-encoding] ,] { set enc [string trim $enc] + # The current implementation of "compress" appears to be + # incorrect (bug [a13b9d0ce1]). Keep it here for + # experimentation only. The tests that use it have the + # constraint "badCompress". The client code in http has + # been removed, but can be restored from comments if + # experimentation is desired. if {$enc in {deflate gzip compress}} { set encoding $enc break @@ -171,6 +177,7 @@ proc Service {chan addr port} { } set nosendclose 0 + set msdeflate 0 foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { @@ -178,6 +185,7 @@ proc Service {chan addr port} { close {set close 1 ; set transfer 0} transfer {set transfer $val} content-type {set type $val} + msdeflate {set msdeflate $val} } } if {$protocol eq "HTTP/1.1"} { @@ -211,10 +219,23 @@ proc Service {chan addr port} { flush $chan chan configure $chan -buffering full -translation binary + if {$encoding eq {deflate}} { + # When http.tcl uses the correct decoder (bug [a13b9d0ce1]) for + # "accept-encoding deflate", i.e. "zlib decompress", this choice of + # encoding2 allows the tests to pass. It appears to do "deflate" + # correctly, but this has not been verified with a non-Tcl client. + set encoding2 compress + } else { + set encoding2 $encoding + } if {$transfer eq "chunked"} { - blow-chunks $data $chan $encoding - } elseif {$encoding ne "identity"} { - puts -nonewline $chan [zlib $encoding $data] + blow-chunks $data $chan $encoding2 + } elseif {$encoding2 ne "identity" && $msdeflate eq {1}} { + puts -nonewline $chan [string range [zlib $encoding2 $data] 2 end-4] + # Used in some tests of "deflate" to produce the non-RFC-compliant + # Microsoft version of "deflate". + } elseif {$encoding2 ne "identity"} { + puts -nonewline $chan [zlib $encoding2 $data] } else { puts -nonewline $chan $data } diff --git a/tests/proc.test b/tests/proc.test index b87af57..118dca1 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -412,6 +412,13 @@ test proc-7.5 {[631b4c45df] Crash in argument processing} { unset -nocomplain val } {} +test proc-7.6 {[51d5f22997] Crash in argument processing} -cleanup { + rename foo {} +} -body { + proc foo {{x {}} {y {}} args} {} + foo +} -result {} + # cleanup catch {rename p ""} |