diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/platform.test | 10 | ||||
| -rw-r--r-- | tests/safe.test | 178 | ||||
| -rw-r--r-- | tests/switch.test | 22 |
3 files changed, 198 insertions, 12 deletions
diff --git a/tests/platform.test b/tests/platform.test index 9d88f98..4f1eb82 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -14,7 +14,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -testConstraint testWinCPUID [llength [info commands testwincpuid]] +testConstraint testCPUID [llength [info commands testcpuid]] test platform-1.1 {TclpSetVariables: tcl_platform} { interp create i @@ -36,12 +36,12 @@ test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { list [expr {$result < 0}] [expr {$result ^ int($result - 1)}] } {1 -1} -# On Windows, test that the CPU ID works +# On Windows/UNIX, test that the CPU ID works -test platform-3.1 {CPU ID on Windows } \ - -constraints testWinCPUID \ +test platform-3.1 {CPU ID on Windows/UNIX} \ + -constraints testCPUID \ -body { - set cpudata [testwincpuid 0] + set cpudata [testcpuid 0] binary format iii \ [lindex $cpudata 1] \ [lindex $cpudata 3] \ diff --git a/tests/safe.test b/tests/safe.test index fbcb2a1..7b83cc6 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -30,7 +30,7 @@ set ::auto_path [info library] catch {safe::interpConfigure} proc equiv {x} {return $x} - + test safe-1.1 {safe::interpConfigure syntax} { list [catch {safe::interpConfigure} msg] $msg; } {1 {no value given for parameter "slave" (use -help for full usage) : @@ -515,6 +515,182 @@ test safe-12.6 {glob is restricted [Bug 2906841]} -setup { safe::interpDelete $i } -result {} +proc mkfile {filename} { + close [open $filename w] +} +#### 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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + $i eval glob -directory $testdir2 *.tm +} -returnCodes error -cleanup { + safe::interpDelete $i + file delete -force $testdir +} -result {permission denied} +test safe-13.4 {another valid glob call [Bug 2964715]} -setup { + set i [safe::interpCreate] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + $i eval \ + glob -directory $testdir [file join deletemetoo *.tm] +} -returnCodes error -cleanup { + safe::interpDelete $i + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval \ + glob -nocomplain -directory $testdir [file join deletemetoo *.tm] +} -cleanup { + safe::interpDelete $i + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 pkgIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval glob -directory $testdir -join -nocomplain * notIndex.tcl +} -cleanup { + safe::interpDelete $i + file delete -force $testdir +} -result {} +rename mkfile {} + +#### 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 +} -result [::tcl::tm::path list] + set ::auto_path $saveAutoPath # cleanup ::tcltest::cleanupTests diff --git a/tests/switch.test b/tests/switch.test index 5ee7216..f04f636 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 { |