summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-05-17 14:14:26 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-05-17 14:14:26 (GMT)
commiteb98b2c7785409192628ad59475e3581ca2b901b (patch)
treea53893d967208756835ec6a76683d4007a153761
parent95a02f829d476464637599f39be7aeaa335c70ad (diff)
downloadtcl-eb98b2c7785409192628ad59475e3581ca2b901b.zip
tcl-eb98b2c7785409192628ad59475e3581ca2b901b.tar.gz
tcl-eb98b2c7785409192628ad59475e3581ca2b901b.tar.bz2
[Bug 2964715]: fixes to globbing in safe interpreters
-rw-r--r--ChangeLog5
-rw-r--r--library/safe.tcl47
-rw-r--r--tests/safe.test178
3 files changed, 212 insertions, 18 deletions
diff --git a/ChangeLog b/ChangeLog
index c841b77..5850670 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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 8a99032..1a340a1 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -491,7 +491,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
}
@@ -670,9 +671,9 @@ proc ::safe::AliasGlob {slave args} {
}
if {$::tcl_platform(platform) eq "windows"} {
- set dirPartRE {^(.*)[\\/]}
+ set dirPartRE {^(.*)[\\/]([^\\/]*)$}
} else {
- set dirPartRE {^(.*)/}
+ set dirPartRE {^(.*)/([^/]*)$}
}
set dir {}
@@ -725,11 +726,10 @@ proc ::safe::AliasGlob {slave args} {
DirInAccessPath $slave $dir
} msg]} {
Log $slave $msg
- if {!$got(-nocomplain)} {
- return -code error "permission denied"
- } else {
+ if {$got(-nocomplain)} {
return
}
+ return -code error "permission denied"
}
lappend cmd -directory $dir
}
@@ -741,19 +741,32 @@ 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] && [catch {
+ foreach opt [lrange $args $at end] {
+ if {![regexp $dirPartRE $opt -> thedir thefile]} {
+ set thedir .
+ }
+ if {$thedir eq "*"} {
+ set mapped 0
+ foreach d [glob -directory [TranslatePath $slave $virtualdir] \
+ -types d -tails *] {
+ catch {
+ DirInAccessPath $slave \
+ [TranslatePath $slave [file join $virtualdir $d]]
+ if {$thefile eq "pkgIndex.tcl" || $thefile eq "*.tm"} {
+ lappend cmd [file join $d $thefile]
+ set mapped 1
+ }
+ }
+ }
+ if {$mapped} continue
+ }
+ if {[catch {
set thedir [file join $virtualdir $thedir]
DirInAccessPath $slave [TranslatePath $slave $thedir]
} msg]} {
Log $slave $msg
- if {$got(-nocomplain)} {
- continue
- } else {
- return -code error "permission denied"
- }
+ if {$got(-nocomplain)} continue
+ return -code error "permission denied"
}
lappend cmd $opt
}
@@ -770,7 +783,7 @@ proc ::safe::AliasGlob {slave args} {
return -code error "script error"
}
- Log $slave "GLOB @ $msg" NOTICE
+ Log $slave "GLOB < $msg" NOTICE
# Translate path back to what the slave should see.
set res {}
@@ -782,7 +795,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 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