diff options
Diffstat (limited to 'tests')
35 files changed, 1044 insertions, 199 deletions
diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 index 979d081..0000000 --- a/tests/Makefile +++ /dev/null @@ -1,11 +0,0 @@ -jimsh ?= ../jimsh -tclsh ?= tclsh - -test: - @LD_LIBRARY_PATH=..:$(LD_LIBRARY_PATH) $(jimsh) runall.tcl - -tcl: - @rc=0; for i in *.test; do LD_LIBRARY_PATH=..:$(LD_LIBRARY_PATH) $(tclsh) -encoding utf-8 $$i || rc=$?; done; exit $$rc - -clean: - rm -f gorp.file2 gorp.file sleepx test1 exec.tmp1 diff --git a/tests/Makefile.in b/tests/Makefile.in new file mode 100644 index 0000000..0567ff0 --- /dev/null +++ b/tests/Makefile.in @@ -0,0 +1,13 @@ +jimsh ?= ../jimsh +tclsh ?= tclsh + +DEF_LD_PATH := @LD_LIBRARY_PATH@="@builddir@:$(@LD_LIBRARY_PATH@)" + +test: + @$(DEF_LD_PATH) $(jimsh) runall.tcl + +tcl: + @rc=0; for i in *.test; do $(tclsh) -encoding utf-8 $$i || rc=$?; done; exit $$rc + +clean: + rm -f gorp.file2 gorp.file sleepx test1 exec.tmp1 diff --git a/tests/alias.test b/tests/alias.test index c539920..4f6e553 100644 --- a/tests/alias.test +++ b/tests/alias.test @@ -62,8 +62,8 @@ test curry-1.4 "Two word curry" { list [$two x] [$two y] } {1 0} -collect -test curry-1.5 "Delete curry" { +test curry-1.5 "Delete curry" references { + collect unset one two collect } {2} diff --git a/tests/array.test b/tests/array.test index ba88147..423276b 100644 --- a/tests/array.test +++ b/tests/array.test @@ -85,4 +85,50 @@ test array-1.14 "access array via unset var" -body { expr {$a($b) + 4} } -returnCodes error -result {can't read "b": no such variable} +test array-1.15 "array unset non-variable" -body { + array unset nonvariable 4 +} -result {} + +test array-1.16 "array names non-variable" -body { + array names nonvariable +} -result {} + +test array-1.17 "array get non-variable" -body { + array get nonvariable +} -result {} + +# This seems like incorrect behaviour, but it matches tclsh +test array-1.18 "array size non-array" -body { + set x 1 + array size x +} -result {0} + +# This seems like incorrect behaviour, but it matches tclsh +test array-1.19 "array unset non-array" -body { + set x 6 + array unset x 4 +} -result {} + +test array-1.20 "array stat" -body { + set output [array stat a] + regexp "1 entries in table.*number of buckets with 1 entries: 1" $output +} -result {1} + +test array-1.21 "array stat non-array" -body { + array stat badvariable +} -returnCodes error -result {"badvariable" isn't an array} + +test array-1.22 "array set non-even args" -body { + array set x { + 1 one + 2 two + 3 +} +} -returnCodes error -result {list must have an even number of elements} + +test array-1.23 "array exists non-array" -body { + set x 4 + array exists x +} -result {0} + testreport diff --git a/tests/binary.test b/tests/binary.test index 3ba1970..8eb93f9 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -13,6 +13,9 @@ source [file dirname [info script]]/testing.tcl needs cmd binary +if {[testConstraint jim]} { + needs cmd pack +} testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] testConstraint maxCompatibility 0 diff --git a/tests/clock.test b/tests/clock.test new file mode 100644 index 0000000..4e32df4 --- /dev/null +++ b/tests/clock.test @@ -0,0 +1,54 @@ +source [file dirname [info script]]/testing.tcl + +needs cmd clock + +if {[catch {clock scan 2000 -format %Y}]} { + testConstraint clockscan 0 +} else { + testConstraint clockscan 1 +} + +test clock-1.1 {clock usage} -body { + clock +} -returnCodes error -match glob -result {wrong # args: should be "clock command ..."*} + +test clock-1.2 {clock usage} -body { + clock blah +} -returnCodes error -match glob -result {clock, unknown command "blah": should be clicks, format, microseconds, milliseconds, *seconds} + +# clock format +test clock-3.1 {clock format tests} { + set clockval 657687766 + clock format $clockval -format {%a %b %d %I:%M:%S %p %Y} -gmt true +} {Sun Nov 04 03:02:46 AM 1990} + +test clock-3.5 {clock format tests} -body { + clock format +} -returnCodes error -result {wrong # args: should be "clock format seconds ?-format string? ?-gmt boolean?"} + +test clock-3.6 {clock format tests} -body { + clock format foo +} -returnCodes error -result {expected integer but got "foo"} + +test clock-3.8 {clock format tests} -body { + clock format a b c d e g +} -returnCodes error -result {wrong # args: should be "clock format seconds ?-format string? ?-gmt boolean?"} + +test clock-3.9 {clock format tests} { + set clockval 0 + clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true +} "Thu Jan 01 12:00:00 AM 1970" + +test clock-3.10 {clock format tests} -body { + clock format 123 -bad arg +} -returnCodes error -result {bad option "-bad": must be -format, or -gmt} + +test clock-3.11 {clock format tests} { + clock format 123 -format "x" +} x + +test clock-4.1 {clock scan tests} clockscan { + clock scan {Sun Nov 04 03:02:46 AM 1990} -format {%a %b %d %I:%M:%S %p %Y} -gmt true +} 657687766 + +testreport diff --git a/tests/defer.test b/tests/defer.test new file mode 100644 index 0000000..c714656 --- /dev/null +++ b/tests/defer.test @@ -0,0 +1,237 @@ +# vim:se syntax=tcl: + +source [file dirname [info script]]/testing.tcl + +needs cmd defer +needs cmd interp + +test defer-1.1 {defer in proc} { + set x - + proc a {} { + set x + + # This does nothing since it increments a local variable + defer {append x L} + # This increments the global variable + defer {append ::x G} + # Will return "-", not "-L" since return happens before defer triggers + return $x + } + list [a] $x +} {+ -G} + +test defer-1.2 {set $defer directly} { + set x - + proc a {} { + lappend jim::defer {append ::x a} + lappend jim::defer {append ::x b} + return $jim::defer + } + list [a] $x +} {{{append ::x a} {append ::x b}} -ba} + + +test defer-1.3 {unset $defer} { + set x - + proc a {} { + defer {append ::x a} + # unset, to remove all defer actions + unset jim::defer + } + a + set x +} {-} + +test defer-1.4 {error in defer - error} { + set x - + proc a {} { + # First defer script will not happen because of error in next defer script + defer {append ::x a} + # Error ignored because of error from proc + defer {blah} + # Last defer script will happen + defer {append ::x b} + # This error will take precedence over the error from defer + error "from a" + } + set rc [catch {a} msg] + list [info ret $rc] $msg $x +} {error {from a} -b} + +test defer-1.5 {error in defer - return} { + set x - + proc a {} { + # First defer script will not happen + defer {append ::x a} + defer {blah} + # Last defer script will happen + defer {append ::x b} + return 3 + } + set rc [catch {a} msg] + list [info ret $rc] $msg $x +} {error {invalid command name "blah"} -b} + +test defer-1.6 {error in defer - ok} { + set x - + proc a {} { + # First defer script will not happen + defer {append ::x a} + # Error ignored because of error from proc + defer {blah} + # Last defer script will happen + defer {append ::x b} + } + set rc [catch {a} msg] + list [info ret $rc] $msg $x +} {error {invalid command name "blah"} -b} + +test defer-1.7 {error in defer - break} { + set x - + proc a {} { + # First defer script will not happen + defer {append ::x a} + # This non-zero return code will take precedence over the proc return + defer {return -code 30 ret30} + # Last defer script will happen + defer {append ::x b} + + return -code 20 ret20 + } + set rc [catch {a} msg] + list [info ret $rc] $msg $x +} {30 ret30 -b} + +test defer-1.8 {error in defer - tailcall} { + set x - + proc a {} { + # This will prevent tailcall from happening + defer {blah} + + # Tailcall will not happen because of error in defer + tailcall append ::x a + } + set rc [catch {a} msg] + list [info ret $rc] $msg $x +} {error {invalid command name "blah"} -} + +test defer-1.9 {Add to defer in defer body} { + set x - + proc a {} { + defer { + # Add to defer in defer + defer { + # This will do nothing + error here + } + } + defer {append ::x a} + } + a + set x +} {-a} + +test defer-1.10 {Unset defer in defer body} { + set x - + proc a {} { + defer { + # This will do nothing + unset -nocomplain jim::defer + } + defer {append ::x a} + } + a + set x +} {-a} + +test defer-1.11 {defer through tailcall} { + set x {} + proc a {} { + defer {append ::x a} + b + } + proc b {} { + defer {append ::x b} + # c will be invoked as through called from a but this + # won't make any difference for defer + tailcall c + } + proc c {} { + defer {append ::x c} + } + a + set x +} {bca} + +test defer-1.12 {defer in recursive call} { + set x {} + proc a {n} { + # defer happens just before the return, so after the recursive call to a + defer {lappend ::x $n} + if {$n > 0} { + a $($n - 1) + } + } + a 3 + set x +} {0 1 2 3} + +test defer-1.13 {defer in recursive tailcall} { + set x {} + proc a {n} { + # defer happens just before the return, so before the tailcall to a + defer {lappend ::x $n} + if {$n > 0} { + tailcall a $($n - 1) + } + } + a 3 + set x +} {3 2 1 0} + +test defer-1.14 {defer capture variables} { + set x {} + proc a {} { + set y 1 + # A normal defer will evaluate at the end of the proc, so $y may change + defer {lappend ::x $y} + incr y + + # What if we want to capture the value of y here? list will work + defer [list lappend ::x $y] + incr y + + # But with multiple statements, list doesn't work, so use a lambda + # to capture the value instead + defer [lambda {} {y} { + # multi-line script + lappend ::x $y + }] + incr y + + return $y + } + list [a] $x +} {4 {3 2 4}} + +test defer-2.1 {defer from interp} -body { + set i [interp] + # defer needs to have some effect to detect on exit, + # so write to a file + file delete defer.tmp + $i eval { + defer { + [open defer.tmp w] puts "leaving child" + } + } + set a [file exists defer.tmp] + $i delete + # Now the file should exist + set f [open defer.tmp] + $f gets b + $f close + list $a $b +} -result {0 {leaving child}} -cleanup { + file delete defer.tmp +} + +testreport diff --git a/tests/dict2.test b/tests/dict2.test index 2e9bcd4..54d4d0d 100644 --- a/tests/dict2.test +++ b/tests/dict2.test @@ -126,7 +126,7 @@ test dict-3.18 {array set non-dict get command} -constraints jim -returnCodes er } -result {missing value to go with key} test dict-4.1 {dict replace command} { - dict replace {a b c d} + dict-sort [dict replace {a b c d}] } {a b c d} test dict-4.2 {dict replace command} { dict-sort [dict replace {a b c d} e f] @@ -197,6 +197,7 @@ test dict-7.9 {dict values command} -returnCodes error -body { test dict-7.10 {dict values command} -returnCodes error -body { dict values a } -result {missing value to go with key} +test dict-7.11 {dict values with duplicate values} {dict values {a b c b} b} {b b} test dict-8.1 {dict size command} {dict size {}} 0 test dict-8.2 {dict size command} {dict size {a b}} 1 diff --git a/tests/event.test b/tests/event.test index 096f21b..123b17c 100644 --- a/tests/event.test +++ b/tests/event.test @@ -15,8 +15,19 @@ needs cmd after eventloop testConstraint socket [expr {[info commands socket] ne ""}] testConstraint exec [expr {[info commands exec] ne ""}] testConstraint signal [expr {[info commands signal] ne ""}] -catch {[socket -ipv6 stream ::1:5000]} ipv6res -testConstraint ipv6 [expr {$ipv6res ne "ipv6 not supported"}] +catch {[socket -ipv6 stream ::1:5000]} res +set ipv6 1 +if {[string match "*not supported" $res]} { + set ipv6 0 +} else { + # Also, if we can't bind an IPv6 socket, don't run IPv6 tests + if {[catch { + [socket -ipv6 stream.server ::1:5000] close + } msg opts]} { + set ipv6 0 + } +} +testConstraint ipv6 $ipv6 test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} jim { catch {rename bgerror {}} diff --git a/tests/exec.test b/tests/exec.test index 8df1aa8..0eb218a 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -17,26 +17,23 @@ source [file dirname [info script]]/testing.tcl needs cmd exec needs cmd flush -needs cmd after eventloop testConstraint unix [expr {$tcl_platform(platform) eq {unix}}] # Sleep which supports fractions of a second if {[info commands sleep] eq {}} { proc sleep {n} { - after [expr {int($n * 1000)}] + exec {*}$::sleepx $n } } set f [open sleepx w] -puts $f "#![info nameofexecutable]" puts $f { - set seconds [lindex $argv 0] - after [expr {int($seconds * 1000)}] + sleep "$@" } close $f #catch {exec chmod +x sleepx} -set sleepx [list [info nameofexecutable] sleepx] +set sleepx [list sh sleepx] # Basic operations. @@ -349,7 +346,7 @@ test exec-12.1 {reaping background processes} -constraints unix -body { exec echo foo > exec.tmp1 & } exec {*}$sleepx 0.1 - catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg + catch {exec ps | fgrep "echo foo" | fgrep -v grep | wc} msg lindex $msg 0 } -cleanup { file delete exec.tmp1 @@ -416,6 +413,29 @@ test exec-16.1 {flush output before exec} -body { Second line Third line} +test exec-17.1 {redirecting from command pipeline} -setup { + makeFile "abc\nghi\njkl" gorp.file +} -body { + set f [open "|cat gorp.file | wc -l" r] + set result [lindex [exec cat <@$f] 0] + close $f + set result +} -cleanup { + file delete gorp.file +} -result {3} + +test exec-17.2 {redirecting to command pipeline} -setup { + makeFile "abc\nghi\njkl" gorp.file +} -body { + set f [open "|wc -l >gorp2.file" w] + exec cat gorp.file >@$f + flush $f + close $f + lindex [exec cat gorp2.file] 0 +} -cleanup { + file delete gorp.file gorp2.file +} -result {3} + file delete sleepx testreport diff --git a/tests/exec2.test b/tests/exec2.test index e43bba0..b4b42cc 100644 --- a/tests/exec2.test +++ b/tests/exec2.test @@ -5,6 +5,16 @@ source [file dirname [info script]]/testing.tcl needs cmd exec +foreach i {pipe signal wait} { + testConstraint $i [expr {[info commands $i] ne ""}] +} +# Some Windows platforms (e.g. AppVeyor) produce ENOSPC rather than killing +# the child with SIGPIPE). So turn off this test for that platform +if {[info exists env(MSYSTEM)] && $env(MSYSTEM) eq "MINGW32"} { + testConstraint nomingw32 0 +} else { + testConstraint nomingw32 1 +} set d \" set s ' @@ -44,4 +54,50 @@ test exec2-2.4 "Remove all env var" { array set env [array get saveenv] +test exec2-3.1 "close pipeline return value" { + set f [open |false] + set rc [catch {close $f} msg opts] + lassign [dict get $opts -errorcode] status pid exitcode + list $rc $msg $status $exitcode +} {1 {child process exited abnormally} CHILDSTATUS 1} + +test exec2-3.2 "close pipeline return value" -constraints {pipe nomingw32} -body { + # Create a pipe and immediately close the read end + lassign [pipe] r w + close $r + # Write more than 64KB which is maximum size of the pipe buffers + # on all systems we have seen + set bigstring [string repeat a 100000] + set f [open [list |cat << $bigstring >$@w]] + set rc [catch {close $f} msg opts] + lassign [dict get $opts -errorcode] status pid exitcode + list $rc $msg $status $exitcode +} -match glob -result {1 {child killed*} CHILDKILLED SIGPIPE} + +test exec2-3.3 "close pipeline with SIGPIPE blocked" -constraints {pipe signal nomingw32} -body { + # Create a pipe and immediately close the read end + lassign [pipe] r w + close $r + signal block SIGPIPE + # Write more than 64KB which is maximum size of the pipe buffers + # on all systems we have seen + set bigstring [string repeat a 100000] + set f [open [list |cat << $bigstring >$@w 2>/dev/null]] + set rc [catch {close $f} msg opts] + lassign [dict get $opts -errorcode] status pid exitcode + list $rc $msg $status $exitcode +} -match glob -result {1 {child process exited*} CHILDSTATUS 1} -cleanup { + signal default SIGPIPE +} + +test exec2-3.4 "wait for background task" -constraints wait -body { + set pid [exec sleep 0.1 &] + lassign [wait $pid] status newpid exitcode + if {$pid != $newpid} { + error "Got wrong pid from wait" + } else { + list $status $exitcode + } +} -result {CHILDSTATUS 0} + testreport diff --git a/tests/expr-base.test b/tests/expr-base.test index 5c9e1da..27d583e 100644 --- a/tests/expr-base.test +++ b/tests/expr-base.test @@ -7,7 +7,6 @@ set good_testcases { 8 8 00 0 07 7 - 08 8 0x5 5 0x0 0 0x00 0 @@ -23,6 +22,11 @@ foreach {str exp} $good_testcases { test expr-base-1.[incr i] "expr conversion" [list expr [list $str]] $exp } +# JimTCL specifically does not adhere to the octal default for numbers starting with zero +test expr-base-2.1 {expr conversion jim specific} -constraints jim -body { + expr [list "08"] +} -result {8} + set bad_testcases { {0x + 1} x @@ -34,6 +38,6 @@ set bad_testcases { set i 0 foreach str $bad_testcases { - test expr-base-2.[incr i] "expr conversion failure" -returnCodes error -body [list expr $str] -match glob -result "*" + test expr-base-3.[incr i] "expr conversion failure" -returnCodes error -body [list expr $str] -match glob -result "*" } testreport diff --git a/tests/expr-new.test b/tests/expr-new.test index 86e776b..c04da05 100644 --- a/tests/expr-new.test +++ b/tests/expr-new.test @@ -294,7 +294,12 @@ test expr-9.10 {CompileRelationalExpr: error compiling relational arm} { test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2 test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253 test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1 -test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -122 + +# JimTCL specifically does not adhere to the octal default for numbers starting with zero +test expr-10.4 {CompileShiftExpr: just add expr} -constraints jim -body { + expr 1-0123 +} -result {-122} + test expr-10.5 {CompileShiftExpr: error in add expr} { catch {expr x+3} msg } {1} @@ -316,7 +321,11 @@ test expr-10.11 {CompileShiftExpr: runtime error} { test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 -test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 19 +# JimTCL specifically does not adhere to the octal default for numbers starting with zero +test expr-11.4 {CompileAddExpr: just multiply expr} -constraints jim -body { + expr 7891%0123 +} -result {19} + test expr-11.5 {CompileAddExpr: error in multiply expr} { catch {expr x*3} msg } {1} @@ -367,7 +376,11 @@ test expr-12.11 {CompileMultiplyExpr: runtime error} { } {1} test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 -test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 123 +# JimTCL specifically does not adhere to the octal default for numbers starting with zero +test expr-13.2 {CompileUnaryExpr: unary exprs} -constraints jim -body { + expr +000123 +} -result {123} + test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 @@ -400,7 +413,11 @@ test expr-13.16 {CompileUnaryExpr: error in primary expr} { test expr-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1 test expr-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123 test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255 -test expr-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 10 +# JimTCL specifically does not adhere to the octal default for numbers starting with zero +test expr-14.4 {CompilePrimaryExpr: literal primary} -constraints jim -body { + expr 00010 +} -result {10} + test expr-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0 test expr-14.6 {CompilePrimaryExpr: literal primary} { expr 3.1400000 diff --git a/tests/expr.test b/tests/expr.test index dbe84f5..b195d4a 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -99,6 +99,14 @@ test expr-2.4 "Ternary operator - missing question" -body { expr {1 : 2} } -returnCodes error -match glob -result * +test expr-2.5 "Ternary operator with -ve values" { + expr {-1?-2:-3} +} -2 + +test expr-2.6 "Ternary operator with -ve values" { + expr {0?-2:-3} +} -3 + test expr-3.1 "in, ni operators" { set l {a b c d} set c C diff --git a/tests/exprsugar.test b/tests/exprsugar.test index 9579203..943945a 100644 --- a/tests/exprsugar.test +++ b/tests/exprsugar.test @@ -48,5 +48,10 @@ test exprsugar-1.11 {Simple operations} { test exprsugar-1.12 {Simple operations} { set x $((2 + 4)) } 6 +# This necessary to ensure that things like exit will pass through expr-sugar +test exprsugar-1.13 {Non-error return inside expr-sugar} -body { + proc a {} { break } + set x $([a]) +} -returnCodes break testreport diff --git a/tests/file.test b/tests/file.test new file mode 100644 index 0000000..fb5a555 --- /dev/null +++ b/tests/file.test @@ -0,0 +1,156 @@ +source [file dirname [info script]]/testing.tcl + +needs cmd file + +test join-1.1 "One name" { + file join abc +} {abc} + +test join-1.2 "One name with trailing slash" { + file join abc/ +} {abc} + +test join-1.3 "One name with leading slash" { + file join /abc +} {/abc} + +test join-1.4 "One name with leading and trailing slash" { + file join /abc/ +} {/abc} + +test join-1.5 "Two names" { + file join abc def +} {abc/def} + +test join-1.6 "Two names with dir trailing slash" { + file join abc/ def +} {abc/def} + +test join-1.7 "Two names with dir leading slash" { + file join /abc def +} {/abc/def} + +test join-1.8 "Two names with dir leading and trailing slash" { + file join /abc/ def +} {/abc/def} + +test join-1.9 "Two names with file trailing slash" { + file join abc def/ +} {abc/def} + +test join-1.10 "Two names with file leading slash" { + file join abc /def +} {/def} + +test join-1.11 "Two names with file leading and trailing slash" { + file join abc /def/ +} {/def} + +test join-1.12 "Two names with double slashes" { + file join abc/ /def +} {/def} + +test join-1.13 "Join to root" { + file join / abc +} {/abc} + +test join-1.14 "Join to root" { + set dir [file join / .] + # Either / or /. is OK here + expr {$dir in {/ /.}} +} 1 + +test join-1.15 "Join to root" { + file join / / +} {/} + +test join-1.16 "Join to root" { + file join /abc / +} {/} + +test join-1.17 "With trailing slash" { + file join /abc/def/ ghi/jkl +} {/abc/def/ghi/jkl} + +test join-2.1 "Dir is empty string" { + file join "" def +} {def} + +test join-2.2 "File is empty string" { + file join abc "" +} {abc} + +test join-2.3 "Path too long" jim { + set components [string repeat {abcdefghi } 500] + list [catch [concat file join $components] msg] $msg +} {1 {Path too long}} + +test tail-1.1 "One component" { + file tail abc +} {abc} + +test tail-1.2 "Two components" { + file tail abc/def +} {def} + +test tail-1.3 "Absolute one component" { + file tail /abc +} {abc} + +test tail-1.4 "Trailing slash" { + file tail abc/ +} {abc} + +test dirname-1.1 "One component" { + file dirname abc +} {.} + +test dirname-1.2 "Two components" { + file dirname abc/def +} {abc} + +test dirname-1.3 "Absolute one component" { + file dirname /abc +} {/} + +test dirname-1.4 "Trailing slash" { + file dirname abc/ +} {.} + +# These tests are courtesy of picol + +test file.12.1 "picol test" {file dirname /foo/bar/grill.txt} /foo/bar +test file.12.2 "picol test" {file dirname /foo/bar/baz/} /foo/bar +test file.12.3 "picol test" {file dirname /foo/bar/baz///} /foo/bar +test file.12.4 "picol test" {file dirname /foo/bar/baz///qux} /foo/bar/baz +test file.12.5 "picol test" {file dirname foo/bar/grill.txt} foo/bar +test file.12.6 "picol test" {file dirname foo/bar/baz/} foo/bar +test file.12.7 "picol test" {file dirname {}} . +test file.12.8 "picol test" {file dirname /} / +test file.12.9 "picol test" {file dirname ///} / + +test file.13.1 "picol test" {file tail /foo/bar/grill.txt} grill.txt +test file.13.2 "picol test" {file tail /foo/bar/baz/} baz +test file.13.3 "picol test" {file tail /foo/bar/baz///} baz +test file.13.4 "picol test" {file dirname /foo/bar/baz///qux} /foo/bar/baz +test file.13.5 "picol test" {file tail foo/bar/grill.txt} grill.txt +test file.13.6 "picol test" {file tail foo/bar/baz/} baz +test file.13.7 "picol test" {file tail {}} {} +test file.13.8 "picol test" {file tail /} {} +test file.13.9 "picol test" {file tail ///} {} + +test file.14 "picol test" {file join foo} foo +test file.15 "picol test" {file join foo bar} foo/bar +test file.16 "picol test" {file join foo /bar} /bar + +if {$tcl_platform(platform) eq {windows}} { + test file.17 "picol test" {file join foo C:/bar grill} C:/bar/grill +} + +test file.18 "picol test" {file split {/foo/space station/bar}} {/ foo {space station} bar} +test file.19 "picol test" {file split {/foo/space station/bar/}} {/ foo {space station} bar} +test file.20 "picol test" {file split {foo/space station/bar}} {foo {space station} bar} +test file.21 "picol test" {file split foo///bar} {foo bar} +test file.22 "picol test" {file split foo} foo + +testreport diff --git a/tests/filejoin.test b/tests/filejoin.test deleted file mode 100644 index 7245938..0000000 --- a/tests/filejoin.test +++ /dev/null @@ -1,84 +0,0 @@ -source [file dirname [info script]]/testing.tcl - -needs cmd file - -test join-1.1 "One name" { - file join abc -} {abc} - -test join-1.2 "One name with trailing slash" { - file join abc/ -} {abc} - -test join-1.3 "One name with leading slash" { - file join /abc -} {/abc} - -test join-1.4 "One name with leading and trailing slash" { - file join /abc/ -} {/abc} - -test join-1.5 "Two names" { - file join abc def -} {abc/def} - -test join-1.6 "Two names with dir trailing slash" { - file join abc/ def -} {abc/def} - -test join-1.7 "Two names with dir leading slash" { - file join /abc def -} {/abc/def} - -test join-1.8 "Two names with dir leading and trailing slash" { - file join /abc/ def -} {/abc/def} - -test join-1.9 "Two names with file trailing slash" { - file join abc def/ -} {abc/def} - -test join-1.10 "Two names with file leading slash" { - file join abc /def -} {/def} - -test join-1.11 "Two names with file leading and trailing slash" { - file join abc /def/ -} {/def} - -test join-1.12 "Two names with double slashes" { - file join abc/ /def -} {/def} - -test join-1.13 "Join to root" { - file join / abc -} {/abc} - -test join-1.14 "Join to root" { - set dir [file join / .] - # Either / or /. is OK here - expr {$dir in {/ /.}} -} 1 - -test join-1.15 "Join to root" { - file join / / -} {/} - -test join-1.16 "Join to root" { - file join /abc / -} {/} - -test join-2.1 "Dir is empty string" { - file join "" def -} {def} - -test join-2.2 "File is empty string" { - file join abc "" -} {abc} - -test join-2.3 "Path too long" jim { - set components [string repeat {abcdefghi } 500] - list [catch [concat file join $components] msg] $msg -} {1 {Path too long}} - -testreport diff --git a/tests/format.test b/tests/format.test index 6a9ce85..bc3e461 100644 --- a/tests/format.test +++ b/tests/format.test @@ -508,6 +508,10 @@ test format-16.4 {format %b} { format %b 1234567 } {100101101011010000111} +test format-16.5 {format %b} { + list [catch {format %b badvalue} msg] $msg +} {1 {expected integer but got "badvalue"}} + # cleanup catch {unset a} catch {unset b} diff --git a/tests/glob2.test b/tests/glob2.test index 5e4be31..80fdd12 100644 --- a/tests/glob2.test +++ b/tests/glob2.test @@ -236,34 +236,6 @@ test fileName-20.1 {Bug 1750300} -setup { removeFile TAGS $d removeDirectory foo } -result 1 -test fileName-20.6 {Bug 2837800} -setup { - # Recall that we have $env(HOME) set so that references - # to ~ point to [temporaryDirectory] - makeFile {} test ~ - set dd [makeDirectory isolate] - set d [makeDirectory ./~ $dd] - set savewd [pwd] - cd $dd -} -body { - glob -nocomplain */test -} -cleanup { - cd $savewd - removeDirectory ./~ $dd - removeDirectory isolate - removeFile test ~ -} -result {} -test fileName-20.7 {Bug 2806250} -setup { - set savewd [pwd] - cd [temporaryDirectory] - set d [makeDirectory isolate] - makeFile {} ./~test $d -} -body { - file exists [lindex [glob -nocomplain isolate/*] 0] -} -cleanup { - removeFile ./~test $d - removeDirectory isolate - cd $savewd -} -result 1 # cleanup catch {file delete -force C:/globTest} diff --git a/tests/json.test b/tests/json.test new file mode 100644 index 0000000..ed73401 --- /dev/null +++ b/tests/json.test @@ -0,0 +1,173 @@ +source [file dirname [info script]]/testing.tcl + +needs cmd json::decode json +needs cmd json::encode json + +set json { +{ + "fossil":"9c65b5432e4aeecf3556e5550c338ce93fd861cc", + "timestamp":1435827337, + "command":"timeline/checkin", + "procTimeUs":3333, + "procTimeMs":3, + "homepage":null, + "payload":{ + "limit":1, + "timeline":[{ + "type":"checkin", + "uuid":"f8b17edee7ff4f16517601c40eb713602aed7a52", + "isLeaf":true, + "timestamp":1435318826, + "user":"juef", + "comment":"adwaita-icon-theme: update to 3.17.3", + "parents":["de628be645cc62429d630f9234c56d1fddfdc2a3"], + "tags":["trunk"] + }] + } +}} + +test json-decode-001 {top level keys} { + lsort [dict keys [json::decode $json]] +} {command fossil homepage payload procTimeMs procTimeUs timestamp} + +# Note that the decode will return the keys/values in order +test json-decode-002 {object value} { + dict get [json::decode $json] payload +} {limit 1 timeline {{type checkin uuid f8b17edee7ff4f16517601c40eb713602aed7a52 isLeaf true timestamp 1435318826 user juef comment {adwaita-icon-theme: update to 3.17.3} parents de628be645cc62429d630f9234c56d1fddfdc2a3 tags trunk}}} + +test json-decode-003 {object nested value} { + dict get [json::decode $json] payload timeline +} {{type checkin uuid f8b17edee7ff4f16517601c40eb713602aed7a52 isLeaf true timestamp 1435318826 user juef comment {adwaita-icon-theme: update to 3.17.3} parents de628be645cc62429d630f9234c56d1fddfdc2a3 tags trunk}} + +test json-decode-004 {array entry from nested value} { + lindex [dict get [json::decode $json] payload timeline] 0 +} {type checkin uuid f8b17edee7ff4f16517601c40eb713602aed7a52 isLeaf true timestamp 1435318826 user juef comment {adwaita-icon-theme: update to 3.17.3} parents de628be645cc62429d630f9234c56d1fddfdc2a3 tags trunk} + +test json-decode-005 {object value from child array entry} { + dict get [lindex [dict get [json::decode $json] payload timeline] 0] comment +} {adwaita-icon-theme: update to 3.17.3} + +test json-decode-006 {unicode escape} { + dict get [json::decode {{"key":"\u2022"}}] key +} \u2022 + +test json-decode-011 {null subsitution} { + dict get [json::decode -null NULL $json] homepage +} {NULL} + +test json-decode-012 {default null value} { + dict get [json::decode $json] homepage +} {null} + +test json-decode-1.1 {Number forms} { + json::decode {[ 1, 2, 3.0, 4, Infinity, NaN, -Infinity, -0.0, 1e5, -1e-5 ]} +} {1 2 3.0 4 Inf NaN -Inf -0.0 1e5 -1e-5} + +test json-2.1 {schema tests} { + lindex [json::decode -schema {[]}] 1 +} {list} + +test json-2.2 {schema tests} { + lindex [json::decode -schema {[1, 2]}] 1 +} {list num} + +test json-2.3 {schema tests} { + lindex [json::decode -schema {[1, 2, [3, 4], 4, 6]}] 1 +} {mixed num num {list num} num num} + +test json-2.4 {schema tests} { + lindex [json::decode -schema {{"a":1, "b":2}}] 1 +} {obj a num b num} + +test json-2.5 {schema tests} { + lindex [json::decode -schema {[1, 2, {a:"b", c:false}, "hello"]}] 1 +} {mixed num num {obj a str c bool} str} + +test json-2.6 {schema tests} { + lindex [json::decode -schema {[1, 2, {a:["b", 1, true, Infinity]}]}] 1 +} {mixed num num {obj a {mixed str num bool num}}} + +test json-2.7 {schema tests} { + lindex [json::decode -schema {[1, 2, {a:["b", 1, true, ["d", "e", "f"]]}]}] 1 +} {mixed num num {obj a {mixed str num bool {list str}}}} + +test json-2.8 {schema tests} { + lindex [json::decode -schema {[1, 2, true, false]}] 1 +} {mixed num num bool bool} + +test json-2.9 {schema tests} { + lindex [json::decode -schema {[{a:1},{b:2}]}] 1 +} {mixed {obj a num} {obj b num}} + + +test json-3.1 {-index array} { + json::decode -index \ + {[null, 1, 2, true, false, "hello"]} +} {0 null 1 1 2 2 3 true 4 false 5 hello} + +test json-3.2 {-index array and object} { + json::decode -index \ + {{"outer": [{"key": "value"}, {"key2": "value2"}]}} +} {outer {0 {key value} 1 {key2 value2}}} + +test json-3.3 {-index array with -schema} { + json::decode -index -schema \ + {[null, 1, 2, true, false, "hello"]} +} "{0 null 1 1 2 2 3 true 4 false 5 hello}\ + {mixed num num num bool bool str}" + +test json-3.4 {-index array with -schema 2} { + json::decode -index -schema \ + {{"outer": [{"key": "value"}, {"key2": "value2"}]}} +} "{outer {0 {key value} 1 {key2 value2}}}\ + {obj outer {mixed {obj key str} {obj key2 str}}}" + + +unset -nocomplain json + +test json-encode-1.1 {String with backslashes} { + json::encode {A "quoted string containing \backslashes\"} +} {"A \"quoted string containing \\backslashes\\\""} + +test json-encode-1.2 {String with special chars} { + json::encode "Various \n special \b characters \t and /slash/ \r too" +} {"Various \n special \b characters \t and \/slash\/ \r too"} + +test json-encode-1.3 {Array of numbers} { + json::encode {1 2 3.0 4 Inf NaN -Inf -0.0 1e5 -1e-5} {list num} +} {[ 1, 2, 3.0, 4, Infinity, NaN, -Infinity, -0.0, 1e5, -1e-5 ]} + +test json-encode-1.4 {Array of strings} { + json::encode {1 2 3.0 4} list +} {[ "1", "2", "3.0", "4" ]} + +test json-encode-1.5 {Array of objects} { + json::encode {{state NY city {New York} postalCode 10021 streetAddress {21 2nd Street}} {state CA city {Los Angeles} postalCode 10345 streetAddress {15 Hale St}}} {list obj postalCode num} +} {[ { "city":"New York", "postalCode":10021, "state":"NY", "streetAddress":"21 2nd Street" }, { "city":"Los Angeles", "postalCode":10345, "state":"CA", "streetAddress":"15 Hale St" } ]} + +test json-encode-1.6 {Simple typeless object} { + json::encode {home {212 555-1234} fax {646 555-4567}} obj +} {{ "fax":"646 555-4567", "home":"212 555-1234" }} + +test json-encode-1.7 {Primitives as num} { + json::encode {a false b null c true} {obj a num b num c num} +} {{ "a":false, "b":null, "c":true }} + +test json-encode-1.8 {Complex schema} { + json::encode {Person {firstName John age 25 lastName Smith years {1972 1980 1995 2002} PhoneNumbers {home {212 555-1234} fax {646 555-4567}} Address {state NY city {New York} postalCode 10021 streetAddress {21 2nd Street}}}} {obj Person {obj age num Address {obj postalCode num} PhoneNumbers obj years {list num}}} +} {{ "Person":{ "Address":{ "city":"New York", "postalCode":10021, "state":"NY", "streetAddress":"21 2nd Street" }, "PhoneNumbers":{ "fax":"646 555-4567", "home":"212 555-1234" }, "age":25, "firstName":"John", "lastName":"Smith", "years":[ 1972, 1980, 1995, 2002 ] } }} + +test json-encode-1.9 {Array of mixed types} { + json::encode {{a b c d} 44} {mixed list num} +} {[ [ "a", "b", "c", "d" ], 44 ]} + +test json-encode-1.10 {Array of objects} { + json::encode {{state NY city {New York} postalCode 10021 streetAddress {21 2nd Street}} {state CA city {Los Angeles} postalCode 10345 streetAddress {15 Hale St}}} {list obj postalCode num} +} {[ { "city":"New York", "postalCode":10021, "state":"NY", "streetAddress":"21 2nd Street" }, { "city":"Los Angeles", "postalCode":10345, "state":"CA", "streetAddress":"15 Hale St" } ]} + +test json-encode-1.11 {Forms of boolean} { + json::encode {-5 4 1 0 yes no true false} {list bool} +} {[ true, true, true, false, true, false, true, false ]} + + +testreport diff --git a/tests/lock.test b/tests/lock.test index 3672d6a..e7b0b2d 100644 --- a/tests/lock.test +++ b/tests/lock.test @@ -42,6 +42,19 @@ test lock-1.5 {grab lock from sub-process} { set stat } 0 +test lock-1.6 {wait for lock} { + # Run a child process that grabs the lock for 0.5 seconds + set pid [exec [info nameofexecutable] -e {set fh [open locktest.file r+]; $fh lock; sleep 0.5} >/dev/null &] + # And wait to acquire the lock in the parent. Should take ~500ms + set start [clock millis] + sleep 0.1 + $fh lock -wait + set delta [expr {[clock millis] - $start}] + if {$delta < 100} { + error "Lock acquired after ${delta}ms" + } +} {} + $fh close file delete locktest.file diff --git a/tests/lreplace.test b/tests/lreplace.test index ba77505..32a2111 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -95,7 +95,18 @@ test lreplace-1.26 {lreplace command} { [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} - +test lreplace-1.27 {lreplace command} -body { + lreplace x 1 1 +} -result x +test lreplace-1.28 {lreplace command} -body { + lreplace x 1 1 y +} -result {x y} +test lreplace-1.29 {lreplace command} -body { + lreplace x 1 1 [error foo] +} -returnCodes 1 -result {foo} +test lreplace-1.30 {lreplace command} -body { + lreplace {not {}alist} 0 0 [error foo] +} -returnCodes 1 -result {foo} test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg @@ -114,10 +125,10 @@ test lreplace-2.5 {lreplace errors} { } {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg -} {1 {list doesn't contain element 3}} +} {0 x} test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 1 1} msg] $msg -} {1 {list doesn't contain element 1}} +} {0 x} test lreplace-3.1 {lreplace won't modify shared argument objects} { proc p {} { @@ -127,6 +138,75 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { p } "a b c" +test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} { + lreplace {} 1 1 +} {} +test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} { + lreplace { } 1 1 +} {} +test lreplace-4.3 {lreplace edge case} { + lreplace {1 2 3} 2 0 +} {1 2 3} +test lreplace-4.4 {lreplace edge case} { + lreplace {1 2 3 4 5} 3 1 +} {1 2 3 4 5} +test lreplace-4.5 {lreplace edge case} { + lreplace {1 2 3 4 5} 3 0 _ +} {1 2 3 _ 4 5} +test lreplace-4.6 {lreplace end-x: bug a4cb3f06c4} { + lreplace {0 1 2 3 4} 0 end-2 +} {3 4} +test lreplace-4.6.1 {lreplace end-x: bug a4cb3f06c4} { + lreplace {0 1 2 3 4} 0 end-2 a b c +} {a b c 3 4} +test lreplace-4.7 {lreplace with two end-indexes: increasing} { + lreplace {0 1 2 3 4} end-2 end-1 +} {0 1 4} +test lreplace-4.7.1 {lreplace with two end-indexes: increasing} { + lreplace {0 1 2 3 4} end-2 end-1 a b c +} {0 1 a b c 4} +test lreplace-4.8 {lreplace with two end-indexes: equal} { + lreplace {0 1 2 3 4} end-2 end-2 +} {0 1 3 4} +test lreplace-4.8.1 {lreplace with two end-indexes: equal} { + lreplace {0 1 2 3 4} end-2 end-2 a b c +} {0 1 a b c 3 4} +test lreplace-4.9 {lreplace with two end-indexes: decreasing} { + lreplace {0 1 2 3 4} end-2 end-3 +} {0 1 2 3 4} +test lreplace-4.9.1 {lreplace with two end-indexes: decreasing} { + lreplace {0 1 2 3 4} end-2 end-3 a b c +} {0 1 a b c 2 3 4} +test lreplace-4.10 {lreplace with two equal indexes} { + lreplace {0 1 2 3 4} 2 2 +} {0 1 3 4} +test lreplace-4.10.1 {lreplace with two equal indexes} { + lreplace {0 1 2 3 4} 2 2 a b c +} {0 1 a b c 3 4} +test lreplace-4.11 {lreplace end index first} { + lreplace {0 1 2 3 4} end-2 1 a b c +} {0 1 a b c 2 3 4} +test lreplace-4.12 {lreplace end index first} { + lreplace {0 1 2 3 4} end-2 2 a b c +} {0 1 a b c 3 4} +test lreplace-4.13 {lreplace empty list} { + lreplace {} 1 1 1 +} 1 +test lreplace-4.14 {lreplace empty list} { + lreplace {} 2 2 2 +} 2 + +test lreplace-5.1 {compiled lreplace: Bug 47ac84309b} { + apply {x { + lreplace $x end 0 + }} {a b c} +} {a b c} +test lreplace-5.2 {compiled lreplace: Bug 47ac84309b} { + apply {x { + lreplace $x end 0 A + }} {a b c} +} {a b A c} + # cleanup catch {unset foo} ::tcltest::cleanupTests diff --git a/tests/lsort.test b/tests/lsort.test index ca2fc49..5808b89 100644 --- a/tests/lsort.test +++ b/tests/lsort.test @@ -149,9 +149,12 @@ test lsort-3.9 {SortCompare procedure, -integer option} { test lsort-3.10 {SortCompare procedure, -integer option} { list [catch {lsort -integer {3 q}} msg] $msg } {1 {expected integer but got "q"}} -test lsort-3.11 {SortCompare procedure, -integer option} { +# JimTCL specifically does not adhere to the octal default for numbers starting with zero +test lsort-3.11 {SortCompare procedure, -integer option} -constraints jim -body { lsort -integer {35 21 0x20 30 023 100 8} -} {8 21 023 30 0x20 35 100} +} -result {8 21 023 30 0x20 35 100} + + test lsort-3.15 {SortCompare procedure, -command option} { proc cmp {a b} { error "comparison error" @@ -176,9 +179,11 @@ test lsort-3.18 {SortCompare procedure, -command option} { } lsort -command cmp {48 6 18 22 21 35 36} } {48 36 35 22 21 18 6} -test lsort-3.19 {SortCompare procedure, -decreasing option} { +# JimTCL specifically does not adhere to the octal default for numbers starting with zero +test lsort-3.19 {SortCompare procedure, -decreasing optio} -constraints jim -body { lsort -decreasing -integer {35 21 0x20 30 023 100 8} -} {100 35 0x20 30 023 21 8} +} -result {100 35 0x20 30 023 21 8} + test lsort-3.20 {SortCompare procedure, -real option} -body { lsort -real {6...4 3} } -returnCodes error -result {expected floating-point number but got "6...4"} @@ -198,24 +203,8 @@ test lsort-3.22 {lsort, unique sort with index} { } {0 4 5} test lsort-4.26 {DefaultCompare procedure, signed characters} utf8 { - set l [lsort [list "abc\u80" "abc"]] - set viewlist {} - foreach s $l { - set viewelem "" - set len [string length $s] - for {set i 0} {$i < $len} {incr i} { - set c [string index $s $i] - scan $c %c d - if {$d > 0 && $d < 128} { - append viewelem $c - } else { - append viewelem "\\[format %03o [expr {$d & 0xff}]]" - } - } - lappend viewlist $viewelem - } - set viewlist -} [list "abc" "abc\\200"] + lsort [list "abc\u80" "abc"] +} [list "abc" "abc\u80"] test lsort-5.1 "Sort case insensitive" { lsort -nocase {ba aB aa ce} diff --git a/tests/misc.test b/tests/misc.test index 60dcf78..0ff2a7a 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -475,6 +475,19 @@ test jimexpr-2.5 "double ** operator" { expr {$result in {unsupported 8.0}} } 1 +test jimexpr-2.6 "exit in expression" { + # The inner 'exit 0' should propagate through the if to + # the outer catch + catch -exit { + set x 1 + if {[catch {exit 0}] == 1} { + set x 2 + } else { + set x 3 + } + } +} 6 + # This one is for test coverage of an unusual case test jimobj-1.1 "duplicate obj with no dupIntRepProc" { proc "x x" {} { return 2 } @@ -550,7 +563,7 @@ test lmap-1.1 {lmap} { test exprerr-1.1 {Error message with bad expr} { catch {expr {5 ||}} msg set msg -} {Expression has bad operands to ||} +} {syntax error in expression "5 ||": premature end of expression} test eval-list-1.1 {Lost string rep with list} { set x {set y 1; incr y} diff --git a/tests/pid.test b/tests/pid.test index 6a534a5..56ffcf8 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -19,7 +19,7 @@ needs cmd pid posix needs cmd exec catch {package require regexp} testConstraint regexp [expr {[info commands regexp] ne {}}] -testConstraint socket [expr {[info commands socket] ne {}}] +testConstraint pipe [expr {[info commands pipe] ne {}}] testConstraint getpid [expr {[catch pid] == 0}] # This is a proxy for tcl || tclcompat testConstraint pidchan [expr {[info commands fconfigure] ne {}}] @@ -29,7 +29,7 @@ file delete test1 test pid-1.1 {pid command} {regexp getpid} { regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid] } 1 -test pid-1.2 {pid command} {regexp socket pidchan} { +test pid-1.2 {pid command} {regexp pipe pidchan} { set f [open {| echo foo | cat >test1} w] set pids [pid $f] close $f @@ -38,7 +38,7 @@ test pid-1.2 {pid command} {regexp socket pidchan} { [regexp {^[0-9]+$} [lindex $pids 1]] \ [expr {[lindex $pids 0] == [lindex $pids 1]}] } {2 1 1 0} -test pid-1.3 {pid command} {socket pidchan} { +test pid-1.3 {pid command} {pipe pidchan} { set f [open test1 w] set pids [pid $f] close $f diff --git a/tests/prefix.test b/tests/prefix.test index 1540f75..e81d429 100644 --- a/tests/prefix.test +++ b/tests/prefix.test @@ -14,12 +14,15 @@ source [file dirname [info script]]/testing.tcl -needs cmd tcl::prefix prefix +needs cmd tcl::prefix tclprefix testConstraint namespace [expr {[info commands namespace] ne ""}] test string-26.1 {tcl::prefix, too few args} -body { tcl::prefix match a } -returnCodes 1 -match glob -result {wrong # args: should be "tcl::prefix match ?options*? table string"} +test string-26.1.1 {tcl::prefix, too few args} -body { + tcl::prefix +} -returnCodes 1 -match glob -result {wrong # args: should be "tcl::prefix subcommand ?arg ...?"} test string-26.2 {tcl::prefix, bad args} -body { tcl::prefix match a b c } -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message} @@ -27,6 +30,9 @@ test string-26.2.1 {tcl::prefix, empty table} -body { tcl::prefix match {} foo } -returnCodes 1 -result {bad option "foo": no valid options} +test string-26.2.2 {tcl::prefix, bad args} -body { + tcl::prefix badoption +} -returnCodes 1 -result {bad option "badoption": must be all, longest, or match} test string-26.3.1 {tcl::prefix, bad args} -body { diff --git a/tests/regcount.test b/tests/regcount.test index 96f4ddd..5c1469e 100644 --- a/tests/regcount.test +++ b/tests/regcount.test @@ -84,6 +84,7 @@ foreach {pat str exp} { (a|y){5,6}? baaaad {} {[[:alpha:]]+} _bcd56_ef bcd {[[:alnum:]]+} _bcd56_ef bcd56 + {[\w]+} :_bcd56_ef _bcd56_ef {[[:space:]]+} "_bc \t\r\n\f\v_" "{ \t\r\n\f\v}" {[\x41-\x43]+} "_ABCD_" ABC {\m.+\M} "#A test#" "{A test}" diff --git a/tests/regexp.test b/tests/regexp.test index 94107eb..2e9b13e 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -222,6 +222,10 @@ test regexp-6.8 {regexp errors} jim { test regexp-6.9 {regexp errors, -start bad int check} { list [catch {regexp -start bogus {^$} {}} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} +test regexp-6.10 {regexp errors, -start too few args} { + list [catch {regexp -all -start} msg] $msg +} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} + test regexp-7.1 {basic regsub operation} { list [regsub aa+ xaxaaaxaa 111&222 foo] $foo @@ -388,6 +392,10 @@ test regexp-11.11 {regsub without final variable name returns value} { test regexp-11.12 {regsub without final variable name returns value} { regsub -all b(\[^d\]*)d abcdeabcfde {,&,\1,} } {a,bcd,c,ea,bcfd,cf,e} +test regexp-11.13 {regsub errors, -start too few args} { + list [catch {regsub -all -nocase -nocase -start} msg] $msg +} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} + # This test crashes on the Mac unless you increase the Stack Space to about 1 # Meg. This is probably bigger than most users want... diff --git a/tests/regexp2.test b/tests/regexp2.test index f7cf516..1aee8cd 100644 --- a/tests/regexp2.test +++ b/tests/regexp2.test @@ -627,6 +627,12 @@ test regexpComp-16.3 {regsub -start} { # lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x # lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x #} {5 /a/b/c/d/e 3 ab/c/d/e} +test regexpComp-16.5 {regexp -start with utf8} utf8 { + regexp -inline -start 1 . \u0442\u0435\u0441\u0442 +} \u0435 +test regexpComp-16.6 {regexp -start with utf8} utf8 { + regsub -start 1 . \u0442\u0435\u0441\u0442 x +} \u0442x\u0441\u0442 test regexpComp-17.1 {regexp -inline} { regexp -inline b ababa @@ -649,6 +655,9 @@ test regexpComp-17.6 {regexp -inline no matches} { test regexpComp-17.7 {regexp -inline, no matchvars allowed} { list [catch {regexp -inline b abc match} msg] $msg } {1 {regexp match variables not allowed when using -inline}} +test regexpComp-17.8 {regexp -indices utf8} utf8 { + regexp -all -inline -start 1 -indices . \u0442\u0435\u0441\u0442 +} {{1 1} {2 2} {3 3}} test regexpComp-18.1 {regexp -all} { regexp -all b bbbbb diff --git a/tests/runall.tcl b/tests/runall.tcl index 5b5d220..2b1c15a 100644 --- a/tests/runall.tcl +++ b/tests/runall.tcl @@ -24,25 +24,35 @@ if {[info commands interp] eq ""} { foreach script [lsort [glob *.test]] { set ::argv0 $script - set i [interp] + if {$script eq "signal.test"} { + # special case, can't run this in a child interpeter + catch -exit { + source $script + } + foreach var {pass fail skip tests} { + incr total($var) $testinfo(num$var) + } + } else { + set i [interp] - foreach var {argv0 auto_path} { - $i eval [list set $var [set ::$var]] - } + foreach var {argv0 auto_path} { + $i eval [list set $var [set ::$var]] + } - # Run the test - catch -exit {$i eval source $script} msg opts - if {[info returncode $opts(-code)] eq "error"} { - puts [format "%16s: --- error ($msg)" $script] - incr total(fail) - } + # Run the test + catch -exit {$i eval source $script} msg opts + if {[info returncode $opts(-code)] eq "error"} { + puts [format "%16s: --- error ($msg)" $script] + incr total(fail) + } - # Extract the counts - foreach var {pass fail skip tests} { - incr total($var) [$i eval "set testinfo(num$var)"] + # Extract the counts + foreach var {pass fail skip tests} { + incr total($var) [$i eval "set testinfo(num$var)"] + } + $i delete } - $i delete stdout flush } puts [string repeat = 73] diff --git a/tests/subst.test b/tests/subst.test index 353af5f..5128a99 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -142,10 +142,13 @@ test subst-10.2 {break in a subst} { test subst-10.3 {break in a subst} { subst {foo [if 1 { break; bogus code}] bar} } {foo } -test subst-10.4 {break in a subst, parse error} { + +# Note that unlike Tcl, Jim throws an error for these two before +# evaluating +test subst-10.4 {break in a subst, parse error} tcl { subst {foo [break ; set a {}{} ; stuff] bar} } {foo } -test subst-10.5 {break in a subst, parse error} { +test subst-10.5 {break in a subst, parse error} tcl { subst {foo [break ;set bar baz ;set a {}{} ; stuff] bar} } {foo } diff --git a/tests/timer.test b/tests/timer.test index 26ffa0a..a493004 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -189,16 +189,7 @@ test timer-6.4 {Tcl_AfterCmd procedure, ms argument} { update list $y $x } {before after} -test timer-6.5 {Tcl_AfterCmd procedure, ms argument} { - set x before - after 60 {set x after} - after 40 - update - set y $x - after 40 - update - list $y $x -} {before after} + test timer-6.6 {Tcl_AfterCmd procedure, cancel option} { list [catch {after cancel} msg] $msg } {1 {wrong # args: should be "after cancel id|command"}} diff --git a/tests/tree.test b/tests/tree.test index 5a7cf74..22a16f5 100644 --- a/tests/tree.test +++ b/tests/tree.test @@ -110,6 +110,21 @@ test tree-2.3 "walk bfs" { set result } {rootnode childnode1 root.c2 root.c3 childnode2 n.c4 n.c5 n.c5.c6} +test tree-3.1 "delete nodes" { + $pt delete node6 + set result {} + $pt walk root bfs {action n} { + if {$action == "enter"} { + lappend result [$pt get $n name] + } + } + set result +} {rootnode childnode1 root.c2 root.c3 childnode2 n.c4} + +test tree-3.2 "can't delete root node" -body { + $pt delete root +} -returnCodes error -result {can't delete root node} + $pt destroy testreport diff --git a/tests/utftcl.test b/tests/utftcl.test index 33b8933..fac14ce 100644 --- a/tests/utftcl.test +++ b/tests/utftcl.test @@ -74,7 +74,8 @@ test utf-4.2 {Tcl_NumUtfChars: length 1} { test utf-4.3 {Tcl_NumUtfChars: long string} { testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] } {7} -test utf-4.4 {Tcl_NumUtfChars: #u0000} { +# This is an invalid utf-8 sequence. Not minimal, so should return 2 +test utf-4.4 {Tcl_NumUtfChars: #u0000} tcl { testnumutfchars [bytestring "\xC0\x80"] } {1} test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} { @@ -86,7 +87,7 @@ test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} { test utf-4.7 {Tcl_NumUtfChars: long string, calc len} { testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 } {7} -test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} { +test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} tcl { testnumutfchars [bytestring "\xC0\x80"] 1 } {1} diff --git a/tests/zlib.test b/tests/zlib.test index f2b4a36..7f56ab2 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -103,6 +103,10 @@ test zlib-3.11 {zlib gzip usage 4} -returnCodes error -body { zlib gzip -level 9 a } -result {wrong # args: should be "zlib gzip data ?-level level?"} +test zlib-3.7 {zlib gunzip bad option} -returnCodes error -body { + zlib gunzip aaa -badoption +} -result {wrong # args: should be "zlib gunzip data ?-buffersize size?"} + test zlib-4.1 {zlib gzip/gunzip} { zlib gunzip [zlib gzip abcdefghijklm] } abcdefghijklm @@ -111,6 +115,18 @@ test zlib-4.2 {zlib gzip/gunzip level and chunk size} { zlib gunzip [zlib gzip abcdefghijklm -level 9] -buffersize 128 } abcdefghijklm +test zlib-4.3 {zlib gzip/gunzip bad level } -body { + zlib gzip abcdefghijklm -level -5 +} -returnCodes error -result {level must be 0 to 9} + +test zlib-4.4 {zlib gzip/gunzip bad level } -body { + zlib gzip abcdefghijklm -level 10 +} -returnCodes error -result {level must be 0 to 9} + +test zlib-4.5 {zlib gzip/gunzip non-int level } -body { + zlib gzip abcdefghijklm -level "abc" +} -returnCodes error -result {wrong # args: should be "zlib gzip data ?-level level?"} + test zlib-5.1 {zlib crc32} { format %x [expr {[zlib crc32 abcdeabcdeabcdeabcdeabcdeabcde] & 0xffffffff}] } 6f73e901 @@ -119,4 +135,9 @@ test zlib-5.2 {zlib crc32} { format %x [expr {[zlib crc32 abcdeabcdeabcdeabcdeabcdeabcde 42] & 0xffffffff}] } ce1c4914 +test zlib-5.3 {zlib crc32 non-int arg} -body { + zlib crc32 abcdeabcdeabcdeabcdeabcdeabcde "abc" +} -returnCodes error -result {expected integer but got "abc"} + + testreport |