diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | library/safe.tcl | 50 | ||||
| -rw-r--r-- | tests/safe.test | 151 |
3 files changed, 181 insertions, 25 deletions
@@ -1,5 +1,10 @@ 2012-05-17 Donal K. Fellows <dkf@users.sf.net> + * library/safe.tcl (safe::InterpInit): Ensure that the module path is + constructed in the correct order. + (safe::AliasGlob): [Bug 2964715]: More extensive handling of what + globbing is required to support package loading. + * doc/expr.n: [Bug 3525462]: Corrected statement about what happens when comparing "0y" and "0x12"; the previously documented behavior was actually a subtle bug (now long-corrected). diff --git a/library/safe.tcl b/library/safe.tcl index b9be5a7..52f6e85 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -509,7 +509,8 @@ proc ::safe::InterpInit { # now, after tm.tcl was loaded. namespace upvar ::safe S$slave state if {[llength $state(tm_path_slave)] > 0} { - ::interp eval $slave [list ::tcl::tm::add {*}$state(tm_path_slave)] + ::interp eval $slave [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] } return $slave } @@ -689,9 +690,9 @@ proc ::safe::AliasGlob {slave args} { } if {$::tcl_platform(platform) eq "windows"} { - set dirPartRE {^(.*)[\\/]} + set dirPartRE {^(.*)[\\/]([^\\/]*)$} } else { - set dirPartRE {^(.*)/} + set dirPartRE {^(.*)/([^/]*)$} } set dir {} @@ -744,9 +745,7 @@ proc ::safe::AliasGlob {slave args} { DirInAccessPath $slave $dir } on error msg { Log $slave $msg - if {$got(-nocomplain)} { - return - } + if {$got(-nocomplain)} return return -code error "permission denied" } lappend cmd -directory $dir @@ -759,20 +758,31 @@ proc ::safe::AliasGlob {slave args} { # Process remaining pattern arguments set firstPattern [llength $cmd] - while {$at < [llength $args]} { - set opt [lindex $args $at] - incr at - if {[regexp $dirPartRE $opt -> thedir]} { - try { - set thedir [file join $virtualdir $thedir] - DirInAccessPath $slave [TranslatePath $slave $thedir] - } on error msg { - Log $slave $msg - if {$got(-nocomplain)} { - continue + foreach opt [lrange $args $at end] { + if {![regexp $dirPartRE $opt -> thedir thefile]} { + set thedir . + } + if {$thedir eq "*" && + ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { + set mapped 0 + foreach d [glob -directory [TranslatePath $slave $virtualdir] \ + -types d -tails *] { + catch { + DirInAccessPath $slave \ + [TranslatePath $slave [file join $virtualdir $d]] + lappend cmd [file join $d $thefile] + set mapped 1 } - return -code error "permission denied" } + if {$mapped} continue + } + try { + DirInAccessPath $slave [TranslatePath $slave \ + [file join $virtualdir $thedir]] + } on error msg { + Log $slave $msg + if {$got(-nocomplain)} continue + return -code error "permission denied" } lappend cmd $opt } @@ -789,7 +799,7 @@ proc ::safe::AliasGlob {slave args} { return -code error "script error" } - Log $slave "GLOB @ $entries" NOTICE + Log $slave "GLOB < $entries" NOTICE # Translate path back to what the slave should see. set res {} @@ -801,7 +811,7 @@ proc ::safe::AliasGlob {slave args} { lappend res $p } - Log $slave "GLOB @ $res" NOTICE + Log $slave "GLOB > $res" NOTICE return $res } diff --git a/tests/safe.test b/tests/safe.test index 827ea11..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) @@ -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]}] |