Attachment "safe.tcl.patch" to
ticket [2964715fff]
added by
kjnash
2010-03-06 20:29:06.
--- original/library/tcl8.5/safe.tcl 2010-01-23 04:36:42.000000000 +0000
+++ patched/library/tcl8.5/safe.tcl 2010-03-06 13:03:49.000000000 +0000
@@ -658,9 +658,50 @@
}
}
+
+# Description of alterations to ::safe::AliasGlob from core-8-5-branch v 1.16.4.6
+#
+# (1) - add a comment header
+# (2) - change test for "pkgIndex.tcl" and move it so that it is effective
+# (3) - give a meaningful error message if pkgIndex.tcl is detected
+# (4) - give a meaningful error message if -directory is used twice
+# (5) - supply a value for dir in cmd
+# (6) - require option -directory
+# - This is a change to the (undocumented) behaviour of the exposed glob
+# command.
+# - The change is compatible with the required use cases for tm.tcl and
+# (if the pkgIndex.tcl test is removed in future) package.tcl.
+# - It is a good fit to the Safe Base idea that operations are permitted
+# only in certain directories.
+
+
+# ------------------------------------------------------------------------------
+# Proc ::safe::AliasGlob
+# ------------------------------------------------------------------------------
# AliasGlob is the target of the "glob" alias in safe interpreters.
+#
+# This command provides a restricted form of glob that a safe interpreter
+# requires to handle Tcl Modules. See tm.tcl, proc ::tcl::tm::UnknownHandler.
+#
+# Restrictions cf. standard glob:
+# (1) option -path is not allowed
+# (2) option -directory must be supplied and must be a directory in the safe
+# interpreter's access path.
+# (3) Final argument must not be "pkgIndex.tcl". This restriction is a kludge
+# to prevent the existence of "safe" glob from breaking tclPkgUnknown.
+# ------------------------------------------------------------------------------
+
proc ::safe::AliasGlob {slave args} {
Log $slave "GLOB ! $args" NOTICE
+
+ if {[lindex $args end] eq "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.
+ return -code error "Safe base rejecting glob call apparently from tclPkgUnknown"
+ }
+
set cmd {}
set at 0
array set got {
@@ -694,20 +735,16 @@
-directory {
if {$got($opt)} {
return -code error \
- {"-directory" cannot be used with "-path"}
+ {"-directory" option can be used only once}
}
set got($opt) 1
set virtualdir [lindex $args [incr at]]
incr at
+
+ # Errors in translation are examined later
+ catch {set dir [TranslatePath $slave $virtualdir]}
lappend cmd -directory $dir
}
- 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.
- return -code error "unknown command glob"
- }
-* {
Log $slave "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
@@ -734,6 +771,8 @@
return
}
}
+ } else {
+ return -code error {when glob is used in the Safe base, option "-directory" must be specified}
}
# Apply the -join semantics ourselves
