[Bug 2964715]: fixes to globbing in safe interpreters

3 files changed, 181 insertions, 25 deletions

diff --git a/ChangeLog b/ChangeLog
index 8f3a0f0..2ac4bb6 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 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]}]