From e52d9cbf151b4d4106c36834e820db9442ec9a3b Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 19 May 2004 20:15:29 +0000 Subject: Massive test cleanup; all tests are run, and constraints are used where necessary. --- ChangeLog | 9 + tests/async.test | 70 +++--- tests/clock.test | 4 +- tests/compExpr-old.test | 41 ++-- tests/compExpr.test | 22 +- tests/exec.test | 10 +- tests/expr-old.test | 53 ++--- tests/expr.test | 28 +-- tests/fCmd.test | 10 +- tests/fileName.test | 36 ++- tests/format.test | 5 +- tests/info.test | 6 +- tests/interp.test | 148 ++++++------ tests/macOSXFCmd.test | 6 +- tests/obj.test | 183 +++++++------- tests/parseExpr.test | 407 ++++++++++++++++--------------- tests/rename.test | 116 ++++----- tests/safe.test | 62 +---- tests/socket.test | 8 +- tests/string.test | 5 +- tests/stringComp.test | 5 +- tests/stringObj.test | 131 +++++----- tests/thread.test | 8 +- tests/unixFCmd.test | 12 +- tests/unixFile.test | 23 +- tests/unixNotfy.test | 23 +- tests/util.test | 12 +- tests/var.test | 115 +++++---- tests/winDde.test | 622 +++++++++++++++++++----------------------------- tests/winFCmd.test | 19 +- tests/winNotify.test | 5 +- tests/winPipe.test | 9 +- 32 files changed, 986 insertions(+), 1227 deletions(-) diff --git a/ChangeLog b/ChangeLog index e634d40..6aa673c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2004-05-19 Donal K. Fellows + + * tests/*.test: Many minor fixes, including ensuring that every + test is run (so constraints control whether the test is doing + anything) and making sure that constraints are always set using + the API instead of poking around inside tcltest's internal + datastructures. Also got rid of all trailing whitespace lines + from the test suite! + 2004-05-19 Andreas Kupries * tclIO.c: Fixed [SF Tcl Bug 943274]. This is the same problem as diff --git a/tests/async.test b/tests/async.test index 863be98..969208c 100644 --- a/tests/async.test +++ b/tests/async.test @@ -11,19 +11,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: async.test,v 1.7 2003/11/16 00:49:20 dkf Exp $ +# RCS: @(#) $Id: async.test,v 1.8 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -if {[info commands testasync] == {}} { - puts "This application hasn't been compiled with the \"testasync\"" - puts "command, so I can't test Tcl_AsyncCreate et al." - ::tcltest::cleanupTests - return -} +testConstraint testasync [llength [info commands testasync]] tcltest::testConstraint threaded [expr { [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded) @@ -53,43 +48,45 @@ proc \# {result code} { return "comment quoting" } -set handler1 [testasync create async1] -set handler2 [testasync create async2] -set handler3 [testasync create async3] -set handler4 [testasync create #] -test async-1.1 {basic async handlers} { +if {[testConstraint testasync]} { + set handler1 [testasync create async1] + set handler2 [testasync create async2] + set handler3 [testasync create async3] + set handler4 [testasync create \#] +} +test async-1.1 {basic async handlers} testasync { set aresult xxx set acode yyy list [catch {testasync mark $handler1 "original" 0} msg] $msg \ $acode $aresult } {0 {new result} 0 original} -test async-1.2 {basic async handlers} { +test async-1.2 {basic async handlers} testasync { set aresult xxx set acode yyy list [catch {testasync mark $handler1 "original" 1} msg] $msg \ $acode $aresult } {0 {new result} 1 original} -test async-1.3 {basic async handlers} { +test async-1.3 {basic async handlers} testasync { set aresult xxx set acode yyy list [catch {testasync mark $handler2 "old" 0} msg] $msg \ $acode $aresult } {1 xyzzy 0 old} -test async-1.4 {basic async handlers} { +test async-1.4 {basic async handlers} testasync { set aresult xxx set acode yyy list [catch {testasync mark $handler2 "old" 3} msg] $msg \ $acode $aresult } {1 xyzzy 3 old} -test async-1.5 {basic async handlers} { +test async-1.5 {basic async handlers} testasync { set aresult xxx list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult } {0 foobar {test pattern}} -test async-1.6 {basic async handlers} { +test async-1.6 {basic async handlers} testasync { set aresult xxx list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult } {1 foobar {test pattern}} -test async-1.7 {basic async handlers} { +test async-1.7 {basic async handlers} testasync { set aresult xxx set acode yyy list [catch {testasync mark $handler4 "original" 0} msg] $msg \ @@ -101,13 +98,11 @@ proc mult1 {result code} { lappend x mult1 return -code 7 mult1 } -set hm1 [testasync create mult1] proc mult2 {result code} { global x lappend x mult2 return -code 9 mult2 } -set hm2 [testasync create mult2] proc mult3 {result code} { global x hm1 hm2 lappend x [catch {testasync mark $hm2 serial2 0}] @@ -115,9 +110,12 @@ proc mult3 {result code} { lappend x mult3 return -code 11 mult3 } -set hm3 [testasync create mult3] - -test async-2.1 {multiple handlers} { +if {[testConstraint testasync]} { + set hm1 [testasync create mult1] + set hm2 [testasync create mult2] + set hm3 [testasync create mult3] +} +test async-2.1 {multiple handlers} testasync { set x {} list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x } {9 mult2 {0 0 mult3 mult1 mult2}} @@ -138,14 +136,16 @@ proc del2 {result code} { lappend x del2 return -code 3 del2 } -testasync delete $handler1 -testasync delete $hm2 -testasync delete $hm3 -set hm2 [testasync create del1] -set hm3 [testasync create mult2] -set hm4 [testasync create del2] +if {[testConstraint testasync]} { + testasync delete $handler1 + testasync delete $hm2 + testasync delete $hm3 + set hm2 [testasync create del1] + set hm3 [testasync create mult2] + set hm4 [testasync create del2] +} -test async-3.1 {deleting handlers} { +test async-3.1 {deleting handlers} testasync { set x {} list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x } {3 del2 {0 0 0 del1 del2}} @@ -183,7 +183,7 @@ proc hang3 {handle} [concat { }] test async-4.1 {async interrupting bytecode sequence} -constraints { - threaded + testasync threaded } -setup { set hm [testasync create async3] } -body { @@ -192,7 +192,7 @@ test async-4.1 {async interrupting bytecode sequence} -constraints { testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { - threaded + testasync threaded } -setup { set hm [testasync create async3] } -body { @@ -201,7 +201,7 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints { testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { - threaded + testasync threaded } -setup { set hm [testasync create async3] } -body { @@ -211,7 +211,9 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { } # cleanup -testasync delete +if {[testConstraint testasync]} { + testasync delete +} ::tcltest::cleanupTests return diff --git a/tests/clock.test b/tests/clock.test index f93e698..9946009 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: clock.test,v 1.27 2004/05/18 21:45:55 kennykb Exp $ +# RCS: @(#) $Id: clock.test,v 1.28 2004/05/19 20:15:31 dkf Exp $ set env(LC_TIME) POSIX @@ -508,7 +508,7 @@ test clock-8.1 {clock scan midnight/gmt range bug 413397} { [clock format [clock scan year -base $5amPST -gmt 1] -format $fmt] } {12/31 12/31} -set ::tcltest::testConstraints(needPST) [expr { +testConstraint needPST [expr { [regexp {^(Pacific.*|P[DS]T)$} [clock format 1 -format %Z]] && ([clock format 1 -format %s] != "%s") }] diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index 2c9b778..b3e0677 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compExpr-old.test,v 1.8 2003/09/12 23:55:34 dkf Exp $ +# RCS: @(#) $Id: compExpr-old.test,v 1.9 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -20,11 +20,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { - set gotT1 0 - puts "This application hasn't been compiled with the \"T1\" and" - puts "\"T2\" math functions, so I'll skip some of the expr tests." + testConstraint testmathfunctions 0 } else { - set gotT1 1 + testConstraint testmathfunctions 1 } # procedures used below @@ -600,24 +598,21 @@ test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} { } {syntax error in expression "sin(1": missing close parenthesis at end of function call while compiling "expr sin(1"} -if $gotT1 { - test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} { - expr 2*T1() - } 246 - test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} { - expr T2()*3 - } 1035 - - test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} { - expr T3(21, 37) - } 37 - test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} { - expr T3(21.2, 37) - } 37.0 - test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} { - expr T3(-21.2, -17.5) - } -17.5 -} +test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr 2*T1() +} 246 +test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T2()*3 +} 1035 +test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T3(21, 37) +} 37 +test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T3(21.2, 37) +} 37.0 +test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T3(-21.2, -17.5) +} -17.5 test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { catch {unset a} diff --git a/tests/compExpr.test b/tests/compExpr.test index cd407d3..4470fef 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compExpr.test,v 1.6 2001/12/06 10:59:17 dkf Exp $ +# RCS: @(#) $Id: compExpr.test,v 1.7 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -16,11 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { - set gotT1 0 - puts "This application hasn't been compiled with the \"T1\" and" - puts "\"T2\" math functions, so I'll skip some of the expr tests." + testConstraint testmathfunctions 0 } else { - set gotT1 1 + testConstraint testmathfunctions 1 } catch {unset a} @@ -294,14 +292,12 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} { list [catch {expr {do_it()}} msg] $msg } {1 {unknown math function "do_it"}} -if $gotT1 { - test compExpr-5.3 {CompileMathFuncCall: call registered math function} { - expr 3*T1()-1 - } 368 - test compExpr-5.4 {CompileMathFuncCall: call registered math function} { - expr T2()*3 - } 1035 -} +test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr 3*T1()-1 +} 368 +test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T2()*3 +} 1035 test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} { list [catch {expr {atan2(1.0)}} msg] $msg } {1 {too few arguments for math function}} diff --git a/tests/exec.test b/tests/exec.test index 18060f6..8d338ca 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: exec.test,v 1.18 2004/02/25 23:56:59 dgp Exp $ +# RCS: @(#) $Id: exec.test,v 1.19 2004/05/19 20:15:31 dkf Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -217,8 +217,8 @@ test exec-4.5 {redirecting output and stderr to file} {exec} { # I/O redirection: input from file. -if { [set ::tcltest::testConstraints(exec)] } { -exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file) +if {[testConstraint exec]} { + exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file) } test exec-5.1 {redirecting input from file} {exec} { exec [interpreter] $path(cat) < $path(gorp.file) @@ -428,8 +428,8 @@ test exec-11.5 {commands in background} {exec} { # Make sure that background commands are properly reaped when # they eventually die. -if { [set ::tcltest::testConstraints(exec)] } { -exec [interpreter] $path(sleep) 3 +if {[testConstraint exec]} { + exec [interpreter] $path(sleep) 3 } test exec-12.1 {reaping background processes} \ {exec unixOnly nonPortable} { diff --git a/tests/expr-old.test b/tests/expr-old.test index 2df8135..1d7b796 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr-old.test,v 1.17 2003/03/27 13:48:58 dkf Exp $ +# RCS: @(#) $Id: expr-old.test,v 1.18 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -21,11 +21,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { - set gotT1 0 - puts "This application hasn't been compiled with the \"T1\" and" - puts "\"T2\" math functions, so I'll skip some of the expr tests." + testConstraint testmathfunctions 0 } else { - set gotT1 1 + testConstraint testmathfunctions 1 } # First, test all of the integer operators individually. @@ -732,11 +730,11 @@ test expr-old-32.24 {math functions in expressions} { # The following test is different for 32-bit versus 64-bit architectures. if {0x80000000 > 0} { - test expr-old-32.25 {math functions in expressions} {nonPortable} { + test expr-old-32.25a {math functions in expressions} {nonPortable} { list [catch {expr abs(0x8000000000000000)} msg] $msg } {1 {integer value too large to represent}} } else { - test expr-old-32.25 {math functions in expressions} {nonPortable} { + test expr-old-32.25b {math functions in expressions} {nonPortable} { list [catch {expr abs(0x80000000)} msg] $msg } {1 {integer value too large to represent}} } @@ -792,14 +790,12 @@ test expr-old-32.41 {math functions in expressions} { test expr-old-32.42 {math functions in expressions} { list [catch {expr hypot(5*.8,3)} msg] $msg } {0 5.0} -if $gotT1 { - test expr-old-32.43 {math functions in expressions} { - expr 2*T1() - } 246 - test expr-old-32.44 {math functions in expressions} { - expr T2()*3 - } 1035 -} +test expr-old-32.43 {math functions in expressions} testmathfunctions { + expr 2*T1() +} 246 +test expr-old-32.44 {math functions in expressions} testmathfunctions { + expr T2()*3 +} 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} @@ -893,11 +889,9 @@ test expr-old-34.15 {errors in math functions} { test expr-old-34.16 {errors in math functions} { list [catch {expr round(-1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -if $gotT1 { - test expr-old-34.17 {errors in math functions} { - list [catch {expr T1(4)} msg] $msg - } {1 {too many arguments for math function}} -} +test expr-old-34.17 {errors in math functions} testmathfunctions { + list [catch {expr T1(4)} msg] $msg +} {1 {too many arguments for math function}} test expr-old-36.1 {ExprLooksLikeInt procedure} -body { expr 0289 @@ -963,24 +957,17 @@ test expr-old-36.16 {ExprLooksLikeInt procedure} { list [catch {expr {$x+1}} msg] $msg } {1 {can't use integer value too large to represent as operand of "+"}} -if {[info commands testexprlong] == {}} { - puts "This application hasn't been compiled with the \"testexprlong\"" - puts "command, so I can't test Tcl_ExprLong etc." -} else { -test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} { +testConstraint testexprlong [llength [info commands testexprlong]] +testConstraint testexprstring [llength [info commands testexprstring]] + +test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong { testexprlong } {This is a result: 5} -} -if {[info commands testexprstring] == {}} { - puts "This application hasn't been compiled with the \"testexprstring\"" - puts "command, so I can't test Tcl_ExprString etc." -} else { -test expr-old-38.1 {Verify Tcl_ExprString's basic operation} { +test expr-old-38.1 {Verify Tcl_ExprString's basic operation} testexprstring { list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \ - [catch {testexprstring "1+"} msg] $msg + [catch {testexprstring "1+"} msg] $msg } {5 10.2 1 {syntax error in expression "1+": premature end of expression}} -} # Special test for Pentium arithmetic bug of 1994: diff --git a/tests/expr.test b/tests/expr.test index 0b2543e..9a168c9 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -10,14 +10,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr.test,v 1.20 2003/09/19 23:05:40 dkf Exp $ +# RCS: @(#) $Id: expr.test,v 1.21 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -testConstraint registeredMathFuncs [expr { +testConstraint testmathfunctions [expr { ([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"}) }] @@ -324,11 +324,11 @@ test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 # architectures because LONG_MIN is different if {0x80000000 > 0} { - test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { + test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { expr {1<<63} } -9223372036854775808 } else { - test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { + test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { expr {1<<31} } -2147483648 } @@ -626,34 +626,34 @@ test expr-15.6 {CompileMathFuncCall: missing ')'} { } {syntax error in expression "sin(1": missing close parenthesis at end of function call while compiling "expr sin(1"} -test expr-15.7 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} { +test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} { expr 2*T1() } 246 -test expr-15.8 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} { +test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} { expr T2()*3 } 1035 -test expr-15.9 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} { +test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} { expr T3(21, 37) } 37 -test expr-15.10 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} { +test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} { expr T3(21.2, 37) } 37.0 -test expr-15.11 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} { +test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} { expr T3(-21.2, -17.5) } -17.5 -test expr-15.12 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} { +test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} { expr T3(21, wide(37)) } 37 -test expr=15.13 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} { +test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} { expr T3(wide(21), 37) } 37 -test expr=15.14 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} { +test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} { expr T3(wide(21), wide(37)) } 37 -test expr-15.15 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} { +test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} { expr T3(21.0, wide(37)) } 37.0 -test expr=15.16 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} { +test expr=15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} { expr T3(wide(21), 37.0) } 37.0 diff --git a/tests/fCmd.test b/tests/fCmd.test index 9e1b3e6..fbf2216 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fCmd.test,v 1.38 2004/03/17 18:14:17 das Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.39 2004/05/19 20:15:31 dkf Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -92,17 +92,17 @@ proc contents {file} { } cd [temporaryDirectory] -set ::tcltest::testConstraints(fileSharing) 0 -set ::tcltest::testConstraints(notFileSharing) 1 +testConstraint fileSharing 0 +testConstraint notFileSharing 1 -set ::tcltest::testConstraints(xdev) 0 +testConstraint xdev 0 if {$tcl_platform(platform) == "unix"} { if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} { set m1 [string range $m1 0 [expr [string first " " $m1]-1]] set m2 [string range $m2 0 [expr [string first " " $m2]-1]] if {$m1 != "" && $m2 != "" && $m1 != $m2 && [file exists $m1] && [file exists $m2]} { - set ::tcltest::testConstraints(xdev) 1 + testConstraint xdev 1 } } } diff --git a/tests/fileName.test b/tests/fileName.test index ae900af..a5f077d 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -10,18 +10,18 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.41 2004/05/04 22:31:10 hobbs Exp $ +# RCS: @(#) $Id: fileName.test,v 1.42 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]] -tcltest::testConstraint testtranslatefilename [string equal testtranslatefilename [info commands testtranslatefilename]] +testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]] +testConstraint testtranslatefilename [string equal testtranslatefilename [info commands testtranslatefilename]] global env -if {[tcltest::testConstraint testsetplatform]} { +if {[testConstraint testsetplatform]} { set platform [testgetplatform] } @@ -204,7 +204,7 @@ test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} { file split foo/bar~/baz } {foo bar~ baz} -if {[tcltest::testConstraint testsetplatform]} { +if {[testConstraint testsetplatform]} { testsetplatform $platform } @@ -662,7 +662,7 @@ test filename-10.22 {Tcl_TranslateFileName} {testsetplatform} { list [catch {testtranslatefilename foo//bar} msg] $msg } {0 {foo\bar}} -if {[tcltest::testConstraint testsetplatform]} { +if {[testConstraint testsetplatform]} { testsetplatform $platform } @@ -721,7 +721,7 @@ test filename-11.12 {Tcl_GlobCmd} {testsetplatform} { set x } {1 {couldn't find HOME environment variable to expand path}} -if {[tcltest::testConstraint testsetplatform]} { +if {[testConstraint testsetplatform]} { testsetplatform $platform } @@ -781,17 +781,17 @@ test filename-11.17.1 {Tcl_GlobCmd} {pcOnly} { if {[string equal $tcl_platform(platform) "windows"]} { if {[string index $tcl_platform(osVersion) 0] >= 5 \ && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} { - tcltest::testConstraint linkDirectory 1 + testConstraint linkDirectory 1 } else { - tcltest::testConstraint linkDirectory 0 + testConstraint linkDirectory 0 } } else { - tcltest::testConstraint linkDirectory 1 + testConstraint linkDirectory 1 } if {[string equal $tcl_platform(platform) "windows"]} { - tcltest::testConstraint symbolicLinkFile 0 + testConstraint symbolicLinkFile 0 } else { - tcltest::testConstraint symbolicLinkFile 1 + testConstraint symbolicLinkFile 1 } test filename-11.17.2 {Tcl_GlobCmd} {notRoot linkDirectory} { set dir [pwd] @@ -1409,7 +1409,7 @@ test filename-15.8 {win and unix specific globbing} {unixOrWin} { # The following tests are only valid for Windows systems. set oldDir [pwd] -if {$::tcltest::testConstraints(pcOnly)} { +if {[testConstraint pcOnly]} { cd c:/ file delete -force globTest file mkdir globTest @@ -1461,10 +1461,8 @@ test filename-16.11 {windows specific globbing} {pcOnly} { # some tests require a shared C drive -if {[catch {cd //[info hostname]/c}]} { - set ::tcltest::testConstraints(sharedCdrive) 0 -} else { - set ::tcltest::testConstraints(sharedCdrive) 1 +if {[testConstraint pcOnly]} { + testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}] } test filename-16.12 {windows specific globbing} {pcOnly sharedCdrive} { @@ -1493,7 +1491,7 @@ test filename-17.1 {windows specific special files} {testsetplatform} { [file pathtype prn] [file pathtype nul] [file pathtype aux] \ [file pathtype foo] } {absolute absolute absolute absolute absolute absolute relative} -if {[tcltest::testConstraint testsetplatform]} { +if {[testConstraint testsetplatform]} { testsetplatform $platform } @@ -1515,7 +1513,7 @@ cd [temporaryDirectory] file delete -force globTest cd $oldpwd set env(HOME) $oldhome -if {[tcltest::testConstraint testsetplatform]} { +if {[testConstraint testsetplatform]} { testsetplatform $platform catch {unset platform} } diff --git a/tests/format.test b/tests/format.test index c6d9731..774fd1e 100644 --- a/tests/format.test +++ b/tests/format.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: format.test,v 1.16 2003/05/14 23:04:32 dkf Exp $ +# RCS: @(#) $Id: format.test,v 1.17 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -22,8 +22,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # fail. Someday I hope this code shouldn't be necessary (code added # 9/9/91). -set ::tcltest::testConstraints(roundOffBug) \ - [expr {"[format %7.1e 68.514]" != "6.8e+01"}] +testConstraint roundOffBug [expr {"[format %7.1e 68.514]" != "6.8e+01"}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 diff --git a/tests/info.test b/tests/info.test index ec77d0b..e95fca2 100644 --- a/tests/info.test +++ b/tests/info.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.26 2004/05/17 21:42:34 dkf Exp $ +# RCS: @(#) $Id: info.test,v 1.27 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -491,8 +491,7 @@ test info-15.7 {info procs option with a global shadowing proc} { # This regression test is currently commented out because it requires # that the implementation of "info procs" looks into the global namespace, # which it does not (in contrast to "info commands") -if {0} { -test info-15.8 {info procs option with a global shadowing proc} { +test info-15.8 {info procs option with a global shadowing proc} knownBug { catch {namespace delete test_ns_info2} proc string_cmd { arg } { puts cmd @@ -509,7 +508,6 @@ test info-15.8 {info procs option with a global shadowing proc} { lsort [info procs string*] } } [lsort [list string_cmd string_cmd2]] -} test info-16.1 {info script option} { list [catch {info script x x} msg] $msg diff --git a/tests/interp.test b/tests/interp.test index ace4ad7..8e84db0 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.31 2004/05/18 09:29:30 dkf Exp $ +# RCS: @(#) $Id: interp.test,v 1.32 2004/05/19 20:15:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -674,85 +674,81 @@ test interp-17.5 {alias loop prevention} { # the bugs as a core dump. # -if {[info commands testinterpdelete] == ""} { - puts "This application hasn't been compiled with the \"testinterpdelete\"" - puts "command, so I can't test slave delete calls" -} else { - test interp-18.1 {testing Tcl_DeleteInterp vs slaves} { - list [catch {testinterpdelete} msg] $msg - } {1 {wrong # args: should be "testinterpdelete path"}} - test interp-18.2 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - testinterpdelete a - } "" - test interp-18.3 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - interp create {a b} - testinterpdelete {a b} - } "" - test interp-18.4 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - interp create {a b} - testinterpdelete a - } "" - test interp-18.5 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - interp create {a b} - interp alias {a b} dodel {} dodel - proc dodel {x} {testinterpdelete $x} - list [catch {interp eval {a b} {dodel {a b}}} msg] $msg - } {0 {}} - test interp-18.6 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - interp create {a b} - interp alias {a b} dodel {} dodel - proc dodel {x} {testinterpdelete $x} - list [catch {interp eval {a b} {dodel a}} msg] $msg - } {0 {}} - test interp-18.7 {eval in deleted interp} { - catch {interp delete a} - interp create a - a eval { +testCosntraint testinterpdelete [llength [info commands testinterpdelete]] +test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + list [catch {testinterpdelete} msg] $msg +} {1 {wrong # args: should be "testinterpdelete path"}} +test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + testinterpdelete a +} "" +test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete {a b} +} "" +test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete a +} "" +test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel {a b}}} msg] $msg +} {0 {}} +test interp-18.6 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel a}} msg] $msg +} {0 {}} +test interp-18.7 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + proc dodel {} { + delme + dosomething else + } + proc dosomething args { + puts "I should not have been called!!" + } + } + a alias delme dela + proc dela {} {interp delete a} + list [catch {a eval dodel} msg] $msg +} {1 {attempt to call eval in deleted interpreter}} +test interp-18.8 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + interp create b + b eval { proc dodel {} { - delme - dosomething else - } - proc dosomething args { - puts "I should not have been called!!" + dela } } - a alias delme dela - proc dela {} {interp delete a} - list [catch {a eval dodel} msg] $msg - } {1 {attempt to call eval in deleted interpreter}} - test interp-18.8 {eval in deleted interp} { - catch {interp delete a} - interp create a - a eval { - interp create b - b eval { - proc dodel {} { - dela - } - } - proc foo {} { - b eval dela - dosomething else - } - proc dosomething args { - puts "I should not have been called!!" - } + proc foo {} { + b eval dela + dosomething else } - interp alias {a b} dela {} dela - proc dela {} {interp delete a} - list [catch {a eval foo} msg] $msg - } {1 {attempt to call eval in deleted interpreter}} -} + proc dosomething args { + puts "I should not have been called!!" + } + } + interp alias {a b} dela {} dela + proc dela {} {interp delete a} + list [catch {a eval foo} msg] $msg +} {1 {attempt to call eval in deleted interpreter}} test interp-18.9 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 0bc6d30..2250435 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: macOSXFCmd.test,v 1.1 2003/05/14 19:21:25 das Exp $ +# RCS: @(#) $Id: macOSXFCmd.test,v 1.2 2004/05/19 20:15:32 dkf Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -23,14 +23,14 @@ set oldcwd [pwd] cd [temporaryDirectory] # check whether macosx file attributes are supported -set ::tcltest::testConstraints(macosxFileAttr) 0 +testConstraint macosxFileAttr 0 if {$tcl_platform(platform) eq "unix" && \ $tcl_platform(os) eq "Darwin"} { catch {file delete -force -- foo.test} close [open foo.test w] catch { file attributes foo.test -creator - set ::tcltest::testConstraints(macosxFileAttr) 1 + testConstraint macosxFileAttr 1 } file delete -force -- foo.test } diff --git a/tests/obj.test b/tests/obj.test index c4ec7d4..a6bb192 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -11,21 +11,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: obj.test,v 1.7 2002/04/26 08:43:38 dkf Exp $ +# RCS: @(#) $Id: obj.test,v 1.8 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -if {[info commands testobj] == {}} { - puts "This application hasn't been compiled with the \"testobj\"" - puts "command, so I can't test the Tcl type and object support." - ::tcltest::cleanupTests - return -} +testConstraint testobj [llength [info commands testobj]] -test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} { +test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { {array search} @@ -47,7 +42,7 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} { set result $r } {1} -test obj-2.1 {Tcl_GetObjType error} { +test obj-2.1 {Tcl_GetObjType error} testobj { list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg } {0 1 {no type foo found}} test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} { @@ -59,14 +54,14 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} { lappend result [testobj refcount 1] } {{} 12 12 double 3} -test obj-3.1 {Tcl_ConvertToType error} { +test obj-3.1 {Tcl_ConvertToType error} testobj { list [testdoubleobj set 1 12.34] [catch {testobj convert 1 int} msg] $msg } {12.34 1 {expected integer but got "12.34"}} -test obj-3.2 {Tcl_ConvertToType error, "empty string" object} { +test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { list [testobj newobj 1] [catch {testobj convert 1 int} msg] $msg } {{} 1 {expected integer but got ""}} -test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} { +test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -74,7 +69,7 @@ test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} { lappend result [testobj refcount 1] } {{} {} string 2} -test obj-5.1 {Tcl_FreeObj} { +test obj-5.1 {Tcl_FreeObj} testobj { set result "" lappend result [testintobj set 1 12345] lappend result [testobj freeallvars] @@ -82,7 +77,7 @@ test obj-5.1 {Tcl_FreeObj} { lappend result $msg } {12345 {} 1 {variable 1 is unset (NULL)}} -test obj-6.1 {Tcl_DuplicateObj, object has internal rep} { +test obj-6.1 {Tcl_DuplicateObj, object has internal rep} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 47] @@ -91,7 +86,7 @@ test obj-6.1 {Tcl_DuplicateObj, object has internal rep} { lappend result [testobj refcount 1] lappend result [testobj refcount 2] } {{} 47 47 47 2 3} -test obj-6.2 {Tcl_DuplicateObj, "empty string" object} { +test obj-6.2 {Tcl_DuplicateObj, "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -101,55 +96,57 @@ test obj-6.2 {Tcl_DuplicateObj, "empty string" object} { lappend result [testobj refcount 2] } {{} {} {} {} 2 3} -test obj-7.1 {Tcl_GetString, return existing string rep} { +# We assume that testobj is an indicator for test*obj as well + +test obj-7.1 {Tcl_GetString, return existing string rep} testobj { set result "" lappend result [testintobj set 1 47] lappend result [testintobj get2 1] } {47 47} -test obj-7.2 {Tcl_GetString, "empty string" object} { +test obj-7.2 {Tcl_GetString, "empty string" object} testobj { set result "" lappend result [testobj newobj 1] lappend result [teststringobj append 1 abc -1] lappend result [teststringobj get2 1] } {{} abc abc} -test obj-7.3 {Tcl_GetString, returns string internal rep (DString)} { +test obj-7.3 {Tcl_GetString, returns string internal rep (DString)} testobj { set result "" lappend result [teststringobj set 1 xyz] lappend result [teststringobj append 1 abc -1] lappend result [teststringobj get2 1] } {xyz xyzabc xyzabc} -test obj-7.4 {Tcl_GetString, recompute string rep from internal rep} { +test obj-7.4 {Tcl_GetString, recompute string rep from internal rep} testobj { set result "" lappend result [testintobj set 1 77] lappend result [testintobj mult10 1] lappend result [teststringobj get2 1] } {77 770 770} -test obj-8.1 {Tcl_GetStringFromObj, return existing string rep} { +test obj-8.1 {Tcl_GetStringFromObj, return existing string rep} testobj { set result "" lappend result [testintobj set 1 47] lappend result [testintobj get 1] } {47 47} -test obj-8.2 {Tcl_GetStringFromObj, "empty string" object} { +test obj-8.2 {Tcl_GetStringFromObj, "empty string" object} testobj { set result "" lappend result [testobj newobj 1] lappend result [teststringobj append 1 abc -1] lappend result [teststringobj get 1] } {{} abc abc} -test obj-8.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} { +test obj-8.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} testobj { set result "" lappend result [teststringobj set 1 xyz] lappend result [teststringobj append 1 abc -1] lappend result [teststringobj get 1] } {xyz xyzabc xyzabc} -test obj-8.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} { +test obj-8.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} testobj { set result "" lappend result [testintobj set 1 77] lappend result [testintobj mult10 1] lappend result [teststringobj get 1] } {77 770 770} -test obj-9.1 {Tcl_NewBooleanObj} { +test obj-9.1 {Tcl_NewBooleanObj} testobj { set result "" lappend result [testobj freeallvars] lappend result [testbooleanobj set 1 0] @@ -157,7 +154,7 @@ test obj-9.1 {Tcl_NewBooleanObj} { lappend result [testobj refcount 1] } {{} 0 boolean 2} -test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} { +test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -165,7 +162,7 @@ test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 0 boolean 2} -test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { +test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 98765] @@ -174,62 +171,62 @@ test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 98765 1 boolean 2} -test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} { +test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} testobj { set result "" lappend result [testbooleanobj set 1 1] lappend result [testbooleanobj not 1] ;# gets existing boolean rep } {1 0} -test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} { +test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} testobj { set result "" lappend result [testintobj set 1 47] lappend result [testbooleanobj not 1] ;# must convert to bool lappend result [testobj type 1] } {47 0 boolean} -test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} { +test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {abc 1 {expected boolean value but got "abc"}} -test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} { +test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {{} 1 {expected boolean value but got ""}} -test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} { +test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} testobj { set result "" lappend result [teststringobj set 1 0xac] lappend result [testbooleanobj not 1] lappend result [testobj type 1] } {0xac 0 boolean} -test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} { +test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} testobj { set result "" lappend result [teststringobj set 1 5.42] lappend result [testbooleanobj not 1] lappend result [testobj type 1] } {5.42 0 boolean} -test obj-12.1 {DupBooleanInternalRep} { +test obj-12.1 {DupBooleanInternalRep} testobj { set result "" lappend result [testbooleanobj set 1 1] lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep lappend result [testbooleanobj get 2] } {1 1 1} -test obj-13.1 {SetBooleanFromAny, int to boolean special case} { +test obj-13.1 {SetBooleanFromAny, int to boolean special case} testobj { set result "" lappend result [testintobj set 1 1234] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {1234 0 boolean} -test obj-13.2 {SetBooleanFromAny, double to boolean special case} { +test obj-13.2 {SetBooleanFromAny, double to boolean special case} testobj { set result "" lappend result [testdoubleobj set 1 3.14159] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {3.14159 0 boolean} -test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} { +test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} testobj { set result "" foreach s {yes no true false on off} { teststringobj set 1 $s @@ -237,46 +234,46 @@ test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} { } lappend result [testobj type 1] } {0 1 0 1 0 1 boolean} -test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} { +test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} testobj { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {456 45 0 boolean} -test obj-13.5 {SetBooleanFromAny, error parsing string} { +test obj-13.5 {SetBooleanFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {abc 1 {expected boolean value but got "abc"}} -test obj-13.6 {SetBooleanFromAny, error parsing string} { +test obj-13.6 {SetBooleanFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 x1.0] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {x1.0 1 {expected boolean value but got "x1.0"}} -test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} { +test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {{} 1 {expected boolean value but got ""}} -test obj-13.8 {SetBooleanFromAny, unicode strings} { +test obj-13.8 {SetBooleanFromAny, unicode strings} testobj { set result "" lappend result [teststringobj set 1 1\u7777] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } "1\u7777 1 {expected boolean value but got \"1\u7777\"}" -test obj-14.1 {UpdateStringOfBoolean} { +test obj-14.1 {UpdateStringOfBoolean} testobj { set result "" lappend result [testbooleanobj set 1 0] lappend result [testbooleanobj not 1] lappend result [testbooleanobj get 1] ;# must update string rep } {0 1 1} -test obj-15.1 {Tcl_NewDoubleObj} { +test obj-15.1 {Tcl_NewDoubleObj} testobj { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 3.1459] @@ -284,7 +281,7 @@ test obj-15.1 {Tcl_NewDoubleObj} { lappend result [testobj refcount 1] } {{} 3.1459 double 2} -test obj-16.1 {Tcl_SetDoubleObj, existing "empty string" object} { +test obj-16.1 {Tcl_SetDoubleObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -292,7 +289,7 @@ test obj-16.1 {Tcl_SetDoubleObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 0.123 double 2} -test obj-16.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { +test obj-16.2 {Tcl_SetDoubleObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 98765] @@ -301,83 +298,83 @@ test obj-16.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 98765 27.56 double 2} -test obj-17.1 {Tcl_GetDoubleFromObj, existing double object} { +test obj-17.1 {Tcl_GetDoubleFromObj, existing double object} testobj { set result "" lappend result [testdoubleobj set 1 16.1] lappend result [testdoubleobj mult10 1] ;# gets existing double rep } {16.1 161.0} -test obj-17.2 {Tcl_GetDoubleFromObj, convert to double} { +test obj-17.2 {Tcl_GetDoubleFromObj, convert to double} testobj { set result "" lappend result [testintobj set 1 477] lappend result [testdoubleobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47.7 double} -test obj-17.3 {Tcl_GetDoubleFromObj, error converting to double} { +test obj-17.3 {Tcl_GetDoubleFromObj, error converting to double} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {abc 1 {expected floating-point number but got "abc"}} -test obj-17.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} { +test obj-17.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testdoubleobj div10 1} msg] lappend result $msg } {{} 1 {expected floating-point number but got ""}} -test obj-18.1 {DupDoubleInternalRep} { +test obj-18.1 {DupDoubleInternalRep} testobj { set result "" lappend result [testdoubleobj set 1 17.1] lappend result [testobj duplicate 1 2] ;# uses DupDoubleInternalRep lappend result [testdoubleobj get 2] } {17.1 17.1 17.1} -test obj-19.1 {SetDoubleFromAny, int to double special case} { +test obj-19.1 {SetDoubleFromAny, int to double special case} testobj { set result "" lappend result [testintobj set 1 1234] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {1234 12340.0 double} -test obj-19.2 {SetDoubleFromAny, boolean to double special case} { +test obj-19.2 {SetDoubleFromAny, boolean to double special case} testobj { set result "" lappend result [testbooleanobj set 1 1] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {1 10.0 double} -test obj-19.3 {SetDoubleFromAny, recompute string rep then parse it} { +test obj-19.3 {SetDoubleFromAny, recompute string rep then parse it} testobj { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {456 45 450.0 double} -test obj-19.4 {SetDoubleFromAny, error parsing string} { +test obj-19.4 {SetDoubleFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {abc 1 {expected floating-point number but got "abc"}} -test obj-19.5 {SetDoubleFromAny, error parsing string} { +test obj-19.5 {SetDoubleFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 x1.0] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {x1.0 1 {expected floating-point number but got "x1.0"}} -test obj-19.6 {SetDoubleFromAny, error converting from "empty string"} { +test obj-19.6 {SetDoubleFromAny, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testdoubleobj div10 1} msg] lappend result $msg } {{} 1 {expected floating-point number but got ""}} -test obj-20.1 {UpdateStringOfDouble} { +test obj-20.1 {UpdateStringOfDouble} testobj { set result "" lappend result [testdoubleobj set 1 3.14159] lappend result [testdoubleobj mult10 1] lappend result [testdoubleobj get 1] ;# must update string rep } {3.14159 31.4159 31.4159} -test obj-21.1 {Tcl_NewIntObj} { +test obj-21.1 {Tcl_NewIntObj} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 55] @@ -385,7 +382,7 @@ test obj-21.1 {Tcl_NewIntObj} { lappend result [testobj refcount 1] } {{} 55 int 2} -test obj-22.1 {Tcl_SetIntObj, existing "empty string" object} { +test obj-22.1 {Tcl_SetIntObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -393,7 +390,7 @@ test obj-22.1 {Tcl_SetIntObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} -test obj-22.2 {Tcl_SetIntObj, existing non-"empty string" object} { +test obj-22.2 {Tcl_SetIntObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] @@ -402,94 +399,94 @@ test obj-22.2 {Tcl_SetIntObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-23.1 {Tcl_GetIntFromObj, existing int object} { +test obj-23.1 {Tcl_GetIntFromObj, existing int object} testobj { set result "" lappend result [testintobj set 1 22] lappend result [testintobj mult10 1] ;# gets existing int rep } {22 220} -test obj-23.2 {Tcl_GetIntFromObj, convert to int} { +test obj-23.2 {Tcl_GetIntFromObj, convert to int} testobj { set result "" lappend result [testintobj set 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-23.3 {Tcl_GetIntFromObj, error converting to int} { +test obj-23.3 {Tcl_GetIntFromObj, error converting to int} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} { +test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {nonPortable} { +test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {testobj nonPortable} { set result "" lappend result [testobj newobj 1] lappend result [testintobj inttoobigtest 1] } {{} 1} -test obj-24.1 {DupIntInternalRep} { +test obj-24.1 {DupIntInternalRep} testobj { set result "" lappend result [testintobj set 1 23] lappend result [testobj duplicate 1 2] ;# uses DupIntInternalRep lappend result [testintobj get 2] } {23 23 23} -test obj-25.1 {SetIntFromAny, int to int special case} { +test obj-25.1 {SetIntFromAny, int to int special case} testobj { set result "" lappend result [testintobj set 1 1234] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {1234 12340 int} -test obj-25.2 {SetIntFromAny, boolean to int special case} { +test obj-25.2 {SetIntFromAny, boolean to int special case} testobj { set result "" lappend result [testbooleanobj set 1 1] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {1 10 int} -test obj-25.3 {SetIntFromAny, recompute string rep then parse it} { +test obj-25.3 {SetIntFromAny, recompute string rep then parse it} testobj { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {456 45 450 int} -test obj-25.4 {SetIntFromAny, error parsing string} { +test obj-25.4 {SetIntFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-25.5 {SetIntFromAny, error parsing string} { +test obj-25.5 {SetIntFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 x17] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {x17 1 {expected integer but got "x17"}} -test obj-25.6 {SetIntFromAny, integer too large} {nonPortable} { +test obj-25.6 {SetIntFromAny, integer too large} {testobj nonPortable} { set result "" lappend result [teststringobj set 1 123456789012345678901] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {123456789012345678901 1 {integer value too large to represent}} -test obj-25.7 {SetIntFromAny, error converting from "empty string"} { +test obj-25.7 {SetIntFromAny, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-26.1 {UpdateStringOfInt} { +test obj-26.1 {UpdateStringOfInt} testobj { set result "" lappend result [testintobj set 1 512] lappend result [testintobj mult10 1] lappend result [testintobj get 1] ;# must update string rep } {512 5120 5120} -test obj-27.1 {Tcl_NewLongObj} { +test obj-27.1 {Tcl_NewLongObj} testobj { set result "" lappend result [testobj freeallvars] testintobj setmaxlong 1 @@ -498,7 +495,7 @@ test obj-27.1 {Tcl_NewLongObj} { lappend result [testobj refcount 1] } {{} 1 int 1} -test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} { +test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -506,7 +503,7 @@ test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} -test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} { +test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] @@ -515,31 +512,31 @@ test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} { +test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} testobj { set result "" lappend result [testintobj setlong 1 22] lappend result [testintobj mult10 1] ;# gets existing long int rep } {22 220} -test obj-29.2 {Tcl_GetLongFromObj, convert to long} { +test obj-29.2 {Tcl_GetLongFromObj, convert to long} testobj { set result "" lappend result [testintobj setlong 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} { +test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} { +test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-30.1 {Ref counting and object deletion, simple types} { +test obj-30.1 {Ref counting and object deletion, simple types} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 1024] @@ -554,50 +551,46 @@ test obj-30.1 {Ref counting and object deletion, simple types} { } {{} 1024 1024 int 4 4 0 boolean 3 2} -test obj-31.1 {regenerate string rep of "end"} { +test obj-31.1 {regenerate string rep of "end"} testobj { testobj freeallvars teststringobj set 1 end testobj convert 1 end-offset testobj invalidateStringRep 1 } end - -test obj-31.2 {regenerate string rep of "end-1"} { +test obj-31.2 {regenerate string rep of "end-1"} testobj { testobj freeallvars teststringobj set 1 end-0x1 testobj convert 1 end-offset testobj invalidateStringRep 1 } end-1 - -test obj-31.3 {regenerate string rep of "end--1"} { +test obj-31.3 {regenerate string rep of "end--1"} testobj { testobj freeallvars teststringobj set 1 end--0x1 testobj convert 1 end-offset testobj invalidateStringRep 1 } end--1 - -test obj-31.4 {regenerate string rep of "end-bigInteger"} { +test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj { testobj freeallvars teststringobj set 1 end-0x7fffffff testobj convert 1 end-offset testobj invalidateStringRep 1 } end-2147483647 - -test obj-31.5 {regenerate string rep of "end--bigInteger"} { +test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { testobj freeallvars teststringobj set 1 end--0x7fffffff testobj convert 1 end-offset testobj invalidateStringRep 1 } end--2147483647 - - -test obj-31.6 {regenerate string rep of "end--bigInteger"} {nonPortable} { +test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj nonPortable} { testobj freeallvars teststringobj set 1 end--0x80000000 testobj convert 1 end-offset testobj invalidateStringRep 1 } end--2147483648 -testobj freeallvars +if {[testConstraint testobj]} { + testobj freeallvars +} # cleanup ::tcltest::cleanupTests diff --git a/tests/parseExpr.test b/tests/parseExpr.test index b5db5e5..e65c646 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parseExpr.test,v 1.11 2003/10/06 14:32:22 dgp Exp $ +# RCS: @(#) $Id: parseExpr.test,v 1.12 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -20,624 +20,619 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # for example, that a math function actually exists, or that the operands # of "<<" are integers. -if {[info commands testexprparser] == {}} { - puts "This application hasn't been compiled with the \"testexprparser\"" - puts "command, so I can't test the Tcl expression parser." - ::tcltest::cleanupTests - return -} +testConstraint testexprparser [llength [info commands testexprparser]] # Some tests only work if wide integers (>32bit) are not found to be # integers at all. -set ::tcltest::testConstraints(wideIntegerUnparsed) \ - [expr {-1 == 0xffffffff}] -test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} { +testConstraint wideIntegerUnparsed [expr {-1 == 0xffffffff}] + +###################################################################### + +test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser [bytestring "1+2\0 +3"] -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} { +test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser "1 + 2" -1 } {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {wideIntegerUnparsed} { +test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} { +test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} testexprparser { list [catch {testexprparser {foo+} -1} msg] $msg } {1 {syntax error in expression "foo+": variable references require preceding $}} -test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} { +test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} testexprparser { list [catch {testexprparser {1+2 345} -1} msg] $msg } {1 {syntax error in expression "1+2 345": extra tokens at end of expression}} -test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} { +test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} testexprparser { testexprparser {2>3? 1 : 0} -1 } {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} { +test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} testexprparser { list [catch {testexprparser {0 || foo} -1} msg] $msg } {1 {syntax error in expression "0 || foo": variable references require preceding $}} -test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} { +test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} testexprparser { testexprparser {1+2} -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} { +test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} testexprparser { testexprparser {1+2 ? 3 : 4} -1 } {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {wideIntegerUnparsed} { +test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} { +test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} testexprparser { testexprparser {1? 3 : 4} -1 } {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} { +test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} testexprparser { list [catch {testexprparser {1? fred : martha} -1} msg] $msg } {1 {syntax error in expression "1? fred : martha": variable references require preceding $}} -test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} { +test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} testexprparser { list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg } {1 {syntax error in expression "1? 2 martha 3": missing colon from ternary conditional}} -test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} { +test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} testexprparser { testexprparser {27||3? 3 : 4&&9} -1 } {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}} -test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} { +test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} testexprparser { list [catch {testexprparser {1? 2 : martha} -1} msg] $msg } {1 {syntax error in expression "1? 2 : martha": variable references require preceding $}} -test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} { +test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} testexprparser { testexprparser {1&&2 || 3} -1 } {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} { +test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} testexprparser { list [catch {testexprparser {1&&foo || 3} -1} msg] $msg } {1 {syntax error in expression "1&&foo || 3": variable references require preceding $}} -test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} { +test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} testexprparser { testexprparser {1&&2? 1 : 0} -1 } {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} { +test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} testexprparser { testexprparser {1&&2 || 3} -1 } {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {wideIntegerUnparsed} { +test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} { +test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1&&2 || 3 || 4} -1 } {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} { +test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg } {1 {syntax error in expression "1&&2 || 3 || martha": variable references require preceding $}} -test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} { +test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} testexprparser { testexprparser {1|2 && 3} -1 } {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} { +test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} testexprparser { list [catch {testexprparser {1&&foo && 3} -1} msg] $msg } {1 {syntax error in expression "1&&foo && 3": variable references require preceding $}} -test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} { +test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} testexprparser { testexprparser {1|2? 1 : 0} -1 } {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} { +test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} testexprparser { testexprparser {1|2 && 3} -1 } {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {wideIntegerUnparsed} { +test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} { +test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1|2 && 3 && 4} -1 } {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} { +test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg } {1 {syntax error in expression "1|2 && 3 && martha": variable references require preceding $}} -test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} { +test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} testexprparser { testexprparser {1^2 | 3} -1 } {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} { +test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} testexprparser { list [catch {testexprparser {1|foo | 3} -1} msg] $msg } {1 {syntax error in expression "1|foo | 3": variable references require preceding $}} -test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} { +test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} testexprparser { testexprparser {1^2? 1 : 0} -1 } {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} { +test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} testexprparser { testexprparser {1^2 | 3} -1 } {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {wideIntegerUnparsed} { +test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} { +test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1^2 | 3 | 4} -1 } {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} { +test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg } {1 {syntax error in expression "1^2 | 3 | martha": variable references require preceding $}} -test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} { +test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} testexprparser { testexprparser {1&2 ^ 3} -1 } {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} { +test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} testexprparser { list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg } {1 {syntax error in expression "1^foo ^ 3": variable references require preceding $}} -test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} { +test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} testexprparser { testexprparser {1&2? 1 : 0} -1 } {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} { +test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} testexprparser { testexprparser {1&2 ^ 3} -1 } {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {wideIntegerUnparsed} { +test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} { +test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1&2 ^ 3 ^ 4} -1 } {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} { +test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg } {1 {syntax error in expression "1&2 ^ 3 ^ martha": variable references require preceding $}} -test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} { +test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} testexprparser { testexprparser {1==2 & 3} -1 } {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} { +test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} testexprparser { list [catch {testexprparser {1!=foo & 3} -1} msg] $msg } {1 {syntax error in expression "1!=foo & 3": variable references require preceding $}} -test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} { +test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} testexprparser { testexprparser {1==2? 1 : 0} -1 } {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} { +test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} testexprparser { testexprparser {1>2 & 3} -1 } {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {wideIntegerUnparsed} { +test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} { +test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<2 & 3 & 4} -1 } {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} { +test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg } {1 {syntax error in expression "1==2 & 3>2 & martha": variable references require preceding $}} -test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} { +test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} testexprparser { testexprparser {1<2 == 3} -1 } {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} { +test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} testexprparser { list [catch {testexprparser {1>=foo == 3} -1} msg] $msg } {1 {syntax error in expression "1>=foo == 3": variable references require preceding $}} -test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} { +test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} testexprparser { testexprparser {1<2? 1 : 0} -1 } {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} { +test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser { testexprparser {1<2 == 3} -1 } {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} { +test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser { testexprparser {1<2 != 3} -1 } {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {wideIntegerUnparsed} { +test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} { +test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<2 == 3 == 4} -1 } {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} { +test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg } {1 {syntax error in expression "1<2 == 3 != martha": variable references require preceding $}} -test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} { +test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} testexprparser { testexprparser {1<<2 < 3} -1 } {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} { +test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} testexprparser { list [catch {testexprparser {1>=foo < 3} -1} msg] $msg } {1 {syntax error in expression "1>=foo < 3": variable references require preceding $}} -test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} { +test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} testexprparser { testexprparser {1<<2? 1 : 0} -1 } {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} { +test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1<<2 < 3} -1 } {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-9.5 {ParseRelationalExpr procedure, next lexeme is relational op} { +test parseExpr-9.5 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1>>2 > 3} -1 } {- {} 0 subexpr {1>>2 > 3} 9 operator > 0 subexpr 1>>2 5 operator >> 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-9.6 {ParseRelationalExpr procedure, next lexeme is relational op} { +test parseExpr-9.6 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1<<2 <= 3} -1 } {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-9.7 {ParseRelationalExpr procedure, next lexeme is relational op} { +test parseExpr-9.7 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1<<2 >= 3} -1 } {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {wideIntegerUnparsed} { +test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} { +test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<<2 < 3 < 4} -1 } {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} { +test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg } {1 {syntax error in expression "1<<2 < 3 > martha": variable references require preceding $}} -test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} { +test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} testexprparser { testexprparser {1+2 << 3} -1 } {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} { +test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} testexprparser { list [catch {testexprparser {1-foo << 3} -1} msg] $msg } {1 {syntax error in expression "1-foo << 3": variable references require preceding $}} -test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} { +test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} testexprparser { testexprparser {1+2? 1 : 0} -1 } {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} { +test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser { testexprparser {1+2 << 3} -1 } {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} { +test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser { testexprparser {1+2 >> 3} -1 } {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {wideIntegerUnparsed} { +test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} { +test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1+2 << 3 << 4} -1 } {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} { +test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg } {1 {syntax error in expression "1+2 << 3 >> martha": variable references require preceding $}} -test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} { +test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} { +test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} testexprparser { list [catch {testexprparser {1/foo + 3} -1} msg] $msg } {1 {syntax error in expression "1/foo + 3": variable references require preceding $}} -test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} { +test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser { testexprparser {1*2? 1 : 0} -1 } {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} { +test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} { +test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 - 3} -1 } {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {wideIntegerUnparsed} { +test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} { +test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1*2 + 3 + 4} -1 } {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} { +test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg } {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}} -test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} { +test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} { +test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} testexprparser { list [catch {testexprparser {1/foo + 3} -1} msg] $msg } {1 {syntax error in expression "1/foo + 3": variable references require preceding $}} -test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} { +test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser { testexprparser {1*2? 1 : 0} -1 } {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} { +test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} { +test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 - 3} -1 } {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {wideIntegerUnparsed} { +test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} { +test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1*2 + 3 + 4} -1 } {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} { +test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg } {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}} -test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} { +test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} testexprparser { testexprparser {+2 * 3} -1 } {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {wideIntegerUnparsed} { +test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-13.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} { +test parseExpr-13.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} testexprparser { testexprparser {+2? 1 : 0} -1 } {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-13.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { +test parseExpr-13.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser { testexprparser {-123 * 3} -1 } {- {} 0 subexpr {-123 * 3} 7 operator * 0 subexpr -123 3 operator - 0 subexpr 123 1 text 123 0 subexpr 3 1 text 3 0 {}} -test parseExpr-13.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { +test parseExpr-13.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser { testexprparser {+-456 / 3} -1 } {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} -test parseExpr-13.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { +test parseExpr-13.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser { testexprparser {+-456 % 3} -1 } {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} -test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {wideIntegerUnparsed} { +test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} { +test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} testexprparser { testexprparser {-2 / 3 % 4} -1 } {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} { +test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} testexprparser { list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg } {1 {syntax error in expression "++2 / 3 * martha": variable references require preceding $}} -test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} { +test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {+2} -1 } {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}} -test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} { +test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {-2} -1 } {- {} 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 {}} -test parseExpr-14.3 {ParseUnaryExpr procedure, first token is unary operator} { +test parseExpr-14.3 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {~2} -1 } {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}} -test parseExpr-14.4 {ParseUnaryExpr procedure, first token is unary operator} { +test parseExpr-14.4 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {!2} -1 } {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}} -test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {wideIntegerUnparsed} { +test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {-12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-14.6 {ParseUnaryExpr procedure, simple unary expr after unary op} { +test parseExpr-14.6 {ParseUnaryExpr procedure, simple unary expr after unary op} testexprparser { testexprparser {+"1234"} -1 } {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}} -test parseExpr-14.7 {ParseUnaryExpr procedure, another unary expr after unary op} { +test parseExpr-14.7 {ParseUnaryExpr procedure, another unary expr after unary op} testexprparser { testexprparser {~!{fred}} -1 } {- {} 0 subexpr ~!{fred} 5 operator ~ 0 subexpr !{fred} 3 operator ! 0 subexpr {{fred}} 1 text fred 0 {}} -test parseExpr-14.8 {ParseUnaryExpr procedure, error in unary expr after unary op} { +test parseExpr-14.8 {ParseUnaryExpr procedure, error in unary expr after unary op} testexprparser { list [catch {testexprparser {+-||27} -1} msg] $msg } {1 {syntax error in expression "+-||27": unexpected operator ||}} -test parseExpr-14.9 {ParseUnaryExpr procedure, error in unary expr after unary op} { +test parseExpr-14.9 {ParseUnaryExpr procedure, error in unary expr after unary op} testexprparser { list [catch {testexprparser {+-||27} -1} msg] $msg } {1 {syntax error in expression "+-||27": unexpected operator ||}} -test parseExpr-14.10 {ParseUnaryExpr procedure, first token is not unary op} { +test parseExpr-14.10 {ParseUnaryExpr procedure, first token is not unary op} testexprparser { testexprparser {123} -1 } {- {} 0 subexpr 123 1 text 123 0 {}} -test parseExpr-14.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} { +test parseExpr-14.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} testexprparser { testexprparser {(1+2)} -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {wideIntegerUnparsed} { +test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-15.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} { +test parseExpr-15.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} testexprparser { testexprparser {({abc}/{def})} -1 } {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}} -test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {wideIntegerUnparsed} { +test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-15.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} { +test parseExpr-15.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} testexprparser { testexprparser {({abc}? 2*4 : -6)} -1 } {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}} -test parseExpr-15.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} { +test parseExpr-15.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} testexprparser { list [catch {testexprparser {(? 123 : 456)} -1} msg] $msg } {1 {syntax error in expression "(? 123 : 456)": unexpected ternary 'then' separator}} -test parseExpr-15.5 {ParsePrimaryExpr procedure, missing ")" after in parenthesized subexpr} { +test parseExpr-15.5 {ParsePrimaryExpr procedure, missing ")" after in parenthesized subexpr} testexprparser { list [catch {testexprparser {({abc}/{def}} -1} msg] $msg } {1 {syntax error in expression "({abc}/{def}": looking for close parenthesis}} -test parseExpr-15.6 {ParsePrimaryExpr procedure, primary is literal} { +test parseExpr-15.6 {ParsePrimaryExpr procedure, primary is literal} testexprparser { testexprparser {12345} -1 } {- {} 0 subexpr 12345 1 text 12345 0 {}} -test parseExpr-15.7 {ParsePrimaryExpr procedure, primary is literal} { +test parseExpr-15.7 {ParsePrimaryExpr procedure, primary is literal} testexprparser { testexprparser {12345.6789} -1 } {- {} 0 subexpr 12345.6789 1 text 12345.6789 0 {}} -test parseExpr-15.8 {ParsePrimaryExpr procedure, primary is var reference} { +test parseExpr-15.8 {ParsePrimaryExpr procedure, primary is var reference} testexprparser { testexprparser {$a} -1 } {- {} 0 subexpr {$a} 2 variable {$a} 1 text a 0 {}} -test parseExpr-15.9 {ParsePrimaryExpr procedure, primary is var reference} { +test parseExpr-15.9 {ParsePrimaryExpr procedure, primary is var reference} testexprparser { testexprparser {$a(hello$there)} -1 } {- {} 0 subexpr {$a(hello$there)} 5 variable {$a(hello$there)} 4 text a 0 text hello 0 variable {$there} 1 text there 0 {}} -test parseExpr-15.10 {ParsePrimaryExpr procedure, primary is var reference} { +test parseExpr-15.10 {ParsePrimaryExpr procedure, primary is var reference} testexprparser { testexprparser {$a()} -1 } {- {} 0 subexpr {$a()} 3 variable {$a()} 2 text a 0 text {} 0 {}} -test parseExpr-15.11 {ParsePrimaryExpr procedure, error in var reference} { +test parseExpr-15.11 {ParsePrimaryExpr procedure, error in var reference} testexprparser { list [catch {testexprparser {$a(} -1} msg] $msg } {1 {missing )}} -test parseExpr-15.12 {ParsePrimaryExpr procedure, primary is quoted string} { +test parseExpr-15.12 {ParsePrimaryExpr procedure, primary is quoted string} testexprparser { testexprparser {"abc $xyz def"} -1 } {- {} 0 subexpr {"abc $xyz def"} 5 word {"abc $xyz def"} 4 text {abc } 0 variable {$xyz} 1 text xyz 0 text { def} 0 {}} -test parseExpr-15.13 {ParsePrimaryExpr procedure, error in quoted string} { +test parseExpr-15.13 {ParsePrimaryExpr procedure, error in quoted string} testexprparser { list [catch {testexprparser {"$a(12"} -1} msg] $msg } {1 {missing )}} -test parseExpr-15.14 {ParsePrimaryExpr procedure, quoted string has multiple tokens} { +test parseExpr-15.14 {ParsePrimaryExpr procedure, quoted string has multiple tokens} testexprparser { testexprparser {"abc [xyz] $def"} -1 } {- {} 0 subexpr {"abc [xyz] $def"} 6 word {"abc [xyz] $def"} 5 text {abc } 0 command {[xyz]} 0 text { } 0 variable {$def} 1 text def 0 {}} -test parseExpr-15.15 {ParsePrimaryExpr procedure, primary is command} { +test parseExpr-15.15 {ParsePrimaryExpr procedure, primary is command} testexprparser { testexprparser {[def]} -1 } {- {} 0 subexpr {[def]} 1 command {[def]} 0 {}} -test parseExpr-15.16 {ParsePrimaryExpr procedure, primary is multiple commands} { +test parseExpr-15.16 {ParsePrimaryExpr procedure, primary is multiple commands} testexprparser { testexprparser {[one; two; three; four;]} -1 } {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}} -test parseExpr-15.17 {ParsePrimaryExpr procedure, primary is multiple commands} { +test parseExpr-15.17 {ParsePrimaryExpr procedure, primary is multiple commands} testexprparser { testexprparser {[one; two; three; four;]} -1 } {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}} -test parseExpr-15.18 {ParsePrimaryExpr procedure, missing close bracket} { +test parseExpr-15.18 {ParsePrimaryExpr procedure, missing close bracket} testexprparser { list [catch {testexprparser {[one} -1} msg] $msg } {1 {missing close-bracket}} -test parseExpr-15.19 {ParsePrimaryExpr procedure, primary is braced string} { +test parseExpr-15.19 {ParsePrimaryExpr procedure, primary is braced string} testexprparser { testexprparser {{hello world}} -1 } {- {} 0 subexpr {{hello world}} 1 text {hello world} 0 {}} -test parseExpr-15.20 {ParsePrimaryExpr procedure, error in primary, which is braced string} { +test parseExpr-15.20 {ParsePrimaryExpr procedure, error in primary, which is braced string} testexprparser { list [catch {testexprparser "\{abc\\\n" -1} msg] $msg } {1 {missing close-brace}} -test parseExpr-15.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} { +test parseExpr-15.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} testexprparser { testexprparser "\{ \\ +123 \}" -1 } {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text { } 0 backslash \\\n\ 0 text {+123 } 0 {}} -test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} { +test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} testexprparser { testexprparser {foo(123)} -1 } {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}} -test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {wideIntegerUnparsed} { +test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} { +test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} testexprparser { list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg } {1 {syntax error in expression "foo 27.4 123)": variable references require preceding $}} -test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {wideIntegerUnparsed} { +test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} { +test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} testexprparser { testexprparser {foo(27*4)} -1 } {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}} -test parseExpr-15.27 {ParsePrimaryExpr procedure, error in function arg} { +test parseExpr-15.27 {ParsePrimaryExpr procedure, error in function arg} testexprparser { list [catch {testexprparser {foo(*1-2)} -1} msg] $msg } {1 {syntax error in expression "foo(*1-2)": unexpected operator *}} -test parseExpr-15.28 {ParsePrimaryExpr procedure, error in function arg} { +test parseExpr-15.28 {ParsePrimaryExpr procedure, error in function arg} testexprparser { list [catch {testexprparser {foo(*1-2)} -1} msg] $msg } {1 {syntax error in expression "foo(*1-2)": unexpected operator *}} -test parseExpr-15.29 {ParsePrimaryExpr procedure, function call, comma after arg} { +test parseExpr-15.29 {ParsePrimaryExpr procedure, function call, comma after arg} testexprparser { testexprparser {foo(27-2, (-2*[foo]))} -1 } {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}} -test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {wideIntegerUnparsed} { +test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-15.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} { +test parseExpr-15.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} testexprparser { list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg } {1 {syntax error in expression "foo(123 [foo])": missing close parenthesis at end of function call}} -test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {wideIntegerUnparsed} { +test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-15.33 {ParsePrimaryExpr procedure, comma-specific message} { +test parseExpr-15.33 {ParsePrimaryExpr procedure, comma-specific message} testexprparser { list [catch {testexprparser {123+,456} -1} msg] $msg } {1 {syntax error in expression "123+,456": commas can only separate function arguments}} -test parseExpr-15.34 {ParsePrimaryExpr procedure, single equal-specific message} { +test parseExpr-15.34 {ParsePrimaryExpr procedure, single equal-specific message} testexprparser { list [catch {testexprparser {123+=456} -1} msg] $msg } {1 {syntax error in expression "123+=456": single equality character not legal in expressions}} -test parseExpr-15.35 {ParsePrimaryExpr procedure, error in parenthesized subexpr} { +test parseExpr-15.35 {ParsePrimaryExpr procedure, error in parenthesized subexpr} testexprparser { list [catch {testexprparser {(: 123 : 456)} -1} msg] $msg } {1 {syntax error in expression "(: 123 : 456)": unexpected ternary 'else' separator}} -test parseExpr-15.36 {ParsePrimaryExpr procedure, missing close-bracket} { +test parseExpr-15.36 {ParsePrimaryExpr procedure, missing close-bracket} testexprparser { # Test for Bug 681841 list [catch {testexprparser {[set a [format bc]} -1} msg] $msg } {1 {missing close-bracket}} -test parseExpr-16.1 {GetLexeme procedure, whitespace before lexeme} { +test parseExpr-16.1 {GetLexeme procedure, whitespace before lexeme} testexprparser { testexprparser { 123} -1 } {- {} 0 subexpr 123 1 text 123 0 {}} -test parseExpr-16.2 {GetLexeme procedure, whitespace before lexeme} { +test parseExpr-16.2 {GetLexeme procedure, whitespace before lexeme} testexprparser { testexprparser { \ 456} -1 } {- {} 0 subexpr 456 1 text 456 0 {}} -test parseExpr-16.3 {GetLexeme procedure, no lexeme after whitespace} { +test parseExpr-16.3 {GetLexeme procedure, no lexeme after whitespace} testexprparser { testexprparser { 123 \ } -1 } {- {} 0 subexpr 123 1 text 123 0 {}} -test parseExpr-16.4 {GetLexeme procedure, integer lexeme} { +test parseExpr-16.4 {GetLexeme procedure, integer lexeme} testexprparser { testexprparser {000} -1 } {- {} 0 subexpr 000 1 text 000 0 {}} -test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {wideIntegerUnparsed} { +test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {testexprparser wideIntegerUnparsed} { list [catch {testexprparser {12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} - -test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -body { +test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -constraints testexprparser -body { testexprparser {0999} -1 } -returnCodes error -match glob -result {*invalid octal number*} - -test parseExpr-16.7 {GetLexeme procedure, double lexeme} { +test parseExpr-16.7 {GetLexeme procedure, double lexeme} testexprparser { testexprparser {0.999} -1 } {- {} 0 subexpr 0.999 1 text 0.999 0 {}} -test parseExpr-16.8 {GetLexeme procedure, double lexeme} { +test parseExpr-16.8 {GetLexeme procedure, double lexeme} testexprparser { testexprparser {.123} -1 } {- {} 0 subexpr .123 1 text .123 0 {}} -test parseExpr-16.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} { +test parseExpr-16.9 {GetLexeme procedure, double lexeme} {testexprparser nonPortable unixOnly} { testexprparser {nan} -1 } {- {} 0 subexpr nan 1 text nan 0 {}} -test parseExpr-16.10 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} { +test parseExpr-16.10 {GetLexeme procedure, double lexeme} {testexprparser nonPortable unixOnly} { testexprparser {NaN} -1 } {- {} 0 subexpr NaN 1 text NaN 0 {}} -test parseExpr-16.11 {GetLexeme procedure, bad double lexeme too big} { +test parseExpr-16.11 {GetLexeme procedure, bad double lexeme too big} testexprparser { list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg } {1 {floating-point value too large to represent}} -test parseExpr-16.12 {GetLexeme procedure, bad double lexeme} { +test parseExpr-16.12 {GetLexeme procedure, bad double lexeme} testexprparser { list [catch {testexprparser {123.4x56} -1} msg] $msg } {1 {syntax error in expression "123.4x56": extra tokens at end of expression}} -test parseExpr-16.13 {GetLexeme procedure, lexeme is "["} { +test parseExpr-16.13 {GetLexeme procedure, lexeme is "["} testexprparser { testexprparser {[foo]} -1 } {- {} 0 subexpr {[foo]} 1 command {[foo]} 0 {}} -test parseExpr-16.14 {GetLexeme procedure, lexeme is open brace} { +test parseExpr-16.14 {GetLexeme procedure, lexeme is open brace} testexprparser { testexprparser {{bar}} -1 } {- {} 0 subexpr {{bar}} 1 text bar 0 {}} -test parseExpr-16.15 {GetLexeme procedure, lexeme is "("} { +test parseExpr-16.15 {GetLexeme procedure, lexeme is "("} testexprparser { testexprparser {(123)} -1 } {- {} 0 subexpr 123 1 text 123 0 {}} -test parseExpr-16.16 {GetLexeme procedure, lexeme is ")"} { +test parseExpr-16.16 {GetLexeme procedure, lexeme is ")"} testexprparser { testexprparser {(2*3)} -1 } {- {} 0 subexpr 2*3 5 operator * 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.17 {GetLexeme procedure, lexeme is "$"} { +test parseExpr-16.17 {GetLexeme procedure, lexeme is "$"} testexprparser { testexprparser {$wombat} -1 } {- {} 0 subexpr {$wombat} 2 variable {$wombat} 1 text wombat 0 {}} -test parseExpr-16.18 "GetLexeme procedure, lexeme is '\"'" { +test parseExpr-16.18 "GetLexeme procedure, lexeme is '\"'" testexprparser { testexprparser {"fred"} -1 } {- {} 0 subexpr {"fred"} 1 text fred 0 {}} -test parseExpr-16.19 {GetLexeme procedure, lexeme is ","} { +test parseExpr-16.19 {GetLexeme procedure, lexeme is ","} testexprparser { testexprparser {foo(1,2)} -1 } {- {} 0 subexpr foo(1,2) 5 operator foo 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-16.20 {GetLexeme procedure, lexeme is "*"} { +test parseExpr-16.20 {GetLexeme procedure, lexeme is "*"} testexprparser { testexprparser {$a*$b} -1 } {- {} 0 subexpr {$a*$b} 7 operator * 0 subexpr {$a} 2 variable {$a} 1 text a 0 subexpr {$b} 2 variable {$b} 1 text b 0 {}} -test parseExpr-16.21 {GetLexeme procedure, lexeme is "/"} { +test parseExpr-16.21 {GetLexeme procedure, lexeme is "/"} testexprparser { testexprparser {5/6} -1 } {- {} 0 subexpr 5/6 5 operator / 0 subexpr 5 1 text 5 0 subexpr 6 1 text 6 0 {}} -test parseExpr-16.22 {GetLexeme procedure, lexeme is "%"} { +test parseExpr-16.22 {GetLexeme procedure, lexeme is "%"} testexprparser { testexprparser {5%[xxx]} -1 } {- {} 0 subexpr {5%[xxx]} 5 operator % 0 subexpr 5 1 text 5 0 subexpr {[xxx]} 1 command {[xxx]} 0 {}} -test parseExpr-16.23 {GetLexeme procedure, lexeme is "+"} { +test parseExpr-16.23 {GetLexeme procedure, lexeme is "+"} testexprparser { testexprparser {1+2} -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-16.24 {GetLexeme procedure, lexeme is "-"} { +test parseExpr-16.24 {GetLexeme procedure, lexeme is "-"} testexprparser { testexprparser {.12-0e27} -1 } {- {} 0 subexpr .12-0e27 5 operator - 0 subexpr .12 1 text .12 0 subexpr 0e27 1 text 0e27 0 {}} -test parseExpr-16.25 {GetLexeme procedure, lexeme is "?" or ":"} { +test parseExpr-16.25 {GetLexeme procedure, lexeme is "?" or ":"} testexprparser { testexprparser {$b? 1 : 0} -1 } {- {} 0 subexpr {$b? 1 : 0} 8 operator ? 0 subexpr {$b} 2 variable {$b} 1 text b 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-16.26 {GetLexeme procedure, lexeme is "<"} { +test parseExpr-16.26 {GetLexeme procedure, lexeme is "<"} testexprparser { testexprparser {2<3} -1 } {- {} 0 subexpr 2<3 5 operator < 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.27 {GetLexeme procedure, lexeme is "<<"} { +test parseExpr-16.27 {GetLexeme procedure, lexeme is "<<"} testexprparser { testexprparser {2<<3} -1 } {- {} 0 subexpr 2<<3 5 operator << 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.28 {GetLexeme procedure, lexeme is "<="} { +test parseExpr-16.28 {GetLexeme procedure, lexeme is "<="} testexprparser { testexprparser {2<=3} -1 } {- {} 0 subexpr 2<=3 5 operator <= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.29 {GetLexeme procedure, lexeme is ">"} { +test parseExpr-16.29 {GetLexeme procedure, lexeme is ">"} testexprparser { testexprparser {2>3} -1 } {- {} 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.30 {GetLexeme procedure, lexeme is ">>"} { +test parseExpr-16.30 {GetLexeme procedure, lexeme is ">>"} testexprparser { testexprparser {2>>3} -1 } {- {} 0 subexpr 2>>3 5 operator >> 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.31 {GetLexeme procedure, lexeme is ">="} { +test parseExpr-16.31 {GetLexeme procedure, lexeme is ">="} testexprparser { testexprparser {2>=3} -1 } {- {} 0 subexpr 2>=3 5 operator >= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.32 {GetLexeme procedure, lexeme is "=="} { +test parseExpr-16.32 {GetLexeme procedure, lexeme is "=="} testexprparser { testexprparser {2==3} -1 } {- {} 0 subexpr 2==3 5 operator == 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.33 {GetLexeme procedure, bad lexeme starting with "="} { +test parseExpr-16.33 {GetLexeme procedure, bad lexeme starting with "="} testexprparser { list [catch {testexprparser {2=+3} -1} msg] $msg } {1 {syntax error in expression "2=+3": extra tokens at end of expression}} -test parseExpr-16.34 {GetLexeme procedure, lexeme is "!="} { +test parseExpr-16.34 {GetLexeme procedure, lexeme is "!="} testexprparser { testexprparser {2!=3} -1 } {- {} 0 subexpr 2!=3 5 operator != 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.35 {GetLexeme procedure, lexeme is "!"} { +test parseExpr-16.35 {GetLexeme procedure, lexeme is "!"} testexprparser { testexprparser {!2} -1 } {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}} -test parseExpr-16.36 {GetLexeme procedure, lexeme is "&&"} { +test parseExpr-16.36 {GetLexeme procedure, lexeme is "&&"} testexprparser { testexprparser {2&&3} -1 } {- {} 0 subexpr 2&&3 5 operator && 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.37 {GetLexeme procedure, lexeme is "&"} { +test parseExpr-16.37 {GetLexeme procedure, lexeme is "&"} testexprparser { testexprparser {1&2} -1 } {- {} 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-16.38 {GetLexeme procedure, lexeme is "^"} { +test parseExpr-16.38 {GetLexeme procedure, lexeme is "^"} testexprparser { testexprparser {1^2} -1 } {- {} 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-16.39 {GetLexeme procedure, lexeme is "||"} { +test parseExpr-16.39 {GetLexeme procedure, lexeme is "||"} testexprparser { testexprparser {2||3} -1 } {- {} 0 subexpr 2||3 5 operator || 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.40 {GetLexeme procedure, lexeme is "|"} { +test parseExpr-16.40 {GetLexeme procedure, lexeme is "|"} testexprparser { testexprparser {1|2} -1 } {- {} 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-16.41 {GetLexeme procedure, lexeme is "~"} { +test parseExpr-16.41 {GetLexeme procedure, lexeme is "~"} testexprparser { testexprparser {~2} -1 } {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}} -test parseExpr-16.42 {GetLexeme procedure, lexeme is func name} { +test parseExpr-16.42 {GetLexeme procedure, lexeme is func name} testexprparser { testexprparser {george()} -1 } {- {} 0 subexpr george() 1 operator george 0 {}} -test parseExpr-16.43 {GetLexeme procedure, lexeme is func name} { +test parseExpr-16.43 {GetLexeme procedure, lexeme is func name} testexprparser { testexprparser {harmonic_ratio(2,3)} -1 } {- {} 0 subexpr harmonic_ratio(2,3) 5 operator harmonic_ratio 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-16.44 {GetLexeme procedure, unknown lexeme} { +test parseExpr-16.44 {GetLexeme procedure, unknown lexeme} testexprparser { list [catch {testexprparser {@27} -1} msg] $msg } {1 {syntax error in expression "@27": character not legal in expressions}} -test parseExpr-17.1 {PrependSubExprTokens procedure, expand token array} { +test parseExpr-17.1 {PrependSubExprTokens procedure, expand token array} testexprparser { testexprparser {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} -1 } {- {} 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 13 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 9 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 5 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 {}} -test parseExpr-18.1 {LogSyntaxError procedure, error in expr longer than 60 chars} { +test parseExpr-18.1 {LogSyntaxError procedure, error in expr longer than 60 chars} testexprparser { list [catch {testexprparser {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1} msg] $msg } {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": premature end of expression}} diff --git a/tests/rename.test b/tests/rename.test index a33afaa..45d6847 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -11,13 +11,15 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: rename.test,v 1.11 2004/03/30 16:22:22 msofer Exp $ +# RCS: @(#) $Id: rename.test,v 1.12 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +testConstraint testdel [llength [info commands testdel]] + # Must eliminate the "unknown" command while the test is running, # especially if the test is being run in a program with its # own special-purpose unknown command. @@ -77,65 +79,63 @@ catch {rename unknown {}} catch {rename unknown.old unknown} catch {rename bar {}} -if {[info command testdel] == "testdel"} { - test rename-4.1 {reentrancy issues with command deletion and renaming} { - set x {} - testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]} - rename foo bar - lappend x | - rename bar {} - set x - } {| deleted {}} - test rename-4.2 {reentrancy issues with command deletion and renaming} { - set x {} - testdel {} foo {lappend x deleted; rename foo bar} - rename foo {} - set x - } {deleted} - test rename-4.3 {reentrancy issues with command deletion and renaming} { - set x {} - testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}} - rename foo {} - lappend x | - rename foo {} - set x - } {deleted | deleted2} - test rename-4.4 {reentrancy issues with command deletion and renaming} { - set x {} - testdel {} foo {lappend x deleted; rename foo bar} - rename foo {} - lappend x | [info command bar] - } {deleted | {}} - test rename-4.5 {reentrancy issues with command deletion and renaming} { - set env(value) before - interp create foo - testdel foo cmd {set env(value) deleted} +test rename-4.1 {reentrancy issues with command deletion and renaming} testdel { + set x {} + testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]} + rename foo bar + lappend x | + rename bar {} + set x +} {| deleted {}} +test rename-4.2 {reentrancy issues with command deletion and renaming} testdel { + set x {} + testdel {} foo {lappend x deleted; rename foo bar} + rename foo {} + set x +} {deleted} +test rename-4.3 {reentrancy issues with command deletion and renaming} testdel { + set x {} + testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}} + rename foo {} + lappend x | + rename foo {} + set x +} {deleted | deleted2} +test rename-4.4 {reentrancy issues with command deletion and renaming} testdel { + set x {} + testdel {} foo {lappend x deleted; rename foo bar} + rename foo {} + lappend x | [info command bar] +} {deleted | {}} +test rename-4.5 {reentrancy issues with command deletion and renaming} testdel { + set env(value) before + interp create foo + testdel foo cmd {set env(value) deleted} + interp delete foo + set env(value) +} {deleted} +test rename-4.6 {reentrancy issues with command deletion and renaming} testdel { + proc kill args { + interp delete foo + } + set env(value) before + interp create foo + foo alias kill kill + testdel foo cmd {set env(value) deleted; kill} + list [catch {foo eval {rename cmd {}}} msg] $msg $env(value) +} {0 {} deleted} +test rename-4.7 {reentrancy issues with command deletion and renaming} testdel { + proc kill args { interp delete foo - set env(value) - } {deleted} - test rename-4.6 {reentrancy issues with command deletion and renaming} { - proc kill args { - interp delete foo - } - set env(value) before - interp create foo - foo alias kill kill - testdel foo cmd {set env(value) deleted; kill} - list [catch {foo eval {rename cmd {}}} msg] $msg $env(value) - } {0 {} deleted} - test rename-4.7 {reentrancy issues with command deletion and renaming} { - proc kill args { - interp delete foo - } - set env(value) before - interp create foo - foo alias kill kill - testdel foo cmd {set env(value) deleted; kill} - list [catch {interp delete foo} msg] $msg $env(value) - } {0 {} deleted} - if {[info exists env(value)]} { - unset env(value) } + set env(value) before + interp create foo + foo alias kill kill + testdel foo cmd {set env(value) deleted; kill} + list [catch {interp delete foo} msg] $msg $env(value) +} {0 {} deleted} +if {[info exists env(value)]} { + unset env(value) } # Save the unknown procedure which is modified by the following test. diff --git a/tests/safe.test b/tests/safe.test index 21fad12..ba6812f 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.test,v 1.13 2002/05/10 18:47:11 dgp Exp $ +# RCS: @(#) $Id: safe.test,v 1.14 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -18,7 +18,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } foreach i [interp slaves] { - interp delete $i + interp delete $i } # Force actual loading of the safe package @@ -32,7 +32,6 @@ test safe-1.1 {safe::interpConfigure syntax} { list [catch {safe::interpConfigure} msg] $msg; } {1 {no value given for parameter "slave" (use -help for full usage) : slave name () name of the slave}} - test safe-1.2 {safe::interpCreate syntax} { list [catch {safe::interpCreate -help} msg] $msg; } {1 {Usage information: @@ -46,7 +45,6 @@ test safe-1.2 {safe::interpCreate syntax} { -nestedLoadOk boolflag (false) allow nested loading -nested boolean (false) nested loading -deleteHook script () delete hook}} - test safe-1.3 {safe::interpInit syntax} { list [catch {safe::interpInit -noStatics} msg] $msg; } {1 {bad value "-noStatics" for parameter @@ -123,8 +121,6 @@ test safe-4.3 {safe::interpDelete, state array (not a public api)} { list $m1 $m2 } "{}\ {can't read \"[safe::InterpStateName a](foo)\": no such variable}" - - test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} { catch {safe::interpDelete a} safe::interpCreate a @@ -132,7 +128,6 @@ test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} { a eval exit catch {namespace eval safe {set [InterpStateName a](foo)}} msg } 1 - test safe-4.5 {safe::interpDelete} { catch {safe::interpDelete a} safe::interpCreate a @@ -165,6 +160,7 @@ proc DI {} { global I; interp delete $I; } + test safe-6.1 {test safe interpreters knowledge of the world} { SI; set r [lsort [$I eval {info globals}]]; DI; set r } {tcl_interactive tcl_patchLevel tcl_platform tcl_version} @@ -202,7 +198,6 @@ test safe-7.1 {tests that everything works at high level} { safe::interpDelete $i set v } 1.0 - test safe-7.2 {tests specific path and interpFind/AddToAccessPath} { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]; # should not add anything (p0) @@ -227,8 +222,6 @@ test safe-8.1 {safe source control on file} { $msg \ [safe::interpDelete $i] ; } {1 {wrong # args: should be "source fileName"} {}} - -# test source control on file name test safe-8.2 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -237,7 +230,6 @@ test safe-8.2 {safe source control on file} { $msg \ [safe::interpDelete $i] ; } {1 {wrong # args: should be "source fileName"} {}} - test safe-8.3 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -252,8 +244,6 @@ test safe-8.3 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}} - - test safe-8.4 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -268,8 +258,6 @@ test safe-8.4 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}} - - test safe-8.5 {safe source control on file} { # This tested filename == *.tcl or tclIndex, but that restriction # was removed in 8.4a4 - hobbs @@ -286,8 +274,6 @@ test safe-8.5 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"] {} {}] - - test safe-8.6 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -302,8 +288,6 @@ test safe-8.6 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"] {} {}] - - test safe-8.7 {safe source control on file} { # This tested length of filename, but that restriction # was removed in 8.4a4 - hobbs @@ -321,7 +305,6 @@ test safe-8.7 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"] {} {}] - test safe-8.8 {safe source forbids -rsrc} { set i "a"; catch {safe::interpDelete $i} @@ -331,7 +314,6 @@ test safe-8.8 {safe source forbids -rsrc} { [safe::interpDelete $i] ; } {1 {wrong # args: should be "source fileName"} {}} - test safe-9.1 {safe interps' deleteHook} { set i "a"; catch {safe::interpDelete $i} @@ -346,7 +328,6 @@ test safe-9.1 {safe interps' deleteHook} { safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"; list [interp eval $i exit] $res } {{} {arg1 arg2 a}} - test safe-9.2 {safe interps' error in deleteHook} { set i "a"; catch {safe::interpDelete $i} @@ -369,17 +350,13 @@ test safe-9.2 {safe interps' error in deleteHook} { $log \ [safe::setLogCmd $prevlog; unset log]; } {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}} - - test safe-9.3 {dual specification of statics} { list [catch {safe::interpCreate -stat true -nostat} msg] $msg } {1 {conflicting values given for -statics and -noStatics}} - test safe-9.4 {dual specification of statics} { # no error shall occur safe::interpDelete [safe::interpCreate -stat false -nostat] } {} - test safe-9.5 {dual specification of nested} { list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg } {1 {conflicting values given for -nested and -nestedLoadOk}} @@ -403,45 +380,38 @@ test safe-9.6 {interpConfigure widget like behaviour} { safe::interpConfigure $i] } {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}} - # testing that nested and statics do what is advertised # (we use a static package : Tcltest) if {[catch {package require Tcltest} msg]} { - puts "This application hasn't been compiled with Tcltest" - puts "skipping remining safe test that relies on it." + testConstraint TcltestPackage 0 } else { - + testConstraint TcltestPackage 1 # we use the Tcltest package , which has no Safe_Init +} -test safe-10.1 {testing statics loading} { +test safe-10.1 {testing statics loading} TcltestPackage { set i [safe::interpCreate] list \ [catch {interp eval $i {load {} Tcltest}} msg] \ $msg \ [safe::interpDelete $i]; } {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}} - -test safe-10.2 {testing statics loading / -nostatics} { +test safe-10.2 {testing statics loading / -nostatics} TcltestPackage { set i [safe::interpCreate -nostatics] list \ [catch {interp eval $i {load {} Tcltest}} msg] \ $msg \ [safe::interpDelete $i]; } {1 {permission denied (static package)} {}} - - - -test safe-10.3 {testing nested statics loading / no nested by default} { +test safe-10.3 {testing nested statics loading / no nested by default} TcltestPackage { set i [safe::interpCreate] list \ [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \ $msg \ [safe::interpDelete $i]; } {1 {permission denied (nested load)} {}} - - -test safe-10.4 {testing nested statics loading / -nestedloadok} { +test safe-10.4 {testing nested statics loading / -nestedloadok} TcltestPackage { set i [safe::interpCreate -nestedloadok] list \ [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \ @@ -449,9 +419,6 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} { [safe::interpDelete $i]; } {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}} - -} - test safe-11.1 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -459,7 +426,6 @@ test safe-11.1 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding option ?arg ...?"} {}} - test safe-11.2 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -467,7 +433,6 @@ test safe-11.2 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding system"} {}} - test safe-11.3 {testing safe encoding} { set i [safe::interpCreate] set result [catch { @@ -475,7 +440,6 @@ test safe-11.3 {testing safe encoding} { } msg] list $result $msg [safe::interpDelete $i] } {0 1 {}} - test safe-11.4 {testing safe encoding} { set i [safe::interpCreate] set result [catch { @@ -483,7 +447,6 @@ test safe-11.4 {testing safe encoding} { } msg] list $result $msg [safe::interpDelete $i] } {0 1 {}} - test safe-11.5 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -491,8 +454,6 @@ test safe-11.5 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {0 foobar {}} - - test safe-11.6 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -500,7 +461,6 @@ test safe-11.6 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {0 foobar {}} - test safe-11.7 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -508,8 +468,6 @@ test safe-11.7 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding convertfrom ?encoding? data"} {}} - - test safe-11.8 {testing safe encoding} { set i [safe::interpCreate] list \ diff --git a/tests/socket.test b/tests/socket.test index e575aa6..9a7bfc2 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: socket.test,v 1.29 2004/03/17 18:14:18 das Exp $ +# RCS: @(#) $Id: socket.test,v 1.30 2004/05/19 20:15:32 dkf Exp $ # Running socket tests with a remote server: # ------------------------------------------ @@ -148,8 +148,8 @@ if {$doTestsWithRemoteServer} { } # Some tests are run only if we are doing testing against a remote server. -set ::tcltest::testConstraints(doTestsWithRemoteServer) $doTestsWithRemoteServer -if {$doTestsWithRemoteServer == 0} { +testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer +if {![testConstraint doTestsWithRemoteServer]} { if {[string first s $::tcltest::verbose] != -1} { puts "Skipping tests with remote server. See tests/socket.test for" puts "information on how to run remote server." @@ -162,7 +162,7 @@ if {$doTestsWithRemoteServer == 0} { # remote server. # -if {$doTestsWithRemoteServer == 1} { +if {[testConstraint doTestsWithRemoteServer]} { proc sendCommand {c} { global commandSocket diff --git a/tests/string.test b/tests/string.test index 083e145..b64fc4d 100644 --- a/tests/string.test +++ b/tests/string.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: string.test,v 1.39 2003/07/04 10:30:27 dkf Exp $ +# RCS: @(#) $Id: string.test,v 1.40 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -21,8 +21,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Some tests require the testobj command -set ::tcltest::testConstraints(testobj) \ - [expr {[info commands testobj] != {}}] +testConstraint testobj [expr {[info commands testobj] != {}}] test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg diff --git a/tests/stringComp.test b/tests/stringComp.test index 14b0107..13a407c 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -15,7 +15,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stringComp.test,v 1.6 2003/02/18 02:25:45 hobbs Exp $ +# RCS: @(#) $Id: stringComp.test,v 1.7 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -24,8 +24,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Some tests require the testobj command -set ::tcltest::testConstraints(testobj) \ - [expr {[info commands testobj] != {}}] +testConstraint testobj [expr {[info commands testobj] != {}}] test string-1.1 {error conditions} { proc foo {} {string gorp a b} diff --git a/tests/stringObj.test b/tests/stringObj.test index e3bdbee..90ec9c3 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -12,27 +12,22 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stringObj.test,v 1.15 2003/02/11 18:46:33 hobbs Exp $ +# RCS: @(#) $Id: stringObj.test,v 1.16 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -if {[info commands testobj] == {}} { - puts "This application hasn't been compiled with the \"testobj\"" - puts "command, so I can't test the Tcl type and object support." - ::tcltest::cleanupTests - return -} +testConstraint testobj [llength [info commands testobj]] -test stringObj-1.1 {string type registration} { +test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] set result [expr {$first != -1}] } {1} -test stringObj-2.1 {Tcl_NewStringObj} { +test stringObj-2.1 {Tcl_NewStringObj} testobj { set result "" lappend result [testobj freeallvars] lappend result [teststringobj set 1 abcd] @@ -40,7 +35,7 @@ test stringObj-2.1 {Tcl_NewStringObj} { lappend result [testobj refcount 1] } {{} abcd string 2} -test stringObj-3.1 {Tcl_SetStringObj, existing "empty string" object} { +test stringObj-3.1 {Tcl_SetStringObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -48,7 +43,7 @@ test stringObj-3.1 {Tcl_SetStringObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} xyz string 2} -test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} { +test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 512] @@ -57,47 +52,47 @@ test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 512 foo string 2} -test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} { +test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} testobj { testobj freeallvars teststringobj set 1 test teststringobj setlength 1 3 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {3 4 tes} -test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} { +test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj { testobj freeallvars teststringobj set 1 abcdef teststringobj setlength 1 10 list [teststringobj length 1] [teststringobj length2 1] } {10 10} -test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} { +test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} testobj { testobj freeallvars teststringobj set 1 abcdef teststringobj append 1 xyzq -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {10 20 abcdefxyzq} -test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} { +test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} testobj { testobj freeallvars testobj newobj 1 teststringobj setlength 1 0 list [teststringobj length2 1] [teststringobj get 1] } {0 {}} -test stringObj-5.1 {Tcl_AppendToObj procedure, type conversion} { +test stringObj-5.1 {Tcl_AppendToObj procedure, type conversion} testobj { testobj freeallvars testintobj set2 1 43 teststringobj append 1 xyz -1 teststringobj get 1 } {43xyz} -test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} { +test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} testobj { testobj freeallvars teststringobj set 1 {x y } teststringobj append 1 bbCCddEE 4 teststringobj append 1 123 -1 teststringobj get 1 } {x y bbCC123} -test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} { +test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj { testobj freeallvars teststringobj set 1 xyz teststringobj setlength 1 15 @@ -111,37 +106,37 @@ test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} { [teststringobj get 1] } {15 15 16 32 xy12345678abcdef} -test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} { +test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} testobj { testobj freeallvars teststringobj set2 1 [list a b] teststringobj appendstrings 1 xyz { 1234 } foo teststringobj get 1 } {a bxyz 1234 foo} -test stringObj-6.2 {Tcl_AppendStringsToObj procedure, counting space} { +test stringObj-6.2 {Tcl_AppendStringsToObj procedure, counting space} testobj { testobj freeallvars teststringobj set 1 abc teststringobj appendstrings 1 list [teststringobj length 1] [teststringobj get 1] } {3 abc} -test stringObj-6.3 {Tcl_AppendStringsToObj procedure, counting space} { +test stringObj-6.3 {Tcl_AppendStringsToObj procedure, counting space} testobj { testobj freeallvars teststringobj set 1 abc teststringobj appendstrings 1 {} {} {} {} list [teststringobj length 1] [teststringobj get 1] } {3 abc} -test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} { +test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} testobj { testobj freeallvars teststringobj set 1 abc teststringobj appendstrings 1 { 123 } abcdefg list [teststringobj length 1] [teststringobj get 1] } {15 {abc 123 abcdefg}} -test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} { +test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 123 abcdefg list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1] } {10 10 123abcdefg} -test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} { +test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -150,7 +145,7 @@ test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} { list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {10 10 ab34567890} -test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} { +test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -159,39 +154,39 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} { list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {11 22 ab34567890x} -test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} { +test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} list [teststringobj length2 1] [teststringobj get 1] } {0 {}} -test stringObj-7.1 {SetStringFromAny procedure} { +test stringObj-7.1 {SetStringFromAny procedure} testobj { testobj freeallvars teststringobj set2 1 [list a b] teststringobj append 1 x -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {4 8 {a bx}} -test stringObj-7.2 {SetStringFromAny procedure, null object} { +test stringObj-7.2 {SetStringFromAny procedure, null object} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {0 0 {}} -test stringObj-7.3 {SetStringFromAny called with non-string obj} { +test stringObj-7.3 {SetStringFromAny called with non-string obj} testobj { set x 2345 list [incr x] [testobj objtype $x] [string index $x end] \ [testobj objtype $x] } {2346 int 6 string} -test stringObj-7.4 {SetStringFromAny called with string obj} { +test stringObj-7.4 {SetStringFromAny called with string obj} testobj { set x "abcdef" list [string length $x] [testobj objtype $x] \ [string length $x] [testobj objtype $x] } {6 string 6 string} -test stringObj-8.1 {DupStringInternalRep procedure} { +test stringObj-8.1 {DupStringInternalRep procedure} testobj { testobj freeallvars teststringobj set 1 {} teststringobj append 1 abcde -1 @@ -201,28 +196,28 @@ test stringObj-8.1 {DupStringInternalRep procedure} { [teststringobj length 2] [teststringobj length2 2] \ [teststringobj ualloc 2] [teststringobj get 2] } {5 10 0 abcde 5 5 0 abcde} -test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} { +test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj { set x abcï¿®ghi string length $x set y $x list [testobj objtype $x] [testobj objtype $y] [append x "®¿ï"] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string string abcï¿®ghi®¿ï abcï¿®ghi string string} -test stringObj-8.3 {DupUnicodeInternalRep, mixed width chars} { +test stringObj-8.3 {DupUnicodeInternalRep, mixed width chars} testobj { set x abcï¿®ghi set y $x string length $x list [testobj objtype $x] [testobj objtype $y] [append x "®¿ï"] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string string abcï¿®ghi®¿ï abcï¿®ghi string string} -test stringObj-8.4 {DupUnicodeInternalRep, all byte-size chars} { +test stringObj-8.4 {DupUnicodeInternalRep, all byte-size chars} testobj { set x abcdefghi string length $x set y $x list [testobj objtype $x] [testobj objtype $y] [append x jkl] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string string abcdefghijkl abcdefghi string string} -test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} { +test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} testobj { set x abcdefghi set y $x string length $x @@ -230,14 +225,14 @@ test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} { [set y] [testobj objtype $x] [testobj objtype $y] } {string string abcdefghijkl abcdefghi string string} -test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} { +test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} testobj { set x abcï¿®ghi set y ®¿ï string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string none abcï¿®ghi®¿ï ®¿ï string none} -test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} { +test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} testobj { set x abcï¿®ghi string length $x list [testobj objtype $x] [append x $x] [testobj objtype $x] \ @@ -245,61 +240,61 @@ test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} { } {string abcï¿®ghiabcï¿®ghi string\ abcï¿®ghiabcï¿®ghiabcï¿®ghiabcï¿®ghi\ string} -test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} { +test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} testobj { set x abcdefghi set y ®¿ï string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string none abcdefghi®¿ï ®¿ï string none} -test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} { +test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} testobj { set x abcdefghi set y jkl string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string none abcdefghijkl jkl string none} -test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} { +test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} testobj { set x abcdefghi string length $x list [testobj objtype $x] [append x $x] [testobj objtype $x] \ [append x $x] [testobj objtype $x] } {string abcdefghiabcdefghi string abcdefghiabcdefghiabcdefghiabcdefghi\ string} -test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} { +test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} testobj { set x abcï¿®ghi set y jkl string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string none abcï¿®ghijkl jkl string none} -test stringObj-9.7 {TclAppendObjToObj, integer src & dest} { +test stringObj-9.7 {TclAppendObjToObj, integer src & dest} testobj { set x [expr {4 * 5}] set y [expr {4 + 5}] list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [testobj objtype $x] [append x $y] [testobj objtype $x] \ [testobj objtype $y] } {int int 209 string 2099 string int} -test stringObj-9.8 {TclAppendObjToObj, integer src & dest} { +test stringObj-9.8 {TclAppendObjToObj, integer src & dest} testobj { set x [expr {4 * 5}] list [testobj objtype $x] [append x $x] [testobj objtype $x] \ [append x $x] [testobj objtype $x] } {int 2020 string 20202020 string} -test stringObj-9.9 {TclAppendObjToObj, integer src & 1-byte dest} { +test stringObj-9.9 {TclAppendObjToObj, integer src & 1-byte dest} testobj { set x abcdefghi set y [expr {4 + 5}] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string int abcdefghi9 9 string int} -test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} { +test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} testobj { set x abcï¿®ghi set y [expr {4 + 5}] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string int abcï¿®ghi9 9 string int} -test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} { +test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} testobj { # bug 2678, in <=8.2.0, the second obj (the one to append) in # Tcl_AppendObjToObj was not correctly checked to see if it was # all one byte chars, so a unicode string would be added as one @@ -317,12 +312,12 @@ test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} { set q } {a b c d e f a ü b å c ï} -test stringObj-10.1 {Tcl_GetRange with all byte-size chars} { +test stringObj-10.1 {Tcl_GetRange with all byte-size chars} testobj { set x "abcdef" list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] } [list none bcde string string] -test stringObj-10.2 {Tcl_GetRange with some mixed width chars} { +test stringObj-10.2 {Tcl_GetRange with some mixed width chars} testobj { # Because this test does not use \uXXXX notation below instead of # hardcoding the values, it may fail in multibyte locales. However, # we need to test that the parser produces untyped objects even when there @@ -332,7 +327,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} { list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] } [list none "bc\u00EF\u00EFde" string string] -test stringObj-10.3 {Tcl_GetRange with some mixed width chars} { +test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { # set x "abcïïdef" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. @@ -341,7 +336,7 @@ test stringObj-10.3 {Tcl_GetRange with some mixed width chars} { list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] } [list string "bc\u00EF\u00EFde" string string] -test stringObj-10.4 {Tcl_GetRange with some mixed width chars} { +test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj { # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. @@ -358,71 +353,71 @@ test stringObj-10.4 {Tcl_GetRange with some mixed width chars} { \u00AEc \ {}] -test stringObj-11.1 {UpdateStringOfString} { +test stringObj-11.1 {UpdateStringOfString} testobj { set x 2345 list [string index $x end] [testobj objtype $x] [incr x] \ [testobj objtype $x] } {5 string 2346 int} -test stringObj-12.1 {Tcl_GetUniChar with byte-size chars} { +test stringObj-12.1 {Tcl_GetUniChar with byte-size chars} testobj { set x "abcdefghi" list [string index $x 0] [string index $x 1] } {a b} -test stringObj-12.2 {Tcl_GetUniChar with byte-size chars} { +test stringObj-12.2 {Tcl_GetUniChar with byte-size chars} testobj { set x "abcdefghi" list [string index $x 3] [string index $x end] } {d i} -test stringObj-12.3 {Tcl_GetUniChar with byte-size chars} { +test stringObj-12.3 {Tcl_GetUniChar with byte-size chars} testobj { set x "abcdefghi" list [string index $x end] [string index $x end-1] } {i h} -test stringObj-12.4 {Tcl_GetUniChar with mixed width chars} { +test stringObj-12.4 {Tcl_GetUniChar with mixed width chars} testobj { string index "ïa¿b®c®¿dï" 0 } "ï" -test stringObj-12.5 {Tcl_GetUniChar} { +test stringObj-12.5 {Tcl_GetUniChar} testobj { set x "ïa¿b®c®¿dï" list [string index $x 4] [string index $x 0] } {® ï} -test stringObj-12.6 {Tcl_GetUniChar} { +test stringObj-12.6 {Tcl_GetUniChar} testobj { string index "ïa¿b®cï¿d®" end } "®" -test stringObj-13.1 {Tcl_GetCharLength with byte-size chars} { +test stringObj-13.1 {Tcl_GetCharLength with byte-size chars} testobj { set a "" list [string length $a] [string length $a] } {0 0} -test stringObj-13.2 {Tcl_GetCharLength with byte-size chars} { +test stringObj-13.2 {Tcl_GetCharLength with byte-size chars} testobj { string length "a" } 1 -test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} { +test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} testobj { set a "abcdef" list [string length $a] [string length $a] } {6 6} -test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} { +test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj { string length "®" } 1 -test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} { +test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj { # string length "￮￮" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE" } 6 -test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} { +test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj { # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" list [string length $a] [string length $a] } {10 10} -test stringObj-13.7 {Tcl_GetCharLength with identity nulls} { +test stringObj-13.7 {Tcl_GetCharLength with identity nulls} testobj { # SF bug #684699 string length [encoding convertfrom identity \x00] } 1 -test stringObj-13.8 {Tcl_GetCharLength with identity nulls} { +test stringObj-13.8 {Tcl_GetCharLength with identity nulls} testobj { string length [encoding convertfrom identity \x01\x00\x02] } 3 -test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} { +test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj { teststringobj set 1 foo teststringobj getunicode 1 teststringobj append 1 bar -1 @@ -433,7 +428,9 @@ test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} { teststringobj get 1 } {bar} -testobj freeallvars +if {[testConstraint testobj]} { + testobj freeallvars +} # cleanup ::tcltest::cleanupTests diff --git a/tests/thread.test b/tests/thread.test index 2686720..216d498 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: thread.test,v 1.10 2000/05/02 22:02:36 kupries Exp $ +# RCS: @(#) $Id: thread.test,v 1.11 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -19,11 +19,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Some tests require the testthread command -set ::tcltest::testConstraints(testthread) \ - [expr {[info commands testthread] != {}}] - -if {$::tcltest::testConstraints(testthread)} { +testConstraint testthread [expr {[info commands testthread] != {}}] +if {[testConstraint testthread]} { testthread errorproc ThreadError proc ThreadError {id info} { diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index e863d3b..32b3d68 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixFCmd.test,v 1.19 2003/05/14 19:21:25 das Exp $ +# RCS: @(#) $Id: unixFCmd.test,v 1.20 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -229,14 +229,15 @@ test unixFCmd-14.2 {GetPermissionsAttribute} {unixOnly notRoot} { # Find a group that exists on this system, or else skip tests that require # groups -set ::tcltest::testConstraints(foundGroup) 0 +set foundgroup 0 if {$tcl_platform(platform) == "unix"} { catch { set groupList [exec groups] set group [lindex $groupList 0] - set ::tcltest::testConstraints(foundGroup) 1 + set foundgroup 1 } } +testConstraint foundGroup $foundgroup #groups hard to test test unixFCmd-15.1 {SetGroupAttribute - invalid group} {unixOnly notRoot} { @@ -326,16 +327,17 @@ test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} { } {1 {error getting working directory name:}} # check whether -readonly attribute is supported -set ::tcltest::testConstraints(readonlyAttr) 0 +set roattr 0 if {$tcl_platform(platform) == "unix"} { catch {file delete -force -- foo.test} close [open foo.test w] catch { file attributes foo.test -readonly - set ::tcltest::testConstraints(readonlyAttr) 1 + set roattr 1 } file delete -force -- foo.test } +testConstraint readonlyAttr $roattr test unixFCmd-19.1 {GetReadOnlyAttribute - file not found} {unixOnly notRoot readonlyAttr} { catch {file delete -force -- foo.test} diff --git a/tests/unixFile.test b/tests/unixFile.test index cc3b9b4..22c3885 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -9,19 +9,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixFile.test,v 1.7 2002/07/05 10:38:43 dkf Exp $ +# RCS: @(#) $Id: unixFile.test,v 1.8 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -if {[info commands testobj] == {}} { - puts "This application hasn't been compiled with the \"testfindexecutable\"" - puts "command, so I can't test the Tcl_FindExecutable function" - ::tcltest::cleanupTests - return -} +testConstraint testfindexecutable [llength [info commands testfindexecutable]] set oldpwd [pwd] cd [temporaryDirectory] @@ -32,31 +27,31 @@ catch { } set absPath [file join [temporaryDirectory] junk] -test unixFile-1.1 {Tcl_FindExecutable} {unixOnly} { +test unixFile-1.1 {Tcl_FindExecutable} {testfindexecutable unixOnly} { set env(PATH) "" testfindexecutable junk } $absPath -test unixFile-1.2 {Tcl_FindExecutable} {unixOnly} { +test unixFile-1.2 {Tcl_FindExecutable} {testfindexecutable unixOnly} { set env(PATH) "/dummy" testfindexecutable junk } {} -test unixFile-1.3 {Tcl_FindExecutable} {unixOnly} { +test unixFile-1.3 {Tcl_FindExecutable} {testfindexecutable unixOnly} { set env(PATH) "/dummy:[pwd]" testfindexecutable junk } $absPath -test unixFile-1.4 {Tcl_FindExecutable} {unixOnly} { +test unixFile-1.4 {Tcl_FindExecutable} {testfindexecutable unixOnly} { set env(PATH) "/dummy:" testfindexecutable junk } $absPath -test unixFile-1.5 {Tcl_FindExecutable} {unixOnly} { +test unixFile-1.5 {Tcl_FindExecutable} {testfindexecutable unixOnly} { set env(PATH) "/dummy:/dummy" testfindexecutable junk } {} -test unixFile-1.6 {Tcl_FindExecutable} {unixOnly} { +test unixFile-1.6 {Tcl_FindExecutable} {testfindexecutable unixOnly} { set env(PATH) "/dummy::/dummy" testfindexecutable junk } $absPath -test unixFile-1.7 {Tcl_FindExecutable} {unixOnly} { +test unixFile-1.7 {Tcl_FindExecutable} {testfindexecutable unixOnly} { set env(PATH) ":/dummy" testfindexecutable junk } $absPath diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index d8f5a4c..2840813 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixNotfy.test,v 1.13 2003/10/06 14:32:22 dgp Exp $ +# RCS: @(#) $Id: unixNotfy.test,v 1.14 2004/05/19 20:15:32 dkf Exp $ # The tests should not be run if you have a notifier which is unable to # detect infinite vwaits, as the tests below will hang. The presence of @@ -21,21 +21,16 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -if {[info exists tk_version]} { - puts "When run in a Tk shell, these tests run hang. Skipping tests ..." - ::tcltest::cleanupTests - return -} - -set ::tcltest::testConstraints(testthread) \ - [expr {[info commands testthread] != {}}] +# When run in a Tk shell, these tests hang. +testConstraint noTk [expr {![info exists tk_version]}] +testConstraint testthread [expr {[info commands testthread] != {}}] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. test unixNotfy-1.1 {Tcl_DeleteFileHandler} \ - -constraints {unixOnly && !testthread} \ + -constraints {noTk && unixOnly && !testthread} \ -body { catch {vwait x} set f [open [makeFile "" foo] w] @@ -49,9 +44,8 @@ test unixNotfy-1.1 {Tcl_DeleteFileHandler} \ catch { close $f } catch { removeFile foo } } - test unixNotfy-1.2 {Tcl_DeleteFileHandler} \ - -constraints {unixOnly && !testthread} \ + -constraints {noTk && unixOnly && !testthread} \ -body { catch {vwait x} set f1 [open [makeFile "" foo] w] @@ -73,7 +67,7 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} \ } test unixNotfy-2.1 {Tcl_DeleteFileHandler} \ - -constraints {unixOnly testthread} \ + -constraints {noTk unixOnly testthread} \ -body { update set f [open [makeFile "" foo] w] @@ -91,9 +85,8 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \ catch { close $f } catch { removeFile foo } } - test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ - -constraints {unixOnly testthread} \ + -constraints {noTk unixOnly testthread} \ -body { update set f1 [open [makeFile "" foo] w] diff --git a/tests/util.test b/tests/util.test index 6c4db29..ae3d0c5 100644 --- a/tests/util.test +++ b/tests/util.test @@ -7,20 +7,13 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: util.test,v 1.13 2003/08/27 20:29:36 dgp Exp $ +# RCS: @(#) $Id: util.test,v 1.14 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -if {[info commands testobj] == {}} { - puts "This application hasn't been compiled with the \"testobj\"" - puts "command, so I can't test the Tcl type and object support." - ::tcltest::cleanupTests - return -} - test util-1.1 {TclFindElement procedure - binary element in middle of list} { lindex {0 foo\x00help 1} 1 } "foo\x00help" @@ -347,8 +340,7 @@ test util-8.1 {TclNeedSpace - correct UTF8 handling} { set result } "\u5420 foo" -set ::tcltest::testConstraints(testdstring) \ - [expr {[info commands testdstring] != {}}] +testConstraint testdstring [expr {[info commands testdstring] != {}}] test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { # Bug 411825 diff --git a/tests/var.test b/tests/var.test index c675d63..93e698b 100644 --- a/tests/var.test +++ b/tests/var.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: var.test,v 1.23 2004/04/28 13:11:35 msofer Exp $ +# RCS: @(#) $Id: var.test,v 1.24 2004/05/19 20:15:32 dkf Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -22,6 +22,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +testConstraint testupvar [llength [info commands testupvar]] +testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] +testConstraint testsetnoerr [info commands testsetnoerr] + catch {rename p ""} catch {namespace delete test_ns_var} catch {unset xx} @@ -202,30 +206,28 @@ test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { p } } {1998} -if {[info commands testupvar] != {}} { - test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} { - catch {unset a} - set a 123321 - proc p {} { - # create global xx linked to global a - testupvar 1 a {} xx global +test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} testupvar { + catch {unset a} + set a 123321 + proc p {} { + # create global xx linked to global a + testupvar 1 a {} xx global + } + list [p] $xx [set xx 789] $a +} {{} 123321 789 789} +test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { + catch {unset a} + set a 456 + namespace eval test_ns_var { + catch {unset ::test_ns_var::vv} + proc p {} { + # create namespace var vv linked to global a + testupvar 1 a {} vv namespace } - list [p] $xx [set xx 789] $a - } {{} 123321 789 789} - test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} { - catch {unset a} - set a 456 - namespace eval test_ns_var { - catch {unset ::test_ns_var::vv} - proc p {} { - # create namespace var vv linked to global a - testupvar 1 a {} vv namespace - } - p - } - list $test_ns_var::vv [set test_ns_var::vv 123] $a - } {456 123 123} -} + p + } + list $test_ns_var::vv [set test_ns_var::vv 123] $a +} {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { catch {unset aaaaa} catch {unset xxxxx} @@ -278,24 +280,22 @@ test var-3.11 {MakeUpvar, my var looks like array elem} -body { upvar #0 aaaaa foo(bar) } -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} -if {[info commands testgetvarfullname] != {}} { - test var-4.1 {Tcl_GetVariableName, global variable} { - catch {unset a} - set a 123 - testgetvarfullname a global - } ::a - test var-4.2 {Tcl_GetVariableName, namespace variable} { - namespace eval test_ns_var { - variable george - testgetvarfullname george namespace - } - } ::test_ns_var::george - test var-4.3 {Tcl_GetVariableName, variable can't be array element} { - catch {unset a} - set a(1) foo - list [catch {testgetvarfullname a(1) global} msg] $msg - } {1 {unknown variable "a(1)"}} -} +test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { + catch {unset a} + set a 123 + testgetvarfullname a global +} ::a +test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { + namespace eval test_ns_var { + variable george + testgetvarfullname george namespace + } +} ::test_ns_var::george +test var-4.3 {Tcl_GetVariableName, variable can't be array element} testgetvarfullname { + catch {unset a} + set a(1) foo + list [catch {testgetvarfullname a(1) global} msg] $msg +} {1 {unknown variable "a(1)"}} test var-5.1 {Tcl_GetVariableFullName, global variable} { catch {unset a} @@ -527,11 +527,7 @@ test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var list [unset test_ns_var::v] $test_ns_var::info } {{} {test_ns_var::v {} u}} -if {[info commands testsetnoerr] == {}} { - puts "This application hasn't been compiled with the \"testsetnoerr\"" - puts "command, so I can't test TclSetVar etc." -} else { -test var-9.1 {behaviour of TclGet/SetVar simple get/set} { +test var-9.1 {behaviour of TclGet/SetVar simple get/set} testsetnoerr { catch {unset u}; catch {unset v} list \ [set u a; testsetnoerr u] \ @@ -539,7 +535,7 @@ test var-9.1 {behaviour of TclGet/SetVar simple get/set} { [testseterr u] \ [unset v; testseterr v b] } [list {before get a} {before set b} {before get a} {before set b}] -test var-9.2 {behaviour of TclGet/SetVar namespace get/set} { +test var-9.2 {behaviour of TclGet/SetVar namespace get/set} testsetnoerr { catch {namespace delete ns} namespace eval ns {variable u a; variable v} list \ @@ -548,46 +544,46 @@ test var-9.2 {behaviour of TclGet/SetVar namespace get/set} { [testseterr ns::u] \ [unset ns::v; testseterr ns::v b] } [list {before get a} {before set b} {before get a} {before set b}] -test var-9.3 {behaviour of TclGetVar no variable} { +test var-9.3 {behaviour of TclGetVar no variable} testsetnoerr { catch {unset u} list \ [catch {testsetnoerr u} res] $res \ [catch {testseterr u} res] $res } {1 {before get} 1 {can't read "u": no such variable}} -test var-9.4 {behaviour of TclGetVar no namespace variable} { +test var-9.4 {behaviour of TclGetVar no namespace variable} testsetnoerr { catch {namespace delete ns} namespace eval ns {} list \ [catch {testsetnoerr ns::w} res] $res \ [catch {testseterr ns::w} res] $res } {1 {before get} 1 {can't read "ns::w": no such variable}} -test var-9.5 {behaviour of TclGetVar no namespace} { +test var-9.5 {behaviour of TclGetVar no namespace} testsetnoerr { catch {namespace delete ns} list \ [catch {testsetnoerr ns::u} res] $res \ [catch {testseterr ns::v} res] $res } {1 {before get} 1 {can't read "ns::v": no such variable}} -test var-9.6 {behaviour of TclSetVar no namespace} { +test var-9.6 {behaviour of TclSetVar no namespace} testsetnoerr { catch {namespace delete ns} list \ [catch {testsetnoerr ns::v 1} res] $res \ [catch {testseterr ns::v 1} res] $res } {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} -test var-9.7 {behaviour of TclGetVar array variable} { +test var-9.7 {behaviour of TclGetVar array variable} testsetnoerr { catch {unset arr} set arr(1) 1; list \ [catch {testsetnoerr arr} res] $res \ [catch {testseterr arr} res] $res } {1 {before get} 1 {can't read "arr": variable is array}} -test var-9.8 {behaviour of TclSetVar array variable} { +test var-9.8 {behaviour of TclSetVar array variable} testsetnoerr { catch {unset arr} set arr(1) 1 list \ [catch {testsetnoerr arr 2} res] $res \ [catch {testseterr arr 2} res] $res } {1 {before set} 1 {can't set "arr": variable is array}} -test var-9.9 {behaviour of TclGetVar read trace success} { +test var-9.9 {behaviour of TclGetVar read trace success} testsetnoerr { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} catch {unset u}; catch {unset v} set u 10 @@ -597,7 +593,7 @@ test var-9.9 {behaviour of TclGetVar read trace success} { [testsetnoerr u] \ [testseterr v] } {{before get 1} {before get 2}} -test var-9.10 {behaviour of TclGetVar read trace error} { +test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { proc writeonly args {error "write-only"} set v 456 trace var v r writeonly @@ -605,7 +601,7 @@ test var-9.10 {behaviour of TclGetVar read trace error} { [catch {testsetnoerr v} msg] $msg \ [catch {testseterr v} msg] $msg } {1 {before get} 1 {can't read "v": write-only}} -test var-9.11 {behaviour of TclSetVar write trace success} { +test var-9.11 {behaviour of TclSetVar write trace success} testsetnoerr { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} catch {unset u}; catch {unset v} set v 1 @@ -615,7 +611,7 @@ test var-9.11 {behaviour of TclSetVar write trace success} { [testsetnoerr u 2] \ [testseterr v 3] } {{before set 4} {before set 6}} -test var-9.12 {behaviour of TclSetVar write trace error} { +test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { proc readonly args {error "read-only"} set v 456 trace var v w readonly @@ -623,12 +619,11 @@ test var-9.12 {behaviour of TclSetVar write trace error} { [catch {testsetnoerr v 2} msg] $msg $v \ [catch {testseterr v 3} msg] $msg $v } {1 {before set} 2 1 {can't set "v": read-only} 3} -} + test var-10.1 {can't nest arrays with array set} { catch {unset arr} list [catch {array set arr(x) {a 1 b 2}} res] $res } {1 {can't set "arr(x)": variable isn't array}} - test var-10.2 {can't nest arrays with array set} { catch {unset arr} list [catch {array set arr(x) {}} res] $res diff --git a/tests/winDde.test b/tests/winDde.test index 5600984..850d839 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winDde.test,v 1.19 2003/10/06 14:32:22 dgp Exp $ +# RCS: @(#) $Id: winDde.test,v 1.20 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -22,10 +22,10 @@ if {$tcl_platform(platform) == "windows"} { set lib [lindex [glob -directory [file join [pwd] [file dirname \ [info nameofexecutable]]] tcldde*.dll] 0] load $lib dde + testConstraint dde 1 }] { + testConstraint dde 0 puts "WARNING: Unable to find the dde package. Skipping dde tests." - ::tcltest::cleanupTests - return } } @@ -112,56 +112,49 @@ proc createChildProcess { ddeServerName {handler {}}} { # ------------------------------------------------------------------------- -test winDde-1.1 {Settings the server's topic name} {pcOnly} { +test winDde-1.1 {Settings the server's topic name} {pcOnly dde} { list [dde servername foobar] [dde servername] [dde servername self] } {foobar foobar self} -test winDde-2.1 {Checking for other services} {pcOnly} { +test winDde-2.1 {Checking for other services} {pcOnly dde} { expr [llength [dde services {} {}]] >= 0 } 1 - test winDde-2.2 {Checking for existence, with service and topic specified} \ - {pcOnly} { + {pcOnly dde} { llength [dde services TclEval self] } 1 - test winDde-2.3 {Checking for existence, with only the service specified} \ - {pcOnly} { + {pcOnly dde} { expr [llength [dde services TclEval {}]] >= 1 } 1 - test winDde-2.4 {Checking for existence, with only the topic specified} \ - {pcOnly} { + {pcOnly dde} { expr [llength [dde services {} self]] >= 1 } 1 # ------------------------------------------------------------------------- -test winDde-3.1 {DDE execute locally} {pcOnly} { +test winDde-3.1 {DDE execute locally} {pcOnly dde} { set a "" dde execute TclEval self {set a "foo"} set a } foo - -test winDde-3.2 {DDE execute -async locally} {pcOnly} { +test winDde-3.2 {DDE execute -async locally} {pcOnly dde} { set a "" dde execute -async TclEval self {set a "foo"} update set a } foo - -test winDde-3.3 {DDE request locally} {pcOnly} { +test winDde-3.3 {DDE request locally} {pcOnly dde} { set a "" dde execute TclEval self {set a "foo"} dde request TclEval self a } foo - -test winDde-3.4 {DDE eval locally} {pcOnly} { +test winDde-3.4 {DDE eval locally} {pcOnly dde} { set a "" dde eval self set a "foo" } foo - -test winDde-3.5 {DDE request locally} {pcOnly} { +test winDde-3.5 {DDE request locally} {pcOnly dde} { set a "" dde execute TclEval self {set a "foo"} dde request -binary TclEval self a @@ -169,7 +162,7 @@ test winDde-3.5 {DDE request locally} {pcOnly} { # ------------------------------------------------------------------------- -test winDde-4.1 {DDE execute remotely} {stdio pcOnly} { +test winDde-4.1 {DDE execute remotely} {stdio pcOnly dde} { set a "" set name child-4.1 set child [createChildProcess $name] @@ -178,8 +171,7 @@ test winDde-4.1 {DDE execute remotely} {stdio pcOnly} { update set a } "" - -test winDde-4.2 {DDE execute async remotely} {stdio pcOnly} { +test winDde-4.2 {DDE execute async remotely} {stdio pcOnly dde} { set a "" set name child-4.2 set child [createChildProcess $name] @@ -188,8 +180,7 @@ test winDde-4.2 {DDE execute async remotely} {stdio pcOnly} { update set a } "" - -test winDde-4.3 {DDE request remotely} {stdio pcOnly} { +test winDde-4.3 {DDE request remotely} {stdio pcOnly dde} { set a "" set name chile-4.3 set child [createChildProcess $name] @@ -199,8 +190,7 @@ test winDde-4.3 {DDE request remotely} {stdio pcOnly} { update set a } foo - -test winDde-4.4 {DDE eval remotely} {stdio pcOnly} { +test winDde-4.4 {DDE eval remotely} {stdio pcOnly dde} { set a "" set name child-4.4 set child [createChildProcess $name] @@ -212,388 +202,260 @@ test winDde-4.4 {DDE eval remotely} {stdio pcOnly} { # ------------------------------------------------------------------------- -test winDde-5.1 {check for bad arguments} {pcOnly} { +test winDde-5.1 {check for bad arguments} {pcOnly dde} { catch {dde execute "" "" "" ""} result set result } {wrong # args: should be "dde execute ?-async? serviceName topicName value"} - -test winDde-5.2 {check for bad arguments} {pcOnly} { +test winDde-5.2 {check for bad arguments} {pcOnly dde} { catch {dde execute "" "" ""} result set result } {cannot execute null data} - -test winDde-5.3 {check for bad arguments} {pcOnly} { +test winDde-5.3 {check for bad arguments} {pcOnly dde} { catch {dde execute -foo "" "" ""} result set result } {wrong # args: should be "dde execute ?-async? serviceName topicName value"} - -test winDde-5.4 {DDE eval bad arguments} {pcOnly} { +test winDde-5.4 {DDE eval bad arguments} {pcOnly dde} { list [catch {dde eval "" "foo"} msg] $msg } {1 {invalid service name ""}} # ------------------------------------------------------------------------- -test winDde-6.1 {DDE servername bad arguments} \ - -constraints pcOnly \ - -body {list [catch {dde servername -z -z -z} msg] $msg} \ - -result {1 {wrong # args: should be "dde servername ?-force? ?-handler proc? ?--? ?serverName?"}} - -test winDde-6.2 {DDE servername set name} \ - -constraints pcOnly \ +test winDde-6.1 {DDE servername bad arguments} -constraints {pcOnly dde} -body { + dde servername -z -z -z +} -returnCodes error -result {wrong # args: should be "dde servername ?-force? ?-handler proc? ?--? ?serverName?"} +test winDde-6.2 {DDE servername set name} -constraints {pcOnly dde} \ -body {dde servername -- winDde-6.2} \ -result {winDde-6.2} - -test winDde-6.3 {DDE servername set exact name} \ - -constraints pcOnly \ +test winDde-6.3 {DDE servername set exact name} -constraints {pcOnly dde} \ -body {dde servername -force winDde-6.3} \ -result {winDde-6.3} - -test winDde-6.4 {DDE servername set exact name} \ - -constraints pcOnly \ +test winDde-6.4 {DDE servername set exact name} -constraints {pcOnly dde} \ -body {dde servername -force -- winDde-6.4} \ -result {winDde-6.4} - -test winDde-6.5 {DDE remote servername collision} \ - -constraints {stdio pcOnly} \ - -setup { - set name child-6.5 - set child [createChildProcess $name] - } \ - -body { - dde servername -- $name - } \ - -cleanup { - dde execute TclEval $name {set done 1} - update - } \ - -result "child-6.5 #2" - -test winDde-6.6 {DDE remote servername collision force} \ - -constraints {stdio pcOnly} \ - -setup { - set name child-6.6 - set child [createChildProcess $name] - } \ - -body { - dde servername -force -- $name - } \ - -cleanup { - dde execute TclEval $name {set done 1} - update - } \ - -result {child-6.6} +test winDde-6.5 {DDE remote servername collision} -constraints {stdio pcOnly dde} -setup { + set name child-6.5 + set child [createChildProcess $name] +} -body { + dde servername -- $name +} -cleanup { + dde execute TclEval $name {set done 1} + update +} -result "child-6.5 #2" +test winDde-6.6 {DDE remote servername collision force} -constraints {stdio pcOnly dde} -setup { + set name child-6.6 + set child [createChildProcess $name] +} -body { + dde servername -force -- $name +} -cleanup { + dde execute TclEval $name {set done 1} + update +} -result {child-6.6} # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter } \ - -constraints pcOnly \ - -setup { - interp create slave - } \ - -body { - slave eval [list load $lib dde] - slave eval [list dde servername -- dde-interp-7.1] - } \ - -cleanup { - interp delete slave - } \ - -result {dde-interp-7.1} - -test winDde-7.2 {DDE slave cleanup} \ - -constraints pcOnly \ - -setup { - interp create slave - slave eval [list load $lib dde] - slave eval [list dde servername -- dde-interp-7.5] - interp delete slave - } \ - -body { - dde services TclEval {} - set s [dde services TclEval {}] - set m [list [list TclEval dde-interp-7.5]] - if {[lsearch -exact $s $m] != -1} { - set s - } - } \ - -result {} - -test winDde-7.3 {DDE present in slave interp} \ - -constraints pcOnly \ - -setup { - interp create slave - slave eval [list load $lib dde] - slave eval [list dde servername -- dde-interp-7.3] - } \ - -body { - dde services TclEval dde-interp-7.3 - } \ - -cleanup { - interp delete slave - } \ - -result {{TclEval dde-interp-7.3}} - -test winDde-7.4 {interp name collision with -force} \ - -constraints pcOnly \ - -setup { - interp create slave - slave eval [list load $lib dde] - slave eval [list dde servername -- dde-interp-7.4] - } \ - -body { - dde servername -force -- dde-interp-7.4 - } \ - -cleanup { - interp delete slave - } \ - -result {dde-interp-7.4} - -test winDde-7.5 {interp name collision without -force} \ - -constraints pcOnly \ - -setup { - interp create slave - slave eval [list load $lib dde] - slave eval [list dde servername -- dde-interp-7.5] - } \ - -body { - dde servername -- dde-interp-7.5 - } \ - -cleanup { - interp delete slave - } \ - -result "dde-interp-7.5 #2" +test winDde-7.1 {Load DDE in slave interpreter } -constraints {pcOnly dde} -setup { + interp create slave +} -body { + slave eval [list load $lib dde] + slave eval [list dde servername -- dde-interp-7.1] +} -cleanup { + interp delete slave +} -result {dde-interp-7.1} +test winDde-7.2 {DDE slave cleanup} -constraints {pcOnly dde} -setup { + interp create slave + slave eval [list load $lib dde] + slave eval [list dde servername -- dde-interp-7.5] + interp delete slave +} -body { + dde services TclEval {} + set s [dde services TclEval {}] + set m [list [list TclEval dde-interp-7.5]] + if {[lsearch -exact $s $m] != -1} { + set s + } +} -result {} +test winDde-7.3 {DDE present in slave interp} -constraints {pcOnly dde} -setup { + interp create slave + slave eval [list load $lib dde] + slave eval [list dde servername -- dde-interp-7.3] +} -body { + dde services TclEval dde-interp-7.3 +} -cleanup { + interp delete slave +} -result {{TclEval dde-interp-7.3}} +test winDde-7.4 {interp name collision with -force} -constraints {pcOnly dde} -setup { + interp create slave + slave eval [list load $lib dde] + slave eval [list dde servername -- dde-interp-7.4] +} -body { + dde servername -force -- dde-interp-7.4 +} -cleanup { + interp delete slave +} -result {dde-interp-7.4} +test winDde-7.5 {interp name collision without -force} -constraints {pcOnly dde} -setup { + interp create slave + slave eval [list load $lib dde] + slave eval [list dde servername -- dde-interp-7.5] +} -body { + dde servername -- dde-interp-7.5 +} -cleanup { + interp delete slave +} -result "dde-interp-7.5 #2" # ------------------------------------------------------------------------- -test winDde-8.1 {Safe DDE load} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - } \ - -body { - list [catch {slave eval dde servername slave} msg] $msg - } \ - -cleanup {interp delete slave} \ - -result {1 {invalid command name "dde"}} - -test winDde-8.2 {Safe DDE set servername} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - } \ - -body { - slave invokehidden dde servername slave - } \ - -cleanup {interp delete slave} \ - -result {slave} - -test winDde-8.3 {Safe DDE check handler required for eval} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave invokehidden dde servername slave - } \ - -body { - catch {dde eval slave set a 1} msg - } \ - -cleanup {interp delete slave} \ - -result {1} - -test winDde-8.4 {Safe DDE check that execute is denied} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave invokehidden dde servername slave - } \ - -body { - slave eval set a 1 - list [catch { - dde execute TclEval slave {set a 2} - slave eval set a - } msg] $msg - } \ - -cleanup {interp delete slave} \ - -result {0 1} - -test winDde-8.5 {Safe DDE check that request is denied} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave invokehidden dde servername slave - } \ - -body { - slave eval set a 1 - list [catch {dde request TclEval slave a} msg] $msg - } \ - -cleanup {interp delete slave} \ - -result {1 {remote server cannot handle this command}} - -test winDde-8.6 {Safe DDE assign handler procedure} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - } \ - -body { - slave invokehidden dde servername -handler DDEACCEPT slave - } \ - -cleanup {interp delete slave} \ - -result slave - -test winDde-8.7 {Safe DDE check simple command} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave - } \ - -body { - list [catch { - dde eval slave set x 1 - } msg] $msg - } \ - -cleanup {interp delete slave} \ - -result {0 {set x 1}} - -test winDde-8.8 {Safe DDE check non-list command} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave - } \ - -body { - list [catch { - set s "c:\\Program Files\\Microsoft Visual Studio\\" - dde eval slave $s - string compare [slave eval set DDECMD] $s - } msg] $msg - } \ - -cleanup {interp delete slave} \ - -result {0 0} - -test winDde-8.9 {Safe DDE check command evaluation} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel #0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave - } \ - -body { - list [catch { - dde eval slave set x 1 - slave eval set x - } msg] $msg - } \ - -cleanup {interp delete slave} \ - -result {0 1} - -test winDde-8.10 {Safe DDE check command evaluation (2)} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel #0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave - } \ - -body { - list [catch { - dde eval slave [list set x 1] - slave eval set x - } msg] $msg - } \ - -cleanup {interp delete slave} \ - -result {0 1} - -test winDde-8.11 {Safe DDE check command evaluation (3)} \ - -constraints pcOnly \ - -setup { - interp create -safe slave - slave invokehidden load $lib dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel #0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave - } \ - -body { - list [catch { - dde eval slave [list [list set x 1]] - slave eval set x - } msg] $msg - } \ - -cleanup {interp delete slave} \ - -result {1 {invalid command name "set x 1"}} +test winDde-8.1 {Safe DDE load} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde +} -body { + list [catch {slave eval dde servername slave} msg] $msg +} -cleanup { + interp delete slave +} -result {1 {invalid command name "dde"}} +test winDde-8.2 {Safe DDE set servername} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde +} -body { + slave invokehidden dde servername slave +} -cleanup {interp delete slave} -result {slave} +test winDde-8.3 {Safe DDE check handler required for eval} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave invokehidden dde servername slave +} -body { + catch {dde eval slave set a 1} msg +} -cleanup {interp delete slave} -result {1} +test winDde-8.4 {Safe DDE check that execute is denied} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave invokehidden dde servername slave +} -body { + slave eval set a 1 + list [catch { + dde execute TclEval slave {set a 2} + slave eval set a + } msg] $msg +} -cleanup {interp delete slave} -result {0 1} +test winDde-8.5 {Safe DDE check that request is denied} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave invokehidden dde servername slave +} -body { + slave eval set a 1 + list [catch {dde request TclEval slave a} msg] $msg +} -cleanup { + interp delete slave +} -result {1 {remote server cannot handle this command}} +test winDde-8.6 {Safe DDE assign handler procedure} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} +} -body { + slave invokehidden dde servername -handler DDEACCEPT slave +} -cleanup {interp delete slave} -result slave +test winDde-8.7 {Safe DDE check simple command} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + slave invokehidden dde servername -handler DDEACCEPT slave +} -body { + list [catch { + dde eval slave set x 1 + } msg] $msg +} -cleanup {interp delete slave} -result {0 {set x 1}} +test winDde-8.8 {Safe DDE check non-list command} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + slave invokehidden dde servername -handler DDEACCEPT slave +} -body { + list [catch { + set s "c:\\Program Files\\Microsoft Visual Studio\\" + dde eval slave $s + string compare [slave eval set DDECMD] $s + } msg] $msg +} -cleanup {interp delete slave} -result {0 0} +test winDde-8.9 {Safe DDE check command evaluation} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + slave invokehidden dde servername -handler DDEACCEPT slave +} -body { + list [catch { + dde eval slave set x 1 + slave eval set x + } msg] $msg +} -cleanup {interp delete slave} -result {0 1} +test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + slave invokehidden dde servername -handler DDEACCEPT slave +} -body { + list [catch { + dde eval slave [list set x 1] + slave eval set x + } msg] $msg +} -cleanup {interp delete slave} -result {0 1} +test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {pcOnly dde} -setup { + interp create -safe slave + slave invokehidden load $lib dde + slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + slave invokehidden dde servername -handler DDEACCEPT slave +} -body { + list [catch { + dde eval slave [list [list set x 1]] + slave eval set x + } msg] $msg +} -cleanup {interp delete slave} -result {1 {invalid command name "set x 1"}} # ------------------------------------------------------------------------- -test winDde-9.1 {External safe DDE check string passing} \ - -constraints {pcOnly stdio} \ - -setup { - set name child-9.1 - set child [createChildProcess $name Handler1] - file copy -force script1.tcl dde-script.tcl - } \ - -body { - list [catch { - dde eval $name set x 1 - gets $child line - set line - } msg] $msg - } \ - -cleanup { - dde execute TclEval $name stop - update - file delete -force -- dde-script.tcl - } \ - -result {0 {set x 1}} - -test winDde-9.2 {External safe DDE check command evaluation} \ - -constraints {pcOnly stdio} \ - -setup { - set name child-9.2 - set child [createChildProcess $name Handler2] - file copy -force script1.tcl dde-script.tcl - } \ - -body { - list [catch { - dde eval $name set x 1 - gets $child line - set line - } msg] $msg - } \ - -cleanup { - dde execute TclEval $name stop - update - file delete -force -- dde-script.tcl - } \ - -result {0 1} - -test winDde-9.3 {External safe DDE check prefixed arguments} \ - -constraints {pcOnly stdio} \ - -setup { - set name child-9.3 - set child [createChildProcess $name [list Handler3 ARG]] - file copy -force script1.tcl dde-script.tcl - } \ - -body { - list [catch { - dde eval $name set x 1 - gets $child line - set line - } msg] $msg - } \ - -cleanup { - dde execute TclEval $name stop - update - file delete -force -- dde-script.tcl - } \ - -result {0 {ARG {set x 1}}} +test winDde-9.1 {External safe DDE check string passing} -constraints {pcOnly dde stdio} -setup { + set name child-9.1 + set child [createChildProcess $name Handler1] + file copy -force script1.tcl dde-script.tcl +} -body { + list [catch { + dde eval $name set x 1 + gets $child line + set line + } msg] $msg +} -cleanup { + dde execute TclEval $name stop + update + file delete -force -- dde-script.tcl +} -result {0 {set x 1}} +test winDde-9.2 {External safe DDE check command evaluation} -constraints {pcOnly dde stdio} -setup { + set name child-9.2 + set child [createChildProcess $name Handler2] + file copy -force script1.tcl dde-script.tcl +} -body { + list [catch { + dde eval $name set x 1 + gets $child line + set line + } msg] $msg +} -cleanup { + dde execute TclEval $name stop + update + file delete -force -- dde-script.tcl +} -result {0 1} +test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {pcOnly dde stdio} -setup { + set name child-9.3 + set child [createChildProcess $name [list Handler3 ARG]] + file copy -force script1.tcl dde-script.tcl +} -body { + list [catch { + dde eval $name set x 1 + gets $child line + set line + } msg] $msg +} -cleanup { + dde execute TclEval $name stop + update + file delete -force -- dde-script.tcl +} -result {0 {ARG {set x 1}}} # ------------------------------------------------------------------------- diff --git a/tests/winFCmd.test b/tests/winFCmd.test index d118e27..5da5dd4 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFCmd.test,v 1.27 2004/05/04 22:30:24 hobbs Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.28 2004/05/19 20:15:32 dkf Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -58,9 +58,6 @@ if {[string equal $tcl_platform(platform) "windows"]} { tcltest::testConstraint winOlderThan2000 0 } -set ::tcltest::testConstraints(cdrom) 0 -set ::tcltest::testConstraints(exdev) 0 - # find a CD-ROM so we can test read-only filesystems. set cdrom {} @@ -99,25 +96,31 @@ proc findfile {dir} { } if {$cdrom != ""} { - set ::tcltest::testConstraints(cdrom) 1 + testConstraint cdrom 1 set cdfile [findfile $cdrom] +} else { + testConstraint cdrom 0 } if {[file exists c:/] && [file exists d:/]} { catch {file delete d:/tf1} if {[catch {close [open d:/tf1 w]}] == 0} { file delete d:/tf1 - set ::tcltest::testConstraints(exdev) 1 + testConstraint exdev 1 + } else { + testConstraint exdev 0 } +} else { + testConstraint exdev 0 } file delete -force -- td1 set foo [catch {open td1 w} testfile] if {$foo} { - set ::tcltest::testConstraints(longFileNames) 0 + testConstraint longFileNames 0 } else { close $testfile - set ::tcltest::testConstraints(longFileNames) 1 + testConstraint longFileNames 1 file delete -force -- td1 } diff --git a/tests/winNotify.test b/tests/winNotify.test index 3183b27..723866e 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -10,15 +10,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winNotify.test,v 1.8 2004/05/19 13:29:33 dkf Exp $ +# RCS: @(#) $Id: winNotify.test,v 1.9 2004/05/19 20:15:32 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -set ::tcltest::testConstraints(testeventloop) \ - [expr {[info commands testeventloop] != {}}] +testConstraint testeventloop [expr {[info commands testeventloop] != {}}] # There is no explicit test for InitNotifier or NotifierExitHandler diff --git a/tests/winPipe.test b/tests/winPipe.test index 4ed7b08..9229533 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winPipe.test,v 1.26 2004/02/02 02:36:14 davygrvy Exp $ +# RCS: @(#) $Id: winPipe.test,v 1.27 2004/05/19 20:15:32 dkf Exp $ package require tcltest namespace import -force ::tcltest::* @@ -22,12 +22,12 @@ testConstraint exec [llength [info commands exec]] set bindir [file join [pwd] [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] -set ::tcltest::testConstraints(cat32) [file exists $cat32] +testConstraint cat32 [file exists $cat32] if {[catch {puts console1 ""}]} { - set ::tcltest::testConstraints(AllocConsole) 1 + testConstraint AllocConsole 1 } else { - set ::tcltest::testConstraints(.console) 1 + testConstraint .console 1 } set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n @@ -434,7 +434,6 @@ test winpipe-8.19 {ensure parse_cmdline isn't doing wildcard replacement} {pcOnl } [list $path(echoArgs.tcl) [list foo * makefile.?c bar]] - # restore old values for env(TMP) and env(TEMP) if {[catch {set env(TMP) $env_tmp}]} { -- cgit v0.12