Attachment "safe.tcl.patch1-3" to
ticket [2964715fff]
added by
kjnash
2010-03-10 23:38:58.
--- original/library/tcl8.5/safe.tcl 2010-01-23 04:36:42.000000000 +0000
+++ patched/library/tcl8.5/safe.tcl 2010-03-10 16:13:18.000000000 +0000
@@ -337,11 +337,15 @@
incr i
}
- set morepaths [::tcl::tm::list]
+ # Reverse the list because ::tcl::tm::add adds to the head of the list.
+ set morepaths [lreverse [::tcl::tm::list]]
+ set firstpass 1
while {[llength $morepaths]} {
set addpaths $morepaths
set morepaths {}
+ # Add each $dir to the access path if it is not already there.
+ # Set morepaths to the subdirectories of the $dir that are added.
foreach dir $addpaths {
# Prevent the addition of dirs on the tm list to the
# result if they are already known.
@@ -355,7 +359,12 @@
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $dir]
- lappend slave_tm_path $token
+ if {$firstpass} {
+ # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
+ # Later passes handle subdirectories, which belong in the
+ # access path but not in the module path.
+ lappend slave_tm_path $token
+ }
incr i
# [Bug 2854929]
@@ -366,6 +375,7 @@
# subdirectories.
lappend morepaths {*}[glob -nocomplain -directory $dir -type d *]
}
+ set firstpass 0
}
set state(access_path) $access_path
@@ -658,9 +668,69 @@
}
}
+
+# 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.
+
+# Further Alterations against {core-8-5-branch v 1.16.4.6 patched by safe.tcl.patch, safe.tcl.patch2}
+# (7) Reverse (4) - use the same misleading error message as glob itself
+# (8) -nocomplain protects against error return if there are no matches; it
+# should not protect against errors in arguments, e.g. no pattern
+# (9) - therefore we can move the test of -directory back into the
+# argument-processing loop
+# (10) Return a specific error message for option -path
+# (11) Give a standard error message for invalid arguments other than -path
+# (12) There is no requirement for -join (if present) to be the last argument
+# (13) Remove the test that the directory part of a (compounded) glob pattern
+# belongs to the access path. Instead, test whether each result of the
+# glob belongs to a directory in the access path. The reason is that the
+# DirInAccessPath test fails for a directory that has a glob wildcard.
+# (14) - therefore we do not need to do the pattern -join here - let glob do it
+
+
+# ------------------------------------------------------------------------------
+# 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.
+#
+# The restricted glob must use the -directory option (which must supply a
+# directory in the slave's access path), and returns only files and directories
+# whose parent directory belongs to the access_path.
+#
+# 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 {
@@ -671,12 +741,6 @@
-- 0
}
- if {$::tcl_platform(platform) eq "windows"} {
- set dirPartRE {^(.*)[\\/]}
- } else {
- set dirPartRE {^(.*)/}
- }
-
set dir {}
set virtualdir {}
@@ -692,6 +756,7 @@
incr at
}
-directory {
+ # Use the same misleading error message as glob:
if {$got($opt)} {
return -code error \
{"-directory" cannot be used with "-path"}
@@ -699,72 +764,50 @@
set got($opt) 1
set virtualdir [lindex $args [incr at]]
incr at
+
+ # Get the real path from the virtual one and check that the path
+ # is in the access path of that slave.
+ if {[catch {
+ set dir [TranslatePath $slave $virtualdir]
+ DirInAccessPath $slave $dir
+ } msg]} {
+ Log $slave $msg
+ return -code error {directory is not in the access path}
+ }
+
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"
+ -path {
+ Log $slave {Safe Base does not allow glob option "-path"}
+ return -code error {Safe Base does not allow glob option "-path"}
}
-* {
- Log $slave "Safe base rejecting glob option '$opt'"
- return -code error "Safe base rejecting glob option '$opt'"
+ Log $slave "bad option \"$opt\": must be -directory, -join, -nocomplain, -tails, -types, or --"
+ return -code error "bad option \"$opt\": must be -directory, -join, -nocomplain, -tails, -types, or --"
}
default {
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)} {
- if {[catch {
- set dir [TranslatePath $slave $virtualdir]
- DirInAccessPath $slave $dir
- } msg]} {
- Log $slave $msg
- if {!$got(-nocomplain)} {
- return -code error "permission denied"
- } else {
- return
- }
- }
+ if {$got(--)} break
}
- # Apply the -join semantics ourselves
- if {$got(-join)} {
- set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
+ if {!$got(-directory)} {
+ return -code error {when glob is used in the Safe Base, option "-directory" must be specified}
}
# 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 {
- 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"
- }
- }
- lappend cmd $opt
+ set pattern [lrange $args $at end]
+ set cmd [concat $cmd $pattern]
+
+ # We could let glob raise this error, but this message is more helpful
+ # than our rewritten message "script error".
+ if {[llength $pattern] == 0} {
+ return -code error {wrong # args: should be "glob ?switches? name ?name ...?"}
}
Log $slave "GLOB = $cmd" NOTICE
- if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
- return
- }
if {[catch {
::interp invokehidden $slave glob {*}$cmd
} msg]} {
@@ -778,16 +821,62 @@
set res {}
set l [string length $dir]
foreach p $msg {
+ # Return only results that are in the access path.
+ # Normalize because [dirname foo/..] is "foo".
+ if {[catch {
+ DirInAccessPath $slave [file dirname [file normalize $p]]
+ }]} {
+ continue
+ }
if {[string equal -length $l $dir $p]} {
set p [string replace $p 0 [expr {$l-1}] $virtualdir]
+ lappend res $p
+ } else {
+ # Something's gone wrong: $p has not been normalized and so should
+ # always begin with $dir.
+ return -code error "error handling glob results"
}
- lappend res $p
}
+ # A non-empty result list $msg might have had all its members removed.
+ if {($res eq {}) && (!$got(-nocomplain))} {
+ # E.g. {no files matched glob pattern "foo"}
+ return -code error [GlobErrorText $got(-join) $pattern]
+ }
Log $slave "GLOB @ $res" NOTICE
return $res
}
+
+# ------------------------------------------------------------------------------
+# Proc ::safe::GlobErrorText
+# ------------------------------------------------------------------------------
+# Command to return a suitable error message for use by AliasGlob, for the case
+# when there are no matches in the access path.
+#
+# Arguments:
+# gotJoin - (boolean) whether glob was called with option -join
+# pattern - list of pattern arguments supplied to glob
+#
+# Return Value: an error message
+# ------------------------------------------------------------------------------
+
+proc ::safe::GlobErrorText {gotJoin pattern} {
+ if {$gotJoin} {
+ set errorPattern [join $pattern /]
+ set numPat 1
+ } else {
+ set errorPattern $pattern
+ set numPat [llength $pattern]
+ }
+ if {$numPat > 1} {
+ set errorWord patterns
+ } else {
+ set errorWord pattern
+ }
+ return "no files matched glob $errorWord \"$errorPattern\""
+}
+
# AliasSource is the target of the "source" alias in safe interpreters.
proc ::safe::AliasSource {slave args} {
@@ -1107,7 +1196,7 @@
# access_path,slave : Ditto, as the path tokens as seen by the slave.
# access_path,map : dict ( token -> path )
# access_path,remap : dict ( path -> token )
- # tm_path_slave : List of TM root directories, as tokens seen by the slave.
+ # tm_path_slave : List of TM module paths, as tokens seen by the slave.
# staticsok : Value of option -statics
# nestedok : Value of option -nested
# cleanupHook : Value of option -deleteHook
