summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/clock.test46
-rw-r--r--tests/cmdIL.test4
-rw-r--r--tests/execute.test181
-rw-r--r--tests/interp.test19
-rw-r--r--tests/regexpComp.test20
-rw-r--r--tests/set.test6
-rw-r--r--tests/switch.test8
7 files changed, 271 insertions, 13 deletions
diff --git a/tests/clock.test b/tests/clock.test
index 3632db6..cbbc758 100644
--- a/tests/clock.test
+++ b/tests/clock.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: clock.test,v 1.79.2.1 2007/09/04 17:44:04 dgp Exp $
+# RCS: @(#) $Id: clock.test,v 1.79.2.2 2008/03/07 22:05:06 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -272,9 +272,13 @@ test clock-1.3 "clock format - empty val" {
clock format 0 -gmt 1 -format ""
} {}
-test clock-1.4 "clock format - bad flag" {
+test clock-1.4 "clock format - bad flag" {*}{
+ -body {
list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
-} {1 {bad switch "-oops", must be -format, -gmt, -locale or -timezone} {CLOCK badSwitch -oops}}
+ }
+ -match glob
+ -result {1 {bad switch "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badSwitch -oops}}
+}
test clock-1.5 "clock format - bad timezone" {
list [catch {clock format 0 -format "%s" -timezone :NOWHERE} msg] $msg $::errorCode
@@ -36588,6 +36592,42 @@ test clock-60.12 {case insensitive month names} {
clock scan "1 DECEMBER 2000" -gmt true -format "%d %b %Y"
} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
+test clock-61.1 {overflow of a wide integer on output} {*}{
+ -body {
+ clock format 0x8000000000000000 -format %s -gmt true
+ }
+ -result {integer value too large to represent}
+ -returnCodes error
+}
+test clock-61.2 {overflow of a wide integer on output} {*}{
+ -body {
+ clock format -0x8000000000000001 -format %s -gmt true
+ }
+ -result {integer value too large to represent}
+ -returnCodes error
+}
+test clock-61.3 {near-miss overflow of a wide integer on output} {
+ clock format 0x7fffffffffffffff -format %s -gmt true
+} [expr 0x7fffffffffffffff]
+test clock-61.4 {near-miss overflow of a wide integer on output} {
+ clock format -0x8000000000000000 -format %s -gmt true
+} [expr -0x8000000000000000]
+
+test clock-62.1 {Bug 1902423} {*}{
+ -setup {::tcl::clock::ClearCaches}
+ -body {
+ set s 1204049747
+ set f1 [clock format $s -format {%Y-%m-%d %T} -locale C]
+ set f2 [clock format $s -format {%Y-%m-%d %H:%M:%S} -locale C]
+ if {$f1 ne $f2} {
+ subst "$f2 is not $f1"
+ } else {
+ subst "ok"
+ }
+ }
+ -result ok
+}
+
# cleanup
namespace delete ::testClock
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 78dcb0a..37ea427 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.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: cmdIL.test,v 1.33.2.2 2008/01/23 16:42:20 dgp Exp $
+# RCS: @(#) $Id: cmdIL.test,v 1.33.2.3 2008/03/07 22:05:07 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -755,7 +755,7 @@ test cmdIL-7.7 {lreverse command - empty object [Bug 1876793]} {
} {}
testConstraint testobj [llength [info commands testobj]]
-test cmdIL-7.7 {lreverse command - shared intrep [Bug 1675044]} -setup {
+test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup {
teststringobj set 1 {1 2 3}
testobj convert 1 list
testobj duplicate 1 2
diff --git a/tests/execute.test b/tests/execute.test
index bc54725..c795e3f 100644
--- a/tests/execute.test
+++ b/tests/execute.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: execute.test,v 1.24 2006/11/03 00:34:52 hobbs Exp $
+# RCS: @(#) $Id: execute.test,v 1.24.2.1 2008/03/07 22:05:07 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -34,6 +34,7 @@ testConstraint testobj [expr {
}]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
+testConstraint testexprlongobj [llength [info commands testexprlongobj]]
# Tests for the omnibus TclExecuteByteCode function:
@@ -584,12 +585,188 @@ test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName o
}
p
} {}
-
test execute-6.2 {Evaluate an expression in a variable; compile the first time, do not the second} {
set w {3*5}
proc a {obj} {expr $obj}
set res "[a $w]:[a $w]"
} {15:15}
+test execute-6.3 {Tcl_ExprObj: don't use cached script bytecode [Bug 1899164]} -setup {
+ proc 0+0 {} {return SCRIPT}
+} -body {
+ set e { 0+0 }
+ if 1 $e
+ if 1 {expr $e}
+} -cleanup {
+ rename 0+0 {}
+} -result 0
+test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]} -setup {
+ proc 0+0 {} {return SCRIPT}
+} -body {
+ set e { 0+0 }
+ if 1 {expr $e}
+ if 1 $e
+} -cleanup {
+ rename 0+0 {}
+} -result SCRIPT
+test execute-6.5 {TclCompEvalObj: bytecode epoch validation} {
+ set script { llength {} }
+ set result {}
+ lappend result [if 1 $script]
+ set origName [namespace which llength]
+ rename $origName llength.orig
+ proc $origName {args} {return AHA!}
+ lappend result [if 1 $script]
+ rename $origName {}
+ rename llength.orig $origName
+ set result
+} {0 AHA!}
+test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} {
+ proc foo {} {set a 1}
+ set a untouched
+ set result {}
+ lappend result [foo] $a
+ lappend result [if 1 [info body foo]] $a
+ rename foo {}
+ set result
+} {1 untouched 1 1}
+test execute-6.7 {TclCompEvalObj: bytecode context validation} {
+ set script { llength {} }
+ namespace eval foo {
+ proc llength {args} {return AHA!}
+ }
+ set result {}
+ lappend result [if 1 $script]
+ lappend result [namespace eval foo $script]
+ namespace delete foo
+ set result
+} {0 AHA!}
+test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} {
+ set script { llength {} }
+ set result {}
+ lappend result [namespace eval foo $script]
+ namespace eval foo {
+ proc llength {args} {return AHA!}
+ }
+ lappend result [namespace eval foo $script]
+ namespace delete foo
+ set result
+} {0 AHA!}
+test execute-6.9 {TclCompEvalObj: bytecode interp validation} {
+ set script { llength {} }
+ interp create slave
+ slave eval {proc llength args {return AHA!}}
+ set result {}
+ lappend result [if 1 $script]
+ lappend result [slave eval $script]
+ interp delete slave
+ set result
+} {0 AHA!}
+test execute-6.10 {TclCompEvalObj: bytecode interp validation} {
+ set script { llength {} }
+ interp create slave
+ set result {}
+ lappend result [slave eval $script]
+ interp delete slave
+ interp create slave
+ lappend result [slave eval $script]
+ interp delete slave
+ set result
+} {0 0}
+test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj {
+ set e { [llength {}]+1 }
+ set result {}
+ interp create slave
+ load {} Tcltest slave
+ interp alias {} e slave testexprlongobj
+ lappend result [e $e]
+ interp delete slave
+ interp create slave
+ load {} Tcltest slave
+ interp alias {} e slave testexprlongobj
+ lappend result [e $e]
+ interp delete slave
+ set result
+} {{This is a result: 1} {This is a result: 1}}
+test execute-6.12 {Tcl_ExprObj: exprcode interp validation} {
+ set e { [llength {}]+1 }
+ set result {}
+ interp create slave
+ interp alias {} e slave expr
+ lappend result [e $e]
+ interp delete slave
+ interp create slave
+ interp alias {} e slave expr
+ lappend result [e $e]
+ interp delete slave
+ set result
+} {1 1}
+test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} {
+ set e { [llength {}]+1 }
+ set result {}
+ lappend result [expr $e]
+ set origName [namespace which llength]
+ rename $origName llength.orig
+ proc $origName {args} {return 1}
+ lappend result [expr $e]
+ rename $origName {}
+ rename llength.orig $origName
+ set result
+} {1 2}
+test execute-6.14 {Tcl_ExprObj: exprcode context validation} {
+ set e { [llength {}]+1 }
+ namespace eval foo {
+ proc llength {args} {return 1}
+ }
+ set result {}
+ lappend result [expr $e]
+ lappend result [namespace eval foo {expr $e}]
+ namespace delete foo
+ set result
+} {1 2}
+test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} {
+ set e { [llength {}]+1 }
+ set result {}
+ lappend result [namespace eval foo {expr $e}]
+ namespace eval foo {
+ proc llength {args} {return 1}
+ }
+ lappend result [namespace eval foo {expr $e}]
+ namespace delete foo
+ set result
+} {1 2}
+test execute-6.16 {Tcl_ExprObj: exprcode interp validation} {
+ set e { [llength {}]+1 }
+ interp create slave
+ interp alias {} e slave expr
+ slave eval {proc llength args {return 1}}
+ set result {}
+ lappend result [expr $e]
+ lappend result [e $e]
+ interp delete slave
+ set result
+} {1 2}
+test execute-6.17 {Tcl_ExprObj: exprcode context validation} {
+ set e { $v }
+ proc foo e {set v 0; expr $e}
+ proc bar e {set v 1; expr $e}
+ set result {}
+ lappend result [foo $e]
+ lappend result [bar $e]
+ rename foo {}
+ rename bar {}
+ set result
+} {0 1}
+test execute-6.18 {Tcl_ExprObj: exprcode context validation} {
+ set e { [llength $v] }
+ proc foo e {set v {}; expr $e}
+ proc bar e {set v v; expr $e}
+ set result {}
+ lappend result [foo $e]
+ lappend result [bar $e]
+ rename foo {}
+ rename bar {}
+ set result
+} {0 1}
test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {
set x 0x100000000
diff --git a/tests/interp.test b/tests/interp.test
index 7409993..af5bbc6 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.51.2.1 2007/12/10 18:32:57 dgp Exp $
+# RCS: @(#) $Id: interp.test,v 1.51.2.2 2008/03/07 22:05:08 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -2360,6 +2360,23 @@ test interp-28.1 {getting fooled by slave's namespace ?} {
set r
} {}
+test interp-28.2 {master's nsName cache should not cross} {
+ set i [interp create]
+ set res [$i eval {
+ set x {namespace children ::}
+ set y [list namespace children ::]
+ namespace delete [{*}$y]
+ set j [interp create]
+ $j eval {namespace delete {*}[namespace children ::]}
+ namespace eval foo {}
+ set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]]
+ interp delete $j
+ set res
+ }]
+ interp delete $i
+ set res
+} {::foo ::foo {} {}}
+
# Part 29: recursion limit
# 29.1.* Argument checking
# 29.2.* Reading and setting the recursion limit
diff --git a/tests/regexpComp.test b/tests/regexpComp.test
index c104a69..c7a5980 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -802,13 +802,13 @@ test regexpComp-21.11 {regexp command compiling tests} {
}
} {0 {}}
-test regexpComp-22.1 {Bug 1810038} {
+test regexpComp-22.0.1 {Bug 1810038} {
evalInProc {
regexp ($|^X)* {}
}
} 1
-test regexpComp-22.2 {regexp compile and backrefs, Bug 1857126} {
+test regexpComp-22.0.2 {regexp compile and backrefs, Bug 1857126} {
evalInProc {
regexp -- {([bc])\1} bb
}
@@ -909,6 +909,22 @@ test regexpComp-24.9 {regexp command compiling tests} {
list [catch {regexp -- $re dogfod} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
+test regexpComp-24.10 {regexp command compiling tests} {
+ # Bug 1902436 - last * escaped
+ evalInProc {
+ set text {this is *bold* !}
+ set re {\*bold\*}
+ regexp -- $re $text
+ }
+} 1
+test regexpComp-24.11 {regexp command compiling tests} {
+ # Bug 1902436 - last * escaped
+ evalInProc {
+ set text {this is *bold* !}
+ set re {\*bold\*.*!}
+ regexp -- $re $text
+ }
+} 1
# cleanup
::tcltest::cleanupTests
diff --git a/tests/set.test b/tests/set.test
index 07d8f01..5377312 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -10,13 +10,15 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: set.test,v 1.11.4.2 2007/11/05 14:20:57 dgp Exp $
+# RCS: @(#) $Id: set.test,v 1.11.4.3 2008/03/07 22:05:08 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
+testConstraint testset2 [llength [info commands testset2]]
+
catch {unset x}
catch {unset i}
@@ -514,7 +516,7 @@ test set-4.6 {set command: runtime error, basic array operations} {
list [catch {$z a} msg] $msg
} {1 {can't read "a": variable is array}}
-test set-5.1 {error on malformed array name} {
+test set-5.1 {error on malformed array name} testset2 {
unset -nocomplain z
catch {testset2 z(a) b} msg
catch {testset2 z(b) a} msg1
diff --git a/tests/switch.test b/tests/switch.test
index 612131d..0aaa6ad 100644
--- a/tests/switch.test
+++ b/tests/switch.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: switch.test,v 1.16.4.2 2008/01/23 16:42:21 dgp Exp $
+# RCS: @(#) $Id: switch.test,v 1.16.4.3 2008/03/07 22:05:08 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -501,6 +501,12 @@ rename cswtest-exact {}
rename iswtest-exact {}
rename cswtest2-exact {}
rename iswtest2-exact {}
+# Bug 1891827
+test switch-10.15 {(not) compiled exact nocase regression} {
+ apply {{} {
+ switch -nocase -- A { a {return yes} default {return no} }
+ }}
+} yes
# Added due to TIP#75
test switch-11.1 {regexp matching with -matchvar} {
generated by cgit v0.12 at 2024-11-24 10:14:51 (GMT)