aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/breakcont.test (renamed from tests/breakcontinue.test)0
-rw-r--r--tests/clock.test2
-rw-r--r--tests/coverage.test2
-rw-r--r--tests/debug.test6
-rw-r--r--tests/dict2.test4
-rw-r--r--tests/event.test50
-rw-r--r--tests/exec-tip424.test424
-rw-r--r--tests/exec.test7
-rw-r--r--tests/exec2.test9
-rw-r--r--tests/exists.test24
-rw-r--r--tests/expr.test7
-rw-r--r--tests/forget-test.tcl3
-rw-r--r--tests/history.test5
-rw-r--r--tests/interactive.test36
-rw-r--r--tests/io.test26
-rw-r--r--tests/jim.test6
-rw-r--r--tests/jimsh.test30
-rw-r--r--tests/loadtest.c12
-rw-r--r--tests/loop.test9
-rw-r--r--tests/lsubst.test139
-rw-r--r--tests/package.test12
-rw-r--r--tests/regexp.test163
-rw-r--r--tests/regexp2.test104
-rw-r--r--tests/socket.test9
-rw-r--r--tests/ssl.test4
-rw-r--r--tests/stringmatch.test12
-rw-r--r--tests/taint.test212
-rw-r--r--tests/try.test9
28 files changed, 1144 insertions, 182 deletions
diff --git a/tests/breakcontinue.test b/tests/breakcont.test
index ddf9438..ddf9438 100644
--- a/tests/breakcontinue.test
+++ b/tests/breakcont.test
diff --git a/tests/clock.test b/tests/clock.test
index 0ef7bb3..26aa17e 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -5,7 +5,7 @@ constraint cmd {clock scan}
test clock-1.1 {clock usage} -body {
clock
-} -returnCodes error -match glob -result {wrong # args: should be "clock command ..."*}
+} -returnCodes error -match glob -result {wrong # args: should be "clock subcommand ?arg ...?"}
test clock-1.2 {clock usage} -body {
clock blah
diff --git a/tests/coverage.test b/tests/coverage.test
index 95933a3..48d1a3c 100644
--- a/tests/coverage.test
+++ b/tests/coverage.test
@@ -175,7 +175,7 @@ test cmd-1 {standard -commands} jim {
test rand-1 {rand} -constraints rand -body {
rand 1 2 3
-} -returnCodes error -result {wrong # args: should be "rand ?min? max"}
+} -returnCodes error -result {wrong # args: should be "rand ?min? ?max?"}
test rand-2 {rand} -constraints rand -body {
rand foo
diff --git a/tests/debug.test b/tests/debug.test
index a86d472..1e6a3ec 100644
--- a/tests/debug.test
+++ b/tests/debug.test
@@ -7,7 +7,7 @@ set x 0
test debug-0.1 {debug too few args} -body {
debug
-} -returnCodes error -match glob -result {wrong # args: should be "debug command ..."*}
+} -returnCodes error -match glob -result {wrong # args: should be "debug subcommand ?arg ...?"}
test debug-0.2 {debug bad option} -body {
debug badoption
@@ -40,7 +40,7 @@ test debug-3.1 {debug objects} -body {
# does not currently check for too many args
test debug-3.2 {debug objects too many args} -body {
debug objects a b c
-} -returnCodes error -result {wrong # args: should be "debug objects"}
+} -returnCodes error -result {wrong # args: should be "debug objects ?-taint?"}
test debug-4.1 {debug invstr too few args} -body {
debug invstr
@@ -100,7 +100,7 @@ test debug-8.1 {debug show} -body {
set x hello
lappend x there
debug show $x
-} -result {refcount: 2, type: list
+} -result {refcount: 2, taint: 0, type: list
chars (11): <<hello there>>
bytes (11): 68 65 6c 6c 6f 20 74 68 65 72 65}
diff --git a/tests/dict2.test b/tests/dict2.test
index 94ba605..57cf069 100644
--- a/tests/dict2.test
+++ b/tests/dict2.test
@@ -22,9 +22,9 @@ proc dict-sort {dict} {
return $result
}
-test dict-1.1 {dict command basic syntax} -returnCodes error -body {
+test dict-1.1 {dict command basic syntax} -body {
dict
-} -match glob -result {wrong # args: should be "dict command ..."*}
+} -returnCodes error -match glob -result {wrong # args: should be "dict subcommand ?arg ...?"}
test dict-1.2 {dict command basic syntax} -returnCodes error -body {
dict ?
} -match glob -result *
diff --git a/tests/event.test b/tests/event.test
index 4f0b3c7..3a0f3bb 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -78,18 +78,24 @@ test event-7.4 {bgerror throws an error} -constraints jim -body {
}
after 0 {error err1}
update
- }
+ } 2>gorp.err
+ set f [open gorp.err]
+ set err [read $f]
+ close $f
+ set err
} -result {stdin:3: Error: inside bgerror
Traceback (most recent call last):
File "stdin", line 6
bgerror err1
File "stdin", line 3, in bgerror
- error {inside bgerror}}
+ error {inside bgerror}
+} -cleanup {
+ file delete gorp.err
+}
# end of bgerror tests
catch {rename bgerror {}}
-
test event-10.1 {Tcl_Exit procedure} exec {
set cmd [list exec [info nameofexecutable] "<<exit 3"]
list [catch $cmd msg] [lindex $errorCode 0] \
@@ -98,10 +104,8 @@ test event-10.1 {Tcl_Exit procedure} exec {
test event-11.1 {Tcl_VwaitCmd procedure} -body {
vwait
-} -returnCodes error -match glob -result {wrong # args: should be "vwait* name"}
-test event-11.2 {Tcl_VwaitCmd procedure} -body {
- vwait a b
-} -returnCodes error -match glob -result {wrong # args: should be "vwait* name"}
+} -returnCodes error -result {wrong # args: should be "vwait ?-signal? name ?script?"}
+
test event-11.3 {Tcl_VwaitCmd procedure} jim {
catch {unset x}
set x 1
@@ -170,9 +174,10 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {s
list $x $y $z
} {3 3 done}
-test event-12.1 {Tcl_UpdateCmd procedure} {
- list [catch {update a b} msg] $msg
-} {1 {wrong # args: should be "update ?idletasks?"}}
+test event-12.1 {Tcl_UpdateCmd procedure - usage} -body {
+ update a b
+} -returnCodes error -result {wrong # args: should be "update ?idletasks?"}
+
test event-12.3 {Tcl_UpdateCmd procedure} {
foreach i [after info] {
after cancel $i
@@ -211,8 +216,8 @@ test event-13.1 "vwait/signal" signal {
signal handle ALRM
list [catch -signal {
alarm 0.1
- # This is just to prevent the vwait from exiting immediately
- stdin readable { format test }
+ # prevent the vwait from exiting immediately
+ after 1000 { }
vwait forever
} msg] $msg
} {5 SIGALRM}
@@ -263,5 +268,26 @@ test event-14.2 {IPv6 socket stream.server client address} {jim socket ipv6} {
list [join [lrange [split $addr6 :] 0 end-1] :]
} {{[::1]}}
+test event-15.1 {vwait with script} {jim} {
+ set x 0
+ set result {}
+
+ local proc waiter {} {&x &result} {
+ lappend result $x
+ after 10 waiter
+ }
+
+ after 10 waiter
+ vwait done_waiter [lambda {} {&x} {
+ # By using a lambda to capture a reference to x, we can
+ # avoid a global variable. (done_waiter is not used)
+ if {[incr x] >= 5} {
+ break
+ }
+ }]
+ # The vwait script iterates 5 times before break, so it will
+ # cancel the event loop before waiter sets done_waiter
+ list $x $result
+} {5 {0 1 2 3 4}}
testreport
diff --git a/tests/exec-tip424.test b/tests/exec-tip424.test
new file mode 100644
index 0000000..043c895
--- /dev/null
+++ b/tests/exec-tip424.test
@@ -0,0 +1,424 @@
+# The same tests as exec.test, but changed to TIP424 exec syntax
+
+source [file dirname [info script]]/testing.tcl
+
+needs cmd exec
+needs cmd flush
+# Need [pipe] to implement [open |command]
+constraint cmd pipe
+
+constraint expr unix {$tcl_platform(platform) eq {unix}}
+
+# Sleep which supports fractions of a second
+if {[info commands sleep] eq {}} {
+ proc sleep {n} {
+ exec {*}$::sleepx $n
+ }
+}
+
+set f [open sleepx w]
+puts $f {
+ sleep "$@"
+}
+close $f
+#catch {exec chmod +x sleepx}
+set sleepx [list sh sleepx]
+
+# Basic operations.
+
+test exec-1.1 {basic exec operation} {
+ exec | {echo a b c}
+} "a b c"
+test exec-1.2 {pipelining} {
+ exec | {echo a b c d} | cat | cat
+} "a b c d"
+test exec-1.3 {pipelining} {
+ set a [exec | {echo a b c d} | cat | wc]
+ list [scan $a "%d %d %d" b c d] $b $c
+} {3 1 4}
+set arg {12345678901234567890123456789012345678901234567890}
+set arg "$arg$arg$arg$arg$arg$arg"
+test exec-1.4 {long command lines} {
+ exec | [list echo $arg]
+} $arg
+set arg {}
+
+# I/O redirection: input from Tcl command.
+
+test exec-2.1 {redirecting input from immediate source} {
+ exec | cat << "Sample text"
+} {Sample text}
+test exec-2.2 {redirecting input from immediate source} {
+ exec | cat << "Sample text" | cat
+} {Sample text}
+test exec-2.4 {redirecting input from immediate source} {
+ exec | cat | cat << "Sample text"
+} {Sample text}
+test exec-2.5 {redirecting input from immediate source} {
+ exec | cat "<<Joined to arrows"
+} {Joined to arrows}
+test exec-2.6 {redirecting input from immediate source, with UTF} {
+ # If this fails, it may give back:
+ # "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
+ # If it does, this means that the UTF -> external conversion did not
+ # occur before writing out the temp file.
+ exec | cat << "\uE9\uE0\uFC\uF1"
+} "\uE9\uE0\uFC\uF1"
+test exec-2.7 {redirecting input from immediate source with nulls} {
+ exec | cat << "Sample\0text"
+} "Sample\0text"
+
+# I/O redirection: output to file.
+
+file delete gorp.file
+test exec-3.1 {redirecting output to file} {
+ exec | {echo "Some simple words"} > gorp.file
+ exec | {cat gorp.file}
+} "Some simple words"
+test exec-3.2 {redirecting output to file} {
+ exec | {echo "More simple words"} | cat >gorp.file | cat
+ exec | {cat gorp.file}
+} "More simple words"
+test exec-3.3 {redirecting output to file} {
+ exec | {echo "Different simple words"} > gorp.file | cat | cat
+ exec | {cat gorp.file}
+} "Different simple words"
+test exec-3.4 {redirecting output to file} {
+ exec | {echo "Some simple words"} >gorp.file
+ exec | {cat gorp.file}
+} "Some simple words"
+test exec-3.5 {redirecting output to file} {
+ exec | {echo "First line"} >gorp.file
+ exec | {echo "Second line"} >> gorp.file
+ exec | {cat gorp.file}
+} "First line\nSecond line"
+test exec-3.7 {redirecting output to file} {
+ set f [open gorp.file w]
+ puts $f "Line 1"
+ flush $f
+ exec | {echo "More text"} >@ $f
+ exec | {echo "Even more"} >@$f
+ puts $f "Line 3"
+ close $f
+ exec | {cat gorp.file}
+} "Line 1\nMore text\nEven more\nLine 3"
+
+# I/O redirection: output and stderr to file.
+
+file delete gorp.file
+test exec-4.1 {redirecting output and stderr to file} {
+ exec | {echo "test output"} >& gorp.file
+ exec | {cat gorp.file}
+} "test output"
+test exec-4.2 {redirecting output and stderr to file} {
+ list [exec | {sh -c "echo foo bar 1>&2"} >&gorp.file] \
+ [exec | {cat gorp.file}]
+} {{} {foo bar}}
+test exec-4.3 {redirecting output and stderr to file} {
+ exec | {echo "first line"} > gorp.file
+ list [exec | {sh -c "echo foo bar 1>&2"} >>&gorp.file] \
+ [exec | {cat gorp.file}]
+} "{} {first line\nfoo bar}"
+test exec-4.4 {redirecting output and stderr to file} {
+ set f [open gorp.file w]
+ puts $f "Line 1"
+ flush $f
+ exec | {echo "More text"} >&@ $f
+ exec | {echo "Even more"} >&@$f
+ puts $f "Line 3"
+ close $f
+ exec | {cat gorp.file}
+} "Line 1\nMore text\nEven more\nLine 3"
+test exec-4.5 {redirecting output and stderr to file} {
+ set f [open gorp.file w]
+ puts $f "Line 1"
+ flush $f
+ exec | {sh -c "echo foo bar 1>&2"} >&@ $f
+ exec | {sh -c "echo xyzzy 1>&2"} >&@$f
+ puts $f "Line 3"
+ close $f
+ exec | {cat gorp.file}
+} "Line 1\nfoo bar\nxyzzy\nLine 3"
+
+# I/O redirection: input from file.
+
+exec | {echo "Just a few thoughts"} > gorp.file
+
+test exec-5.1 {redirecting input from file} {
+ exec | cat < gorp.file
+} {Just a few thoughts}
+test exec-5.2 {redirecting input from file} {
+ exec | cat | cat < gorp.file
+} {Just a few thoughts}
+test exec-5.3 {redirecting input from file} {
+ exec | cat < gorp.file | cat
+} {Just a few thoughts}
+test exec-5.5 {redirecting input from file} {
+ exec | cat <gorp.file
+} {Just a few thoughts}
+test exec-5.6 {redirecting input from file} {
+ set f [open gorp.file r]
+ set result [exec | cat <@ $f]
+ close $f
+ set result
+} {Just a few thoughts}
+test exec-5.7 {redirecting input from file} {
+ set f [open gorp.file r]
+ set result [exec | cat <@$f]
+ close $f
+ set result
+} {Just a few thoughts}
+
+# I/O redirection: standard error through a pipeline.
+
+test exec-6.1 {redirecting stderr through a pipeline} {
+ exec | {sh -c "echo foo bar"} |& cat
+} "foo bar"
+test exec-6.2 {redirecting stderr through a pipeline} {
+ exec | {sh -c "echo foo bar 1>&2"} |& cat
+} "foo bar"
+test exec-6.3 {redirecting stderr through a pipeline} {
+ exec | {sh -c "echo foo bar 1>&2"} \
+ |& cat |& cat
+} "foo bar"
+
+# I/O redirection: combinations.
+
+file delete gorp.file2
+test exec-7.1 {multiple I/O redirections} {
+ exec | cat << "command input" > gorp.file2 < gorp.file
+ exec | {cat gorp.file2}
+} {Just a few thoughts}
+test exec-7.2 {multiple I/O redirections} {
+ exec cat < gorp.file << "command input"
+} {command input}
+
+# Long input to command and output from command.
+
+set a [string repeat a 1000000]
+test exec-8.1 {long input and output} {
+ string length [exec | cat << $a]
+} 1000000
+
+# More than 20 arguments to exec.
+
+test exec-8.1 {long input and output} {
+ exec | {echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}
+} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}
+
+# Commands that return errors.
+
+test exec-9.1 {commands returning errors} {
+ catch {exec | gorp456}
+} {1}
+test exec-9.2 {commands returning errors} {
+ catch {exec | {echo foo} | foo123} msg
+} {1}
+test exec-9.3 {commands returning errors} {
+ list [catch {exec | [list {*}$sleepx 0.1] | false | [list {*}$sleepx 0.1]} msg]
+} {1}
+test exec-9.4 {commands returning errors} jim {
+ list [catch {exec | false | {echo "foo bar"}} msg] $msg
+} {1 {foo bar}}
+test exec-9.5 {commands returning errors} {
+ list [catch {exec | gorp456 | {echo a b c}} msg]
+} {1}
+test exec-9.6 {commands returning errors} jim {
+ list [catch {exec | {sh -c "echo error msg 1>&2"}} msg] $msg
+} {0 {error msg}}
+test exec-9.7 {commands returning errors} jim {
+ # Note: Use sleep here to ensure the order
+ list [catch {exec | {sh -c "echo error msg 1 1>&2"} \
+ | {sh -c "sleep 0.1; echo error msg 2 1>&2"}} msg] $msg
+} {0 {error msg 1
+error msg 2}}
+
+# Errors in executing the Tcl command, as opposed to errors in the
+# processes that are invoked.
+
+test exec-10.1 {errors in exec invocation} {
+ list [catch {exec |} msg]
+} {1}
+test exec-10.3 {errors in exec invocation} {
+ list [catch {exec | cat |} msg] $msg
+} {1 {cmdlist required after |}}
+test exec-10.4 {errors in exec invocation} {
+ list [catch {exec | cat | | cat} msg] $msg
+} {1 {invalid redirection cat}}
+test exec-10.5 {errors in exec invocation} {
+ list [catch {exec | cat | |& cat} msg] $msg
+} {1 {invalid redirection cat}}
+test exec-10.6 {errors in exec invocation} {
+ list [catch {exec | cat |&} msg] $msg
+} {1 {cmdlist required after |&}}
+test exec-10.7 {errors in exec invocation} {
+ list [catch {exec | cat <} msg] $msg
+} {1 {can't specify "<" as last word in command}}
+test exec-10.8 {errors in exec invocation} {
+ list [catch {exec | cat >} msg] $msg
+} {1 {can't specify ">" as last word in command}}
+test exec-10.9 {errors in exec invocation} {
+ list [catch {exec | cat <<} msg] $msg
+} {1 {can't specify "<<" as last word in command}}
+test exec-10.10 {errors in exec invocation} {
+ list [catch {exec | cat >>} msg] $msg
+} {1 {can't specify ">>" as last word in command}}
+test exec-10.11 {errors in exec invocation} {
+ list [catch {exec | cat >&} msg] $msg
+} {1 {can't specify ">&" as last word in command}}
+test exec-10.12 {errors in exec invocation} {
+ list [catch {exec | cat >>&} msg] $msg
+} {1 {can't specify ">>&" as last word in command}}
+test exec-10.13 {errors in exec invocation} {
+ list [catch {exec | cat >@} msg] $msg
+} {1 {can't specify ">@" as last word in command}}
+test exec-10.14 {errors in exec invocation} {
+ list [catch {exec | cat <@} msg] $msg
+} {1 {can't specify "<@" as last word in command}}
+test exec-10.15 {errors in exec invocation} {
+ list [catch {exec | cat < a/b/c} msg] [string tolower $msg]
+} {1 {couldn't read file "a/b/c": no such file or directory}}
+test exec-10.16 {errors in exec invocation} {
+ list [catch {exec | cat << foo > a/b/c} msg] [string tolower $msg]
+} {1 {couldn't write file "a/b/c": no such file or directory}}
+test exec-10.17 {errors in exec invocation} {
+ list [catch {exec | cat << foo > a/b/c} msg] [string tolower $msg]
+} {1 {couldn't write file "a/b/c": no such file or directory}}
+set f [open gorp.file w]
+test exec-10.18 {errors in exec invocation} {
+ list [catch {exec | cat <<test <@ $f} msg]
+} 1
+close $f
+set f [open gorp.file r]
+test exec-10.19 {errors in exec invocation} {
+ list [catch {exec | cat <<test >@ $f} msg]
+} 1
+close $f
+
+# Commands in background.
+
+test exec-11.1 {commands in background} {
+ set x [lindex [time {exec | [list {*}$sleepx 0.2] &}] 0]
+ expr $x<1000000
+} 1
+test exec-11.2 {commands in background} {
+ list [catch {exec | {echo a &b}} msg] $msg
+} {0 {a &b}}
+test exec-11.3 {commands in background} {
+ llength [exec | [list {*}$sleepx 0.1] &]
+} 1
+test exec-11.4 {commands in background} {
+ llength [exec | [list {*}$sleepx 0.1] | [list {*}$sleepx 0.1] | [list {*}$sleepx 0.1] &]
+} 3
+
+# Make sure that background commands are properly reaped when
+# they eventually die.
+
+exec | [list {*}$sleepx 0.3]
+
+test exec-12.1 {reaping background processes} -constraints unix -body {
+ for {set i 0} {$i < 20} {incr i} {
+ exec | {echo foo} > exec.tmp1 &
+ }
+ exec | [list {*}$sleepx 0.1]
+ catch {exec | ps | {fgrep "echo foo"} | {fgrep -v grep} | wc} msg
+ lindex $msg 0
+} -cleanup {
+ file delete exec.tmp1
+} -result 0
+
+# Redirecting standard error separately from standard output
+
+test exec-15.1 {standard error redirection} {
+ exec | {echo "First line"} > gorp.file
+ list [exec | {sh -c "echo foo bar 1>&2"} 2> gorp.file] \
+ [exec | {cat gorp.file}]
+} {{} {foo bar}}
+test exec-15.2 {standard error redirection} {
+ list [exec | {sh -c "echo foo bar 1>&2"} \
+ | {echo biz baz} >gorp.file 2> gorp.file2] \
+ [exec | {cat gorp.file}] \
+ [exec | {cat gorp.file2}]
+} {{} {biz baz} {foo bar}}
+test exec-15.3 {standard error redirection} {
+ list [exec | {sh -c "echo foo bar 1>&2"} \
+ | {echo biz baz} 2>gorp.file > gorp.file2] \
+ [exec | {cat gorp.file}] \
+ [exec | {cat gorp.file2}]
+} {{} {foo bar} {biz baz}}
+test exec-15.4 {standard error redirection} {
+ set f [open gorp.file w]
+ puts $f "Line 1"
+ flush $f
+ exec | {sh -c "echo foo bar 1>&2"} 2>@ $f
+ puts $f "Line 3"
+ close $f
+ exec | {cat gorp.file}
+} {Line 1
+foo bar
+Line 3}
+test exec-15.5 {standard error redirection} {
+ exec | {echo "First line"} > gorp.file
+ exec | {sh -c "echo foo bar 1>&2"} 2>> gorp.file
+ exec | {cat gorp.file}
+} {First line
+foo bar}
+test exec-15.6 {standard error redirection} {
+ exec | {sh -c "echo foo bar 1>&2"} > gorp.file2 2> gorp.file \
+ >& gorp.file 2> gorp.file2 | {echo biz baz}
+ list [exec | {cat gorp.file}] [exec | {cat gorp.file2}]
+} {{biz baz} {foo bar}}
+test exec-15.7 {combine standard output/standard error} -body {
+ exec | {sh -c "echo foo bar 1>&2"} > gorp.file 2>@1
+ exec | {cat gorp.file}
+} -cleanup {
+ file delete gorp.file gorp.file2
+} -result {foo bar}
+
+test exec-16.1 {flush output before exec} -body {
+ set f [open gorp.file w]
+ puts $f "First line"
+ exec | {echo "Second line"} >@ $f
+ puts $f "Third line"
+ close $f
+ exec | {cat gorp.file}
+} -cleanup {
+ file delete gorp.file
+} -result {First line
+Second line
+Third line}
+
+test exec-17.1 {redirecting from command pipeline} -setup {
+ makeFile "abc\nghi\njkl" gorp.file
+} -constraints pipe -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
+} -constraints pipe -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}
+
+test exec-17.3 {redirecting stderr to stdout} -body {
+ exec | {sh -c "echo foo bar 1>&2"} 2>@1
+} -result {foo bar}
+
+file delete sleepx
+
+# Now we probably have a lot of unreaped zombies at this point
+# so reap them to avoid confusing further tests
+wait
+
+testreport
diff --git a/tests/exec.test b/tests/exec.test
index 85014a7..ee76573 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -268,7 +268,8 @@ error msg 2}}
test exec-10.1 {errors in exec invocation} {
list [catch {exec} msg]
} {1}
-test exec-10.2 {errors in exec invocation} {
+# Note that with TIP424 exec, this is no longer an error in Jim
+test exec-10.2 {errors in exec invocation} tcl {
list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.3 {errors in exec invocation} {
@@ -443,6 +444,10 @@ test exec-17.2 {redirecting to command pipeline} -setup {
file delete gorp.file gorp2.file
} -result {3}
+test exec-17.3 {redirecting stderr to stdout} -body {
+ exec sh -c "echo foo bar 1>&2" 2>@1
+} -result {foo bar}
+
file delete sleepx
# Now we probably have a lot of unreaped zombies at this point
diff --git a/tests/exec2.test b/tests/exec2.test
index 9daef58..e63cbbd 100644
--- a/tests/exec2.test
+++ b/tests/exec2.test
@@ -172,4 +172,13 @@ test exec2-5.6 {wait -1 to wait for any child} -constraints {after jim nomingw32
list $status $($waitpid == $pid) $code
} -result {CHILDSTATUS 1 0}
+test exec2-5.7 {wait -nohang for child not finished} -constraints {after jim nomingw32} -body {
+ set pid [exec sleep 10 &]
+ # Get the status of the running child
+ wait -nohang $pid
+} -result {NONE 0 -1} -cleanup {
+ kill $pid
+ wait $pid
+}
+
testreport
diff --git a/tests/exists.test b/tests/exists.test
index 7531b0c..b46ec26 100644
--- a/tests/exists.test
+++ b/tests/exists.test
@@ -76,12 +76,28 @@ test exists-1.16 "Exists local lambda" lambda {
a
} 1
-test exists-1.17 {exists usage} -body {
+test exists-1.17 "Exists -channel" {
+ exists -channel bogus
+} 0
+
+test exists-1.18 "Exists -channel" {
+ exists -channel stdout
+} 1
+
+test exists-1.19 "Exists -channel" {
+ exists -channel info
+} 0
+
+test exists-1.20 "Exists -channel" {
+ exists -channel a
+} 0
+
+test exists-2.1 {exists usage} -body {
exists -dummy blah
-} -returnCodes error -result {bad option "-dummy": must be -alias, -command, -proc, or -var}
+} -returnCodes error -result {bad option "-dummy": must be -alias, -channel, -command, -proc, or -var}
-test exists-1.18 {exists usage} -body {
+test exists-2.2 {exists usage} -body {
exists abc def ghi
-} -returnCodes error -result {wrong # args: should be "exists ?option? name"}
+} -returnCodes error -result {wrong # args: should be "exists ?-command|-proc|-alias|-channel|-var? name"}
testreport
diff --git a/tests/expr.test b/tests/expr.test
index 7e26c0a..bc52afd 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -154,5 +154,12 @@ test expr-5.3 {boolean in expression} {
expr {true ? 4 : 5}
} {4}
+test expr-6.1 "Unary negation on boolean - should return error" -body {
+ expr {-true}
+} -returnCodes error -result {can't use non-numeric string as operand of "-"}
+
+test expr-6.2 "Unary plus on boolean - should return error" -body {
+ expr {+true}
+} -returnCodes error -result {can't use non-numeric string as operand of "+"}
testreport
diff --git a/tests/forget-test.tcl b/tests/forget-test.tcl
new file mode 100644
index 0000000..8d4289b
--- /dev/null
+++ b/tests/forget-test.tcl
@@ -0,0 +1,3 @@
+# This is a dummy package used for testing package forget
+
+set forgotten 1
diff --git a/tests/history.test b/tests/history.test
index e0ff0e2..f0fa05a 100644
--- a/tests/history.test
+++ b/tests/history.test
@@ -4,9 +4,8 @@ needs cmd {history save}
needs expr "jim::lineedit" {$jim::lineedit}
test history-1.1 {history usage} -body {
- history
-} -returnCodes error -result {wrong # args: should be "history command ..."
-Use "history -help ?command?" for help}
+ history
+} -returnCodes error -result {wrong # args: should be "history subcommand ?arg ...?"}
test history-1.2 {history -help} -body {
history -help
diff --git a/tests/interactive.test b/tests/interactive.test
index 8d19512..e92b6d1 100644
--- a/tests/interactive.test
+++ b/tests/interactive.test
@@ -31,15 +31,15 @@ file delete test_history
wait-for-prompt $p
$p send "history load test_history\r"
# skip echoed output
-$p expect {\r\n}
+$p expect "\r\n"
wait-for-prompt $p
test interactive-1.1 {basic command} -body {
$p send "lsort \[info commands li*\]\r"
# skip echoed output
- $p expect {\r\n}
+ $p expect "\r\n"
# get command result
- $p expect {\r\n}
+ $p expect "\r\n"
$p before
} -result {lindex linsert list} -cleanup {
wait-for-prompt $p
@@ -57,7 +57,7 @@ test interactive-1.2 {command line completion} lineedit {
$p expect {list} { incr check }
$p send \r
}
- $p expect {\r\n}
+ $p expect "\r\n"
wait-for-prompt $p
list $check $failed
@@ -65,8 +65,8 @@ test interactive-1.2 {command line completion} lineedit {
test interactive-1.3 {history show} -constraints lineedit -body {
$p send "history show\r"
- $p expect {\r\n}
- $p expect {history show\r\n}
+ $p expect "\r\n"
+ $p expect "history show\r\n"
string cat [$p before] [$p after]
} -result " 1 history load test_history\r\n 2 lsort \[info commands li*\]\r\n 3 list\r\n 4 history show\r\n" -cleanup {
wait-for-prompt $p
@@ -74,11 +74,11 @@ test interactive-1.3 {history show} -constraints lineedit -body {
test interactive-1.4 {history getline} -constraints lineedit -body {
$p send "history getline {PROMPT> }\r"
- $p expect {\r\n}
+ $p expect "\r\n"
sleep 0.25
$p send "abc\bd\x01e\r"
- $p expect {\r\n}
- $p expect {\r\n}
+ $p expect "\r\n"
+ $p expect "\r\n"
$p before
} -result {eabd} -cleanup {
wait-for-prompt $p
@@ -86,16 +86,16 @@ test interactive-1.4 {history getline} -constraints lineedit -body {
test interactive-1.5 {history getline} -constraints lineedit -body {
$p send "set len \[history getline {PROMPT> } buf\]\r"
- $p expect {\r\n}
+ $p expect "\r\n"
sleep 0.25
$p send "abcde\r"
- $p expect {\r\n}
- $p expect {\r\n}
+ $p expect "\r\n"
+ $p expect "\r\n"
sleep 0.25
$p wait-for-prompt
$p send "list \$len \$buf\r"
- $p expect {\r\n}
- $p expect {\r\n}
+ $p expect "\r\n"
+ $p expect "\r\n"
$p before
} -result {5 abcde} -cleanup {
wait-for-prompt $p
@@ -108,9 +108,9 @@ test interactive-1.6 {insert wide character} -constraints {utf8 lineedit} -body
$p send \x1bOD
$p send y
$p send \r
- $p expect {\r\n}
+ $p expect "\r\n"
sleep 0.25
- $p expect {\r\n}
+ $p expect "\r\n"
$p before
} -result ay\u1100b -cleanup {
wait-for-prompt $p
@@ -123,9 +123,9 @@ test interactive-1.7 {insert utf-8 combining character} -constraints {utf8 linee
$p send \x1bOD
$p send y
$p send \r
- $p expect {\r\n}
+ $p expect "\r\n"
sleep 0.25
- $p expect {\r\n}
+ $p expect "\r\n"
$p before
} -result yx\u0300 -cleanup {
wait-for-prompt $p
diff --git a/tests/io.test b/tests/io.test
new file mode 100644
index 0000000..1b06439
--- /dev/null
+++ b/tests/io.test
@@ -0,0 +1,26 @@
+source [file dirname [info script]]/testing.tcl
+
+# This is a proxy for tcl || tclcompat
+constraint cmd fconfigure
+
+# The tests in this file are intended to test Tcl-compatible I/O features
+
+test io-1.1 {translation binary} -body {
+ # write a file via stdout in binary mode
+ # This will always work on Unix
+ set script {
+ fconfigure stdout -translation binary
+ puts line1
+ puts line2
+ }
+ exec [info nameofexecutable] << $script >binary.out
+ # Read it back in binary mode
+ set f [open binary.out rb]
+ set buf [read $f]
+ close $f
+ set buf
+} -cleanup {
+ file delete binary.out
+} -result "line1\nline2\n"
+
+testreport
diff --git a/tests/jim.test b/tests/jim.test
index 16e56fa..2d245db 100644
--- a/tests/jim.test
+++ b/tests/jim.test
@@ -3152,9 +3152,9 @@ test info-2.4 {info commands option} {
} {_test1_ _test2_}
catch {rename _test1_ {}}
catch {rename _test2_ {}}
-test info-2.5 {info commands option} {
+test info-2.5 {info commands option} -body {
list [catch {info commands a b} msg] $msg
-} {1 {wrong # args: should be "info commands ?pattern?"}}
+ } -result {1 {wrong # args: should be "info commands ?-all? ?pattern?"}}
test info-3.1 {info exists option} {
set value foo
info exists value
@@ -3557,7 +3557,7 @@ catch {unset sum; unset err; unset i}
################################################################################
test env-1.1 {env} -body {
env abc def ghi
-} -returnCodes error -result {wrong # args: should be "env varName ?default?"}
+} -returnCodes error -result {wrong # args: should be "env ?varName? ?default?"}
test env-1.2 {env} -body {
env DOES_NOT_EXIST abc
diff --git a/tests/jimsh.test b/tests/jimsh.test
index a02ed9f..8faf2d8 100644
--- a/tests/jimsh.test
+++ b/tests/jimsh.test
@@ -28,29 +28,17 @@ test jimsh-1.5 {jimsh --version} {
test jimsh-1.6 {jimsh -e with error} -body {
exec [info nameofexecutable] -e blah
-} -returnCodes error -result {invalid command name "blah"}
+} -returnCodes error -match glob -result {invalid command name "blah"*}
-test jimsh-1.7 {jimsh prompt} -body {
- exec [info nameofexecutable] << "set x 3\nincr x\nexit \$x\n"
-} -returnCodes error -match glob -result {Welcome to Jim version *
-. 3
-. 4
-. }
+test jimsh-1.7 {jimsh exit code} -body {
+ set script "set x 3\nincr x\nexit \$x\n"
+ set rc [catch {exec [info nameofexecutable] << $script} msg opts]
+ lassign [dict get $opts -errorcode] status pid exitcode
+ list $rc $status $exitcode
+} -result {1 CHILDSTATUS 4}
-test jimsh-1.8 {jimsh prompt - error} -body {
+test jimsh-1.8 {jimsh error} -body {
exec [info nameofexecutable] << "blah\n"
-} -match glob -result {Welcome to Jim version *
-. invalid command name "blah"
-\[error\] . }
-
-test jimsh-1.9 {jimsh prompt - error} -body {
- exec [info nameofexecutable] << "throw 99\n"
-} -match glob -result {Welcome to Jim version *
-. \[99\] . }
-
-test jimsh-1.10 {jimsh prompt - continuation} -body {
- exec [info nameofexecutable] << "set x {\nabc\n}\n"
-} -match glob -result "Welcome to Jim version *\n. {> {> \nabc\n\n. "
-
+} -returnCodes error -match glob -result {stdin:1: Error: invalid command name "blah"*}
testreport
diff --git a/tests/loadtest.c b/tests/loadtest.c
index 138e403..170e056 100644
--- a/tests/loadtest.c
+++ b/tests/loadtest.c
@@ -17,19 +17,11 @@ static const jim_subcmd_type loadtest_command_table[] = {
{ NULL }
};
-static int loadtest_cmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
-{
- return Jim_CallSubCmd(interp, Jim_ParseSubCmd(interp, loadtest_command_table, argc, argv), argc, argv);
-}
-
#ifndef NO_ENTRYPOINT
int Jim_loadtestInit(Jim_Interp *interp)
{
- if (Jim_PackageProvide(interp, "loadtest", "1.0", JIM_ERRMSG)) {
- return JIM_ERR;
- }
-
- Jim_CreateCommand(interp, "loadtest", loadtest_cmd, 0, 0);
+ Jim_PackageProvideCheck(interp, "loadtest");
+ Jim_RegisterSubCmd(interp, "loadtest", loadtest_command_table, NULL);
return JIM_OK;
}
diff --git a/tests/loop.test b/tests/loop.test
index c6144e0..43fe562 100644
--- a/tests/loop.test
+++ b/tests/loop.test
@@ -152,6 +152,15 @@ test loop-2.8 {modify loop var} {
set a
} {1 2 3 4 5}
+# Previously this would leak memory (configure --maintainer)
+test loop-2.9 {fail to set loop var} -body {
+ set i 1
+ loop i(x) 1 6 {
+ incr y
+ }
+ set y
+} -returnCodes error -result {can't set "i(x)": variable isn't array}
+
testreport
break
diff --git a/tests/lsubst.test b/tests/lsubst.test
new file mode 100644
index 0000000..1c2c082
--- /dev/null
+++ b/tests/lsubst.test
@@ -0,0 +1,139 @@
+source [file dirname [info script]]/testing.tcl
+
+needs cmd lsubst
+
+test lsubst-1.1 {no args} -body {
+ lsubst
+} -returnCodes error -result {wrong # args: should be "lsubst ?-line? string"}
+
+test lsubst-1.2 {too many args} -body {
+ lsubst a b c
+} -returnCodes error -result {wrong # args: should be "lsubst ?-line? string"}
+
+test lsubst-1.3 {basic, no subst} -body {
+ lsubst {a b c}
+} -result {a b c}
+
+test lsubst-1.4 {basics, vars} -body {
+ set a 1
+ set b "2 3"
+ set c "4 5 6"
+ set d ".1"
+ lsubst {$a $b $c$d}
+} -result {1 {2 3} {4 5 6.1}}
+
+test lsubst-1.5 {comments} -body {
+ # It is helpful to be able to include comments in a list definition
+ # just like in a script
+ lsubst {
+ # comment line
+ 1
+ 2 3
+ # comment line with continuation \
+ this is also a comments
+ 4 ;# comment at end of line
+ 5
+ }
+} -result {1 2 3 4 5}
+
+test lsubst-1.6 {commands} -body {
+ set a 0
+ lsubst {
+ [incr a]
+ [incr a]
+ [list d e]
+ [string cat f g][string cat h i]
+ }
+} -result {1 2 {d e} fghi}
+
+test lsubst-1.7 {expand} -body {
+ set a {1 2}
+ set space " "
+ set b {3 4 5}
+ lsubst {
+ {*}$a
+ {*}$a$space$b$space[list 6 7]
+ }
+} -result {1 2 1 2 3 4 5 6 7}
+
+test lsubst-1.8 {empty case} -body {
+ lsubst {
+ # Nothing
+ }
+} -result {}
+
+test lsubst-1.9 {backslash escapes} -body {
+ lsubst {
+ # char escapes
+ \r\n\t
+ # unicode escapes
+ \u00b5
+ # hex escapes
+ \x41\x42
+ }
+} -result [list \r\n\t \u00b5 AB]
+
+test lsubst-1.10 {simple -line} -body {
+ set a {1 2}
+ set b {3 4 5}
+ lsubst -line {
+ # This line won't produce a list, but the next will produce a list with two elements
+ {*}$a
+ # And this one will have three elements
+ one two $b
+ }
+} -result {{1 2} {one two {3 4 5}}}
+
+test lsubst-2.1 {error, missing [} -body {
+ lsubst {
+ # Missing bracket
+ [string cat
+ }
+} -returnCodes error -result {unmatched "["}
+
+test lsubst-2.2 {error, invalid command} -body {
+ lsubst {
+ a
+ [dummy]
+ b
+ }
+} -returnCodes error -result {invalid command name "dummy"}
+
+test lsubst-2.3 {error, unset variable} -body {
+ lsubst {
+ a
+ $doesnotexist
+ b
+ }
+} -returnCodes error -result {can't read "doesnotexist": no such variable}
+
+test lsubst-2.4 {break} -body {
+ lsubst {
+ a
+ [break]
+ b
+ }
+} -returnCodes error -result {invoked "break" outside of a loop}
+
+test lsubst-2.5 {continue} -body {
+ lsubst {
+ a
+ [continue]
+ b
+ }
+} -returnCodes error -result {invoked "continue" outside of a loop}
+
+test lsubst-3.1 {preservation of line numbers} -body {
+ set x abc
+ set src1 [info source $x]
+ set list [lsubst {
+ a
+ $x
+ b
+ }]
+ if {[info source [lindex $list 1]] ne [info source $x]} {
+ error "source does not match
+ }
+} -result {}
+
+testreport
diff --git a/tests/package.test b/tests/package.test
index b8afa18..1484bd6 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -20,5 +20,17 @@ test package-1.3 {package names} -body {
expr {"stdlib" in [package names]}
} -result 1
+test package-2.1 {package forget} -body {
+ # First pretend the package was loaded
+ package provide forget-test
+ # Now it won't load anything
+ package require forget-test
+ # Now forget it and another unloaded test
+ package forget forget-test missing
+ # And load the local package
+ package require forget-test
+ info exists forgotten
+} -result 1
+
testreport
diff --git a/tests/regexp.test b/tests/regexp.test
index 7aeb72e..2e60b64 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -37,12 +37,12 @@ test regexp-1.5 {basic regexp operation} {
test regexp-1.6 {basic regexp operation} regexp_are {
list [catch {regexp {} abc} msg] $msg
} {0 1}
-#test regexp-1.7 {regexp utf compliance} {
-# # if not UTF-8 aware, result is "0 1"
-# set foo "\u4e4eb q"
-# regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
-# list [string compare $foo $bar] [regexp 4 $bar]
-#} {0 0}
+test regexp-1.7 {regexp utf compliance} {
+ # if not UTF-8 aware, result is "0 1"
+ set foo "\u4e4eb q"
+ regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
+ list [string compare $foo $bar] [regexp 4 $bar]
+} {0 0}
test regexp-2.1 {getting substrings back from regexp} {
@@ -193,15 +193,18 @@ test regexp-5.5 {exercise cache of compiled expressions} {
regexp .*e xe
} 1
-test regexp-6.1 {regexp errors} {
+test regexp-6.1 {regexp errors} -body {
list [catch {regexp a} msg] $msg
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
-test regexp-6.2 {regexp errors} {
+} -result {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
+
+test regexp-6.2 {regexp errors} -body {
list [catch {regexp -nocase a} msg] $msg
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
-test regexp-6.3 {regexp errors} jim {
+} -result {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
+
+test regexp-6.3 {regexp errors} -body {
list [catch {regexp -gorp a} msg] $msg
-} {1 {bad switch "-gorp": must be --, -all, -indices, -inline, -line, -nocase, or -start}}
+} -result {1 {bad option "-gorp": must be -all, -expanded, -indices, -inline, -line, -lineanchor, -linestop, -nocase, -start, or --}}
+
test regexp-6.4 {regexp errors} {
catch {regexp a( b} msg
} 1
@@ -219,13 +222,14 @@ test regexp-6.8 {regexp errors} jim {
set f1 44
list [catch {regexp abc abc f1(f2)} msg] $msg
} {1 {can't set "f1(f2)": variable isn't array}}
-test regexp-6.9 {regexp errors, -start bad int check} {
+
+test regexp-6.9 {regexp errors, -start bad int check} -body {
list [catch {regexp -start bogus {^$} {}} msg] $msg
-} {1 {bad index "bogus": must be intexpr or end?[+-]intexpr?}}
-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 ...?"}}
+} -match glob -result {1 {bad index "bogus": must be int* or end\?\[+-\]int*\?}}
+test regexp-6.10 {regexp errors, -start too few args} -body {
+ list [catch {regexp -all -start} msg] $msg
+} -result {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-7.1 {basic regsub operation} {
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
@@ -279,12 +283,12 @@ test regexp-7.16 {basic regsub operation} {
set foo xxx
list [regsub x "" y foo] $foo
} {0 {}}
-#test regexp-7.17 {regsub utf compliance} {
-# # if not UTF-8 aware, result is "0 1"
-# set foo "xyz555ijka\u4e4ebpqr"
-# regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
-# list [string compare $foo $bar] [regexp 4 $bar]
-#} {0 0}
+test regexp-7.17 {regsub utf compliance} {
+ # if not UTF-8 aware, result is "0 1"
+ set foo "xyz555ijka\u4e4ebpqr"
+ regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
+ list [string compare $foo $bar] [regexp 4 $bar]
+} {0 0}
test regexp-8.1 {case conversion in regsub} {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
@@ -344,30 +348,32 @@ test regexp-10.3 {newline sensitivity in regsub} {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
} "1 {dabc\n123\nxb}"
-#test regexp-10.4 {partial newline sensitivity in regsub} {
-# set foo xxx
-# list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
-#} "1 {da\n123}"
-#test regexp-10.5 {inverse partial newline sensitivity in regsub} {
-# set foo xxx
-# list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
-#} "1 {da\nb123\nxb}"
+test regexp-10.4 {partial newline sensitivity in regsub} regexp_are {
+ set foo xxx
+ list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
+} "1 {da\n123}"
+test regexp-10.5 {inverse partial newline sensitivity in regsub} regexp_are {
+ set foo xxx
+ list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
+} "1 {da\nb123\nxb}"
test regexp-11.1 {regsub errors} {
list [catch {regsub a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.2 {regsub errors} {
list [catch {regsub -nocase a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.3 {regsub errors} {
list [catch {regsub -nocase -all a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} {
list [catch {regsub a b c d e f} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
-test regexp-11.5 {regsub errors} -constraints jim -body {
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
+
+test regexp-11.5 {regsub errors} -body {
list [catch {regsub -gorp a b c} msg] $msg
-} -result {1 {bad switch "-gorp": must be --, -all, -command, -line, -nocase, or -start}}
+} -result {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -lineanchor, -linestop, -nocase, -start, or --}}
+
test regexp-11.6 {regsub errors} {
catch {regsub -nocase a( b c d} msg
} 1
@@ -376,9 +382,11 @@ test regexp-11.7 {regsub errors} jim {
set f1 44
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
} {1 {can't set "f1(f2)": variable isn't array}}
-test regexp-11.8 {regsub errors, -start bad int check} {
+
+test regexp-11.8 {regsub errors, -start bad int check} -body {
list [catch {regsub -start bogus pattern string rep var} msg] $msg
-} {1 {bad index "bogus": must be intexpr or end?[+-]intexpr?}}
+} -match glob -result {1 {bad index "bogus": must be int* or end\?\[+-\]int*\?}}
+
test regexp-11.9 {regsub without final variable name returns value} {
regsub b abaca X
} {aXaca}
@@ -394,7 +402,7 @@ test regexp-11.12 {regsub without final variable name returns value} {
} {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?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
# This test crashes on the Mac unless you increase the Stack Space to about 1
@@ -489,7 +497,7 @@ test regexp-16.3 {regsub -start} {
catch {unset x}
list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
-test regexp-16.4 {regsub -start, \A behavior} {
+test regexp-16.4 {regsub -start, \A behavior} regexp_are {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
@@ -583,19 +591,24 @@ test regexp-18.12 {regexp -all -inline -indices} {
regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
+test regexp-18.13 {regexp -all with match vars} -body {
+ regexp -all a(b(c)d|e(f)g)h abcdhaefgh a b c d e
+ list $a $b $c $d $e
+} -result {aefgh efg {} f {}}
+
test regexp-19.1 {regsub null replacement} {
regsub -all {@} {@hel@lo@} "\0a\0" result
list $result [string length $result]
} "\0a\0hel\0a\0lo\0a\0 14"
-#test regexp-20.1 {regsub shared object shimmering} {
-# # Bug #461322
-# set a abcdefghijklmnopqurstuvwxyz
-# set b $a
-# set c abcdefghijklmnopqurstuvwxyz0123456789
-# regsub $a $c $b d
-# list $d [string length $d] [string bytelength $d]
-#} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
+test regexp-20.1 {regsub shared object shimmering} {
+ # Bug #461322
+ set a abcdefghijklmnopqurstuvwxyz
+ set b $a
+ set c abcdefghijklmnopqurstuvwxyz0123456789
+ regsub $a $c $b d
+ list $d [string length $d] [string bytelength $d]
+} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
#test regexp-20.2 {regsub shared object shimmering with -about} {
# eval regexp -about abc
#} {0 {}}
@@ -636,9 +649,9 @@ test regexp-21.9 {regexp works with empty string offset} {
regexp -start 3 -- \$ {123}
} {1}
-#test regexp-21.10 {multiple matches handle newlines} {
-# regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
-#} "foo\nfoo\nfoo\n"
+test regexp-21.10 {multiple matches handle newlines} regexp_are {
+ regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
+} "foo\nfoo\nfoo\n"
test regexp-21.11 {multiple matches handle newlines} {
regsub -all -line -- ^ "a\nb\nc" \#
@@ -661,30 +674,40 @@ test regexp-21.15 {Replace literal backslash} {
set value
} "\\abc\\def"
+test regexp-21.16 {Replace nothing} {
+ regsub -all {x*} anything !
+} {!a!n!y!t!h!i!n!g!}
+
+test regexp-21.17 {Replace nothing via empty pattern} regexp_are {
+ # Interestingly in this case Tcl does not match
+ # at end of string while the previous case does
+ regsub -all {} anything !
+} {!a!n!y!t!h!i!n!g}
+
test regexp-22.1 {char range} {
regexp -all -inline {[a-c]+} "defaaghbcadfbaacccd"
} {aa bca baaccc}
# Tcl doesn't like this
-test regexp-22.2 {reversed char range} jim {
+test regexp-22.2 {reversed char range} {jim regexp_are} {
regexp -all -inline {[c-a]+} "defaaghbcadfbaacccd"
} {aa bca baaccc}
# Note that here the hex escapes are interpreted by regexp, not by Tcl
-test regexp-22.3 {hex digits} {
+test regexp-22.3 {hex digits} regexp_are {
regexp -all -inline {[\x6a-\x6c]+} "jlaksdjflkwueorilkj"
} {jl k j lk lkj}
-test regexp-22.4 {uppercase hex digits} {
+test regexp-22.4 {uppercase hex digits} regexp_are {
regexp -all -inline {[\x6A-\x6C]+} "jlaksdjflkwueorilkj"
} {jl k j lk lkj}
# Below \x9X will be treated as \x9 followed by X
-test regexp-22.5 {invalid hex digits} {
+test regexp-22.5 {invalid hex digits} regexp_are {
regexp -all -inline {[\x9X\x6C]+} "jla\tX6djflyw\tueorilkj"
} [list l \tX l \t l]
-test regexp-22.6 {unicode hex digits} jim {
+test regexp-22.6 {unicode hex digits} {jim regexp_are} {
regexp -all -inline {[\u{41}-\u{00043}]+} "AVBASDFBABDFBAFBAFA"
} {A BA BAB BA BA A}
@@ -693,15 +716,15 @@ test regexp-22.7 {unicode hex digits with invalid exscape} jim {
regexp -all -inline {[\u{X41}]+} "uVBAX{SD4B1}DFBAFBAFA"
} {u X\{ 4 1\}}
-test regexp-22.8 {unicode hex digits} {
+test regexp-22.8 {unicode hex digits} regexp_are {
regexp -all -inline {[\u0041-\u0043]+} "AVBASDFBABDFBAFBAFA"
} {A BA BAB BA BA A}
-test regexp-22.9 {\U unicode hex digits} {
+test regexp-22.9 {\U unicode hex digits} regexp_are {
regexp -all -inline {[\U00000041-\U00000043]+} "AVBASDFBABDFBAFBAFA"
} {A BA BAB BA BA A}
-test regexp-22.10 {Various char escapes} {
+test regexp-22.10 {Various char escapes} regexp_are {
set result {}
foreach match [regexp -all -inline {[\e\f\v\t\b]+} "A\f\vBB\b\tC\x1BG"] {
set chars {}
@@ -714,15 +737,15 @@ test regexp-22.10 {Various char escapes} {
join $result |
} {12,11|8,9|27}
-test regexp-22.11 {backslash as last char} -body {
+test regexp-22.11 {backslash as last char} -constraints regexp_are -body {
regexp -all -inline "\[a\\" "ba\\d\[ef"
} -returnCodes error -result {couldn't compile regular expression pattern: invalid escape \ sequence}
-test regexp-22.12 {missing closing bracket} -body {
+test regexp-22.12 {missing closing bracket} -constraints regexp_are -body {
regexp -all -inline {[abc} "abcdefghi"
} -returnCodes error -result {couldn't compile regular expression pattern: brackets [] not balanced}
-test regexp-22.13 {empty alternative} {
+test regexp-22.13 {empty alternative} regexp_are {
regexp -all -inline {a(a|b|)c} "aacbacbaa"
} {aac a ac {}}
@@ -734,11 +757,11 @@ test regexp-22.15 {- in set} {
regexp -all -inline {[-ab]+} "aac\[ba\]cb-aa"
} {aa ba b-aa}
-test regexp-22.16 {\s in set} {
+test regexp-22.16 {\s in set} regexp_are {
regexp -all -inline {[\sa]+} "aac\[b a\]c\tb-aa"
} [list aa " a" \t aa]
-test regexp-22.17 {\d in set} {
+test regexp-22.17 {\d in set} regexp_are {
regexp -all -inline {[a\d]+} "a0ac\[b a\]44c\tb-1aa7"
} {a0a a 44 1aa7}
@@ -761,13 +784,13 @@ test regexp-27.5 {regsub -command} {
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} {
+test regexp-27.7 {regsub -command representation smash} regexp_are {
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} {
+test regexp-27.8 {regsub -command representation smash} regexp_are {
set ::t {apply {n {
expr {[llength [lindex $::t 1 1 1]] + $n}
}}}
@@ -789,15 +812,15 @@ test reg-31.1 {[[:xdigit:]] behaves correctly when followed by [[:space:]]} {
# Code used to produce {1 2:::DebugWin32 2 :::DebugWin32} !!!
} {1 2 2 {}}
-test reg-31.2 {scanner not reset in failed optional group} {
+test reg-31.2 {scanner not reset in failed optional group} regexp_are {
regexp -inline {^(?:(-)(?:(\w[\w-]*)\|)?)?(\w[\w-]*)$} -debug
} {-debug - {} debug}
-test reg-31.2 {invalid digit check in class} -body {
+test reg-31.2 {invalid digit check in class} -constraints regexp_are -body {
regexp {[[:digit:\0]} 1
} -returnCodes error -result {couldn't compile regular expression pattern: brackets [] not balanced}
-test reg-31.3 {invalid trailing backslash} -body {
+test reg-31.3 {invalid trailing backslash} -constraints regexp_are -body {
regexp "\[abc\\" a
} -returnCodes error -result {couldn't compile regular expression pattern: invalid escape \ sequence}
diff --git a/tests/regexp2.test b/tests/regexp2.test
index 571c981..c965cf9 100644
--- a/tests/regexp2.test
+++ b/tests/regexp2.test
@@ -463,12 +463,12 @@ test regexpComp-9.6 {-all option to regsub} {
}
} {1 123xxx}
-#test regexpComp-10.1 {expanded syntax in regsub} {
-# evalInProc {
-# set foo xxx
-# list [regsub -expanded ". \#comment\n . \#comment2" abc def foo] $foo
-# }
-#} {1 defc}
+test regexpComp-10.1 {expanded syntax in regsub} {
+ evalInProc {
+ set foo xxx
+ list [regsub -expanded ". \#comment\n . \#comment2" abc def foo] $foo
+ }
+} {1 defc}
test regexpComp-10.2 {newline sensitivity in regsub} {
evalInProc {
set foo xxx
@@ -481,18 +481,18 @@ test regexpComp-10.3 {newline sensitivity in regsub} {
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
}
} "1 {dabc\n123\nxb}"
-#test regexpComp-10.4 {partial newline sensitivity in regsub} {
-# evalInProc {
-# set foo xxx
-# list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
-# }
-#} "1 {da\n123}"
-#test regexpComp-10.5 {inverse partial newline sensitivity in regsub} {
-# evalInProc {
-# set foo xxx
-# list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
-# }
-#} "1 {da\nb123\nxb}"
+test regexpComp-10.4 {partial newline sensitivity in regsub} {
+ evalInProc {
+ set foo xxx
+ list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
+ }
+} "1 {da\n123}"
+test regexpComp-10.5 {inverse partial newline sensitivity in regsub} {
+ evalInProc {
+ set foo xxx
+ list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
+ }
+} "1 {da\nb123\nxb}"
test regexpComp-10.6 {\Z only matching end of string with -line} {
evalInProc {
set foo xxx
@@ -507,27 +507,29 @@ test regexpComp-11.1 {regsub errors} {
evalInProc {
list [catch {regsub a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.2 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.3 {regsub errors} {
evalInProc {
list [catch {regsub -nocase -all a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.4 {regsub errors} {
evalInProc {
list [catch {regsub a b c d e f} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
-#test regexpComp-11.5 {regsub errors} {
-# evalInProc {
-# list [catch {regsub -gorp a b c} msg] $msg
-# }
-#} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
+
+test regexpComp-11.5 {regsub errors} -body {
+ evalInProc {
+ list [catch {regsub -gorp a b c} msg] $msg
+ }
+} -result {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -lineanchor, -linestop, -nocase, -start, or --}}
+
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
@@ -805,11 +807,17 @@ test regexpComp-21.10 {regexp command compiling tests} {
}
} {3 barfbarobaro}
# This useless expression fails. Jim returns "bar"
-#test regexpComp-21.11 {regexp command compiling tests} {
-# evalInProc {
-# list [regsub -all "" "" bar str] $str
-# }
-#} {0 {}}
+test regexpComp-21.11 {regexp command compiling tests} {
+ evalInProc {
+ list [regsub -all "" "" bar str] $str
+ }
+} {0 {}}
+test regexpComp-21.12 {regexp empty pattern with utf8} utf8 {
+ # Make sure the second char isn't sliced up
+ evalInProc {
+ regsub -all "" a\u0442bc !
+ }
+} "!a!\u0442!b!c"
# We can forgive the underlying regexp engine for not supporting this.
# Why not use this instead? "((^X)*|\$)"
@@ -943,4 +951,36 @@ test regexp-25.3 {End of word} {
regexp {\mcd\M} cdef
} 0
+test regexp-25.4 {Braces not a repeat count} {
+ regexp "{abc}" "test{abc}def"
+} 1
+
+test regexp-25.5 {Repeat follows nothing} -body {
+ regexp "{3}" "test{3}def"
+} -returnCodes error -match glob -result {couldn't compile regular expression pattern: *}
+
+test regexp-25.6 {Meta char after nothing is error} -body {
+ regexp "?" "te?st"
+} -returnCodes error -match glob -result {couldn't compile regular expression pattern: *}
+
+test regexp-26.1 {regexp operator =~} jim {
+ expr {"abc" =~ "^a"}
+} 1
+
+test regexp-26.2 {regexp operator =~} jim {
+ expr {"abc" =~ "^b"}
+} 0
+
+test regexp-26.2 {regexp operator =~} jim {
+ expr {"abc" =~ ".b."}
+} 1
+
+test regexp-26.3 {regexp operator =~ invalid regexp} -constraints jim -body {
+ expr {"abc" =~ {[}}
+} -returnCodes error -result {couldn't compile regular expression pattern: brackets [] not balanced}
+
+test regexp-27.1 {regexp expanded} -body {
+ regexp -expanded -all -inline { a ( b b ) + } {abbbbbbcde}
+} -returnCodes ok -result {abbbbbb bb}
+
testreport
diff --git a/tests/socket.test b/tests/socket.test
index cc7d3d6..acb5347 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -120,6 +120,11 @@ test socket-1.7 {socketpair} -body {
lassign [socket pair] s1 s2
$s1 buffering line
$s2 buffering line
+ # We trust the data received on these sockets
+ if {[exists -command taint]} {
+ $s1 taint source 0
+ $s2 taint source 0
+ }
stdout flush
if {[os.fork] == 0} {
$s1 close
@@ -345,6 +350,10 @@ if {[os.fork] == 0} {
# read everything available (non-blocking read)
set buf [$c read]
if {[string length $buf]} {
+ # It is safe to send this back to where it came from
+ if {[exists -command untaint]} {
+ untaint buf
+ }
$c puts -nonewline $buf
$c flush
}
diff --git a/tests/ssl.test b/tests/ssl.test
index d147c92..7c69358 100644
--- a/tests/ssl.test
+++ b/tests/ssl.test
@@ -22,6 +22,10 @@ if {[os.fork] == 0} {
$c readable {
# read everything available and echo it back
set buf [$c read]
+ # We don't mind sending tainted data back to it's source
+ if {[exists -command taint]} {
+ untaint buf
+ }
$c puts -nonewline $buf
$c flush
if {[$c eof]} {
diff --git a/tests/stringmatch.test b/tests/stringmatch.test
index f0eab2a..2a60631 100644
--- a/tests/stringmatch.test
+++ b/tests/stringmatch.test
@@ -230,4 +230,16 @@ test stringmatch-7.4 {null in pattern} {
string match *b\[\0a\]r* foobar
} 1
+test regexp-8.1 {string match operator =*} {
+ expr {"abc" =* "a*"}
+} 1
+
+test regexp-26.2 {regexp operator =~} {
+ expr {"abc" =* "b*"}
+} 0
+
+test regexp-26.2 {regexp operator =~} {
+ expr {"abc" =* {*[bB]c}}
+} 1
+
testreport
diff --git a/tests/taint.test b/tests/taint.test
new file mode 100644
index 0000000..3e924f8
--- /dev/null
+++ b/tests/taint.test
@@ -0,0 +1,212 @@
+source [file dirname [info script]]/testing.tcl
+
+needs cmd taint
+
+# create a tainted var
+set t tainted
+taint t
+
+test taint-1.1 {taint simple var} {
+ info tainted $t
+} 1
+
+test taint-1.2 {set taint, simple var} {
+ set x $t
+ info tainted $x
+} 1
+
+test taint-1.3 {untaint ref counting simple var} {
+ untaint x
+ list [info tainted $x] [info tainted $t]
+} {0 1}
+
+# Tainting an array element taints the array/dict, but
+# not each element
+test taint-1.4 {taint array var} {
+ set a {1 one 2 two}
+ taint a(2)
+ list [info tainted $a(1)] [info tainted $a(2)] [info tainted $a]
+} {0 1 1}
+
+# Adding a tainted value to an array taints the array/dict, but
+# not each element
+test taint-1.5 {tainted value taints dict} {
+ unset -nocomplain a
+ array set a {1 one 2 two}
+ set a(3) $t
+ list [info tainted $a(1)] [info tainted $a(3)] [info tainted $a]
+} {0 1 1}
+
+# lappend taints the list, but not each element
+test taint-1.6 {lappend with taint} {
+ set a {1 2}
+ lappend a $t
+ list [info tainted $a] [lmap p $a {info tainted $p}]
+} {1 {0 0 1}}
+
+# lset taints the list, but not each element
+test taint-1.7 {lset with taint} {
+ set a [list a b c d]
+ lset a 1 $t
+ list [info tainted $a] [lmap p $a {info tainted $p}]
+} {1 {0 1 0 0}}
+
+# append taints the string
+test taint-1.8 {append with taint} {
+ set a abc
+ append a $t
+ info tainted $a
+} 1
+
+test taint-1.9 {taint entire list} {
+ set a [list 1 2 3]
+ taint a
+ list [info tainted $a] [lmap p $a {info tainted $p}]
+} {1 {1 1 1}}
+
+test taint-1.10 {taint entire dict} {
+ set a [dict create a 1 b 2 c 3]
+ taint a
+ list [info tainted $a] [info tainted [dict get $a b]]
+} {1 1}
+
+
+test taint-1.11 {interpolation with taint} {
+ set x "x$t"
+ info tainted $x
+} 1
+
+test taint-1.12 {lrange with taint} {
+ set a [list 1 2 3 $t 5 6]
+ info tainted [lrange $a 0 1]
+} 0
+
+test taint-1.13 {lrange with taint} {
+ set a [list 1 2 3 $t 5 6]
+ info tainted [lrange $a 2 4]
+} 1
+
+test taint-1.14 {lindex with taint} {
+ set a [list 1 2 3 $t 5 6]
+ info tainted [lindex $a 1]
+} 0
+
+test taint-1.15 {lassign with taint} {
+ set a [list 1 $t 3]
+ lassign $a x y z
+ list [info tainted $x] [info tainted $y] [info tainted $z]
+} {0 1 0}
+
+test taint-1.16 {lreverse with taint} {
+ set a [lreverse [list 1 2 $t]]
+ list [info tainted $a] [lmap p $a {info tainted $p}]
+} {1 {1 0 0}}
+
+test taint-1.17 {lsort with taint} {
+ set a [lsort [list zzz aaa $t bbb ppp]]
+ list [info tainted $a] [lmap p $a {info tainted $p}]
+} {1 {0 0 0 1 0}}
+
+test taint-1.18 {lreplace with taint} {
+ set a {a b c}
+ set b [lreplace $a 1 1 $t]
+ list [info tainted $b] [lmap p $b {info tainted $p}]
+} {1 {0 1 0}}
+
+test taint-1.19 {dict with taint} {
+ set a [dict create a 1 b 2 c $t d 4]
+ info tainted $a
+} 1
+
+test taint-1.20 {dict with taint} {
+ set a [dict create a 1 b 2 c $t d 4]
+ info tainted [dict get $a b]
+} 0
+
+test taint-1.21 {dict with taint} {
+ set a [dict create a 1 b 2 c $t d 4]
+ info tainted [dict get $a c]
+} 1
+
+test taint-1.22 {dict with taint} {
+ dict set a $t e
+ set result {}
+ foreach i [lsort [dict keys $a]] {
+ set v [dict get $a $i]
+ lappend result [list $i $v [info tainted $i] [info tainted $v]]
+ }
+ set result
+} {{a 1 0 0} {b 2 0 0} {c tainted 0 1} {d 4 0 0} {tainted e 1 0}}
+
+test taint-1.23 {nested dict with taint} {
+ set a [dict create]
+ dict set a 1 A 1-A
+ dict set a 2 A 2-A
+ dict set a 1 T $t
+ info tainted $a
+} 1
+
+test taint-2.1 {exec with tainted data} -body {
+ exec $t
+} -returnCodes error -result {exec: tainted data}
+
+test taint-2.2 {eval with tainted data - allowed} {
+ eval "set a $t"
+} tainted
+
+test taint-2.3 {eval with braced tainted data - allowed} {
+ eval {set a $t}
+} tainted
+
+test taint-2.4 {eval exec with tainted data} -body {
+ eval {exec $t}
+} -returnCodes error -result {exec: tainted data}
+
+test taint-2.5 {open with tainted data} -body {
+ open "|$t"
+} -returnCodes error -result {open: tainted data}
+
+test taint-2.6 {file delete with tainted data} -body {
+ file delete $t
+} -returnCodes error -result {file delete: tainted data}
+
+test taint-2.7 {check errorcode on tainted data} -body {
+ try {
+ eval {exec $t}
+ } on error {msg opts} {
+ dict get $opts -errorcode
+ }
+} -result {TAINTED}
+
+test taint-3.1 {filehandle not taint source by default} {
+ set f [open [info script]]
+ gets $f buf
+ info tainted $buf
+} 0
+
+test taint-3.2 {set taint source on filehandle} {
+ $f taint source 1
+ gets $f buf
+ info tainted $buf
+} 1
+
+test taint-3.3 {filehandle not taint sink by default} -body {
+ set g [open out.tmp w]
+ puts $g $t
+} -result {}
+
+test taint-3.4 {set taint sink on filehandle} -body {
+ $g taint sink 1
+ puts $g $t
+} -returnCodes error -result "puts: tainted data"
+
+test taint-3.5 {copyto taint source to sink} -body {
+ $f copyto $g
+} -returnCodes error -result {copying tainted source}
+
+$f close
+$g close
+
+file delete out.tmp
+
+testreport
diff --git a/tests/try.test b/tests/try.test
index 0d76865..36a9bf9 100644
--- a/tests/try.test
+++ b/tests/try.test
@@ -104,7 +104,7 @@ test try-2.1 "try ... trap" -body {
try {
a
} trap CUSTOM {msg opts} {
- list $msg $opts(-code) $opts(-errorcode)
+ list $msg [dict get $opts -code] [dict get $opts -errorcode]
}
} -result {{custom errorcode} 1 {CUSTOM RESULT}}
@@ -140,6 +140,13 @@ test try-2.5 "trap match first but not second" -body {
}
} -returnCodes error -result failed
+test try-2.6 "trap match too long" -body {
+ try {
+ apply {{} {return -code error -errorcode {FOO BAR} failed}}
+ } trap {FOO BAR BAZ} {msg opts} {
+ list trapped
+ }
+} -returnCodes error -result failed
proc c {} {
try {
generated by cgit v1.1 at 2025-10-17 07:24:30 +0000