summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/dict.test8
-rw-r--r--tests/oo.test110
-rw-r--r--tests/safe.test155
-rw-r--r--tests/switch.test22
-rw-r--r--tests/zlib.test16
5 files changed, 289 insertions, 22 deletions
diff --git a/tests/dict.test b/tests/dict.test
index 5277cf6..77bacf6 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -1475,7 +1475,7 @@ proc linenumber {} {
dict get [info frame -1] line
}
test dict-23.1 {dict compilation crash: Bug 3487626} {
- apply {n {
+ apply {{} {apply {n {
set e {}
set k {}
dict for {a b} {c {d {e {f g}}}} {
@@ -1487,14 +1487,14 @@ test dict-23.1 {dict compilation crash: Bug 3487626} {
}
}
}
- }} [linenumber]
+ }} [linenumber]}}
} 5
test dict-23.2 {dict compilation crash: Bug 3487626} knownBug {
# Something isn't quite right in line number and continuation line
# tracking; at time of writing, this test produces 7, not 5, which
# indicates that the extra newlines in the non-script argument are
# confusing things.
- apply {n {
+ apply {{} {apply {n {
set e {}
set k {}
dict for {a {
@@ -1518,7 +1518,7 @@ j
}
}
}
- }} [linenumber]
+ }} [linenumber]}}
} 5
rename linenumber {}
diff --git a/tests/oo.test b/tests/oo.test
index f3c0bda..00663e9 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1974,7 +1974,7 @@ test oo-18.1 {OO: define command support} {
} {1 foo {foo
while executing
"error foo"
- (in definition script for object "oo::object" line 1)
+ (in definition script for class "::oo::object" line 1)
invoked from within
"oo::define oo::object {error foo}"}}
test oo-18.2 {OO: define command support} {
@@ -1987,7 +1987,7 @@ test oo-18.3 {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 1)
+ (in definition script for class "::foo" line 1)
invoked from within
"oo::class create foo {error bar}"}}
test oo-18.3a {OO: define command support} {
@@ -1997,7 +1997,7 @@ test oo-18.3a {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 2)
+ (in definition script for class "::foo" line 2)
invoked from within
"oo::class create foo {
error bar
@@ -2015,7 +2015,7 @@ test oo-18.3b {OO: define command support} {
("eval" body line 1)
invoked from within
"eval eval error bar"
- (in definition script for object "::foo" line 2)
+ (in definition script for class "::foo" line 2)
invoked from within
"oo::class create foo {
eval eval error bar
@@ -2070,6 +2070,106 @@ test oo-18.5 {OO: more error traces from the guts} -setup {
(class "::cls" method "eval" line 1)
invoked from within
"obj eval {error bar}"}}
+test oo-18.6 {class construction reference management and errors} -setup {
+ oo::class create super_abc
+} -body {
+ catch {
+oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}
+ } msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ super_abc destroy
+} -result {foo
+ while executing
+"::error foo"
+ (in definition script for class "::def" line 4)
+ invoked from within
+"oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}"}
+test oo-18.7 {OO: objdefine command support} -setup {
+ oo::object create ::inst
+} -body {
+ list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo
+} -cleanup {
+ catch {::inst destroy}
+ catch {::INST destroy}
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in definition script for object "::INST" line 1)
+ invoked from within
+"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
+test oo-18.8 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::bar" line 1)
+ invoked from within
+"self {error foobar}"
+ (in definition script for class "::bar" line 1)
+ invoked from within
+"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
+test oo-18.9 {OO: define/self command support} -setup {
+ oo::class create master
+ set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
+ superclass master
+ }]
+} -body {
+ catch {oo::define $c {error err}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {err
+ while executing
+"error err"
+ (in definition script for class "::now_this_is_a_very_very_long..." line 1)
+ invoked from within
+"oo::define $c {error err}"}
+test oo-18.10 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::foo" line 1)
+ invoked from within
+"self {rename ::foo {}; error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {self {rename ::foo {}; error foobar}}"}
+test oo-18.11 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {this command cannot be called when the object has been deleted
+ while executing
+"self {error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {rename ::foo {}; self {error foobar}}"}
test oo-19.1 {OO: varname method} -setup {
oo::object create inst
@@ -3189,7 +3289,7 @@ test oo-33.2 {TIP 380: slots - defaulting} -setup {
} -cleanup {
rename $s {}
} -result {{} {a b c destroy unknown}}
-test oo-32.3 {TIP 380: slots - defaulting} -setup {
+test oo-33.3 {TIP 380: slots - defaulting} -setup {
set s [SampleSlot new]
} -body {
oo::objdefine $s forward --default-operation my -set
diff --git a/tests/safe.test b/tests/safe.test
index 2d7f476..98d4543 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -27,9 +27,7 @@ set ::auto_path [info library]
# Force actual loading of the safe package because we use un exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
-
-proc equiv {x} {return $x}
-
+
# testing that nested and statics do what is advertised (we use a static
# package - Tcltest - but it might be absent if we're in standard tclsh)
@@ -94,7 +92,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
lsort [a aliases]
} -cleanup {
safe::interpDelete a
-} -result {::tcl::info::nameofexecutable clock encoding exit file glob load source}
+} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
@@ -538,11 +536,154 @@ test safe-12.7 {glob is restricted} -setup {
set i [safe::interpCreate]
} -body {
$i eval glob *
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+} -result {permission denied}
+
+proc buildEnvironment {filename} {
+ upvar 1 testdir testdir testdir2 testdir2 testfile testfile
+ set testdir [makeDirectory deletethisdir]
+ set testdir2 [makeDirectory deletemetoo $testdir]
+ set testfile [makeFile {} $filename $testdir2]
+}
+#### New tests for Safe base glob, with patches @ Bug 2964715
+test safe-13.1 {glob is restricted [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+} -body {
+ $i eval glob *
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+} -result {permission denied}
+test safe-13.2 {mimic the valid glob call by ::tcl::tm::UnknownHandler [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval glob -nocomplain -directory $testdir2 *.tm]
+ if {$result eq [list $testfile]} {
+ return "glob match"
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {glob match}
+test safe-13.3 {cf 13.2 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ $i eval glob -directory $testdir2 *.tm
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {permission denied}
+test safe-13.4 {another valid glob call [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval \
+ glob -nocomplain -directory $testdir [file join deletemetoo *.tm]]
+ if {$result eq [list $testfile]} {
+ return "glob match"
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {glob match}
+test safe-13.5 {as 13.4 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ $i eval \
+ glob -directory $testdir [file join deletemetoo *.tm]
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {permission denied}
+test safe-13.6 {as 13.4 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ $i eval \
+ glob -nocomplain -directory $testdir [file join deletemetoo *.tm]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment pkgIndex.tcl
+} -body {
+ set safeTD [::safe::interpAddToAccessPath $i $testdir]
+ ::safe::interpAddToAccessPath $i $testdir2
+ string map [list $safeTD EXPECTED] [$i eval [list \
+ glob -directory $safeTD -join * pkgIndex.tcl]]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}}
+# Note the extra {} around the result above; that's *expected* because of the
+# format of virtual path roots.
+test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ set safeTD [::safe::interpAddToAccessPath $i $testdir]
+ ::safe::interpAddToAccessPath $i $testdir2
+ $i eval [list glob -directory $safeTD -join -nocomplain * notIndex.tcl]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+test safe-13.9 {as 13.8 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval \
+ glob -directory $testdir -join -nocomplain * notIndex.tcl]
+ if {$result eq [list $testfile]} {
+ return {glob match}
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {no match: }
+test safe-13.10 {as 13.8 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ $i eval glob -directory $testdir -join -nocomplain * notIndex.tcl
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+rename buildEnvironment {}
+
+#### Test for the module path
+test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+} -body {
+ set tm {}
+ foreach token [$i eval ::tcl::tm::path list] {
+ lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token]
+ }
+ return $tm
} -cleanup {
safe::interpDelete $i
-} -match glob -result *
+} -result [::tcl::tm::path list]
-test safe-13.1 {safe file ensemble does not surprise code} -setup {
+test safe-15.1 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
} -body {
set result [expr {"file" in [interp hidden $i]}]
@@ -556,7 +697,7 @@ test safe-13.1 {safe file ensemble does not surprise code} -setup {
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
interp delete $i
-} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {invalid command name "::tcl::file::isdirectory"}}
+} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
set ::auto_path $saveAutoPath
# cleanup
diff --git a/tests/switch.test b/tests/switch.test
index 255be00..a03948b 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -536,7 +536,7 @@ test switch-11.6 {-matchvar unwritable} {
test switch-12.1 {regexp matching with -indexvar} {
switch -regexp -indexvar x -- abc {.(.). {set x}}
-} {{0 3} {1 2}}
+} {{0 2} {1 1}}
test switch-12.2 {regexp matching with -indexvar} {
set x GOOD
switch -regexp -indexvar x -- abc {.(.).. {list $x z}}
@@ -544,7 +544,7 @@ test switch-12.2 {regexp matching with -indexvar} {
} GOOD
test switch-12.3 {regexp matching with -indexvar} {
switch -regexp -indexvar x -- "a b c" {.(.). {set x}}
-} {{0 3} {1 2}}
+} {{0 2} {1 1}}
test switch-12.4 {regexp matching with -indexvar} {
set x BAD
switch -regexp -indexvar x -- "a b c" {
@@ -560,22 +560,32 @@ test switch-12.6 {-indexvar unwritable} {
set x {}
list [catch {switch -regexp -indexvar x(x) -- abc . {set x}} msg] $x $msg
} {1 {} {can't set "x(x)": variable isn't array}}
+test switch-12.7 {[Bug 3106532] -indexvar should be directly usable with [string range]} {
+ set str abcdef
+ switch -regexp -indexvar x -- $str ^... {string range $str {*}[lindex $x 0]}
+} abc
+test switch-12.8 {-indexvar and matched empty strings} {
+ switch -regexp -indexvar x -- abcdef ^...(x?) {return $x}
+} {{0 2} {3 2}}
+test switch-12.9 {-indexvar and unmatched strings} {
+ switch -regexp -indexvar x -- abcdef ^...(x)? {return $x}
+} {{0 2} {-1 -1}}
test switch-13.1 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
. {list $x $y}
}
-} {{{0 1}} a}
+} {{{0 0}} a}
test switch-13.2 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
.$ {list $x $y}
}
-} {{{2 3}} c}
+} {{{2 2}} c}
test switch-13.3 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
(.)(.)(.) {list $x $y}
}
-} {{{0 3} {0 1} {1 2} {2 3}} {abc a b c}}
+} {{{0 2} {0 0} {1 1} {2 2}} {abc a b c}}
test switch-13.4 {-indexvar -matchvar combinations} {
set x -
set y -
@@ -597,7 +607,7 @@ test switch-13.6 {-indexvar -matchvar combinations} {
list [catch {
switch -regexp -indexvar x -matchvar y(y) abc {. {list $x $y}}
} msg] $x $y $msg
-} {1 {{0 1}} - {can't set "y(y)": variable isn't array}}
+} {1 {{0 0}} - {can't set "y(y)": variable isn't array}}
test switch-14.1 {-regexp -- compilation [Bug 1854399]} {
switch -regexp -- 0 {
diff --git a/tests/zlib.test b/tests/zlib.test
index 3aaca29..d8d710a 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -147,6 +147,7 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait total
+ after cancel {set total timeout}
} finally {
close $sin
}
@@ -226,6 +227,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list read $::total size [file size $file]
} -cleanup {
@@ -251,6 +253,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup {
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list read $::total size [file size $file]
} -cleanup {
@@ -284,6 +287,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup {
after 1000 {set ::total timeout}
fcopy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0]
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list $::total size [file size $file]
} -cleanup {
@@ -312,6 +316,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -339,6 +344,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -366,6 +372,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -396,6 +403,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -428,6 +436,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -460,6 +469,7 @@ test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -502,6 +512,8 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
@@ -538,6 +550,8 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
@@ -576,6 +590,8 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
generated by cgit v0.12 at 2024-11-15 16:56:21 (GMT)