* library/tm.tcl: Modified the handling of Tcl Modules and of the

	* library/safe.tcl: Safe Base to interact nicely with each other,
	* library/init.tcl: enabling requiring Tcl Modules in safe
	* tests/safe.test: interpreters. Fixes [Bug 1999119].

5 files changed, 160 insertions, 23 deletions

diff --git a/ChangeLog b/ChangeLog
index cdc4f83..0bdc9e5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2008-06-25  Andreas Kupries  <andreask@activestate.com>
+
+	* library/tm.tcl: Modified the handling of Tcl Modules and of the
+	* library/safe.tcl: Safe Base to interact nicely with each other,
+	* library/init.tcl: enabling requiring Tcl Modules in safe
+	* tests/safe.test: interpreters. Fixes [Bug 1999119].
+
 2008-06-25  Don Porter  <dgp@users.sourceforge.net>
 
 	*** 8.6a1 TAGGED FOR RELEASE ***
diff --git a/library/init.tcl b/library/init.tcl
index 83981ae..3a3b105 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
 # Default system startup file for Tcl-based applications.  Defines
 # "unknown" procedure and auto-load facilities.
 #
-# RCS: @(#) $Id: init.tcl,v 1.106 2008/06/19 15:37:04 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.107 2008/06/25 17:40:03 andreas_kupries Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -156,7 +156,7 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
 
 
 if {[interp issafe]} {
-    package unknown ::tclPkgUnknown
+    package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
 } else {
     # Set up search for Tcl Modules (TIP #189).
     # and setup platform specific unknown package handlers
diff --git a/library/safe.tcl b/library/safe.tcl
index 186c2e7..afdf639 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.16 2006/11/03 00:34:52 hobbs Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.17 2008/06/25 17:40:03 andreas_kupries Exp $
 
 #
 # The implementation is based on namespaces. These naming conventions
@@ -369,9 +369,21 @@ namespace eval ::safe {
 	    lappend slave_auto_path "\$[PathToken $i]"
 	    incr i
 	}
+	# Extend the access list with the paths used to look for Tcl
+	# Modules. We safe the virtual form separately as well, as
+	# syncing it with the slave has to be defered until the
+	# necessary commands are present for setup.
+	foreach dir [::tcl::tm::list] {
+	    lappend access_path $dir
+	    Set [PathToken $i $slave] $dir
+	    lappend slave_auto_path "\$[PathToken $i]"
+	    lappend slave_tm_path   "\$[PathToken $i]"
+	    incr i
+	}
 	Set $nname $i
 	Set [PathListName $slave] $access_path
 	Set [VirtualPathListName $slave] $slave_auto_path
+	Set [TmPathListName      $slave] $slave_tm_path
 
 	Set [StaticsOkName $slave] $staticsok
 	Set [NestedOkName $slave] $nestedok
@@ -448,6 +460,10 @@ proc ::safe::interpAddToAccessPath {slave path} {
 	::interp alias $slave encoding {} [namespace current]::AliasEncoding \
 		$slave
 
+	# Handling Tcl Modules, we need a restricted form of Glob.
+	::interp alias $slave glob {} [namespace current]::AliasGlob \
+		$slave
+
 	# This alias lets the slave have access to a subset of the 'file'
 	# command functionality.
 
@@ -463,8 +479,8 @@ proc ::safe::interpAddToAccessPath {slave path} {
 	# by Tcl_MakeSafe(3)
 
 
-	# Source init.tcl into the slave, to get auto_load and other
-	# procedures defined:
+	# Source init.tcl and tm.tcl into the slave, to get auto_load
+	# and other procedures defined:
 
 	if {[catch {::interp eval $slave\
 		{source [file join $tcl_library init.tcl]}} msg]} {
@@ -472,6 +488,16 @@ proc ::safe::interpAddToAccessPath {slave path} {
 	    error "can't source init.tcl into slave $slave ($msg)"
 	}
 
+	if {[catch {::interp eval $slave \
+		{source [file join $tcl_library tm.tcl]}} msg]} {
+	    Log $slave "can't source tm.tcl ($msg)"
+	    error "can't source tm.tcl into slave $slave ($msg)"
+	}
+
+	# Sync the paths used to search for Tcl modules. This can be
+	# done only now, after tm.tcl was loaded.
+	::interp eval $slave [list ::tcl::tm::add {*}[Set [TmPathListName $slave]]]
+
 	return $slave
     }
 
@@ -610,6 +636,10 @@ proc ::safe::setLogCmd {args} {
     proc VirtualPathListName {slave} {
 	return "[InterpStateName $slave](access_path_slave)"
     }
+    # returns the variable name of the complete tm path list
+    proc TmPathListName {slave} {
+	return "[InterpStateName $slave](tm_path_slave)"
+    }
     # returns the variable name of the number of items
     proc PathNumberName {slave} {
 	return "[InterpStateName $slave](access_path,n)"
@@ -707,19 +737,96 @@ proc ::safe::setLogCmd {args} {
 	}
     }
 
+    # AliasGlob is the target of the "glob" alias in safe interpreters.
+
+    proc AliasGlob {slave args} {
+	Log $slave "GLOB ! $args" NOTICE
+	set cmd {}
+	set at 0
+
+	set dir        {}
+	set virtualdir {}
+
+	while {$at < [llength $args]} {
+	    switch -glob -- [set opt [lindex $args $at]] {
+		-nocomplain -
+		-join       { lappend cmd $opt ; incr at }
+		-directory  {
+		    lappend cmd $opt ; incr at
+		    set virtualdir [lindex $args $at]
+
+		    # get the real path from the virtual one.
+		    if {[catch {set dir [TranslatePath $slave $virtualdir]} msg]} {
+			Log $slave $msg
+			return -code error "permission denied"
+		    }
+		    # check that the path is in the access path of that slave
+		    if {[catch {DirInAccessPath $slave $dir} msg]} {
+			Log $slave $msg
+			return -code error "permission denied"
+		    }
+		    lappend cmd $dir ; incr at
+		}
+		pkgIndex.tcl {
+		    # Oops, this is globbing a subdirectory in regular
+		    # package search. That is not wanted. Abort,
+		    # handler does catch already (because glob was not
+		    # defined before). See package.tcl, lines 484ff in
+		    # tclPkgUnknown.
+		    error "unknown command glob"
+		}
+		-* {
+		    Log $slave "Safe base rejecting glob option '$opt'"
+		    error      "Safe base rejecting glob option '$opt'"
+		}
+		default {
+		    lappend cmd $opt ; incr at
+		}
+	    }
+	}
+
+	Log $slave "GLOB = $cmd" NOTICE
+
+	if {[catch {::interp invokehidden $slave glob {*}$cmd} msg]} {
+	    Log $slave $msg
+	    return -code error "script error"
+	}
+
+	Log $slave "GLOB @ $msg" NOTICE
+
+	# Translate path back to what the slave should see.
+	set res {}
+	foreach p $msg {
+	    regsub -- ^$dir $p $virtualdir p
+	    lappend res $p
+	}
+
+	Log $slave "GLOB @ $res" NOTICE
+	return $res
+    }
 
     # AliasSource is the target of the "source" alias in safe interpreters.
 
     proc AliasSource {slave args} {
 
 	set argc [llength $args]
-	# Allow only "source filename"
+	# Extended for handling of Tcl Modules to allow not only
+	# "source filename", but "source -encoding E filename" as
+	# well.
+	if {[lindex $args 0] eq "-encoding"} {
+	    incr argc -2
+	    set encoding [lrange $args 0 1]
+	    set at 2
+	} else {
+	    set at 0
+	    set encoding {}
+	}
 	if {$argc != 1} {
-	    set msg "wrong # args: should be \"source fileName\""
+	    set msg "wrong # args: should be \"source ?-encoding E? fileName\""
 	    Log $slave "$msg ($args)"
 	    return -code error $msg
 	}
-	set file [lindex $args 0]
+	set file [lindex $args $at]
 	
 	# get the real path from the virtual one.
 	if {[catch {set file [TranslatePath $slave $file]} msg]} {
@@ -740,7 +847,7 @@ proc ::safe::setLogCmd {args} {
 	}
 
 	# passed all the tests , lets source it:
-	if {[catch {::interp invokehidden $slave source $file} msg]} {
+	if {[catch {::interp invokehidden $slave source {*}$encoding $file} msg]} {
 	    Log $slave $msg
 	    return -code error "script error"
 	}
@@ -840,6 +947,25 @@ proc ::safe::setLogCmd {args} {
 	}
     }
 
+    proc DirInAccessPath {slave dir} {
+	set access_path [GetAccessPath $slave]
+
+	if {[file isfile $dir]} {
+	    error "\"$dir\": is a file"
+	}
+
+	# Normalize paths for comparison since lsearch knows nothing of
+	# potential pathname anomalies.
+	set norm_dir [file normalize $dir]
+	foreach path $access_path {
+	    lappend norm_access_path [file normalize $path]
+	}
+
+	if {[lsearch -exact $norm_access_path $norm_dir] == -1} {
+	    error "\"$dir\": not in access_path"
+	}
+    }
+
     # This procedure enables access from a safe interpreter to only a subset of
     # the subcommands of a command:
 
diff --git a/library/tm.tcl b/library/tm.tcl
index aee74f5..f6ffe5d 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -214,11 +214,11 @@ proc ::tcl::tm::UnknownHandler {original name args} {
 
 	set satisfied 0
 	foreach path $paths {
-	    if {![file exists $path]} {
+	    if {![interp issafe] && ![file exists $path]} {
 		continue
 	    }
 	    set currentsearchpath [file join $path $pkgroot]
-	    if {![file exists $currentsearchpath]} {
+	    if {![interp issafe] && ![file exists $currentsearchpath]} {
 		continue
 	    }
 	    set strip [llength [file split $path]]
@@ -352,9 +352,13 @@ proc ::tcl::tm::roots {paths} {
     foreach pa $paths {
 	set p [file join $pa tcl$major]
 	for {set n $minor} {$n >= 0} {incr n -1} {
-	    path add [file normalize [file join $p ${major}.${n}]]
+	    set px [file join $p ${major}.${n}]
+	    if {![interp issafe]} { set px [file normalize $px] }
+	    path add $px
 	}
-	path add [file normalize [file join $p site-tcl]]
+	set px [file join $p site-tcl]
+	if {![interp issafe]} { set px [file normalize $px] }
+	path add $px 
     }
     return
 }
@@ -362,4 +366,4 @@ proc ::tcl::tm::roots {paths} {
 # Initialization. Set up the default paths, then insert the new
 # handler into the chain.
 
-::tcl::tm::Defaults
+if {![interp issafe]} { ::tcl::tm::Defaults }
diff --git a/tests/safe.test b/tests/safe.test
index e1b4a36..fb66f8c 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.22 2006/12/05 18:45:51 andreas_kupries Exp $
+# RCS: @(#) $Id: safe.test,v 1.23 2008/06/25 17:40:05 andreas_kupries Exp $
 
 package require Tcl 8.5
 
@@ -89,7 +89,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} {
     set l [lsort [a aliases]]
     safe::interpDelete a
     set l
-} {clock encoding exit file load source}
+} {clock encoding exit file glob load source}
 test safe-3.3 {calling safe::interpCreate on trusted interp} {
     catch {safe::interpDelete a}
     safe::interpCreate a
@@ -201,7 +201,7 @@ test safe-7.1 {tests that everything works at high level} {
     safe::interpDelete $i
     set v
 } 1.0
-test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
+test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
     set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];
     # should not add anything (p0)
     set token1 [safe::interpAddToAccessPath $i [info library]]
@@ -213,7 +213,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
 	    [catch {interp eval $i {package require http 1}} msg] $msg \
 	    [safe::interpConfigure $i]\
 	    [safe::interpDelete $i]
-} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
+} -match glob -result "{\$p(:0:)} {\$p(:17:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library * /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
 
 
 # test source control on file name
@@ -224,7 +224,7 @@ test safe-8.1 {safe source control on file} {
     list  [catch {$i eval {source}} msg] \
 	    $msg \
 	    [safe::interpDelete $i] ;
-} {1 {wrong # args: should be "source fileName"} {}}
+} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}}
 test safe-8.2 {safe source control on file} {
     set i "a";
     catch {safe::interpDelete $i}
@@ -232,7 +232,7 @@ test safe-8.2 {safe source control on file} {
     list  [catch {$i eval {source}} msg] \
 	    $msg \
 	    [safe::interpDelete $i] ;
-} {1 {wrong # args: should be "source fileName"} {}}
+} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}}
 test safe-8.3 {safe source control on file} {
     set i "a";
     catch {safe::interpDelete $i}
@@ -315,7 +315,7 @@ test safe-8.8 {safe source forbids -rsrc} {
     list  [catch {$i eval {source -rsrc Init}} msg] \
 	    $msg \
 	    [safe::interpDelete $i] ;
-} {1 {wrong # args: should be "source fileName"} {}}
+} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}}
 
 test safe-9.1 {safe interps' deleteHook} {
     set i "a";
@@ -364,7 +364,7 @@ test safe-9.5 {dual specification of nested} {
     list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg
 } {1 {conflicting values given for -nested and -nestedLoadOk}}
 
-test safe-9.6 {interpConfigure widget like behaviour} {
+test safe-9.6 {interpConfigure widget like behaviour} -body {
    # this test shall work, don't try to "fix it" unless
    # you *really* know what you are doing (ie you are me :p) -- dl
    list [set i [safe::interpCreate \
@@ -381,7 +381,7 @@ test safe-9.6 {interpConfigure widget like behaviour} {
 	 safe::interpConfigure $i]\
 	[safe::interpConfigure $i -deleteHook toto -nosta -nested 0;
 	 safe::interpConfigure $i]
-} {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}}
+} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}}
 
 # testing that nested and statics do what is advertised
 # (we use a static package : Tcltest)