diff options
author | dgp <dgp@users.sourceforge.net> | 2017-06-22 12:25:35 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2017-06-22 12:25:35 (GMT) |
commit | 69201f94bdcef502012a231e2100bceef5062f90 (patch) | |
tree | 318ce059db03075568b505a7caa2624fce436e13 /tests | |
parent | 6aa0cc7188b6df1dac97b03bc0b9240aa780799b (diff) | |
parent | f57dacd4955b9dd474cfd9d4e4d55cac22990f6c (diff) | |
download | tcl-69201f94bdcef502012a231e2100bceef5062f90.zip tcl-69201f94bdcef502012a231e2100bceef5062f90.tar.gz tcl-69201f94bdcef502012a231e2100bceef5062f90.tar.bz2 |
merge trunktip_463
Diffstat (limited to 'tests')
-rw-r--r-- | tests/binary.test | 12 | ||||
-rw-r--r-- | tests/chanio.test | 8 | ||||
-rw-r--r-- | tests/clock.test | 55 | ||||
-rw-r--r-- | tests/cmdAH.test | 4 | ||||
-rw-r--r-- | tests/coroutine.test | 39 | ||||
-rw-r--r-- | tests/encoding.test | 49 | ||||
-rw-r--r-- | tests/fileName.test | 3 | ||||
-rw-r--r-- | tests/fileSystem.test | 10 | ||||
-rw-r--r-- | tests/format.test | 86 | ||||
-rw-r--r-- | tests/http.test | 16 | ||||
-rw-r--r-- | tests/httpd | 7 | ||||
-rw-r--r-- | tests/httpold.test | 6 | ||||
-rw-r--r-- | tests/incr.test | 12 | ||||
-rw-r--r-- | tests/interp.test | 4 | ||||
-rw-r--r-- | tests/io.test | 4 | ||||
-rw-r--r-- | tests/link.test | 2 | ||||
-rw-r--r-- | tests/load.test | 25 | ||||
-rw-r--r-- | tests/nre.test | 6 | ||||
-rw-r--r-- | tests/oo.test | 38 | ||||
-rw-r--r-- | tests/scan.test | 18 | ||||
-rw-r--r-- | tests/socket.test | 41 | ||||
-rw-r--r-- | tests/string.test | 53 | ||||
-rw-r--r-- | tests/unixInit.test | 17 | ||||
-rw-r--r-- | tests/utf.test | 53 | ||||
-rw-r--r-- | tests/util.test | 32 | ||||
-rw-r--r-- | tests/zlib.test | 66 |
26 files changed, 513 insertions, 153 deletions
diff --git a/tests/binary.test b/tests/binary.test index 7738f69..1ee815b 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -1506,6 +1506,18 @@ test binary-37.9 {GetFormatSpec: numbers} { binary scan $x f* bla set bla } {1.0 -1.0 2.0 -2.0 0.0} +test binary-37.10 {GetFormatSpec: count overflow} { + binary scan x a[format %ld 0x7fffffff] r +} 0 +test binary-37.11 {GetFormatSpec: count overflow} { + binary scan x a[format %ld 0x10000000] r +} 0 +test binary-37.12 {GetFormatSpec: count overflow} { + binary scan x a[format %ld 0x100000000] r +} 0 +test binary-37.13 {GetFormatSpec: count overflow} { + binary scan x a[format %lld 0x10000000000000000] r +} 0 test binary-38.1 {FormatNumber: word alignment} { set x [binary format c1s1 1 1] diff --git a/tests/chanio.test b/tests/chanio.test index 075b64e..8c74566 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -5338,7 +5338,7 @@ test chan-io-40.2 {POSIX open access modes: CREAT} -setup { } -constraints {unix} -body { set f [open $path(test3) {WRONLY CREAT} 0600] file stat $path(test3) stats - set x [format "0%o" [expr $stats(mode)&0o777]] + set x [format "%#o" [expr $stats(mode)&0o777]] chan puts $f "line 1" chan close $f set f [open $path(test3) r] @@ -5352,8 +5352,8 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup { # This test only works if your umask is 2, like ouster's. chan close [open $path(test3) {WRONLY CREAT}] file stat $path(test3) stats - format "0%o" [expr $stats(mode)&0o777] -} -result [format %04o [expr {0o666 & ~ $umaskValue}]] + format "%#o" [expr $stats(mode)&0o777] +} -result [format %#4o [expr {0o666 & ~ $umaskValue}]] test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -body { @@ -6775,7 +6775,7 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { } 5 test chan-io-52.11 {TclCopyChannel & encodings} -setup { set f [open $path(utf8-fcopy.txt) w] - fconfigure $f -encoding utf-8 + fconfigure $f -encoding utf-8 -translation lf puts $f "\u0410\u0410" close $f } -constraints {fcopy} -body { diff --git a/tests/clock.test b/tests/clock.test index 6a0fecd..b1afa39 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -34992,10 +34992,6 @@ test clock-29.1800 {time parsing} { } 86399 # END testcases29 - -# BEGIN testcases30 - -# Test [clock add] test clock-30.1 {clock add years} { set t [clock scan 2000-01-01 -format %Y-%m-%d -timezone :UTC] set f [clock add $t 1 year -timezone :UTC] @@ -35222,57 +35218,6 @@ test clock-30.25 {clock add seconds at DST conversion} { set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S %z} \ -timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00] } {2004-10-31 01:00:00 -0500} -test clock-30.26 {clock add weekdays} { - set t [clock scan {2013-11-20}] ;# Wednesday - set f1 [clock add $t 3 weekdays] - set x1 [clock format $f1 -format {%Y-%m-%d}] -} {2013-11-25} -test clock-30.27 {clock add weekdays starting on Saturday} { - set t [clock scan {2013-11-23}] ;# Saturday - set f1 [clock add $t 1 weekday] - set x1 [clock format $f1 -format {%Y-%m-%d}] -} {2013-11-25} -test clock-30.28 {clock add weekdays starting on Sunday} { - set t [clock scan {2013-11-24}] ;# Sunday - set f1 [clock add $t 1 weekday] - set x1 [clock format $f1 -format {%Y-%m-%d}] -} {2013-11-25} -test clock-30.29 {clock add 0 weekdays starting on a weekend} { - set t [clock scan {2016-02-27}] ;# Saturday - set f1 [clock add $t 0 weekdays] - set x1 [clock format $f1 -format {%Y-%m-%d}] -} {2016-02-27} -test clock-30.30 {clock add weekdays and back} -body { - set n [clock seconds] - # we start on each day of the week - for {set i 0} {$i < 7} {incr i} { - set start [clock add $n $i days] - set startu [clock format $start -format %u] - # add 0 - 100 weekdays - for {set j 0} {$j < 100} {incr j} { - set forth [clock add $start $j weekdays] - set back [clock add $forth -$j weekdays] - # If $s was a weekday or $j was 0, $b must be the same day. - # Otherwise, $b must be the immediately preceeding Friday - set fail 0 - if {$j == 0 || $startu < 6} { - if {$start != $back} { set fail 1} - } else { - set friday [clock add $start -[expr {$startu % 5}] days] - if {$friday != $back} { set fail 1 } - } - if {$fail} { - set sdate [clock format $start -format {%Y-%m-%d}] - set bdate [clock format $back -format {%Y-%m-%d}] - return "$sdate + $j - $j := $bdate" - } - } - } - return "OK" -} -result {OK} - -# END testcases30 - test clock-31.1 {system locale} \ -constraints win \ diff --git a/tests/cmdAH.test b/tests/cmdAH.test index b4ef605..3c58c1b 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -167,10 +167,10 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding -} -result {wrong # args: should be "encoding option ?arg ...?"} +} -result {wrong # args: should be "encoding subcommand ?arg ...?"} test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo -} -result {bad option "foo": must be convertfrom, convertto, dirs, names, or system} +} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto } -result {wrong # args: should be "encoding convertto ?encoding? data"} diff --git a/tests/coroutine.test b/tests/coroutine.test index 86fa6e3..07feb53 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -741,6 +741,45 @@ test coroutine-7.12 {coro floor above street level #3008307} -body { list } -result {} +test coroutine-8.0.0 {coro inject executed} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + demo + set ::result none + tcl::unsupported::inject demo set ::result inject-executed + demo + set ::result +} -result {inject-executed} +test coroutine-8.0.1 {coro inject after error} -body { + coroutine demo apply {{} { foreach i {1 2} yield; error test }} + demo + set ::result none + tcl::unsupported::inject demo set ::result inject-executed + lappend ::result [catch {demo} err] $err +} -result {inject-executed 1 test} +test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body { + interp create slave + slave eval { + coroutine demo apply {{} { while {1} yield }} + demo + tcl::unsupported::inject demo set ::result inject-executed + } + interp delete slave +} -result {} +test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { + interp create slave + slave eval { + coroutine demo apply {{} { while {1} yield }} + demo + tcl::unsupported::inject demo set ::result inject-executed + } + slave eval demo + set result [slave eval {set ::result}] + + interp delete slave + set result +} -result {inject-executed} + + # cleanup unset lambda diff --git a/tests/encoding.test b/tests/encoding.test index 4dddbb5..be1f4d5 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -34,8 +34,9 @@ proc runtests {} { # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] testConstraint exec [llength [info commands exec]] -testConstraint testgetdefenc [llength [info commands testgetdefenc]] +testConstraint testgetencpath [llength [info commands testgetencpath]] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested @@ -332,9 +333,14 @@ test encoding-16.1 {UnicodeToUtfProc} { set val [encoding convertfrom unicode NN] list $val [format %x [scan $val %c]] } "\u4e4e 4e4e" +test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body { + set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"] + list $val [format %x [scan $val %c]] +} -result "\U460dc 460dc" -test encoding-17.1 {UtfToUnicodeProc} { -} {} +test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body { + encoding convertto unicode "\U460dc" +} -result "\xd8\xd8\xdc\xdc" test encoding-18.1 {TableToUtfProc} { } {} @@ -448,6 +454,31 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { list $count [viewable $line] } [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"] +test encoding-24.4 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xc0\x80"] +} 1 +test encoding-24.5 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xc0\x81"] +} 2 +test encoding-24.6 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xc1\xbf"] +} 2 +test encoding-24.7 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xc2\x80"] +} 1 +test encoding-24.8 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xe0\x80\x80"] +} 3 +test encoding-24.9 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xe0\x9f\xbf"] +} 3 +test encoding-24.10 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xe0\xa0\x80"] +} 1 +test encoding-24.11 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xef\xbf\xbf"] +} 1 + file delete [file join [temporaryDirectory] iso2022.txt] # @@ -570,15 +601,15 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { } } -test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { - testgetdefenc +test encoding-26.0 {Tcl_GetEncodingSearchPath} -constraints { + testgetencpath } -setup { - set origDir [testgetdefenc] - testsetdefenc slappy + set origPath [testgetencpath] + testsetencpath slappy } -body { - testgetdefenc + testgetencpath } -cleanup { - testsetdefenc $origDir + testsetencpath $origPath } -result slappy file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout] diff --git a/tests/fileName.test b/tests/fileName.test index 387d844..ce89623 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -441,6 +441,9 @@ test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b } "/a/b" +test filename-7.19 {[Bug f34cf83dd0]} { + file join foo //bar +} /bar test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 1941936..4c90376 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -367,6 +367,16 @@ test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} { testPathEqual [file norm /../../] [file norm /] } ok +test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -constraints unix -body { + set x //foo + file normalize $x + file join $x bar +} -result /foo/bar +test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body { + set x //foo + file normalize $x + file join $x +} -result /foo test filesystem-2.0 {new native path} {unix} { foreach f [lsort [glob -nocomplain /usr/bin/c*]] { diff --git a/tests/format.test b/tests/format.test index e199398..7fa6a72 100644 --- a/tests/format.test +++ b/tests/format.test @@ -21,6 +21,7 @@ testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] testConstraint wideIs64bit \ [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 @@ -52,32 +53,51 @@ test format-1.7.1 {integer formatting} longIs64bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffffffffffff4} test format-1.8 {integer formatting} longIs32bit { - format "%#x %#X %#X %#x" 6 34 16923 -12 -1 -} {0x6 0X22 0X421B 0xfffffff4} + format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 +} {0x0 0x6 0X22 0X421B 0xfffffff4} test format-1.8.1 {integer formatting} longIs64bit { - format "%#x %#X %#X %#x" 6 34 16923 -12 -1 -} {0x6 0X22 0X421B 0xfffffffffffffff4} + format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 +} {0x0 0x6 0X22 0X421B 0xfffffffffffffff4} test format-1.9 {integer formatting} longIs32bit { - format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 -} { 0x6 0x22 0x421b 0xfffffff4} + format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 +} { 0x0 0x6 0x22 0x421b 0xfffffff4} test format-1.9.1 {integer formatting} longIs64bit { - format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 -} { 0x6 0x22 0x421b 0xfffffffffffffff4} + format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 +} { 0x0 0x6 0x22 0x421b 0xfffffffffffffff4} test format-1.10 {integer formatting} longIs32bit { - format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 -} {0x6 0x22 0x421b 0xfffffff4 } + format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 +} {0x0 0x6 0x22 0x421b 0xfffffff4 } test format-1.10.1 {integer formatting} longIs64bit { - format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 -} {0x6 0x22 0x421b 0xfffffffffffffff4 } + format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 +} {0x0 0x6 0x22 0x421b 0xfffffffffffffff4 } test format-1.11 {integer formatting} longIs32bit { - format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 -} {06 042 041033 037777777764 } + format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 +} {0 06 042 041033 037777777764 } test format-1.11.1 {integer formatting} longIs64bit { - format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 -} {06 042 041033 01777777777777777777764} + format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 +} {0 06 042 041033 01777777777777777777764} test format-1.12 {integer formatting} { - format "%b %#b %llb" 5 5 [expr {2**100}] -} {101 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} + format "%b %#b %#b %llb" 5 0 5 [expr {2**100}] +} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} +test format-1.13 {integer formatting} longIs32bit { + format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 +} {0 6 34 16923 -12} +test format-1.13.1 {integer formatting} longIs64bit { + format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 +} {0 6 34 16923 -12} +test format-1.14 {integer formatting} longIs32bit { + format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 +} { 0 6 34 16923 -12} +test format-1.14.1 {integer formatting} longIs64bit { + format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 +} { 0 6 34 16923 -12} +test format-1.15 {integer formatting} longIs32bit { + format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 +} {0 6 34 16923 -12 } +test format-1.15.1 {integer formatting} longIs64bit { + format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 +} {0 6 34 16923 -12 } + test format-2.1 {string formatting} { format "%s %s %c %s" abcd {This is a very long test string.} 120 x @@ -349,9 +369,9 @@ test format-8.19 {error conditions} { catch {format %q x} } 1 test format-8.20 {error conditions} { - catch {format %q x} msg + catch {format %r x} msg set msg -} {bad field specifier "q"} +} {bad field specifier "r"} test format-8.21 {error conditions} { catch {format %d} } 1 @@ -363,6 +383,26 @@ test format-8.23 {error conditions} { catch {format "%d %d" 24 xyz} msg set msg } {expected integer but got "xyz"} +# Since "%zd" and "%td" are equivalent to "%lld" in 64-bit platforms and +# equivalent to "%d" in 32-bit platforms, they are really not useful in +# scripts, therefore they are not documented. It's intended use is through +# the function Tcl_AppendPrintfToObj (et al). +test format-8.24 {Undocumented formats} -body { + format "%zd %td %d" [expr 2**30] [expr 2**30] [expr 2**30] +} -result {1073741824 1073741824 1073741824} +test format-8.25 {Undocumented formats} -constraints pointerIs64bit -body { + format "%zd %td %lld" [expr 2**33] [expr 2**33] [expr 2**33] +} -result {8589934592 8589934592 8589934592} +# Since "%p" is equivalent to "%#llx" in 64-bit platforms and equivalent +# to "%#x" in 32-bit platforms, it are really not useful in scripts, +# therefore they are not documented. It's intended use is through the +# function Tcl_AppendPrintfToObj (et al). +test format-8.26 {Undocumented formats} -body { + format "%p %#x" [expr 2**31] [expr 2**31] +} -result {0x80000000 0x80000000} +test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body { + format "%p %#llx" [expr 2**33] [expr 2**33] +} -result {0x200000000 0x200000000} test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} @@ -528,6 +568,12 @@ test format-17.3 {testing %ld with non-wide} {wideIs64bit} { test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 +test format-17.5 {testing %llu with positive bignum} -body { + format %llu 0xabcdef0123456789abcdef +} -returnCodes 1 -result {unsigned bignum format is invalid} +test format-17.6 {testing %llu with negative number} -body { + format %llu -1 +} -returnCodes 1 -result {unsigned bignum format is invalid} test format-18.1 {do not demote existing numeric values} { set a 0xaaaaaaaa diff --git a/tests/http.test b/tests/http.test index 12ad475..210c2fb 100644 --- a/tests/http.test +++ b/tests/http.test @@ -36,7 +36,6 @@ proc bgerror {args} { puts stderr $errorInfo } -set port 8010 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" catch {unset data} @@ -55,9 +54,8 @@ catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] thread::send $httpthread [list source $httpdFile] - thread::send $httpthread [list set port $port] thread::send $httpthread [list set bindata $bindata] - thread::send $httpthread {httpd_init $port} + thread::send $httpthread {httpd_init 0; set port} port puts "Running httpd in thread $httpthread" } else { if {![file exists $httpdFile]} { @@ -69,10 +67,8 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { # Let the OS pick the port; that's much more flexible if {[catch {httpd_init 0} listen]} { puts "Cannot start http server, http test skipped" - unset port + catch {unset port} return - } else { - set port [lindex [fconfigure $listen -sockname] 2] } } @@ -592,6 +588,14 @@ test http-4.15 {http::Event} -body { } -cleanup { catch {http::cleanup $token} } -returnCodes 1 -match glob -result "couldn't open socket*" +test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -body { + set before [chan names] + set token [http::geturl $url -headers {X-Connection keep-alive}] + http::cleanup $token + update + set after [chan names] + expr {$before eq $after} +} -result 1 test http-5.1 {http::formatQuery} { http::formatQuery name1 value1 name2 "value two" diff --git a/tests/httpd b/tests/httpd index 40e10df..f15d71b 100644 --- a/tests/httpd +++ b/tests/httpd @@ -11,7 +11,12 @@ #set httpLog 1 proc httpd_init {{port 8015}} { - socket -server httpdAccept $port + set s [socket -server httpdAccept $port] + # Save the actual port number in a global variable. + # This is important when we're called with port 0 + # for picking an unused port at random. + set ::port [lindex [chan configure $s -sockname] 2] + return $s } proc httpd_log {args} { global httpLog diff --git a/tests/httpold.test b/tests/httpold.test index 5995bed..ab26613 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -1,3 +1,4 @@ +# -*- tcl -*- # Commands covered: http_config, http_get, http_wait, http_reset # # This file contains a collection of tests for the http script library. @@ -41,10 +42,9 @@ catch {unset data} ## source [file join [file dirname [info script]] httpd] -set port 8010 -if [catch {httpd_init $port} listen] { +if [catch {httpd_init 0} listen] { puts "Cannot start http server, http test skipped" - unset port + catch {unset port} ::tcltest::cleanupTests return } diff --git a/tests/incr.test b/tests/incr.test index 9243be0..aa2872a 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -494,6 +494,18 @@ test incr-2.31 {incr command (compiled): bad increment} { (reading increment) invoked from within "incr x 1a"}} +test incr-2.32 {incr command (compiled): bad pure list increment} { + list [catch {incr x [list 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [list 1 2]"}} +test incr-2.33 {incr command (compiled): bad pure dict increment} { + list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [dict create 1 2]"}} test incr-3.1 {increment by wide amount: bytecode route} { set x 0 diff --git a/tests/interp.test b/tests/interp.test index ed76f1a..1389304 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} foreach i [interp slaves] { interp delete $i @@ -615,6 +615,8 @@ test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185} } -body { interp alias {} p1 $interp {} p1 one two three +} -cleanup { + interp delete $interp } -result {one two three} # part 15: testing file sharing diff --git a/tests/io.test b/tests/io.test index 6e7420d..3fc370d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -5652,8 +5652,8 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} { set f [open $path(test3) {WRONLY CREAT}] close $f file stat $path(test3) stats - format "0%o" [expr $stats(mode)&0o777] -} [format %04o [expr {0o666 & ~ $umaskValue}]] + format "%#o" [expr $stats(mode)&0o777] +} [format %#4o [expr {0o666 & ~ $umaskValue}]] test io-40.4 {POSIX open access modes: CREAT} { file delete $path(test3) set f [open $path(test3) w] diff --git a/tests/link.test b/tests/link.test index dda7d6b..6bff356 100644 --- a/tests/link.test +++ b/tests/link.test @@ -152,7 +152,7 @@ test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup { set uwide "0O" concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide } -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O} -test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup { +test link-2.9 {writing C variables from Tcl} -constraints {testlink} -setup { testlink delete } -body { testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 diff --git a/tests/load.test b/tests/load.test index 7c4b47f..4cd1fcd 100644 --- a/tests/load.test +++ b/tests/load.test @@ -185,23 +185,30 @@ test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { info loaded } -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] -teststaticpkg Test 1 1 -teststaticpkg Another 0 1 -teststaticpkg More 0 1 -teststaticpkg Double 0 1 -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { +testConstraint teststaticpkg_8.x \ + [if {[testConstraint teststaticpkg]} { + teststaticpkg Test 1 1 + teststaticpkg Another 0 1 + teststaticpkg More 0 1 + teststaticpkg Double 0 1 + expr 1 + } else { + expr 0 + }] + +test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] -test load-8.2 {TclGetLoadedPackages procedure} -body { +test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { +test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] -test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { +test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] { +test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { load [file join $testDir pkgb$ext] pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] diff --git a/tests/nre.test b/tests/nre.test index 3313df5..58f5511 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -64,9 +64,11 @@ if {[testConstraint testnrelevels]} { namespace import testnre::* } -test nre-0.1 {levels while unwinding} { +test nre-0.1 {levels while unwinding} -body { testnreunwind -} {0 0 0} +} -constraints { + testnrelevels +} -result {0 0 0} test nre-1.1 {self-recursive procs} -setup { proc a i [makebody {a $i}] diff --git a/tests/oo.test b/tests/oo.test index ccb05c1..e03911b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2241,6 +2241,44 @@ test oo-17.10 {OO: class introspection} -setup { oo::define foo unexport {*}[info class methods foo -all] info class methods foo -all } -result {} +set stdmethods {<cloned> destroy eval unknown variable varname} +test oo-17.11 {OO: object method unexport (bug 900cb0284bc)} -setup { + oo::object create o + oo::objdefine o unexport m +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy +} -result $stdmethods +test oo-17.12 {OO: instance method unexport (bug 900cb0284bc)} -setup { + oo::class create c + c create o + oo::objdefine o unexport m +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy + c destroy +} -result $stdmethods +test oo-17.13 {OO: class method unexport (bug 900cb0284bc)} -setup { + oo::class create c + oo::define c unexport m +} -body { + lsort [info class methods c -all -private] +} -cleanup { + c destroy +} -result $stdmethods +test oo-17.14 {OO: instance method unexport (bug 900cb0284bc)} -setup { + oo::class create c + oo::define c unexport m + c create o +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy + c destroy +} -result $stdmethods + test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo diff --git a/tests/scan.test b/tests/scan.test index 7540c9c..b36b412 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -541,6 +541,24 @@ test scan-5.15 {Bug be003d570f} { test scan-5.16 {Bug be003d570f} { scan 0x40 %b } 0 +test scan-5.17 {bigint scanning} -setup { + set a {}; set b {}; set c {} +} -body { + list [scan "207698809136909011942886895,abcdef0123456789abcdef,125715736004432126361152746757" \ + %lld,%llx,%llo a b c] $a $b $c +} -result {3 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895} +test scan-5.18 {bigint scanning underflow} -setup { + set a {}; +} -body { + list [scan "-207698809136909011942886895" \ + %llu a] $a +} -returnCodes 1 -result {unsigned bignum scans are invalid} +test scan-5.18 {bigint scanning invalid} -setup { + set a {}; +} -body { + list [scan "207698809136909011942886895" \ + %llu a] $a +} -returnCodes 1 -result {unsigned bignum scans are invalid} test scan-6.1 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} diff --git a/tests/socket.test b/tests/socket.test index 80b0251..d3d56fa 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -60,8 +60,13 @@ # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. -package require tcltest 2 -namespace import -force ::tcltest::* +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the Thread package or exec command testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] @@ -69,7 +74,30 @@ testConstraint exec [llength [info commands exec]] # Produce a random port number in the Dynamic/Private range # from 49152 through 65535. -proc randport {} { expr {int(rand()*16383+49152)} } +proc randport {} { + # firstly try dynamic port via server-socket(0): + set port 0x7fffffff + catch { + set port [lindex [fconfigure [set s [socket -server {} 0]] -sockname] 2] + close $s + } + while {[catch { + close [socket -server {} $port] + } msg]} { + if {[incr i] > 1000} {return -code error "too many iterations to get free random port: $msg"} + # try random port: + set port [expr {int(rand()*16383+49152)}] + } + return $port +} + +# Check if testsocket testflags is available +testConstraint testsocket_testflags [expr {![catch { + set h [socket -async localhost [randport]] + testsocket testflags $h 0 + close $h + }]}] + # Test the latency of tcp connections over the loopback interface. Some OSes # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes @@ -2266,12 +2294,17 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener unset x } -result {socket is not connected} -returnCodes 1 test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ - -constraints {socket nonPortable} \ + -constraints {socket testsocket_testflags} \ -body { set sock [socket -async localhost [randport]] + # Set the socket in async test mode. + # The async connect will not be continued on the following fconfigure + # and puts/flush. Thus, the connect will fail after them. + testsocket testflags $sock 1 fconfigure $sock -blocking 0 puts $sock ok flush $sock + testsocket testflags $sock 0 fileevent $sock writable {set x 1} vwait x close $sock diff --git a/tests/string.test b/tests/string.test index 11cbcff..7b02928 100644 --- a/tests/string.test +++ b/tests/string.test @@ -576,12 +576,12 @@ test string-6.85 {string is control} { } 0 test string-6.86 {string is graph} { ## graph is any print char, except space - list [string is gra -fail var "0123abc!@#\$\u0100 "] $var -} {0 12} + list [string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "] $var +} {0 14} test string-6.87 {string is print} { ## basically any printable char - list [string is print -fail var "0123abc!@#\$\u0100 \u0010"] $var -} {0 13} + list [string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"] $var +} {0 15} test string-6.88 {string is punct} { ## any graph char that isn't alnum list [string is punct -fail var "_!@#\u00beq0"] $var @@ -1994,6 +1994,51 @@ test string-29.4 {string cat, many args} { set r2 [string compare $xx [eval "string cat $vvs"]] list $r1 $r2 } {0 0} +test string-29.5 {string cat, efficiency} -body { + tcl::unsupported::representation [string cat [list x] [list]] +} -match glob -result {*no string representation} +test string-29.6 {string cat, efficiency} -body { + tcl::unsupported::representation [string cat [list] [list x]] +} -match glob -result {*no string representation} +test string-29.7 {string cat, efficiency} -body { + tcl::unsupported::representation [string cat [list x] [list] [list]] +} -match glob -result {*no string representation} +test string-29.8 {string cat, efficiency} -body { + tcl::unsupported::representation [string cat [list] [list x] [list]] +} -match glob -result {*no string representation} +test string-29.9 {string cat, efficiency} -body { + tcl::unsupported::representation [string cat [list] [list] [list x]] +} -match glob -result {*no string representation} +test string-29.10 {string cat, efficiency} -body { + tcl::unsupported::representation [string cat [list x] [list x]] +} -match glob -result {*, string representation "xx"} +test string-29.11 {string cat, efficiency} -body { + tcl::unsupported::representation \ + [string cat [list x] [encoding convertto utf-8 {}]] +} -match glob -result {*no string representation} +test string-29.12 {string cat, efficiency} -body { + tcl::unsupported::representation \ + [string cat [encoding convertto utf-8 {}] [list x]] +} -match glob -result {*, string representation "x"} +test string-29.13 {string cat, efficiency} -body { + tcl::unsupported::representation [string cat \ + [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]] +} -match glob -result {*, string representation "x"} +test string-29.14 {string cat, efficiency} -setup { + set e [encoding convertto utf-8 {}] +} -cleanup { + unset e +} -body { + tcl::unsupported::representation [string cat $e $e [list x]] +} -match glob -result {*no string representation} +test string-29.15 {string cat, efficiency} -setup { + set e [encoding convertto utf-8 {}] + set f [encoding convertto utf-8 {}] +} -cleanup { + unset e f +} -body { + tcl::unsupported::representation [string cat $e $f $e $f [list x]] +} -match glob -result {*no string representation} diff --git a/tests/unixInit.test b/tests/unixInit.test index 05338ed..0469ee8 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -15,6 +15,9 @@ namespace import ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C + +# Some tests require the testgetencpath command +testConstraint testgetencpath [llength [info commands testgetencpath]] test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} @@ -87,13 +90,15 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} skip [concat [skip] unixInit-2.*] -test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { - set origDir [testgetdefenc] - testsetdefenc slappy - set path [testgetdefenc] - testsetdefenc $origDir +test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} -constraints { + testgetencpath +} -body { + set origPath [testgetencpath] + testsetencpath slappy + set path [testgetencpath] + testsetencpath $origPath set path -} {slappy} +} -result {slappy} test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { diff --git a/tests/utf.test b/tests/utf.test index a03dd6c..422ab08 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -20,6 +20,9 @@ testConstraint testbytestring [llength [info commands testbytestring]] catch {unset x} +# Some tests require support for 4-byte UTF-8 sequences +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] + test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { expr {"\x01" eq [testbytestring "\x01"]} } 1 @@ -38,6 +41,9 @@ test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]} } 1 +test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints {fullutf testbytestring} -body { + expr {"\U014e4e" eq [testbytestring "\xf0\x94\xb9\x8e"]} +} -result 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -60,9 +66,21 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestrin test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { string length [testbytestring "\xE4\xb9\x8e"] } {1} -test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { - string length [testbytestring "\xF4\xA2\xA2\xA2"] +test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { + string length [testbytestring "\xF0\x90\x80\x80"] +} -result {1} +test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { + string length [testbytestring "\xF4\x8F\xBF\xBF"] +} -result {1} +test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { + string length [testbytestring "\xF0\x8F\xBF\xBF"] +} {4} +test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring { + string length [testbytestring "\xF4\x90\x80\x80"] } {4} +test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { + string length [testbytestring "\xF8\xA2\xA2\xA2\xA2"] +} {5} test utf-3.1 {Tcl_UtfCharComplete} { } {} @@ -81,17 +99,24 @@ test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC0\x80"] } {1} test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars { - testnumutfchars "" 1 + testnumutfchars "" 0 } {0} test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC2\xA2"] 1 + testnumutfchars [testbytestring "\xC2\xA2"] 2 } {1} test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 10 } {7} test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC0\x80"] 1 + testnumutfchars [testbytestring "\xC0\x80"] 2 } {1} +# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check +test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xE2\x82\xAC"] 2 +} {2} +test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\x00"] 2 +} {2} test utf-5.1 {Tcl_UtfFindFirsts} { } {} @@ -195,8 +220,16 @@ bsCheck \Ua1 161 bsCheck \U4e21 20001 bsCheck \U004e21 20001 bsCheck \U00004e21 20001 -bsCheck \U00110000 65533 -bsCheck \Uffffffff 65533 +bsCheck \U0000004e21 78 +if {[testConstraint fullutf]} { + bsCheck \U00110000 69632 + bsCheck \U01100000 69632 + bsCheck \U11000000 69632 + bsCheck \U0010FFFF 1114111 + bsCheck \U010FFFF0 1114111 + bsCheck \U10FFFF00 1114111 + bsCheck \UFFFFFFFF 1048575 +} test utf-11.1 {Tcl_UtfToUpper} { string toupper {} @@ -264,8 +297,8 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} { string tolower aA } aa test utf-16.2 {Tcl_UniCharToLower, positive delta} { - string tolower \u0178\u00ff\uA78D\u01c5 -} \u00ff\u00ff\u0265\u01c6 + string tolower \u0178\u00ff\uA78D\u01c5\U10400 +} \u00ff\u00ff\u0265\u01c6\U10428 test utf-17.1 {Tcl_UniCharToLower, no delta} { string tolower ! diff --git a/tests/util.test b/tests/util.test index 1a3eecb..22d120b 100644 --- a/tests/util.test +++ b/tests/util.test @@ -4027,21 +4027,45 @@ test util-18.2 {Tcl_ObjPrintf} {testprint} { } {9223372036854775807} test util-18.3 {Tcl_ObjPrintf} {testprint} { - testprint %Ld [expr 2**63-1] + testprint %qd [expr 2**63-1] } {9223372036854775807} test util-18.4 {Tcl_ObjPrintf} {testprint} { + testprint %jd [expr 2**63-1] +} {9223372036854775807} + +test util-18.5 {Tcl_ObjPrintf} {testprint} { testprint %lld [expr -2**63] } {-9223372036854775808} -test util-18.5 {Tcl_ObjPrintf} {testprint} { +test util-18.6 {Tcl_ObjPrintf} {testprint} { testprint %I64d [expr -2**63] } {-9223372036854775808} -test util-18.6 {Tcl_ObjPrintf} {testprint} { - testprint %Ld [expr -2**63] +test util-18.7 {Tcl_ObjPrintf} {testprint} { + testprint %qd [expr -2**63] } {-9223372036854775808} +test util-18.8 {Tcl_ObjPrintf} {testprint} { + testprint %jd [expr -2**63] +} {-9223372036854775808} + +test util-18.9 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %I32d" [expr -2**63+2] +} {-9223372036854775806 2} + +test util-18.10 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %p" 65535 +} {65535 0xffff} + +test util-18.11 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %td" 65536 +} {65536 65536} + +test util-18.12 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %Id" 65537 +} {65537 65537} + set ::tcl_precision $saved_precision # cleanup diff --git a/tests/zlib.test b/tests/zlib.test index ae8742b..c2f7825 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -157,6 +157,48 @@ test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup { catch {$strm close} unset -nocomplain randdata data } -result {120185 18003000} +test zlib-7.9 {zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set z1 [zlib stream gzip] + set z2 [zlib stream gzip] +} -body { + $z1 put ABCDEedbca.. + $z1 finalize + zlib gunzip [$z1 get] +} -cleanup { + $z1 close +} -result ABCDEedbca.. +test zlib-7.10 {zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set z2 [zlib stream gzip] +} -body { + $z2 put -finalize ABCDEedbca.. + zlib gunzip [$z2 get] +} -cleanup { + $z2 close +} -result ABCDEedbca.. +test zlib-7.11 {zlib stream put -finalize (bug 25842c161)} -constraints zlib -setup { + set c [zlib stream gzip] + set d [zlib stream gunzip] +} -body { + $c put abcdeEDCBA.. + $c finalize + $d put [$c get] + $d finalize + $d get +} -cleanup { + $c close + $d close +} -result abcdeEDCBA.. +test zlib-7.12 {zlib stream put; zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set c [zlib stream gzip] + set d [zlib stream gunzip] +} -body { + $c put -finalize abcdeEDCBA.. + $d put -finalize [$c get] + $d get +} -cleanup { + $c close + $d close +} -result abcdeEDCBA.. test zlib-8.1 {zlib transformation} -constraints zlib -setup { set file [makeFile {} test.gz] @@ -269,7 +311,7 @@ test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $outSide -blocking 1 -translation binary -buffering none fconfigure $inSide -blocking 1 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide @@ -288,7 +330,7 @@ test zlib-8.9 {transformation and fconfigure} -setup { set strm [zlib stream decompress] } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $outSide -blocking 1 -translation binary -buffering none fconfigure $inSide -blocking 1 -translation binary puts -nonewline $outSide $spdyHeaders set result [fconfigure $outSide -checksum] @@ -305,7 +347,7 @@ test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints {zlib recentZlib} -body { zlib push deflate $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $outSide -blocking 1 -translation binary -buffering none fconfigure $inSide -blocking 1 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide @@ -327,7 +369,7 @@ test zlib-8.11 {transformation and fconfigure} -setup { set strm [zlib stream inflate] } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $outSide -blocking 1 -translation binary -buffering none fconfigure $inSide -blocking 1 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide @@ -345,7 +387,7 @@ test zlib-8.12 {transformation and fconfigure} -setup { } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide - fconfigure $outSide -blocking 0 -translation binary + fconfigure $outSide -blocking 1 -translation binary fconfigure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide @@ -362,7 +404,7 @@ test zlib-8.13 {transformation and fconfigure} -setup { } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary + fconfigure $outSide -blocking 1 -translation binary fconfigure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide @@ -379,7 +421,7 @@ test zlib-8.14 {transformation and fconfigure} -setup { } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide - fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $outSide -blocking 1 -buffering none -translation binary fconfigure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide @@ -395,7 +437,7 @@ test zlib-8.15 {transformation and fconfigure} -setup { } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $outSide -blocking 1 -buffering none -translation binary fconfigure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide @@ -466,6 +508,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c + set ::total -1 }}} 0] set file [makeFile {} test.gz] } -body { @@ -473,7 +516,10 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { set sin [socket $addr $port] chan configure $sin -translation binary zlib push gunzip $sin - update + after 1000 {set ::total timeout} + vwait ::total + after cancel {set ::total timeout} + if {$::total != -1} {error "unexpected value $::total of ::total"} set total [fcopy $sin [set fout [open $file wb]]] close $sin close $fout @@ -958,7 +1004,7 @@ test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup { } -cleanup { removeFile $filesrc removeFile $filedst -} -result 4152 +} -result 56 ::tcltest::cleanupTests return |