diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/dict.test | 8 | ||||
| -rw-r--r-- | tests/safe.test | 155 | ||||
| -rw-r--r-- | tests/switch.test | 22 | ||||
| -rw-r--r-- | tests/zlib.test | 16 |
4 files changed, 184 insertions, 17 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/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 05b5ed5..6c0e4f8 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 } @@ -261,6 +262,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 { @@ -286,6 +288,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 { @@ -319,6 +322,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 { @@ -347,6 +351,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -374,6 +379,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -401,6 +407,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -431,6 +438,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 @@ -463,6 +471,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 @@ -495,6 +504,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 @@ -537,6 +547,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 @@ -573,6 +585,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 @@ -611,6 +625,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 |