Attachment "safe.tcl.patch3" to
ticket [2964715fff]
added by
kjnash
2010-03-10 23:38:38.
--- original/library/tcl8.5/safe.tcl 2010-03-08 19:36:05.000000000 +0000
+++ patched/library/tcl8.5/safe.tcl 2010-03-10 16:13:18.000000000 +0000
@@ -684,6 +684,21 @@
# - 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
@@ -693,6 +708,10 @@
# 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
@@ -722,12 +741,6 @@
-- 0
}
- if {$::tcl_platform(platform) eq "windows"} {
- set dirPartRE {^(.*)[\\/]}
- } else {
- set dirPartRE {^(.*)/}
- }
-
set dir {}
set virtualdir {}
@@ -743,77 +756,58 @@
incr at
}
-directory {
+ # Use the same misleading error message as glob:
if {$got($opt)} {
return -code error \
- {"-directory" option can be used only once}
+ {"-directory" cannot be used with "-path"}
}
set got($opt) 1
set virtualdir [lindex $args [incr at]]
incr at
- # Errors in translation are examined later
- catch {set dir [TranslatePath $slave $virtualdir]}
+ # 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
}
+ -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
- }
- }
- } else {
- return -code error {when glob is used in the Safe base, option "-directory" must be specified}
+ 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]} {
@@ -827,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} {
