summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/assemble.test6
-rw-r--r--tests/basic.test10
-rw-r--r--tests/chanio.test11
-rw-r--r--tests/cmdIL.test33
-rw-r--r--tests/compExpr-old.test22
-rw-r--r--tests/compExpr.test12
-rw-r--r--tests/coroutine.test2
-rw-r--r--tests/exec.test1
-rw-r--r--tests/expr-old.test17
-rw-r--r--tests/expr.test48
-rw-r--r--tests/foreach.test6
-rw-r--r--tests/format.test34
-rw-r--r--tests/httpold.test300
-rw-r--r--tests/info.test2
-rw-r--r--tests/io.test9
-rw-r--r--tests/ioCmd.test9
-rw-r--r--tests/ioTrans.test2
-rw-r--r--tests/join.test5
-rw-r--r--tests/lindex.test9
-rw-r--r--tests/lrange.test18
-rw-r--r--tests/lreplace.test14
-rw-r--r--tests/lsearch.test196
-rw-r--r--tests/msgcat.test292
-rw-r--r--tests/obj.test47
-rw-r--r--tests/oo.test239
-rw-r--r--tests/package.test12
-rw-r--r--tests/process.test31
-rw-r--r--tests/safe.test8
-rw-r--r--tests/scan.test4
-rw-r--r--tests/string.test10
-rw-r--r--tests/unixFCmd.test14
31 files changed, 849 insertions, 574 deletions
diff --git a/tests/assemble.test b/tests/assemble.test
index 6e5308d..d7c47a9 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -1584,6 +1584,12 @@ test assemble-15.7 {listIndexImm} {
}
-result c
}
+test assemble-15.8 {listIndexImm} {
+ assemble {push {a b c}; listIndexImm end+2}
+} {}
+test assemble-15.9 {listIndexImm} {
+ assemble {push {a b c}; listIndexImm -1-1}
+} {}
# assemble-16 - invokeStk
diff --git a/tests/basic.test b/tests/basic.test
index d47613a..0e4ddea 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -893,21 +893,17 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup {
rename stress {}
} -result 0
-test basic-48.17.$noComp {expansion: object safety} -setup {
- set old_precision $::tcl_precision
- set ::tcl_precision 4
- } -constraints $constraints -body {
+test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body {
set third [expr {1.0/3.0}]
set l [list $third $third]
set x [run {list $third {*}$l $third}]
- set res [list]
+ set res [list]
foreach t $x {
lappend res [expr {$t * 3.0}]
}
set res
} -cleanup {
- set ::tcl_precision $old_precision
- unset old_precision res t l x third
+ unset res t l x third
} -result {1.0 1.0 1.0 1.0}
test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body {
diff --git a/tests/chanio.test b/tests/chanio.test
index 8c74566..97e7e70 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -5345,7 +5345,7 @@ test chan-io-40.2 {POSIX open access modes: CREAT} -setup {
lappend x [chan gets $f]
} -cleanup {
chan close $f
-} -result {0600 {line 1}}
+} -result {0o600 {line 1}}
test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -constraints {unix umask} -body {
@@ -5353,7 +5353,7 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
chan close [open $path(test3) {WRONLY CREAT}]
file stat $path(test3) stats
format "%#o" [expr $stats(mode)&0o777]
-} -result [format %#4o [expr {0o666 & ~ $umaskValue}]]
+} -result [format %#5o [expr {0o666 & ~ $umaskValue}]]
test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -body {
@@ -5866,6 +5866,8 @@ test chan-io-47.6 {file events on shared files, deleting file events} -setup {
testfevent delete
chan close $f
} -result {{script 1} {}}
+unset path(foo)
+removeFile foo
set path(bar) [makeFile {} bar]
@@ -5961,6 +5963,9 @@ test chan-io-48.3 {testing readability conditions} -setup {
} -cleanup {
chan close $f
} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
+unset path(bar)
+removeFile bar
+
test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup {
file delete $path(test1)
set c 0
@@ -6790,8 +6795,6 @@ test chan-io-52.11 {TclCopyChannel & encodings} -setup {
chan close $in
chan close $out
file size $path(kyrillic.txt)
-} -cleanup {
- file delete $path(utf8-fcopy.txt)
} -result 3
test chan-io-53.1 {CopyData} -setup {
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index df59e6e..b9444b6 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -160,6 +160,12 @@ test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf {
test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf {
lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
+test cmdIL-1.41 {lsort -stride and -index} -body {
+ lsort -stride 2 -index -2 {a 2 b 1}
+} -returnCodes error -result {index "-2" cannot select an element from any list}
+test cmdIL-1.42 {lsort -stride and-index} -body {
+ lsort -stride 2 -index -1-1 {a 2 b 1}
+} -returnCodes error -result {index "-1-1" cannot select an element from any list}
# Can't think of any good tests for the MergeSort and MergeLists procedures,
# except a bunch of random lists to sort.
@@ -216,6 +222,33 @@ test cmdIL-3.4.1 {SortCompare procedure, -index option} -body {
test cmdIL-3.5 {SortCompare procedure, -index option} -body {
lsort -integer -index 2 {{20 10 13} {15}}
} -returnCodes error -result {element 2 missing from sublist "15"}
+test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index 1+3 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {element 4 missing from sublist "1 . c"}
+test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "-1-1" cannot select an element from any list}
+test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index -2 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "-2" cannot select an element from any list}
+test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index end-4 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {element -2 missing from sublist "1 . c"}
+test cmdIL-3.5.5 {SortCompare procedure, -index option} {
+ lsort -index {} {a b}
+} {a b}
+test cmdIL-3.5.6 {SortCompare procedure, -index option} {
+ lsort -index {} [list a \{]
+} {a \{}
+test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index end--1 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "end--1" cannot select an element from any list}
+test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index end+1 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "end+1" cannot select an element from any list}
+test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index end+2 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "end+2" cannot select an element from any list}
test cmdIL-3.6 {SortCompare procedure, -index option} {
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
} {{3 25 20} {2 5 25} {1 15 30}}
diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test
index bae26a0..0136ccd 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -20,12 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
@@ -602,22 +596,6 @@ test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body {
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
-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}
set a(VALUE) ff15
diff --git a/tests/compExpr.test b/tests/compExpr.test
index 14c875d..3b44af8 100644
--- a/tests/compExpr.test
+++ b/tests/compExpr.test
@@ -16,12 +16,6 @@ if {"::tcltest" ni [namespace children]} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -319,12 +313,6 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body {
expr {do_it()}
} -returnCodes error -match glob -result {* "*do_it"}
-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} -body {
expr {atan2(1.0)}
} -returnCodes error -match glob -result {too few arguments for math function*}
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 07feb53..8217a92 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -739,6 +739,8 @@ test coroutine-7.12 {coro floor above street level #3008307} -body {
}
boom ; # does not crash: the coro floor is a good insulator
list
+} -cleanup {
+ rename boom {}; rename cc {}; rename c {}
} -result {}
test coroutine-8.0.0 {coro inject executed} -body {
diff --git a/tests/exec.test b/tests/exec.test
index dffd960..3d1cd56 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -300,7 +300,6 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} {
# I/O redirection: combinations.
set path(gorp.file2) [makeFile {} gorp.file2]
-file delete $path(gorp.file2)
test exec-7.1 {multiple I/O redirections} {exec} {
exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file)
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 8c159b2..a73b77a 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -24,12 +24,6 @@ testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
@@ -847,12 +841,6 @@ 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}
-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}
@@ -952,11 +940,6 @@ test expr-old-34.15 {errors in math functions} {
test expr-old-34.16 {errors in math functions} {
expr round(-1.0e30)
} -1000000000000000019884624838656
-test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \
- -body {
- list [catch {expr T1(4)} msg] $msg
- } -match glob -result {1 {too many arguments for math function*}}
-
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0o289
} -returnCodes error -match glob -result {*invalid octal number*}
diff --git a/tests/expr.test b/tests/expr.test
index 8e083c5..de6eb4a 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -18,10 +18,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-testConstraint testmathfunctions [expr {
- ([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"})
-}]
-
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
@@ -685,41 +681,6 @@ test expr-15.5 {CompileMathFuncCall: too few arguments} -body {
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
-test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr 2*T1()
-} 246
-test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T2()*3
-} 1035
-test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(21, 37)
-} 37
-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} {testmathfunctions} {
- expr T3(-21.2, -17.5)
-} -17.5
-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} {testmathfunctions} {
- expr T3(wide(21), 37)
-} 37
-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} {testmathfunctions} {
- expr T3(21.0, wide(37))
-} 37.0
-test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), 37.0)
-} 37.0
-test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints {
- testmathfunctions
-} -body {
- expr T3(0,"a")
-} -returnCodes error -result {argument to math function didn't have numeric value}
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
@@ -5838,6 +5799,15 @@ test expr-32.5 {Bug 1585704} {
test expr-32.6 {Bug 1585704} {
expr -(1<<32)%(1<<63)
} [expr (1<<63)-(1<<32)]
+test expr-32.7 {bignum regression} {
+ expr {0%(1<<63)}
+} 0
+test expr-32.8 {bignum regression} {
+ expr {0%-(1<<63)}
+} 0
+test expr-32.9 {bignum regression} {
+ expr {0%-(1+(1<<63))}
+} 0
test expr-33.1 {parse largest long value} longIs32bit {
set max_long_str 2147483647
diff --git a/tests/foreach.test b/tests/foreach.test
index 6fd5476..84af4bd 100644
--- a/tests/foreach.test
+++ b/tests/foreach.test
@@ -212,14 +212,16 @@ test foreach-6.4 {break tests} {
set msg
} {wrong # args: should be "break"}
# Check for bug #406709
-test foreach-6.5 {break tests} {
+test foreach-6.5 {break tests} -body {
proc a {} {
set a 1
foreach b b {list [concat a; break]; incr a}
incr a
}
a
-} {2}
+} -cleanup {
+ rename a {}
+} -result {2}
# Test for incorrect "double evaluation" semantics
test foreach-7.1 {delayed substitution of body} {
diff --git a/tests/format.test b/tests/format.test
index 094b7b3..ed8676a 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -28,7 +28,7 @@ test format-1.1 {integer formatting} {
} { 34 16923 -12 -1}
test format-1.2 {integer formatting} {
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
-} { 6 34 16923 -12 -1 0xe 0XC}
+} { 6 34 16923 -12 -1 0xe 0xC}
test format-1.3 {integer formatting} longIs32bit {
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} { 6 34 16923 4294967284 -1 0}
@@ -54,40 +54,40 @@ test format-1.7.1 {integer formatting} longIs64bit {
} { 6 22 421b fffffffffffffff4}
test format-1.8 {integer formatting} longIs32bit {
format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0X22 0X421B 0xfffffff4}
+} {0 0x6 0x22 0x421B 0xfffffff4}
test format-1.8.1 {integer formatting} longIs64bit {
format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0X22 0X421B 0xfffffffffffffff4}
+} {0 0x6 0x22 0x421B 0xfffffffffffffff4}
test format-1.9 {integer formatting} longIs32bit {
format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
-} { 0x0 0x6 0x22 0x421b 0xfffffff4}
+} { 0 0x6 0x22 0x421b 0xfffffff4}
test format-1.9.1 {integer formatting} longIs64bit {
format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
-} { 0x0 0x6 0x22 0x421b 0xfffffffffffffff4}
+} { 0 0x6 0x22 0x421b 0xfffffffffffffff4}
test format-1.10 {integer formatting} longIs32bit {
format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0x22 0x421b 0xfffffff4 }
+} {0 0x6 0x22 0x421b 0xfffffff4 }
test format-1.10.1 {integer formatting} longIs64bit {
format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0x22 0x421b 0xfffffffffffffff4 }
+} {0 0x6 0x22 0x421b 0xfffffffffffffff4 }
test format-1.11 {integer formatting} longIs32bit {
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
-} {0 06 042 041033 037777777764 }
+} {0 0o6 0o42 0o41033 0o37777777764 }
test format-1.11.1 {integer formatting} longIs64bit {
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
-} {0 06 042 041033 01777777777777777777764}
+} {0 0o6 0o42 0o41033 0o1777777777777777777764}
test format-1.12 {integer formatting} {
format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
-} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
+} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-1.13 {integer formatting} {
- format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
-} {0d0 0d6 0d34 0d16923 -0d12}
+ format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
+} {0 0d6 0d34 0d16923 -0d12}
test format-1.14 {integer formatting} {
- format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
-} { 0d0 0d6 0d34 0d16923 -0d12}
+ format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1
+} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-1.15 {integer formatting} {
- format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
-} {0d0 0d6 0d34 0d16923 -0d12 }
+ format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1
+} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-2.1 {string formatting} {
@@ -561,7 +561,7 @@ test format-17.4 {testing %l with non-integer} {
} 1.000000
test format-17.5 {testing %llu with positive bignum} -body {
format %llu 0xabcdef0123456789abcdef
-} -returnCodes 1 -result {unsigned bignum format is invalid}
+} -result 207698809136909011942886895
test format-17.6 {testing %llu with negative number} -body {
format %llu -1
} -returnCodes 1 -result {unsigned bignum format is invalid}
diff --git a/tests/httpold.test b/tests/httpold.test
deleted file mode 100644
index dda0189..0000000
--- a/tests/httpold.test
+++ /dev/null
@@ -1,300 +0,0 @@
-# -*- tcl -*-
-# Commands covered: http_config, http_get, http_wait, http_reset
-#
-# This file contains a collection of tests for the http script library.
-# Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
-
-if {[catch {package require http 1.0}]} {
- if {[info exists httpold]} {
- catch {puts "Cannot load http 1.0 package"}
- ::tcltest::cleanupTests
- return
- } else {
- catch {puts "Running http 1.0 tests in slave interp"}
- set interp [interp create httpold]
- $interp eval [list set httpold "running"]
- $interp eval [list set argv $argv]
- $interp eval [list source [info script]]
- interp delete $interp
- ::tcltest::cleanupTests
- return
- }
-}
-
-if {$::tcl_platform(os) eq "Darwin"} {
- # Name resolution often a problem on OSX; not focus of HTTP package anyway
- set HOST localhost
-} else {
- set HOST [info hostname]
-}
-
-set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
-catch {unset data}
-
-##
-## The httpd script implement a stub http server
-##
-source [file join [file dirname [info script]] httpd]
-
-if [catch {httpd_init 0} listen] {
- puts "Cannot start http server, http test skipped"
- catch {unset port}
- ::tcltest::cleanupTests
- return
-}
-
-test httpold-1.1 {http_config} {
- http_config
-} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
-
-test httpold-1.2 {http_config} {
- http_config -proxyfilter
-} httpProxyRequired
-
-test httpold-1.3 {http_config} {
- catch {http_config -junk}
-} 1
-
-test httpold-1.4 {http_config} {
- http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
- set x [http_config]
- http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
- -useragent "Tcl http client package 1.0"
- set x
-} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
-
-test httpold-1.5 {http_config} {
- catch {http_config -proxyhost {} -junk 8080}
-} 1
-
-test httpold-2.1 {http_reset} {
- catch {http_reset http#1}
-} 0
-
-test httpold-3.1 {http_get} {
- catch {http_get -bogus flag}
-} 1
-test httpold-3.2 {http_get} {
- catch {http_get http:junk} err
- set err
-} {Unsupported URL: http:junk}
-
-set url ${::HOST}:$port
-test httpold-3.3 {http_get} {
- set token [http_get $url]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET /</h2>
-</body></html>"
-
-set tail /a/b/c
-set url ${::HOST}:$port/a/b/c
-set binurl ${::HOST}:$port/binary
-
-test httpold-3.4 {http_get} {
- set token [http_get $url]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-proc selfproxy {host} {
- global port
- return [list ${::HOST} $port]
-}
-test httpold-3.5 {http_get} {
- http_config -proxyfilter selfproxy
- set token [http_get $url]
- http_config -proxyfilter httpProxyRequired
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
-</body></html>"
-
-test httpold-3.6 {http_get} {
- http_config -proxyfilter bogus
- set token [http_get $url]
- http_config -proxyfilter httpProxyRequired
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-3.7 {http_get} {
- set token [http_get $url -headers {Pragma no-cache}]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-3.8 {http_get} {
- set token [http_get $url -query Name=Value&Foo=Bar]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>POST $tail</h2>
-<h2>Query</h2>
-<dl>
-<dt>Name<dd>Value
-<dt>Foo<dd>Bar
-</dl>
-</body></html>"
-
-test httpold-3.9 {http_get} {
- set token [http_get $url -validate 1]
- http_code $token
-} "HTTP/1.0 200 OK"
-
-
-test httpold-4.1 {httpEvent} {
- set token [http_get $url]
- upvar #0 $token data
- array set meta $data(meta)
- expr ($data(totalsize) == $meta(Content-Length))
-} 1
-
-test httpold-4.2 {httpEvent} {
- set token [http_get $url]
- upvar #0 $token data
- array set meta $data(meta)
- string compare $data(type) [string trim $meta(Content-Type)]
-} 0
-
-test httpold-4.3 {httpEvent} {
- set token [http_get $url]
- http_code $token
-} {HTTP/1.0 200 Data follows}
-
-test httpold-4.4 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $url -channel $out]
- close $out
- set in [open $testfile]
- set x [read $in]
- close $in
- removeFile $testfile
- set x
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-4.5 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $url -channel $out]
- close $out
- upvar #0 $token data
- removeFile $testfile
- expr $data(currentsize) == $data(totalsize)
-} 1
-
-test httpold-4.6 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $binurl -channel $out]
- close $out
- set in [open $testfile]
- fconfigure $in -translation binary
- set x [read $in]
- close $in
- removeFile $testfile
- set x
-} "$bindata$binurl"
-
-proc myProgress {token total current} {
- global progress httpLog
- if {[info exists httpLog] && $httpLog} {
- puts "progress $total $current"
- }
- set progress [list $total $current]
-}
-if 0 {
- # This test hangs on Windows95 because the client never gets EOF
- set httpLog 1
- test httpold-4.6 {httpEvent} {
- set token [http_get $url -blocksize 50 -progress myProgress]
- set progress
- } {111 111}
-}
-test httpold-4.7 {httpEvent} {
- set token [http_get $url -progress myProgress]
- set progress
-} {111 111}
-test httpold-4.8 {httpEvent} {
- set token [http_get $url]
- http_status $token
-} {ok}
-test httpold-4.9 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_code $token
-} {HTTP/1.0 200 Data follows}
-test httpold-4.10 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_size $token
-} {111}
-test httpold-4.11 {httpEvent} {
- set token [http_get $url -timeout 1 -command {#}]
- http_reset $token
- http_status $token
-} {reset}
-test httpold-4.12 {httpEvent} {
- update
- set x {}
- after 500 {lappend x ok}
- set token [http_get $url -timeout 1 -command {lappend x fail}]
- vwait x
- list [http_status $token] $x
-} {timeout ok}
-
-test httpold-5.1 {http_formatQuery} {
- http_formatQuery name1 value1 name2 "value two"
-} {name1=value1&name2=value+two}
-
-test httpold-5.2 {http_formatQuery} {
- http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
-} {name1=%7ebwelch&name2=%a1%a2%a2}
-
-test httpold-5.3 {http_formatQuery} {
- http_formatQuery lines "line1\nline2\nline3"
-} {lines=line1%0d%0aline2%0d%0aline3}
-
-test httpold-6.1 {httpProxyRequired} {
- update
- http_config -proxyhost ${::HOST} -proxyport $port
- set token [http_get $url]
- http_wait $token
- http_config -proxyhost {} -proxyport {}
- upvar #0 $token data
- set data(body)
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
-</body></html>"
-
-# cleanup
-catch {unset url}
-catch {unset port}
-catch {unset data}
-close $listen
-::tcltest::cleanupTests
-return
diff --git a/tests/info.test b/tests/info.test
index fd89b47..8176ad3 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -2398,7 +2398,7 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body {
# -------------------------------------------------------------------------
unset -nocomplain res
-test info-39.0 {Bug 4b61afd660} -setup {
+test info-39.2 {Bug 4b61afd660} -setup {
proc probe {} {
return [dict get [info frame -1] line]
}
diff --git a/tests/io.test b/tests/io.test
index 3fc370d..20bb565 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -5638,7 +5638,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT} 0o600]
file stat $path(test3) stats
- set x [format "0o%o" [expr $stats(mode)&0o777]]
+ set x [format "%#o" [expr $stats(mode)&0o777]]
puts $f "line 1"
close $f
set f [open $path(test3) r]
@@ -5653,7 +5653,7 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} {
close $f
file stat $path(test3) stats
format "%#o" [expr $stats(mode)&0o777]
-} [format %#4o [expr {0o666 & ~ $umaskValue}]]
+} [format %#5o [expr {0o666 & ~ $umaskValue}]]
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
@@ -6163,6 +6163,8 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil
close $f
set x
} {{script 1} {}}
+unset path(foo)
+removeFile foo
set path(bar) [makeFile {} bar]
@@ -6265,6 +6267,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe
close $f
list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
+unset path(bar)
+removeFile bar
+
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index cd89a02..cab4e97 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -384,7 +384,6 @@ test iocmd-10.5 {fblocked command} {
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
-file delete $path(test5)
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
set f [open $path(test4) w]
close $f
@@ -2058,6 +2057,8 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
lappend res [catch {interp eval $idb [list close $chan]} msg] $msg
set res
+} -cleanup {
+ interp delete $idb
} -constraints {testchannel} \
-result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
@@ -2100,6 +2101,8 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
set res
}]
set res
+} -cleanup {
+ interp delete $idb
} -constraints {testchannel} -result {Owner lost}
test iocmd-32.2 {delete interp of reflected chan} {
@@ -3836,8 +3839,6 @@ foreach file [list test1 test2 test3 test4] {
}
# delay long enough for background processes to finish
after 500
-foreach file [list test5] {
- removeFile $file
-}
+removeFile test5
cleanupTests
return
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 63a609f..75752f7 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -1200,6 +1200,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup {
# without invoking the transform handler.
} -cleanup {
tempdone
+ interp delete $idb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
set ida [interp create]; #puts <<$ida>>
@@ -1240,6 +1241,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
}]
} -cleanup {
tempdone
+ interp delete $idb
} -result {Owner lost}
test iortrans-11.2 {delete interp of reflected transform} -setup {
interp create slave
diff --git a/tests/join.test b/tests/join.test
index 4abe233..4aeb093 100644
--- a/tests/join.test
+++ b/tests/join.test
@@ -45,6 +45,11 @@ test join-3.1 {joinString is binary ok} {
test join-3.2 {join is binary ok} {
string length [join "a\0b a\0b a\0b"]
} 11
+
+test join-4.1 {shimmer segfault prevention} {
+ set l {0 0}
+ join $l $l
+} {00 00}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/lindex.test b/tests/lindex.test
index 29eb898..bb3f005 100644
--- a/tests/lindex.test
+++ b/tests/lindex.test
@@ -79,6 +79,15 @@ test lindex-3.7 {indexes don't shimmer wide ints} {
set x [expr {(wide(1)<<31) - 2}]
list $x [lindex {1 2 3} $x] [incr x] [incr x]
} {2147483646 {} 2147483647 2147483648}
+test lindex-3.8 {compiled with static indices out of range, negative} {
+ list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3]
+} [lrepeat 3 {}]
+test lindex-3.9 {compiled with calculated indices out of range, negative constant} {
+ list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1]
+} [lrepeat 3 {}]
+test lindex-3.10 {compiled with calculated indices out of range, after end} {
+ list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3]
+} [lrepeat 3 {}]
# Indices relative to end
diff --git a/tests/lrange.test b/tests/lrange.test
index 02b9c65..a5367a4 100644
--- a/tests/lrange.test
+++ b/tests/lrange.test
@@ -90,6 +90,24 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} {
lrange $l 0 end-5
}} {1 2 3 4 5}
} {}
+
+test lrange-3.2 {compiled with static indices out of range, negative} {
+ list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
+} [lrepeat 4 {}]
+test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
+ list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
+} [lrepeat 4 {}]
+test lrange-3.4 {compiled with calculated indices out of range, after end} {
+ list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2]
+} [lrepeat 4 {}]
+
+test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
+ list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
+} [lrepeat 4 {a b}]
+test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
+ list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
+} [lrepeat 4 {b c}]
+
# cleanup
::tcltest::cleanupTests
diff --git a/tests/lreplace.test b/tests/lreplace.test
index d7f8226..4a6b853 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -98,12 +98,18 @@ test lreplace-1.26 {lreplace command} {
[set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]]
} {a {} {}}
-test lreplace-1.27 {lreplace command} {
+test lreplace-1.27 {lreplace command} -body {
lreplace x 1 1
-} x
-test lreplace-1.28 {lreplace command} {
+} -returnCodes 1 -result {list doesn't contain element 1}
+test lreplace-1.28 {lreplace command} -body {
lreplace x 1 1 y
-} {x y}
+} -returnCodes 1 -result {list doesn't contain element 1}
+test lreplace-1.29 {lreplace command} -body {
+ lreplace x 1 1 [error foo]
+} -returnCodes 1 -result {foo}
+test lreplace-1.30 {lreplace command} -body {
+ lreplace {not {}alist} 0 0 [error foo]
+} -returnCodes 1 -result {foo}
test lreplace-2.1 {lreplace errors} {
list [catch lreplace msg] $msg
diff --git a/tests/lsearch.test b/tests/lsearch.test
index b2c1812..e401581 100644
--- a/tests/lsearch.test
+++ b/tests/lsearch.test
@@ -59,7 +59,7 @@ test lsearch-2.9 {search modes} {
} 1
test lsearch-2.10 {search modes} -returnCodes error -body {
lsearch -glib {b.x bx xy bcx} b.x
-} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-2.11 {search modes with -nocase} {
lsearch -exact -nocase {a b c A B C} A
} 0
@@ -87,10 +87,10 @@ test lsearch-3.2 {lsearch errors} -returnCodes error -body {
} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"}
test lsearch-3.3 {lsearch errors} -returnCodes error -body {
lsearch a b c
-} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-3.4 {lsearch errors} -returnCodes error -body {
lsearch a b c d
-} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-3.5 {lsearch errors} -returnCodes error -body {
lsearch "\{" b
} -result {unmatched open brace in list}
@@ -418,6 +418,34 @@ test lsearch-17.6 {lsearch -index option, basic functionality} {
test lsearch-17.7 {lsearch -index option, basic functionality} {
lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b}
} {0 1}
+test lsearch-17.8 {lsearch -index option, empty argument} {
+ lsearch -index {} a a
+} 0
+test lsearch-17.9 {lsearch -index option, empty argument} {
+ lsearch -index {} a a
+} [lsearch a a]
+test lsearch-17.10 {lsearch -index option, empty argument} {
+ lsearch -index {} [list \{] \{
+} 0
+test lsearch-17.11 {lsearch -index option, empty argument} {
+ lsearch -index {} [list \{] \{
+} [lsearch [list \{] \{]
+test lsearch-17.12 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index -2 a a
+} -returnCodes error -result {index "-2" cannot select an element from any list}
+test lsearch-17.13 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index -1-1 a a
+} -returnCodes error -result {index "-1-1" cannot select an element from any list}
+test lsearch-17.14 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index end--1 a a
+} -returnCodes error -result {index "end--1" cannot select an element from any list}
+test lsearch-17.15 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index end+1 a a
+} -returnCodes error -result {index "end+1" cannot select an element from any list}
+test lsearch-17.16 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index end+2 a a
+} -returnCodes error -result {index "end+2" cannot select an element from any list}
+
test lsearch-18.1 {lsearch -index option, list as index basic functionality} {
lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
@@ -435,21 +463,30 @@ test lsearch-18.5 {lsearch -index option, list as index basic functionality} {
lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
} {0 1}
-test lsearch-19.1 {lsearch -sunindices option} {
+test lsearch-19.1 {lsearch -subindices option} {
lsearch -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
} {1 0 0}
-test lsearch-19.2 {lsearch -sunindices option} {
+test lsearch-19.2 {lsearch -subindices option} {
lsearch -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
} {0 2 0}
-test lsearch-19.3 {lsearch -sunindices option} {
+test lsearch-19.3 {lsearch -subindices option} {
lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b*
} {0 1 1}
-test lsearch-19.4 {lsearch -sunindices option} {
+test lsearch-19.4 {lsearch -subindices option} {
lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b}
} {0 0 1}
-test lsearch-19.5 {lsearch -sunindices option} {
+test lsearch-19.5 {lsearch -subindices option} {
lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
} {{0 0 0} {1 0 0}}
+test lsearch-19.6 {lsearch -subindices option} {
+ lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {{0 1 0} {1 1 0}}
+test lsearch-19.7 {lsearch -subindices option} {
+ lsearch -subindices -index end {{1 a}} a
+} {0 1}
+test lsearch-19.8 {lsearch -subindices option} {
+ lsearch -subindices -all -index end {{1 a}} a
+} {{0 1}}
test lsearch-20.1 {lsearch -index option, index larger than sublists} -body {
lsearch -index 2 {{a c} {a b} {a a}} a
@@ -509,6 +546,149 @@ test lsearch-22.5 {lsearch -bisect, all equal} {
test lsearch-22.6 {lsearch -sorted, all equal} {
lsearch -sorted -integer {5 5 5 5} 5
} {0}
+
+test lsearch-23.1 {lsearch -stride option, errors} -body {
+ lsearch -stride {a b} a
+} -returnCodes error -result {"-stride" option must be followed by stride length}
+test lsearch-23.2 {lsearch -stride option, errors} -body {
+ lsearch -stride 0 {a b} a
+} -returnCodes error -result {stride length must be at least 1}
+test lsearch-23.3 {lsearch -stride option, errors} -body {
+ lsearch -stride 2 {a b c} a
+} -returnCodes error -result {list size must be a multiple of the stride length}
+test lsearch-23.4 {lsearch -stride option, errors} -body {
+ lsearch -stride 5 {a b c} a
+} -returnCodes error -result {list size must be a multiple of the stride length}
+test lsearch-23.5 {lsearch -stride option, errors} -body {
+ # Stride equal to length is ok
+ lsearch -stride 3 {a b c} a
+} -result 0
+
+test lsearch-24.1 {lsearch -stride option} -body {
+ lsearch -stride 2 {a b c d e f g h} d
+} -result -1
+test lsearch-24.2 {lsearch -stride option} -body {
+ lsearch -stride 2 {a b c d e f g h} e
+} -result 4
+test lsearch-24.3 {lsearch -stride option} -body {
+ lsearch -stride 3 {a b c d e f g h i} e
+} -result -1
+test lsearch-24.4 {lsearch -stride option} -body {
+ # Result points first in group
+ lsearch -stride 3 -index 1 {a b c d e f g h i} e
+} -result 3
+test lsearch-24.5 {lsearch -stride option} -body {
+ lsearch -inline -stride 2 {a b c d e f g h} d
+} -result {}
+test lsearch-24.6 {lsearch -stride option} -body {
+ # Inline result is a "single element" strided list
+ lsearch -inline -stride 2 {a b c d e f g h} e
+} -result "e f"
+test lsearch-24.7 {lsearch -stride option} -body {
+ lsearch -inline -stride 3 {a b c d e f g h i} e
+} -result {}
+test lsearch-24.8 {lsearch -stride option} -body {
+ lsearch -inline -stride 3 -index 1 {a b c d e f g h i} e
+} -result "d e f"
+test lsearch-24.9 {lsearch -stride option} -body {
+ lsearch -all -inline -stride 3 -index 1 {a b c d e f g e i} e
+} -result "d e f g e i"
+test lsearch-24.10 {lsearch -stride option} -body {
+ lsearch -all -inline -stride 3 -index 0 {a b c d e f a e i} a
+} -result "a b c a e i"
+test lsearch-24.11 {lsearch -stride option} -body {
+ # Stride 1 is same as no stride
+ lsearch -stride 1 {a b c d e f g h} d
+} -result 3
+
+# 25* mimics 19* but with -inline added to -subindices
+test lsearch-25.1 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
+} {a}
+test lsearch-25.2 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
+} {a}
+test lsearch-25.3 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b*
+} {bb}
+test lsearch-25.4 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b}
+} {cb}
+test lsearch-25.5 {lsearch -subindices option} {
+ lsearch -inline -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {a a}
+test lsearch-25.6 {lsearch -subindices option} {
+ lsearch -inline -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {a a}
+
+# 26* mimics 19* but with -stride added
+test lsearch-26.1 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {3 0}
+test lsearch-26.2 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {2 0}
+test lsearch-26.3 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b*
+} {1 1}
+test lsearch-26.4 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b}
+} {0 1}
+test lsearch-26.5 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a
+} {{0 0} {3 0}}
+test lsearch-26.6 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a
+} {{1 0} {4 0}}
+
+# 27* mimics 25* but with -stride added
+test lsearch-27.1 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {a}
+test lsearch-27.2 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {a}
+test lsearch-27.3 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b*
+} {bb}
+test lsearch-27.4 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b}
+} {cb}
+test lsearch-27.5 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a
+} {a a}
+test lsearch-27.6 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a
+} {a a}
+
+test lsearch-28.1 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 5
+} -result 0
+test lsearch-28.2 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 3
+} -result -1
+test lsearch-28.3 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 7
+} -result 2
+test lsearch-28.4 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 8
+} -result -1
+test lsearch-28.5 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 9
+} -result 4
+test lsearch-28.6 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 2
+} -result -1
+test lsearch-28.7 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 0 -subindices {5 3 7 8 9 2} 9
+} -result 4
+test lsearch-28.8 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 1 -subindices {3 5 8 7 2 9} 9
+} -result 5
+test lsearch-28.9 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 1 -subindices -inline {3 5 8 7 2 9} 9
+} -result 9
+
# cleanup
catch {unset res}
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 1c3ce58..0d2f928 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -55,8 +55,13 @@ namespace eval ::msgcat::test {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
+if {[package vsatisfies [package provide msgcat] 1.7]} {
+ set result [string tolower \
+ [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]]
+} else {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
+}
} else {
if {([info sharedlibextension] eq ".dll")
&& ![catch {package require registry}]} {
@@ -194,6 +199,28 @@ namespace eval ::msgcat::test {
mclocale looks/ok/../../../../but/is/path/to/evil/code
} -returnCodes error -match glob -result {invalid newLocale value *}
+ test msgcat-1.14 {mcpreferences, custom locale preferences} -setup {
+ variable locale [mclocale]
+ mclocale en
+ mcpreferences fr en {}
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result {fr en {}}
+
+ test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\
+ -setup {
+ variable locale [mclocale]
+ mcpreferences fr en {}
+ mclocale en
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result {en {}}
+
+
# Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
test msgcat-2.1 {mcset, global scope} {
@@ -688,7 +715,7 @@ namespace eval ::msgcat::test {
test msgcat-9.1 {mcexists no parameter} -body {
mcexists
} -returnCodes 1\
- -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"}
+ -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"}
test msgcat-9.2 {mcexists unknown option} -body {
mcexists -unknown src
@@ -724,12 +751,34 @@ namespace eval ::msgcat::test {
mcset foo k1 v1
} -cleanup {
mclocale $locale
+ namespace delete ::foo
} -body {
- namespace eval ::msgcat::test::sub {
+ namespace eval ::foo {
list [::msgcat::mcexists k1]\
- [::msgcat::mcexists -exactnamespace k1]
+ [::msgcat::mcexists -namespace ::msgcat::test k1]
}
- } -result {1 0}
+ } -result {0 1}
+
+ test msgcat-9.6 {mcexists -namespace ns parameter} -setup {
+ mcforgetpackage
+ variable locale [mclocale]
+ mclocale foo_bar
+ mcset foo k1 v1
+ } -cleanup {
+ mclocale $locale
+ namespace delete ::foo
+ } -body {
+ namespace eval ::foo {
+ list [::msgcat::mcexists k1]\
+ [::msgcat::mcexists -namespace ::msgcat::test k1]
+ }
+ } -result {0 1}
+
+ test msgcat-9.7 {mcexists -namespace - ns argument missing} -body {
+ mcexists -namespace src
+ } -returnCodes 1\
+ -result {Argument missing for switch "-namespace"}
+
# Tests msgcat-10.*: [mcloadedlocales]
@@ -811,13 +860,18 @@ namespace eval ::msgcat::test {
test msgcat-12.1 {mcpackagelocale no subcommand} -body {
mcpackagelocale
} -returnCodes 1\
- -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"}
+ -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"}
test msgcat-12.2 {mclpackagelocale wrong subcommand} -body {
mcpackagelocale junk
} -returnCodes 1\
-result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset}
+ test msgcat-12.2.1 {mclpackagelocale set multiple args} -body {
+ mcpackagelocale set a b
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcpackagelocale set ?locale?"}
+
test msgcat-12.3 {mcpackagelocale set} -setup {
variable locale [mclocale]
} -cleanup {
@@ -922,6 +976,30 @@ namespace eval ::msgcat::test {
list [mcpackagelocale present foo] [mcpackagelocale present bar]
} -result {0 1}
+ test msgcat-12.11 {mcpackagelocale custom preferences} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ set res [list [mcpackagelocale preferences]]
+ mcpackagelocale preferences bar {}
+ lappend res [mcpackagelocale preferences]
+ } -result {{foo {}} {bar {}}}
+
+ test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ mcpackagelocale preferences
+ mcpackagelocale isset
+ } -result {0}
+
+
# Tests msgcat-13.*: [mcpackageconfig subcmds]
test msgcat-13.1 {mcpackageconfig no subcommand} -body {
@@ -1073,8 +1151,212 @@ namespace eval ::msgcat::test {
} -returnCodes 1\
-result {fail}
+
+ # Tests msgcat-15.*: tcloo coverage
+
+ # There are 4 use-cases, where 3 must be tested now:
+ # - namespace defined, in class definition, class defined oo, classless
+
+ test msgcat-15.1 {mc in class setup} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::class create ClassCur
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar
+ } -body {
+ oo::define bar::ClassCur msgcat::mc con2
+ } -result con2bar
+
+ test msgcat-15.2 {mc in class} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::class create ClassCur
+ oo::define ClassCur method method1 {} {::msgcat::mc con2}
+ }
+ # full namespace is ::msgcat::test:baz
+ namespace eval baz {
+ set ObjCur [::msgcat::test::bar::ClassCur new]
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar baz
+ } -body {
+ $baz::ObjCur method1
+ } -result con2bar
+
+ test msgcat-15.3 {mc in classless object} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {::msgcat::mc con2}
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar
+ } -body {
+ bar::ObjCur method1
+ } -result con2bar
+
+ test msgcat-15.4 {mc in classless object with explicite namespace eval}\
+ -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {
+ namespace eval ::msgcat::test::baz {
+ ::msgcat::mc con2
+ }
+ }
+ }
+ namespace eval baz {
+ ::msgcat::mcset foo_BAR con2 con2baz
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace eval baz {::msgcat::mcforgetpackage}
+ namespace delete bar baz
+ } -body {
+ bar::ObjCur method1
+ } -result con2baz
+
+ # Test msgcat-16.*: command mcpackagenamespaceget
+
+ test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
+ namespace eval baz {msgcat::mcpackagenamespaceget}
+ } -result ::msgcat::test::baz
+
+ test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
+ namespace eval bar {
+ oo::class create ClassCur
+ oo::define ClassCur variable a
+ }
+ } -cleanup {
+ namespace delete bar
+ } -body {
+ oo::define bar::ClassCur msgcat::mcpackagenamespaceget
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.3 {mcpackagenamespaceget in class} -setup {
+ namespace eval bar {
+ oo::class create ClassCur
+ oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget}
+ }
+ namespace eval baz {
+ set ObjCur [::msgcat::test::bar::ClassCur new]
+ }
+ } -cleanup {
+ namespace delete bar baz
+ } -body {
+ $baz::ObjCur method1
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup {
+ namespace eval bar {
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget}
+ }
+ } -cleanup {
+ namespace delete bar
+ } -body {
+ bar::ObjCur method1
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.5\
+ {mcpackagenamespaceget in classless object with explicite namespace eval}\
+ -setup {
+ namespace eval bar {
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {
+ namespace eval ::msgcat::test::baz {
+ msgcat::mcpackagenamespaceget
+ }
+ }
+ }
+ } -cleanup {
+ namespace delete bar baz
+ } -body {
+ bar::ObjCur method1
+ } -result ::msgcat::test::baz
+
+
+ # Test msgcat-17.*: mcn command
+
+ test msgcat-17.1 {mcn no parameters} -body {
+ mcn
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcn ns src ?arg ...?"}
+
+ test msgcat-17.2 {mcn} -setup {
+ namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ ::msgcat::mcn [namespace current]::bar con1
+ } -result con1bar
+
+
interp bgerror {} $bgerrorsaved
+ # Tests msgcat-15.*: [mcutil]
+
+ test msgcat-15.1 {mcutil - no argument} -body {
+ mcutil
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil subcommand ?arg ...?"}
+
+ test msgcat-15.2 {mcutil - wrong argument} -body {
+ mcutil junk
+ } -returnCodes 1\
+ -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
+
+ test msgcat-15.3 {mcutil - partial argument} -body {
+ mcutil getsystem
+ } -returnCodes 1\
+ -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
+
+ test msgcat-15.4 {mcutil getpreferences - no argument} -body {
+ mcutil getpreferences
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil getpreferences locale"}
+
+ test msgcat-15.5 {mcutil getpreferences - DE_de} -body {
+ mcutil getpreferences DE_de
+ } -result {de_de de {}}
+
+ test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body {
+ mcutil getsystemlocale DE_de
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil getsystemlocale"}
+
+ # The result is system dependent
+ # So just test if it runs
+ # The environment variable version was test with test 0.x
+ test msgcat-15.7 {mcutil getsystemlocale} -body {
+ mcutil getsystemlocale
+ set ok ok
+ } -result {ok}
+
+
cleanupTests
}
namespace delete ::msgcat::test
diff --git a/tests/obj.test b/tests/obj.test
index 833c906..cb62d3f 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -30,7 +30,6 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes
bytecode
cmdName
dict
- end-offset
regexp
string
} {
@@ -52,15 +51,6 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj {
lappend result [testobj refcount 1]
} {{} 12 12 bytearray 3}
-test obj-3.1 {Tcl_ConvertToType error} testobj {
- list [testdoubleobj set 1 12.34] \
- [catch {testobj convert 1 end-offset} msg] \
- $msg
-} {12.34 1 {bad index "12.34": must be end?[+-]integer?}}
-test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj {
- list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg
-} {{} 1 {bad index "": must be end?[+-]integer?}}
-
test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj {
set result ""
lappend result [testobj freeallvars]
@@ -551,43 +541,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj {
} {{} 1024 1024 int 4 4 0 int 3 2}
-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"} 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"} 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"} 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"} 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"} {testobj longIs32bit} {
- testobj freeallvars
- teststringobj set 1 end--0x80000000
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end--2147483648
-
test obj-32.1 {freeing very large object trees} {
set x {}
for {set i 0} {$i<100000} {incr i} {
diff --git a/tests/oo.test b/tests/oo.test
index b9c5067..2d23a3c 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -13,6 +13,13 @@ if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
+
+# The foundational objects oo::object and oo::class are sensitive to reference
+# counting errors and are deallocated only when an interp is deleted, so in
+# this test suite, interp creation and interp deletion are often used in
+# leaktests in order to leverage this sensitivity.
+
+
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
@@ -47,7 +54,7 @@ test oo-0.2 {basic test of OO's ability to clean up its initial state} {
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
- [oo::object new] destroy
+ [oo::object new] destroy
}
} -constraints memory -result 0
test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
@@ -57,7 +64,13 @@ test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
foo destroy
}
} -constraints memory -result 0
-test oo-0.5 {testing literal leak on interp delete} memory {
+test oo-0.5.1 {testing object foundation cleanup} memory {
+ leaktest {
+ interp create foo
+ interp delete foo
+ }
+} 0
+test oo-0.5.2 {testing literal leak on interp delete} memory {
leaktest {
interp create foo
foo eval {oo::object new}
@@ -131,6 +144,10 @@ test oo-1.4 {basic test of OO functionality} -body {
test oo-1.4.1 {fully-qualified nested name} -body {
oo::object create ::one::two::three
} -result {::one::two::three}
+test oo-1.4.2 {automatic command name has same name as namespace} -body {
+ set obj [oo::object new]
+ expr {[info object namespace $obj] == $obj}
+} -result 1
test oo-1.5 {basic test of OO functionality} -body {
oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
@@ -261,7 +278,21 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
rename test-oo-1.18 {}
A destroy
} -result ::C
-test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
+test oo-1.18.1 {no memory leak: superclass} -setup {
+} -constraints memory -body {
+
+ leaktest {
+ interp create t
+ t eval {
+ oo::class create A {
+ superclass oo::class
+ }
+ }
+ interp delete t
+ }
+} -cleanup {
+} -result 0
+test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup {
proc test-oo-1.18 {} return
} -constraints memory -body {
leaktest {
@@ -274,7 +305,7 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
} -cleanup {
rename test-oo-1.18 {}
} -result 0
-test oo-1.18.2 {Bug 21c144f0f5} -setup {
+test oo-1.18.3 {Bug 21c144f0f5} -setup {
interp create slave
} -body {
slave eval {
@@ -1498,7 +1529,56 @@ test oo-11.5 {OO: cleanup} {
return done
} done
-test oo-11.6 {
+test oo-11.6.1 {
+ OO: cleanup of when an class is mixed into itself
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ oo::class create obj1
+ ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+ rename obj1 {}
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.2 {
+ OO: cleanup ReleaseClassContents() where class is mixed into one of its
+ instances
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ interp1 eval {
+ oo::class create obj1
+ ::oo::copy obj1 obj2
+ rename obj2 {}
+ rename obj1 {}
+ }
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.3 {
+ OO: cleanup ReleaseClassContents() where class is mixed into one of its
+ instances
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ interp1 eval {
+ oo::class create obj1
+ ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+
+ ::oo::copy obj1 obj2
+ rename obj2 {}
+ rename obj1 {}
+ }
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.4 {
OO: cleanup ReleaseClassContents() where class is mixed into one of its
instances
} -body {
@@ -1514,9 +1594,9 @@ test oo-11.6 {
# No segmentation fault
return done
-} -cleanup {
+} -result done -cleanup {
rename obj1 {}
-} -result done
+}
test oo-12.1 {OO: filters} {
oo::class create Aclass
@@ -1703,13 +1783,13 @@ test oo-13.2 {OO: changing an object's class} -body {
oo::objdefine foo class oo::class
} -cleanup {
foo destroy
-} -returnCodes 1 -result {may not change a non-class object into a class object}
+} -result {}
test oo-13.3 {OO: changing an object's class} -body {
oo::class create foo
oo::objdefine foo class oo::object
} -cleanup {
foo destroy
-} -returnCodes 1 -result {may not change a class object into a non-class object}
+} -result {}
test oo-13.4 {OO: changing an object's class} -body {
oo::class create foo {
method m {} {
@@ -2061,7 +2141,20 @@ test oo-15.12 {OO: object cloning with target NS} -setup {
Super destroy
catch {namespace delete ::existing}
} -result {::existing refers to an existing namespace}
-test oo-15.13 {OO: object cloning with target NS} -setup {
+test oo-15.13.1 {
+ OO: object cloning with target NS
+ Valgrind will report a leak if the reference count of the namespace isn't
+ properly incremented.
+} -setup {
+ oo::class create Cls {}
+} -body {
+ oo::copy Cls Cls2 ::dupens
+ return done
+} -cleanup {
+ Cls destroy
+ Cls2 destroy
+} -result done
+test oo-15.13.2 {OO: object cloning with target NS} -setup {
oo::class create Super
oo::class create Cls {superclass Super}
} -body {
@@ -3657,99 +3750,110 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
cls destroy
} -result {0 {}}
-oo::class create SampleSlot {
- superclass oo::Slot
- constructor {} {
- variable contents {a b c} ops {}
- }
- method contents {} {variable contents; return $contents}
- method ops {} {variable ops; return $ops}
- method Get {} {
- variable contents
- variable ops
- lappend ops [info level] Get
- return $contents
- }
- method Set {lst} {
- variable contents $lst
- variable ops
- lappend ops [info level] Set $lst
- return
+proc SampleSlotSetup script {
+ set script0 {
+ oo::class create SampleSlot {
+ superclass oo::Slot
+ constructor {} {
+ variable contents {a b c} ops {}
+ }
+ method contents {} {variable contents; return $contents}
+ method ops {} {variable ops; return $ops}
+ method Get {} {
+ variable contents
+ variable ops
+ lappend ops [info level] Get
+ return $contents
+ }
+ method Set {lst} {
+ variable contents $lst
+ variable ops
+ lappend ops [info level] Set $lst
+ return
+ }
+ }
}
+ append script0 \n$script
}
-test oo-32.1 {TIP 380: slots - class test} -setup {
+proc SampleSlotCleanup script {
+ set script0 {
+ SampleSlot destroy
+ }
+ append script \n$script0
+}
+
+test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {a b c} {}}
-test oo-32.2 {TIP 380: slots - class test} -setup {
+}] -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -clear] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {} {1 Set {}}}
-test oo-32.3 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
-test oo-32.4 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -set d e f] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {d e f} {1 Set {d e f}}}
-test oo-32.5 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
-test oo-33.1 {TIP 380: slots - defaulting} -setup {
+test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
list [$s x y] [$s contents]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} {a b c x y}}
-test oo-33.2 {TIP 380: slots - defaulting} -setup {
+}] -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
list [$s destroy; $s unknown] [$s contents]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} {a b c destroy unknown}}
-test oo-33.3 {TIP 380: slots - defaulting} -setup {
+}] -result {{} {a b c destroy unknown}}
+test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
oo::objdefine $s forward --default-operation my -set
list [$s destroy; $s unknown] [$s contents] [$s ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} unknown {1 Set destroy 1 Set unknown}}
-test oo-33.4 {TIP 380: slots - errors} -setup {
+}] -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
# Method names beginning with "-" are special to slots
$s -grill q
-} -returnCodes error -cleanup {
+} -returnCodes error -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
-
-SampleSlot destroy
+}] -result \
+ {unknown method "-grill": must be -append, -clear, -set, contents or ops}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]
@@ -3891,9 +3995,6 @@ test oo-35.6 {
rename obj {}
} -result done
-
-
-
test oo-36.1 {TIP #470: introspection within oo::define} {
oo::define oo::object self
} ::oo::object
diff --git a/tests/package.test b/tests/package.test
index bb938b8..2843701 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -625,6 +625,18 @@ test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constrain
package require t
set x
} -result {1.1}
+test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
+ package forget t
+} -body {
+ coroutine coro1 apply {{} {
+ package ifneeded t 2.1 {
+ yield
+ package provide t 2.1
+ }
+ package require t 2.1
+ }}
+ list [catch {coro1} msg] $msg
+} -match glob -result {0 2.1}
test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
diff --git a/tests/process.test b/tests/process.test
new file mode 100644
index 0000000..fb3a5e2
--- /dev/null
+++ b/tests/process.test
@@ -0,0 +1,31 @@
+# process.test --
+#
+# This file contains a collection of tests for the tcl::process ensemble.
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors. No output means no errors were found.
+#
+# Copyright (c) 2017 Frederic Bonnet
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+}
+
+test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
+ tcl::process
+} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
+test process-1.2 {tcl::process command basic syntax} -returnCodes error -body {
+ tcl::process ?
+} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status}
+
+test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1}
+test process-2.2 {tcl::process autopurge set true} {
+ tcl::process autopurge true
+ tcl::process autopurge
+} {1}
+test process-2.3 {tcl::process autopurge set false} {
+ tcl::process autopurge false
+ tcl::process autopurge
+} {0}
diff --git a/tests/safe.test b/tests/safe.test
index 33ee166..df60de6 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -180,17 +180,17 @@ test safe-6.3 {test safe interpreters knowledge of the world} {
# leaking infos, but they still do...
# high level general test
-test safe-7.1 {tests that everything works at high level} {
+test safe-7.1 {tests that everything works at high level} -body {
set i [safe::interpCreate]
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a slave works like in the master)
- set v [interp eval $i {package require http 1}]
+ set v [interp eval $i {package require http 2}]
# no error shall occur:
- interp eval $i {http_config}
+ interp eval $i {http::config}
safe::interpDelete $i
set v
-} 1.0
+} -match glob -result 2.*
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
diff --git a/tests/scan.test b/tests/scan.test
index 98c581b..1f32b9f 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -557,8 +557,8 @@ test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
- %llu a] $a
-} -returnCodes 1 -result {unsigned bignum scans are invalid}
+ %llu a] $a
+} -result {1 207698809136909011942886895}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
diff --git a/tests/string.test b/tests/string.test
index cebaf4c..f4b94de 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -24,6 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
+testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -1203,6 +1204,9 @@ test string-11.54 {string match, failure} {
[string match *a*l*\u0000*cba* $longString] \
[string match *===* $longString]
} {0 1 1 1 0 0}
+test string-11.55 {string match, invalid binary optimization} {
+ [format string] match \u0141 [binary format c 65]
+} 0
test string-12.1 {string range} {
list [catch {string range} msg] $msg
@@ -1288,6 +1292,9 @@ test string-12.22 {string range, shimmering binary/index} {
binary scan $s a* x
string range $s $s end
} 000000001
+test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} fullutf {
+ list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]
+} [list \U100000 {} b]
test string-13.1 {string repeat} {
list [catch {string repeat} msg] $msg
@@ -1386,6 +1393,9 @@ test string-14.17 {string replace} {
test string-14.18 {string replace} {
string replace abcdefghijklmnop 10 9 XXX
} {abcdefghijklmnop}
+test string-14.19 {string replace} {
+ string replace {} -1 0 A
+} A
test string-15.1 {string tolower too few args} {
list [catch {string tolower} msg] $msg
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index 183c145..08eb664 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -221,12 +221,12 @@ test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup {
cleanup
} -constraints {unix notRoot} -body {
close [open tf1 a]
- file attributes tf1 -permissions 0472
+ file attributes tf1 -permissions 0o472
file copy tf1 tf2
file attributes tf2 -permissions
} -cleanup {
cleanup
-} -result 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
+} -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
test unixFCmd-3.1 {CopyFile not done} {emptyTest unix notRoot} {
} {}
@@ -375,11 +375,11 @@ proc permcheck {testnum permList expected} {
set result
} $expected
}
-permcheck unixFCmd-17.5 rwxrwxrwx 00777
-permcheck unixFCmd-17.6 r--r---w- 00442
-permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 00740 00540 00547}
-permcheck unixFCmd-17.11 --x--x--x 00111
-permcheck unixFCmd-17.12 {0 a+rwx} {00000 00777}
+permcheck unixFCmd-17.5 rwxrwxrwx 0o777
+permcheck unixFCmd-17.6 r--r---w- 0o442
+permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 0o740 0o540 0o547}
+permcheck unixFCmd-17.11 --x--x--x 0o111
+permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777}
file delete -force -- foo.test
test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup {
generated by cgit v0.12 at 2024-11-16 14:31:37 (GMT)