summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2017-06-22 12:25:35 (GMT)
committerdgp <dgp@users.sourceforge.net>2017-06-22 12:25:35 (GMT)
commit69201f94bdcef502012a231e2100bceef5062f90 (patch)
tree318ce059db03075568b505a7caa2624fce436e13 /tests
parent6aa0cc7188b6df1dac97b03bc0b9240aa780799b (diff)
parentf57dacd4955b9dd474cfd9d4e4d55cac22990f6c (diff)
downloadtcl-69201f94bdcef502012a231e2100bceef5062f90.zip
tcl-69201f94bdcef502012a231e2100bceef5062f90.tar.gz
tcl-69201f94bdcef502012a231e2100bceef5062f90.tar.bz2
merge trunktip_463
Diffstat (limited to 'tests')
-rw-r--r--tests/binary.test12
-rw-r--r--tests/chanio.test8
-rw-r--r--tests/clock.test55
-rw-r--r--tests/cmdAH.test4
-rw-r--r--tests/coroutine.test39
-rw-r--r--tests/encoding.test49
-rw-r--r--tests/fileName.test3
-rw-r--r--tests/fileSystem.test10
-rw-r--r--tests/format.test86
-rw-r--r--tests/http.test16
-rw-r--r--tests/httpd7
-rw-r--r--tests/httpold.test6
-rw-r--r--tests/incr.test12
-rw-r--r--tests/interp.test4
-rw-r--r--tests/io.test4
-rw-r--r--tests/link.test2
-rw-r--r--tests/load.test25
-rw-r--r--tests/nre.test6
-rw-r--r--tests/oo.test38
-rw-r--r--tests/scan.test18
-rw-r--r--tests/socket.test41
-rw-r--r--tests/string.test53
-rw-r--r--tests/unixInit.test17
-rw-r--r--tests/utf.test53
-rw-r--r--tests/util.test32
-rw-r--r--tests/zlib.test66
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