summaryrefslogtreecommitdiffstats
path: root/library/safe.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/safe.tcl')
-rw-r--r--library/safe.tcl180
1 files changed, 93 insertions, 87 deletions
diff --git a/library/safe.tcl b/library/safe.tcl
index 2dd4aed..ea6391d 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -151,10 +151,18 @@ proc ::safe::interpConfigure {args} {
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
switch -exact -- $name {
- -accessPath {return [list -accessPath $state(access_path)]}
- -statics {return [list -statics $state(staticsok)]}
- -nested {return [list -nested $state(nestedok)]}
- -deleteHook {return [list -deleteHook $state(cleanupHook)]}
+ -accessPath {
+ return [list -accessPath $state(access_path)]
+ }
+ -statics {
+ return [list -statics $state(staticsok)]
+ }
+ -nested {
+ return [list -nested $state(nestedok)]
+ }
+ -deleteHook {
+ return [list -deleteHook $state(cleanupHook)]
+ }
-noStatics {
# it is most probably a set in fact but we would need
# then to jump to the set part and it is not *sure*
@@ -192,7 +200,7 @@ proc ::safe::interpConfigure {args} {
if {
![::tcl::OptProcArgGiven -statics]
&& ![::tcl::OptProcArgGiven -noStatics]
- } {
+ } then {
set statics $state(staticsok)
} else {
set statics [InterpStatics]
@@ -200,7 +208,7 @@ proc ::safe::interpConfigure {args} {
if {
[::tcl::OptProcArgGiven -nested] ||
[::tcl::OptProcArgGiven -nestedLoadOk]
- } {
+ } then {
set nested [InterpNested]
} else {
set nested $state(nestedok)
@@ -457,8 +465,19 @@ proc ::safe::InterpInit {
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
- AliasSubset $slave file \
- file dir.* join root.* ext.* tail path.* split
+ ::interp expose $slave file
+ foreach subcommand {dirname extension rootname tail} {
+ ::interp alias $slave ::tcl::file::$subcommand {} \
+ ::safe::AliasFileSubcommand $slave $subcommand
+ }
+ foreach subcommand {
+ atime attributes copy delete executable exists isdirectory isfile
+ link lstat mtime mkdir nativename normalize owned readable readlink
+ rename size stat tempfile type volumes writable
+ } {
+ ::interp alias $slave ::tcl::file::$subcommand {} \
+ ::safe::BadSubcommand $slave file $subcommand
+ }
# Subcommands of info
foreach {subcommand alias} {
@@ -475,16 +494,16 @@ proc ::safe::InterpInit {
if {[catch {::interp eval $slave {
source [file join $tcl_library init.tcl]
- }} msg]} {
+ }} msg opt]} {
Log $slave "can't source init.tcl ($msg)"
- return -code error "can't source init.tcl into slave $slave ($msg)"
+ return -options $opt "can't source init.tcl into slave $slave ($msg)"
}
if {[catch {::interp eval $slave {
source [file join $tcl_library tm.tcl]
- }} msg]} {
+ }} msg opt]} {
Log $slave "can't source tm.tcl ($msg)"
- return -code error "can't source tm.tcl into slave $slave ($msg)"
+ return -options $opt "can't source tm.tcl into slave $slave ($msg)"
}
# Sync the paths used to search for Tcl modules. This can be done only
@@ -538,9 +557,9 @@ proc ::safe::interpDelete {slave} {
# remove the hook now, otherwise if the hook calls us somehow,
# we'll loop
unset state(cleanupHook)
- if {[catch {
+ try {
{*}$hook $slave
- } err]} {
+ } on error err {
Log $slave "Delete hook error ($err)"
}
}
@@ -657,7 +676,19 @@ proc ::safe::CheckFileName {slave file} {
}
}
+# AliasFileSubcommand handles selected subcommands of [file] in safe
+# interpreters that are *almost* safe. In particular, it just acts to
+# prevent discovery of what home directories exist.
+
+proc ::safe::AliasFileSubcommand {slave subcommand name} {
+ if {[string match ~* $name]} {
+ set name ./$name
+ }
+ tailcall ::interp invokehidden $slave tcl:file:$subcommand $name
+}
+
# AliasGlob is the target of the "glob" alias in safe interpreters.
+
proc ::safe::AliasGlob {slave args} {
Log $slave "GLOB ! $args" NOTICE
set cmd {}
@@ -721,14 +752,12 @@ proc ::safe::AliasGlob {slave args} {
# access path of that slave. Done after basic argument processing so that
# we know if -nocomplain is set.
if {$got(-directory)} {
- if {[catch {
+ try {
set dir [TranslatePath $slave $virtualdir]
DirInAccessPath $slave $dir
- } msg]} {
+ } on error msg {
Log $slave $msg
- if {$got(-nocomplain)} {
- return
- }
+ if {$got(-nocomplain)} return
return -code error "permission denied"
}
lappend cmd -directory $dir
@@ -744,26 +773,27 @@ proc ::safe::AliasGlob {slave args} {
foreach opt [lrange $args $at end] {
if {![regexp $dirPartRE $opt -> thedir thefile]} {
set thedir .
+ } elseif {[string match ~* $thedir]} {
+ set thedir ./$thedir
}
- if {$thedir eq "*"} {
+ if {$thedir eq "*" &&
+ ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
set mapped 0
foreach d [glob -directory [TranslatePath $slave $virtualdir] \
-types d -tails *] {
catch {
DirInAccessPath $slave \
[TranslatePath $slave [file join $virtualdir $d]]
- if {$thefile eq "pkgIndex.tcl" || $thefile eq "*.tm"} {
- lappend cmd [file join $d $thefile]
- set mapped 1
- }
+ lappend cmd [file join $d $thefile]
+ set mapped 1
}
}
if {$mapped} continue
}
- if {[catch {
- set thedir [file join $virtualdir $thedir]
- DirInAccessPath $slave [TranslatePath $slave $thedir]
- } msg]} {
+ try {
+ DirInAccessPath $slave [TranslatePath $slave \
+ [file join $virtualdir $thedir]]
+ } on error msg {
Log $slave $msg
if {$got(-nocomplain)} continue
return -code error "permission denied"
@@ -776,19 +806,19 @@ proc ::safe::AliasGlob {slave args} {
if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
return
}
- if {[catch {
- ::interp invokehidden $slave glob {*}$cmd
- } msg]} {
+ try {
+ set entries [::interp invokehidden $slave glob {*}$cmd]
+ } on error msg {
Log $slave $msg
return -code error "script error"
}
- Log $slave "GLOB < $msg" NOTICE
+ Log $slave "GLOB < $entries" NOTICE
# Translate path back to what the slave should see.
set res {}
set l [string length $dir]
- foreach p $msg {
+ foreach p $entries {
if {[string equal -length $l $dir $p]} {
set p [string replace $p 0 [expr {$l-1}] $virtualdir]
}
@@ -852,6 +882,7 @@ proc ::safe::AliasSource {slave args} {
# because we want to control [info script] in the slave so information
# doesn't leak so much. [Bug 2913625]
set old [::interp eval $slave {info script}]
+ set replacementMsg "script error"
set code [catch {
set f [open $realfile]
fconfigure $f -eofchar \032
@@ -861,14 +892,17 @@ proc ::safe::AliasSource {slave args} {
set contents [read $f]
close $f
::interp eval $slave [list info script $file]
- ::interp eval $slave $contents
} msg opt]
+ if {$code == 0} {
+ set code [catch {::interp eval $slave $contents} msg opt]
+ set replacementMsg $msg
+ }
catch {interp eval $slave [list info script $old]}
# Note that all non-errors are fine result codes from [source], so we must
# take a little care to do it properly. [Bug 2923613]
if {$code == 1} {
Log $slave $msg
- return -code error "script error"
+ return -code error $replacementMsg
}
return -code $code -options $opt $msg
}
@@ -918,30 +952,28 @@ proc ::safe::AliasLoad {slave file args} {
# file loading
# get the real path from the virtual one.
- if {[catch {
+ try {
set file [TranslatePath $slave $file]
- } msg]} {
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# check the translated path
- if {[catch {
+ try {
FileInAccessPath $slave $file
- } msg]} {
+ } on error msg {
Log $slave $msg
return -code error "permission denied (path)"
}
}
- if {[catch {
- ::interp invokehidden $slave load $file $package $target
- } msg]} {
+ try {
+ return [::interp invokehidden $slave load $file $package $target]
+ } on error msg {
Log $slave $msg
return -code error $msg
}
-
- return $msg
}
# FileInAccessPath raises an error if the file is not found in the list of
@@ -986,59 +1018,33 @@ proc ::safe::DirInAccessPath {slave dir} {
}
}
-# This procedure enables access from a safe interpreter to only a subset
-# of the subcommands of a command:
+# This procedure is used to report an attempt to use an unsafe member of an
+# ensemble command.
-proc ::safe::Subset {slave command okpat args} {
- set subcommand [lindex $args 0]
- if {[regexp $okpat $subcommand]} {
- return [$command {*}$args]
- }
+proc ::safe::BadSubcommand {slave command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
- return -code error $msg
-}
-
-# This procedure installs an alias in a slave that invokes "safesubset" in
-# the master to execute allowed subcommands. It precomputes the pattern of
-# allowed subcommands; you can use wildcards in the pattern if you wish to
-# allow subcommand abbreviation.
-#
-# Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
-
-proc ::safe::AliasSubset {slave alias target args} {
- set pat "^([join $args |])\$"
- ::interp alias $slave $alias {}\
- [namespace current]::Subset $slave $target $pat
+ return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc ::safe::AliasEncoding {slave option args} {
- # Careful; do not want empty option to get through to the [string equal]
- if {[regexp {^(name.*|convert.*|)$} $option]} {
- return [::interp invokehidden $slave encoding $option {*}$args]
- }
-
- if {[string equal -length [string length $option] $option "system"]} {
- if {[llength $args] == 0} {
- # passed all the tests , lets source it:
- if {[catch {
- set sysenc [::interp invokehidden $slave encoding system]
- } msg]} {
- Log $slave $msg
- return -code error "script error"
- }
- return $sysenc
+ # Note that [encoding dirs] is not supported in safe slaves at all
+ set subcommands {convertfrom convertto names system}
+ try {
+ set option [tcl::prefix match -error [list -level 1 -errorcode \
+ [list TCL LOOKUP INDEX option $option]] $subcommands $option]
+ # Special case: [encoding system] ok, but [encoding system foo] not
+ if {$option eq "system" && [llength $args]} {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be \"encoding system\""
}
- set msg "wrong # args: should be \"encoding system\""
- set code {TCL WRONGARGS}
- } else {
- set msg "bad option \"$option\": must be convertfrom, convertto, names, or system"
- set code [list TCL LOOKUP INDEX option $option]
+ } on error {msg options} {
+ Log $slave $msg
+ return -options $options $msg
}
- Log $slave $msg
- return -code error -errorcode $code $msg
+ tailcall ::interp invokehidden $slave encoding $option {*}$args
}
# Various minor hiding of platform features. [Bug 2913625]
generated by cgit v0.12 at 2024-06-28 21:54:48 (GMT)