summaryrefslogtreecommitdiffstats
path: root/library/safe.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/safe.tcl')
-rw-r--r--library/safe.tcl164
1 files changed, 76 insertions, 88 deletions
diff --git a/library/safe.tcl b/library/safe.tcl
index 1a340a1..52f6e85 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -4,7 +4,7 @@
# It implements a virtual path mecanism to hide the real pathnames from the
# slave. It runs in a master interpreter and sets up data structure and
# aliases that will be invoked when used from a slave interpreter.
-#
+#
# See the safe.n man page for details.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
@@ -36,7 +36,7 @@ proc ::safe::InterpStatics {} {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -noStatics]
- if {$flag && (!$noStatics == !$statics)
+ if {$flag && (!$noStatics == !$statics)
&& ([::tcl::OptProcArgGiven -statics])} {
return -code error\
"conflicting values given for -statics and -noStatics"
@@ -57,7 +57,7 @@ proc ::safe::InterpNested {} {
set flag [::tcl::OptProcArgGiven -nestedLoadOk]
# note that the test here is the opposite of the "InterpStatics" one
# (it is not -noNested... because of the wanted default value)
- if {$flag && (!$nestedLoadOk != !$nested)
+ if {$flag && (!$nestedLoadOk != !$nested)
&& ([::tcl::OptProcArgGiven -nested])} {
return -code error\
"conflicting values given for -nested and -nestedLoadOk"
@@ -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)
@@ -238,7 +246,7 @@ proc ::safe::interpConfigure {args} {
#
# Returns the slave name.
#
-# Optional Arguments :
+# Optional Arguments :
# + slave name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
# if empty: the master auto_path will be used.
@@ -249,7 +257,7 @@ proc ::safe::interpConfigure {args} {
# use the full name and no indent so auto_mkIndex can find us
proc ::safe::InterpCreate {
- slave
+ slave
access_path
staticsok
nestedok
@@ -424,7 +432,7 @@ proc ::safe::interpAddToAccessPath {slave path} {
# interpreter. It is useful when you want to install the safe base aliases
# into a preexisting safe interpreter.
proc ::safe::InterpInit {
- slave
+ slave
access_path
staticsok
nestedok
@@ -457,8 +465,18 @@ 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 {} file $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} {
@@ -538,9 +556,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)"
}
}
@@ -563,7 +581,7 @@ proc ::safe::interpDelete {slave} {
return
}
-# Set (or get) the logging mecanism
+# Set (or get) the logging mecanism
proc ::safe::setLogCmd {args} {
variable Log
@@ -658,6 +676,7 @@ proc ::safe::CheckFileName {slave file} {
}
# 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 +740,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
@@ -745,25 +762,24 @@ proc ::safe::AliasGlob {slave args} {
if {![regexp $dirPartRE $opt -> thedir thefile]} {
set 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 +792,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]
}
@@ -918,30 +934,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 +1000,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-11-06 08:44:42 (GMT)