diff options
Diffstat (limited to 'tests')
38 files changed, 959 insertions, 265 deletions
diff --git a/tests/assemble.test b/tests/assemble.test index d17bfd9..6e5308d 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -852,7 +852,7 @@ test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result] $result $errorCode + list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] } } -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} diff --git a/tests/basic.test b/tests/basic.test index bff9a95..7819241 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -224,6 +224,21 @@ test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified i list [test_ns_basic::cmd] \ [namespace delete test_ns_basic] } {::test_ns_basic {}} +test basic-15.2 {Tcl_CreateObjCommand, Bug 0e4d88b650} -setup { + proc deleter {ns args} { + namespace delete $ns + } + namespace eval n { + proc p {} {} + } + trace add command n::p delete [list [namespace which deleter] [namespace current]::n] +} -body { + proc n::p {} {} +} -cleanup { + namespace delete n + rename deleter {} +} + test basic-16.1 {TclInvokeStringCommand} {emptyTest} { } {} 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 8e27af9..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 { diff --git a/tests/clock.test b/tests/clock.test index 6a0fecd..4ec4db2 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -15416,30 +15416,9 @@ test clock-5.29 {time zone boundary case 1948-09-26 01:00:01} detroit { clock format -671047199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} -test clock-5.30 {time zone boundary case 1967-06-14 01:59:59} detroit { - clock format -80499601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.31 {time zone boundary case 1967-06-14 03:00:00} detroit { - clock format -80499600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.32 {time zone boundary case 1967-06-14 03:00:01} detroit { - clock format -80499599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.33 {time zone boundary case 1967-10-29 01:59:59} detroit { - clock format -68666401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.34 {time zone boundary case 1967-10-29 01:00:00} detroit { - clock format -68666400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.35 {time zone boundary case 1967-10-29 01:00:01} detroit { - clock format -68666399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} + +# Detroit did not observe Daylight Saving Time in 1967 + test clock-5.36 {time zone boundary case 1972-12-31 23:59:59} detroit { clock format 94712399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit @@ -34992,10 +34971,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 +35197,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 3c58c1b..e334dff 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -188,7 +188,7 @@ test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding convertto jis0208 \u4e4e } -cleanup { encoding system $system @@ -210,7 +210,7 @@ test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding convertfrom jis0208 8C } -cleanup { encoding system $system @@ -224,11 +224,11 @@ test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body { test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding system } -cleanup { encoding system $system -} -result identity +} -result iso8859-1 test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 23a5f96..df59e6e 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -19,6 +19,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort @@ -147,6 +148,18 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { {{b i g} 12345} {{d e m o} 34512} } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} +test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii -nocase [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { + lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { + lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. @@ -219,8 +232,8 @@ test cmdIL-3.10 {SortCompare procedure, -integer option} -body { lsort -integer {3 q} } -returnCodes error -result {expected integer but got "q"} test cmdIL-3.11 {SortCompare procedure, -integer option} { - lsort -integer {35 21 0x20 30 0o23 100 8} -} {8 0o23 21 30 0x20 35 100} + lsort -integer {35 21 0x20 0d30 0o23 100 8} +} {8 0o23 21 0d30 0x20 35 100} test cmdIL-3.12 {SortCompare procedure, -real option} -body { lsort -real {6...4 3} } -returnCodes error -result {expected floating-point number but got "6...4"} 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..e447c20 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -34,8 +34,11 @@ proc runtests {} { # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] +testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint teststringbytes [llength [info commands teststringbytes]] +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 @@ -74,11 +77,11 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] set x [encoding convertto shiftjis \u4e4e] ;# old one found - encoding system identity + encoding system iso8859-1 llength shiftjis ;# Shimmer away any cache of Tcl_Encoding lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg } -cleanup { - encoding system identity + encoding system iso8859-1 encoding dirs $path encoding system $system } -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" @@ -135,7 +138,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup { encoding system jis0208 encoding convertto \u4e4e } -cleanup { - encoding system identity + encoding system iso8859-1 encoding system $old } -result {8C} test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { @@ -258,7 +261,7 @@ test encoding-11.5.1 {LoadEncodingFile: escape file} { test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] - encoding system identity + encoding system iso8859-1 } -body { cd [temporaryDirectory] encoding dirs [file join tmp encoding] @@ -307,34 +310,31 @@ test encoding-13.1 {LoadEscapeTable} { viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]] } [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"] -test encoding-14.1 {BinaryProc} { - encoding convertto identity \x12\x34\x56\xff\x69 -} "\x12\x34\x56\xc3\xbf\x69" - test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" -test encoding-15.2 {UtfToUtfProc null character output} { - set x \u0000 - set y [encoding convertto utf-8 \u0000] - set y [encoding convertfrom identity $y] - binary scan $y H* z - list [string bytelength $x] [string bytelength $y] $z -} {2 1 00} -test encoding-15.3 {UtfToUtfProc null character input} { - set x [encoding convertfrom identity \x00] - set y [encoding convertfrom utf-8 $x] - binary scan [encoding convertto identity $y] H* z - list [string bytelength $x] [string bytelength $y] $z -} {1 2 c080} +test encoding-15.2 {UtfToUtfProc null character output} testbytestring { + binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z + set z +} 00 +test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { + set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]] + binary scan [teststringbytes $y] H* z + set z +} c080 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 +448,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 +595,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/exec.test b/tests/exec.test index 2a4b31e..dffd960 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -671,8 +671,12 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { exec /bin/sh -c \ {for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile & exec /bin/sh -c \ + {for a in 4 5 6; do sleep 1; echo $a >&2; done} 2>>$tmpfile & + exec /bin/sh -c \ {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile & - # The above two shell invokations take about 3 seconds to finish, so allow + exec /bin/sh -c \ + {for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile & + # The above four shell invokations take about 3 seconds to finish, so allow # 5s (in case the machine is busy) after 5000 # Check that no bytes have got lost through mixups with overlapping @@ -681,7 +685,7 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { file size $tmpfile } -cleanup { removeFile $tmpfile -} -result 14 +} -result 26 # Tests to ensure batch files and .CMD (Bug 9ece99d58b) # can be executed on Windows diff --git a/tests/execute.test b/tests/execute.test index 5b8ce2d..6c277f8 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -724,7 +724,7 @@ test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup { } set result {} lappend result [expr $e] - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} @@ -733,11 +733,11 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu } -body { set e { [llength {}]+1 } set result {} - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] namespace eval foo { proc llength {args} {return 1} } - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} diff --git a/tests/expr-old.test b/tests/expr-old.test index 3adfb63..8c159b2 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -1159,8 +1159,8 @@ test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {too few arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {too few arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] @@ -1170,6 +1170,12 @@ test expr-old-40.5 {min math function} -body { test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} @@ -1178,8 +1184,8 @@ test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {too few arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {too few arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] @@ -1189,6 +1195,12 @@ test expr-old-41.5 {max math function} -body { test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: 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 a4ea25e..094b7b3 100644 --- a/tests/format.test +++ b/tests/format.test @@ -53,32 +53,42 @@ 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} { + format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 +} {0d0 0d6 0d34 0d16923 -0d12} +test format-1.14 {integer formatting} { + format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 +} { 0d0 0d6 0d34 0d16923 -0d12} +test format-1.15 {integer formatting} { + format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 +} {0d0 0d6 0d34 0d16923 -0d12 } + test format-2.1 {string formatting} { format "%s %s %c %s" abcd {This is a very long test string.} 120 x @@ -549,9 +559,9 @@ 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 bignum} { +test format-17.5 {testing %llu with positive bignum} -body { format %llu 0xabcdef0123456789abcdef -} 207698809136909011942886895 +} -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} diff --git a/tests/http.test b/tests/http.test index 75c963d..e165804 100644 --- a/tests/http.test +++ b/tests/http.test @@ -36,6 +36,13 @@ proc bgerror {args} { puts stderr $errorInfo } +if {$::tcl_platform(os) eq "Darwin"} { + # Name resolution often a problem on OSX; not focus of HTTP package anyway + set HOST localhost +} else { + set HOST [info hostname] +} + set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" catch {unset data} @@ -114,8 +121,8 @@ test http-3.1 {http::geturl} -returnCodes error -body { test http-3.2 {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} -set url //[info hostname]:$port -set badurl //[info hostname]:[expr $port+1] +set url //${::HOST}:$port +set badurl //${::HOST}:[expr $port+1] test http-3.3 {http::geturl} -body { set token [http::geturl $url] http::data $token @@ -126,13 +133,13 @@ test http-3.3 {http::geturl} -body { <h2>GET /</h2> </body></html>" set tail /a/b/c -set url //[info hostname]:$port/a/b/c -set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c -set binurl //[info hostname]:$port/binary -set xmlurl //[info hostname]:$port/xml -set posturl //[info hostname]:$port/post -set badposturl //[info hostname]:$port/droppost -set authorityurl //[info hostname]:$port +set url //${::HOST}:$port/a/b/c +set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c +set binurl //${::HOST}:$port/binary +set xmlurl //${::HOST}:$port/xml +set posturl //${::HOST}:$port/post +set badposturl //${::HOST}:$port/droppost +set authorityurl //${::HOST}:$port set ipv6url http://\[::1\]:$port/ test http-3.4 {http::geturl} -body { set token [http::geturl $url] @@ -145,7 +152,7 @@ test http-3.4 {http::geturl} -body { </body></html>" proc selfproxy {host} { global port - return [list [info hostname] $port] + return [list ${::HOST} $port] } test http-3.5 {http::geturl} -body { http::config -proxyfilter selfproxy @@ -588,6 +595,20 @@ 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]} -setup { + proc list-difference {l1 l2} { + lmap item $l2 {if {$item in $l1} continue; set item} + } +} -body { + set before [chan names] + set token [http::geturl $url -headers {X-Connection keep-alive}] + http::cleanup $token + update + # Compute what channels have been unexpectedly leaked past cleanup + list-difference $before [chan names] +} -cleanup { + rename list-difference {} +} -result {} test http-5.1 {http::formatQuery} { http::formatQuery name1 value1 name2 "value two" @@ -608,7 +629,7 @@ test http-5.5 {http::formatQuery} { } {name1=~bwelch&name2=%A1%A2%A2} test http-6.1 {http::ProxyRequired} -body { - http::config -proxyhost [info hostname] -proxyport $port + http::config -proxyhost ${::HOST} -proxyport $port set token [http::geturl $url] http::wait $token upvar #0 $token data diff --git a/tests/httpd b/tests/httpd index f15d71b..982f3b8 100644 --- a/tests/httpd +++ b/tests/httpd @@ -10,6 +10,13 @@ #set httpLog 1 +if {$::tcl_platform(os) eq "Darwin"} { + # Name resolution often a problem on OSX; not focus of HTTP package anyway + set HOST localhost +} else { + set HOST [info hostname] +} + proc httpd_init {{port 8015}} { set s [socket -server httpdAccept $port] # Save the actual port number in a global variable. @@ -173,7 +180,7 @@ proc httpdRespond { sock } { switch -glob -- $data(url) { *binary* { - set html "$bindata[info hostname]:$port$data(url)" + set html "$bindata${::HOST}:$port$data(url)" set type application/octet-stream } *xml* { diff --git a/tests/httpold.test b/tests/httpold.test index ab26613..dda0189 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -34,6 +34,13 @@ if {[catch {package require http 1.0}]} { } } +if {$::tcl_platform(os) eq "Darwin"} { + # Name resolution often a problem on OSX; not focus of HTTP package anyway + set HOST localhost +} else { + set HOST [info hostname] +} + set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" catch {unset data} @@ -85,7 +92,7 @@ test httpold-3.2 {http_get} { set err } {Unsupported URL: http:junk} -set url [info hostname]:$port +set url ${::HOST}:$port test httpold-3.3 {http_get} { set token [http_get $url] http_data $token @@ -95,8 +102,8 @@ test httpold-3.3 {http_get} { </body></html>" set tail /a/b/c -set url [info hostname]:$port/a/b/c -set binurl [info hostname]:$port/binary +set url ${::HOST}:$port/a/b/c +set binurl ${::HOST}:$port/binary test httpold-3.4 {http_get} { set token [http_get $url] @@ -108,7 +115,7 @@ test httpold-3.4 {http_get} { proc selfproxy {host} { global port - return [list [info hostname] $port] + return [list ${::HOST} $port] } test httpold-3.5 {http_get} { http_config -proxyfilter selfproxy @@ -273,7 +280,7 @@ test httpold-5.3 {http_formatQuery} { test httpold-6.1 {httpProxyRequired} { update - http_config -proxyhost [info hostname] -proxyport $port + http_config -proxyhost ${::HOST} -proxyport $port set token [http_get $url] http_wait $token http_config -proxyhost {} -proxyport {} diff --git a/tests/init.test b/tests/init.test index 0241283..2a81b52 100644 --- a/tests/init.test +++ b/tests/init.test @@ -168,6 +168,16 @@ foreach arg [subst -nocommands -novariables { incr count } +test init-4.$count {[Bug 46f801ed5a]} -setup { + auto_reset + array set auto_index {demo {proc demo {} {tailcall error foo}}} +} -body { + demo +} -cleanup { + array unset auto_index demo + rename demo {} +} -returnCodes error -result foo + test init-5.0 {return options passed through ::unknown} -setup { catch {rename xxx {}} set ::auto_index(::xxx) {proc ::xxx {} { diff --git a/tests/interp.test b/tests/interp.test index 1389304..4ea04e3 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -1847,7 +1847,7 @@ test interp-23.2 {testing hiding vs aliases: safe interp} -setup { lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a -} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] +} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { catch {interp delete a} 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..a12759d 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 @@ -173,6 +173,27 @@ test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup { set uwide 0 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide } -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0} +test link-2.10 {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 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + set int "0x" + set real "0b" + set bool 0 + set string "0" + set wide "0D" + set char "0X" + set uchar "0B" + set short "0D" + set ushort "0x" + set uint "0b" + set long "0d" + set ulong "0X" + set float "0B" + set uwide "0D" + 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 0D 0X 0B 0D 0x 0b 0d 0X 0B 0D} test link-3.1 {read-only variables} -constraints {testlink} -setup { testlink delete diff --git a/tests/namespace.test b/tests/namespace.test index f6f817b..9fa9331 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1784,8 +1784,11 @@ test namespace-42.7 {ensembles: nested} -body { list [ns x0 z] [ns x1] [ns x2] [ns x3] } -cleanup { namespace delete ns -} -result {{1 ::ns::x0::z} 1 2 3} -test namespace-42.8 {ensembles: [Bug 1670091]} -setup { +} -result {{1 z} 1 2 3} +test namespace-42.8 { + ensembles: [Bug 1670091], panic due to pointer to a deallocated List + struct. +} -setup { proc demo args {} variable target [list [namespace which demo] x] proc trial args {variable target; string length $target} @@ -1800,6 +1803,34 @@ test namespace-42.8 {ensembles: [Bug 1670091]} -setup { rename foo {} } -result {} +test namespace-42.9 { + ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a + deallocated List struct. +} -setup { + namespace eval n {namespace ensemble create} + set lst [dict create one ::two] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name*} + +test namespace-42.10 { + ensembles: [Bug 4f6a1ebd64] segmentation fault due to pointer to a + deallocated List struct (this time with duplicate of one in "dict"). +} -setup { + namespace eval n {namespace ensemble create} + set lst [list one ::two one ::three] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name *three*} + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* @@ -1920,7 +1951,7 @@ test namespace-44.5 {ensemble: errors} -setup { foobar foobarcon } -cleanup { rename foobar {} -} -returnCodes error -result {invalid command name "::foobarconfigure"} +} -returnCodes error -result {invalid command name "foobarconfigure"} test namespace-44.6 {ensemble: errors} -returnCodes error -body { namespace ensemble create gorp } -result {wrong # args: should be "namespace ensemble create ?option value ...?"} @@ -2084,7 +2115,7 @@ test namespace-47.1 {ensemble: unknown handler} { lappend result [catch {ns c d e} msg] $msg lappend result [catch {ns Magic foo bar spong wibble} msg] $msg list $result [lsort [info commands ::ns::*]] $log [namespace delete ns] -} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}} +} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}} test namespace-47.2 {ensemble: unknown handler} { namespace eval ns { namespace export {[a-z]*} @@ -3183,7 +3214,7 @@ test namespace-53.10 {ensembles: nested rewrite} -setup { 1 {wrong # args: should be "ns z1 x a1"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ - 1 {wrong # args: should be "::ns::x::z0"}\ + 1 {wrong # args: should be "z0"}\ 0 {1 v}\ 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} @@ -3267,6 +3298,18 @@ test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} { } } } {::testing::abc::def ::testing::abc::ghi} + +test namespace-56.4 {bug 16fe1b5807: names starting with ":"} { +namespace eval : { + namespace ensemble create + namespace export * + proc p1 {} { + return 16fe1b5807 + } +} + +: p1 +} 16fe1b5807 # cleanup catch {rename cmd1 {}} diff --git a/tests/oo.test b/tests/oo.test index e03911b..b9c5067 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -128,6 +128,9 @@ test oo-1.3 {basic test of OO functionality: no classes} { test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} +test oo-1.4.1 {fully-qualified nested name} -body { + oo::object create ::one::two::three +} -result {::one::two::three} test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} @@ -1482,6 +1485,38 @@ test oo-11.4 {OO: cleanup} { lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} +test oo-11.5 {OO: cleanup} { + oo::class create obj1 + + trace add command obj1 delete {apply {{name1 name2 action} { + set namespace [info object namespace $name1] + namespace delete $namespace + }}} + + rename obj1 {} + # No segmentation fault + return done +} done + +test oo-11.6 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -body { + oo::class create obj1 + ::oo::define obj1 {self mixin [self]} + + ::oo::copy obj1 obj2 + ::oo::objdefine obj2 {mixin [self]} + + ::oo::copy obj2 obj3 + rename obj3 {} + rename obj2 {} + + # No segmentation fault + return done +} -cleanup { + rename obj1 {} +} -result done test oo-12.1 {OO: filters} { oo::class create Aclass @@ -2013,6 +2048,52 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup { } -cleanup { FooClass destroy } -result {foo bar grill bar} +test oo-15.11 {OO: object cloning} -returnCodes error -body { + oo::copy +} -result {wrong # args: should be "oo::copy sourceName ?targetName? ?targetNamespace?"} +test oo-15.12 {OO: object cloning with target NS} -setup { + oo::class create Super + oo::class create Cls {superclass Super} +} -body { + namespace eval ::existing {} + oo::copy Cls {} ::existing +} -returnCodes error -cleanup { + Super destroy + catch {namespace delete ::existing} +} -result {::existing refers to an existing namespace} +test oo-15.13 {OO: object cloning with target NS} -setup { + oo::class create Super + oo::class create Cls {superclass Super} +} -body { + list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens] +} -cleanup { + Super destroy +} -result {0 ::Cls2 1} +test oo-15.14 {OO: object cloning with target NS} -setup { + oo::class create Cls {export eval} + set result {} +} -body { + Cls create obj + obj eval { + proc test-15.14 {} {} + } + lappend result [info commands ::dupens::t*] + oo::copy obj obj2 ::dupens + lappend result [info commands ::dupens::t*] +} -cleanup { + Cls destroy +} -result {{} ::dupens::test-15.14} +test oo-15.15 {method cloning must ensure that there is a string representation of bodies} -setup { + oo::class create cls +} -body { + cls create foo + oo::objdefine foo { + method m1 {} [string map {a b} {return hello}] + } + [oo::copy foo] m1 +} -cleanup { + cls destroy +} -result hello test oo-16.1 {OO: object introspection} -body { info object @@ -3765,7 +3846,161 @@ test oo-35.4 {Bug 593baa032c: mixins list teardown} { oo::class create D {mixin B} namespace eval [info object namespace D] [list [namespace which B] destroy] } {} +test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly} -setup { + oo::class create base { + unexport destroy + } +} -body { + oo::class create C { + superclass base + method c {} {} + } + oo::class create D { + superclass base + mixin C + method d {} {} + } + oo::class create E { + superclass D + method e {} {} + } + E create e1 + list [lsort [info class methods E -all]] [lsort [info object methods e1 -all]] +} -cleanup { + base destroy +} -result {{c d e} {c d e}} +test oo-35.6 { + Bug : teardown of an object that is a class that is an instance of itself +} -setup { + oo::class create obj + + oo::copy obj obj1 obj1 + oo::objdefine obj1 { + mixin obj1 obj + } + oo::copy obj1 obj2 + oo::objdefine obj2 { + mixin obj2 obj1 + } +} -body { + rename obj2 {} + rename obj1 {} + # doesn't crash + return done +} -cleanup { + rename obj {} +} -result done + + + +test oo-36.1 {TIP #470: introspection within oo::define} { + oo::define oo::object self +} ::oo::object +test oo-36.2 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls +} -body { + oo::define Cls self +} -cleanup { + Cls destroy +} -result ::Cls +test oo-36.3 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self] + } + return $result +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.4 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self {}] + } + return $result +} -cleanup { + Super destroy +} -result {} +test oo-36.5 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self self] + } +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls + set result uncalled +} -body { + Cls create obj + oo::objdefine obj { + ::set ::result [self] + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self anything + } +} -returnCodes error -cleanup { + Cls destroy +} -result {wrong # args: should be "self"} +test oo-36.9 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::define::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + list [oo::define Cls testself] $result +} -cleanup { + Cls destroy + catch {rename oo::define::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}} +test oo-36.10 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::objdefine::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + Cls create obj + list [oo::objdefine obj testself] $result +} -cleanup { + Cls destroy + catch {rename oo::objdefine::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}} cleanupTests return diff --git a/tests/package.test b/tests/package.test index 99f9f06..bb938b8 100644 --- a/tests/package.test +++ b/tests/package.test @@ -20,18 +20,19 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -testConstraint testpreferstable [llength [info commands testpreferstable]] - # Do all this in a slave interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoSlaveInterpreter $i {*}$argv +load {} Tcltest $i interp eval $i { namespace import -force ::tcltest::* -package forget {*}[package names] +#package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" + +testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create @@ -139,7 +140,7 @@ test package-3.1 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.4} test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -149,7 +150,7 @@ test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.5} test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -159,7 +160,7 @@ test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.2 - return $x + set x } -result {2.3} test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -169,7 +170,7 @@ test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require -exact t 2.3 - return $x + set x } -result {2.3} test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -179,7 +180,7 @@ test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.1 - return $x + set x } -result {2.4} test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { package forget t @@ -238,7 +239,7 @@ test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { } -body { package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" package require t 1.2 - return $x + set x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t @@ -256,7 +257,7 @@ test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { } package unknown pkgUnknown package require -exact t 1.5 - return $x + set x } -cleanup { package unknown {} } -result {t 1.5-1.5} @@ -283,7 +284,7 @@ test package-3.15 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package provide [lindex $args 0] 2.0 } package require {a b} - return $x + set x } -cleanup { package unknown {} } -result {{a b} 0-} @@ -575,15 +576,23 @@ test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + interp create child + load {} Tcltest child + child eval { testpreferstable package forget t set x xxx + } } -body { + child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x + } +} -cleanup { + interp delete child } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -593,7 +602,7 @@ test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -603,34 +612,69 @@ test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} +test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + testpreferstable + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.1} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + set x +} -result {1.1} + test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + } +} -cleanup { + interp delete child +} -result {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package forget foo -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] set result {} + } } -body { + child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] + } +} -cleanup { + interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} @@ -638,6 +682,9 @@ test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] + } +} -cleanup { + interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 @@ -656,28 +703,55 @@ test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] -} {{} {}} + } +} -cleanup { + interp delete child +} -result {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] + } +} -cleanup { + interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t @@ -690,18 +764,31 @@ test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] + } +} -cleanup { + interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide @@ -1239,11 +1326,9 @@ proc prefer {args} { } } -test package-13.0 {package prefer defaults} -constraints testpreferstable -setup { - testpreferstable -} -body { +test package-13.0 {package prefer defaults} -body { prefer -} -result stable +} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer @@ -1260,23 +1345,25 @@ test package-14.1 {bogus argument} -returnCodes error -body { test package-15.0 {set, keep} -constraints testpreferstable -setup { testpreferstable -} -body {package prefer stable} -result stable +} -body {package prefer} -result stable test package-15.1 {set stable, keep} -constraints testpreferstable -setup { testpreferstable -} -body {prefer stable} -result {stable stable} +} -body {package prefer stable} -result stable test package-15.2 {set latest, change} -constraints testpreferstable -setup { testpreferstable -} -body {prefer latest} -result {stable latest} +} -body {package prefer latest} -result latest test package-15.3 {set latest, keep} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest latest -} -result {stable latest latest} + package prefer latest + package prefer latest +} -result latest test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest stable -} -result {stable latest latest} + package prefer latest + package prefer stable +} -result latest rename prefer {} diff --git a/tests/platform.test b/tests/platform.test index 5838a41..8a68351 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -16,7 +16,9 @@ namespace eval ::tcl::test::platform { namespace import ::tcltest::test namespace import ::tcltest::cleanupTests - variable ::tcl_platform + # This is not how [variable] works. See TIP 276. + #variable ::tcl_platform + namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/regexp.test b/tests/regexp.test index 4ffdbdb..7367af7 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -19,6 +19,20 @@ if {"::tcltest" ni [namespace children]} { unset -nocomplain foo testConstraint exec [llength [info commands exec]] + +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc memtest script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} + } +} test regexp-1.1 {basic regexp operation} { regexp ab*c abbbc @@ -453,7 +467,7 @@ test regexp-11.4 {regsub errors} { } {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -1123,6 +1137,57 @@ test regexp-26.12 {regexp with -line option} { test regexp-26.13 {regexp without -line option} { regexp -all -inline -- {a*} "b\n" } {{} {}} + +test regexp-27.1 {regsub -command} { + regsub -command {.x.} {abcxdef} {string length} +} ab3ef +test regexp-27.2 {regsub -command} { + regsub -command {.x.} {abcxdefxghi} {string length} +} ab3efxghi +test regexp-27.3 {regsub -command} { + set x 0 + regsub -all -command {(?=.)} abcde {apply {args {incr ::x}}} +} 1a2b3c4d5e +test regexp-27.4 {regsub -command} -body { + regsub -command {.x.} {abcxdef} error +} -returnCodes error -result cxd +test regexp-27.5 {regsub -command} { + regsub -command {(.)(.)} {abcdef} {list ,} +} {, ab a bcdef} +test regexp-27.6 {regsub -command} { + regsub -command -all {(.)(.)} {abcdef} {list ,} +} {, ab a b, cd c d, ef e f} +test regexp-27.7 {regsub -command representation smash} { + set ::s {123=456 789} + regsub -command -all {\d+} $::s {apply {n { + expr {[llength $::s] + $n} + }}} +} {125=458 791} +test regexp-27.8 {regsub -command representation smash} { + set ::t {apply {n { + expr {[llength [lindex $::t 1 1 1]] + $n} + }}} + regsub -command -all {\d+} "123=456 789" $::t +} {131=464 797} +test regexp-27.9 {regsub -command memory leak testing} memory { + set ::s "123=456 789" + set ::t {apply {n { + expr {[llength [lindex $::t 1 1 1]] + [llength $::s] + $n} + }}} + memtest { + regsub -command -all {\d+} $::s $::t + } +} 0 +test regexp-27.10 {regsub -command error cases} -returnCodes error -body { + regsub -command . abc "def \{ghi" +} -result {unmatched open brace in list} +test regexp-27.11 {regsub -command error cases} -returnCodes error -body { + regsub -command . abc {} +} -result {command prefix must be a list of at least one element} +test regexp-27.12 {regsub -command representation smash} { + set s {list (.+)} + regsub -command $s {list list} $s +} {(.+) {list list} list} # cleanup ::tcltest::cleanupTests diff --git a/tests/regexpComp.test b/tests/regexpComp.test index b8e64b6..fbf8012 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -587,7 +587,7 @@ test regexpComp-11.5 {regsub errors} { evalInProc { list [catch {regsub -gorp a b c} msg] $msg } -} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexpComp-11.6 {regsub errors} { evalInProc { list [catch {regsub -nocase a( b c d} msg] $msg diff --git a/tests/resolver.test b/tests/resolver.test index 9bb4c08..b0b395d 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -139,13 +139,10 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s variable r2 "" } } -constraints testinterpresolver -body { - set r0 [namespace eval ::ns2 {x}] - set r1 [namespace eval ::ns2 {z}] - namespace eval ::ns2 { + list [namespace eval ::ns2 {x}] [namespace eval ::ns2 {z}] [namespace eval ::ns2 { namespace import ::ns1::z - set r2 [z] - } - list $r0 $r1 $r2 + z + }] } -cleanup { testinterpresolver down namespace delete ::ns2 diff --git a/tests/safe.test b/tests/safe.test index e43ce12..33ee166 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -74,7 +74,7 @@ test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -s lsort [a aliases] } -cleanup { interp delete a -} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} +} -result {clock} test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} diff --git a/tests/scan.test b/tests/scan.test index 8ddb595..b36b412 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -542,18 +542,23 @@ test scan-5.16 {Bug be003d570f} { scan 0x40 %b } 0 test scan-5.17 {bigint scanning} -setup { - set a {}; set b {}; set c {}; set d {} + set a {}; set b {}; set c {} } -body { - list [scan "207698809136909011942886895,207698809136909011942886895,abcdef0123456789abcdef,125715736004432126361152746757" \ - %llu,%lld,%llx,%llo a b c d] $a $b $c $d -} -result {4 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895} + 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/split.test b/tests/split.test index 585fef5..2d180e0 100644 --- a/tests/split.test +++ b/tests/split.test @@ -70,6 +70,9 @@ test split-1.13 {basic split commands} { test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} +test split-1.15 {basic split commands} -body { + split "a\U01f4a9b" {} +} -result "a \U01f4a9 b" test split-2.1 {split errors} { list [catch split msg] $msg $errorCode diff --git a/tests/string.test b/tests/string.test index 11cbcff..cebaf4c 100644 --- a/tests/string.test +++ b/tests/string.test @@ -28,6 +28,11 @@ testConstraint testindexobj [expr {[info commands testindexobj] != {}}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +proc representationpoke s { + set r [::tcl::unsupported::representation $s] + list [lindex $r 3] [string match {*, string representation "*"} $r] +} + test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} @@ -224,6 +229,13 @@ test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { set uchar \u057e ;# character with two-byte encoding in utf-8 string first % %#$uchar$uchar#$uchar$uchar#% 3 } 8 +test string-4.16 {string first, normal string vs pure unicode string} { + set s hello + regexp ll $s m + # Representation checks are canaries + list [representationpoke $s] [representationpoke $m] \ + [string first $m $s] +} {{string 1} {string 0} 2} test string-5.1 {string index} { list [catch {string index} msg] $msg @@ -576,12 +588,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 @@ -1371,6 +1383,9 @@ test string-14.16 {string replace} { test string-14.17 {string replace} { string replace abcdefghijklmnop end end-1 } {abcdefghijklmnop} +test string-14.18 {string replace} { + string replace abcdefghijklmnop 10 9 XXX +} {abcdefghijklmnop} test string-15.1 {string tolower too few args} { list [catch {string tolower} msg] $msg @@ -1682,40 +1697,40 @@ test string-24.4 {string reverse command - unshared string} { string reverse $x$y } edcba test string-24.5 {string reverse command - shared unicode string} { - set x abcde\udead + set x abcde\ud0ad string reverse $x -} \udeadedcba +} \ud0adedcba test string-24.6 {string reverse command - unshared string} { set x abc - set y de\udead + set y de\ud0ad string reverse $x$y -} \udeadedcba +} \ud0adedcba test string-24.7 {string reverse command - simple case} { string reverse a } a test string-24.8 {string reverse command - simple case} { - string reverse \udead -} \udead + string reverse \ud0ad +} \ud0ad test string-24.9 {string reverse command - simple case} { string reverse {} } {} test string-24.10 {string reverse command - corner case} { - set x \ubeef\udead + set x \ubeef\ud0ad string reverse $x -} \udead\ubeef +} \ud0ad\ubeef test string-24.11 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string reverse $x$y -} \udead\ubeef +} \ud0ad\ubeef test string-24.12 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string is ascii [string reverse $x$y] } 0 test string-24.13 {string reverse command - pure Unicode string} { - string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5] -} \udead\ubeef\udead\ubeef\udead + string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5] +} \ud0ad\ubeef\ud0ad\ubeef\ud0ad test string-24.14 {string reverse command - pure bytearray} { binary scan [string reverse [binary format H* 010203]] H* x set x @@ -1994,9 +2009,52 @@ 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} + # cleanup rename MemStress {} catch {rename foo {}} diff --git a/tests/stringObj.test b/tests/stringObj.test index 49f268e..a78b5f8 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -480,7 +480,6 @@ test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo - if {[testConstraint testobj]} { testobj freeallvars @@ -489,3 +488,7 @@ if {[testConstraint testobj]} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: 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..d0fa7be 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,14 +66,29 @@ 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 {2} +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 {2} +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} { } {} testConstraint testnumutfchars [llength [info commands testnumutfchars]] +testConstraint testfindfirst [llength [info commands testfindfirst]] +testConstraint testfindlast [llength [info commands testfindlast]] + test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" } {0} @@ -81,20 +102,31 @@ 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} { -} {} +test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} { + testfindfirst [testbytestring "abcbc"] 98 +} {bcbc} +test utf-5.1 {Tcl_UtfFindLast} {testfindlast testbytestring} { + testfindlast [testbytestring "abcbc"] 98 +} {bc} test utf-6.1 {Tcl_UtfNext} { } {} @@ -195,8 +227,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 +304,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 22d120b..35fc642 100644 --- a/tests/util.test +++ b/tests/util.test @@ -553,6 +553,12 @@ test util-9.0.6 {TclGetIntForIndex} { test util-9.0.7 {TclGetIntForIndex} { string index abcd { 01 } } b +test util-9.0.8 {TclGetIntForIndex} { + string index abcd { 0d0 } +} a +test util-9.0.9 {TclGetIntForIndex} { + string index abcd { -0d0 } +} a test util-9.1.0 {TclGetIntForIndex} { string index abcd 3 } d @@ -565,6 +571,12 @@ test util-9.1.2 {TclGetIntForIndex} { test util-9.1.3 {TclGetIntForIndex} { string index abcdefghijk { 0xa } } k +test util-9.1.4 {TclGetIntForIndex} { + string index abcdefghijk 0d10 +} k +test util-9.1.5 {TclGetIntForIndex} { + string index abcdefghijk { 0d10 } +} k test util-9.2.0 {TclGetIntForIndex} { string index abcd end } d @@ -672,12 +684,18 @@ test util-9.30 {TclGetIntForIndex} -body { test util-9.31 {TclGetIntForIndex} -body { string index a 0x } -returnCodes error -match glob -result * +test util-9.31.1 {TclGetIntForIndex} -body { + string index a 0d +} -returnCodes error -match glob -result * test util-9.32 {TclGetIntForIndex} -body { string index a 0x1FFFFFFFF+0 } -returnCodes error -match glob -result * test util-9.33 {TclGetIntForIndex} -body { string index a 100000000000+0 } -returnCodes error -match glob -result * +test util-9.33.1 {TclGetIntForIndex} -body { + string index a 0d100000000000+0 +} -returnCodes error -match glob -result * test util-9.34 {TclGetIntForIndex} -body { string index a 1.0 } -returnCodes error -match glob -result * diff --git a/tests/zlib.test b/tests/zlib.test index 9f06eb1..c2f7825 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -1004,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 |