Upgrade to Safe Base's handling of [glob] to be more permissive with the

feature set supported, but stricter with path management. It also now has an
error pattern more like the standard [glob] command.

3 files changed, 126 insertions, 34 deletions

diff --git a/ChangeLog b/ChangeLog
index 2940341..c62b2ac 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,13 +1,19 @@
+2009-12-16  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/safe.tcl (::safe::AliasGlob): Upgrade to correctly support a
+	larger fraction of [glob] functionality, while being stricter about
+	directory management.
+
 2009-12-11  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclTest.c:	Fix gcc warning: ignoring return value of ‘write’,
-	* unix/tclUnixNotify.c  declared with attribute warn_unused_result
-	* unix/tclUnixPipe.c
-	* generic/tclInt.decls  CONSTify functions TclpGetUserHome and
-	* generic/tclIntDecls.h TclSetPreInitScript (TIP #27)
-	* generic/tclInterp.c
-	* win/tclWinFile.c
-	* unix/tclUnixFile.c
+	* generic/tclTest.c:	Fix gcc warning: ignoring return value of
+	* unix/tclUnixNotify.c:	‘write’, declared with attribute
+	* unix/tclUnixPipe.c:	warn_unused_result.
+	* generic/tclInt.decls:	CONSTify functions TclpGetUserHome and
+	* generic/tclIntDecls.h:TclSetPreInitScript (TIP #27)
+	* generic/tclInterp.c:
+	* win/tclWinFile.c:
+	* unix/tclUnixFile.c:
 
 2009-12-16  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/library/safe.tcl b/library/safe.tcl
index 8bc26f9..6d896ea 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: safe.tcl,v 1.34 2009/12/03 15:49:22 dkf Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.35 2009/12/16 23:44:15 dkf Exp $
 
 #
 # The implementation is based on namespaces. These naming conventions are
@@ -651,34 +651,48 @@ proc ::safe::CheckFileName {slave file} {
 }
 
 # AliasGlob is the target of the "glob" alias in safe interpreters.
+
 proc ::safe::AliasGlob {slave args} {
     Log $slave "GLOB ! $args" NOTICE
     set cmd {}
     set at 0
+    array set got {
+	-directory 0
+	-nocomplain 0
+	-join 0
+	-tails 0
+	-- 0
+    }
+
+    if {$::tcl_platform(platform) eq "windows"} {
+	set dirPartRE {^(.*)[\\/]}
+    } else {
+	set dirPartRE {^(.*)/}
+    }
 
     set dir        {}
     set virtualdir {}
 
     while {$at < [llength $args]} {
 	switch -glob -- [set opt [lindex $args $at]] {
-	    -nocomplain -
-	    -join {
+	    -nocomplain - -- - -join - -tails {
 		lappend cmd $opt
+		set got($opt) 1
+		incr at
+	    }
+	    -types - -type {
+		lappend cmd -types [lindex $args [incr at]]
 		incr at
 	    }
 	    -directory {
-		set virtualdir [lindex $args [incr at]]
-		# Get the real path from the virtual one and check that the
-		# path is in the access path of that slave.
-		try {
-		    set dir [TranslatePath $slave $virtualdir]
-		    DirInAccessPath $slave $dir
-		} on error msg {
-		    Log $slave $msg
-		    return -code error "permission denied"
+		if {$got($opt)} {
+		    return -code error \
+			{"-directory" cannot be used with "-path"}
 		}
-		lappend cmd -directory $dir
+		set got($opt) 1
+		set virtualdir [lindex $args [incr at]]
 		incr at
+		lappend cmd -directory $dir
 	    }
 	    pkgIndex.tcl {
 		# Oops, this is globbing a subdirectory in regular package
@@ -692,26 +706,60 @@ proc ::safe::AliasGlob {slave args} {
 		return -code error "Safe base rejecting glob option '$opt'"
 	    }
 	    default {
-		if {[regexp {(.*)[\\/]} $opt -> thedir]} {
-		    try {
-			DirInAccessPath $slave [TranslatePath $slave $thedir]
-		    } on error msg {
-			Log $slave $msg
-			return -code error "permission denied"
-		    }
+		break
+	    }
+	}
+	if {$got(--) || $got(-join)} break
+    }
+
+    # Get the real path from the virtual one and check that the path is in the
+    # access path of that slave. Done after basic argument processing so that
+    # we know if -nocomplain is set.
+    if {$got(-directory)} {
+	try {
+	    set dir [TranslatePath $slave $virtualdir]
+	    DirInAccessPath $slave $dir
+	} on error msg {
+	    Log $slave $msg
+	    if {$got(-nocomplain)} {
+		return
+	    }
+	    return -code error "permission denied"
+	}
+    }
+
+    # Apply the -join semantics ourselves
+    if {$got(-join)} {
+	set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
+    }
+
+    # 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
 		}
-		lappend cmd $opt
-		incr at
+		return -code error "permission denied"
 	    }
 	}
+	lappend cmd $opt
     }
 
     Log $slave "GLOB = $cmd" NOTICE
 
+    if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
+	return
+    }
     try {
 	::interp invokehidden $slave glob {*}$cmd
-    } on ok msg {
-	# Nothing to be done, just capture the 'msg' for later.
     } on error msg {
 	Log $slave $msg
 	return -code error "script error"
@@ -721,8 +769,11 @@ proc ::safe::AliasGlob {slave args} {
 
     # Translate path back to what the slave should see.
     set res {}
+    set l [string length $dir]
     foreach p $msg {
-	regsub -- ^$dir $p $virtualdir p
+	if {[string equal -length $l $dir $p]} {
+	    set p [string replace $p 0 [expr {$l-1}] $virtualdir]
+	}
 	lappend res $p
     }
 
diff --git a/tests/safe.test b/tests/safe.test
index c8e170f..3e451d4 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: safe.test,v 1.28 2009/12/03 15:49:22 dkf Exp $
+# RCS: @(#) $Id: safe.test,v 1.29 2009/12/16 23:44:15 dkf Exp $
 
 package require Tcl 8.5
 
@@ -498,6 +498,41 @@ test safe-12.1 {glob is restricted [Bug 2906841]} -setup {
 } -returnCodes error -cleanup {
     safe::interpDelete $i
 } -result "permission denied"
+test safe-12.2 {glob is restricted [Bug 2906841]} -setup {
+    set i [safe::interpCreate]
+} -body {
+    $i eval glob -directory .. *
+} -returnCodes error -cleanup {
+    safe::interpDelete $i
+} -result "permission denied"
+test safe-12.3 {glob is restricted [Bug 2906841]} -setup {
+    set i [safe::interpCreate]
+} -body {
+    $i eval glob -join .. *
+} -returnCodes error -cleanup {
+    safe::interpDelete $i
+} -result "permission denied"
+test safe-12.4 {glob is restricted [Bug 2906841]} -setup {
+    set i [safe::interpCreate]
+} -body {
+    $i eval glob -nocomplain ../*
+} -cleanup {
+    safe::interpDelete $i
+} -result {}
+test safe-12.5 {glob is restricted [Bug 2906841]} -setup {
+    set i [safe::interpCreate]
+} -body {
+    $i eval glob -directory .. -nocomplain *
+} -cleanup {
+    safe::interpDelete $i
+} -result {}
+test safe-12.6 {glob is restricted [Bug 2906841]} -setup {
+    set i [safe::interpCreate]
+} -body {
+    $i eval glob -nocomplain -join .. *
+} -cleanup {
+    safe::interpDelete $i
+} -result {}
 
 set ::auto_path $saveAutoPath
 # cleanup