summaryrefslogtreecommitdiffstats
path: root/library/safe.tcl
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-07-26 11:40:23 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-07-26 11:40:23 (GMT)
commit28382cdb6fac8d003aae6aa6f51e1f697a98b0bb (patch)
treee22eb3ddb38c85e343dae2cb0cde5ac87478437b /library/safe.tcl
parente63d03a4041d0bad29310200c93a63dbc132363d (diff)
downloadtcl-28382cdb6fac8d003aae6aa6f51e1f697a98b0bb.zip
tcl-28382cdb6fac8d003aae6aa6f51e1f697a98b0bb.tar.gz
tcl-28382cdb6fac8d003aae6aa6f51e1f697a98b0bb.tar.bz2
Use [try] to replace obscurer uses of [catch].
Diffstat (limited to 'library/safe.tcl')
-rw-r--r--library/safe.tcl452
1 files changed, 230 insertions, 222 deletions
diff --git a/library/safe.tcl b/library/safe.tcl
index afdf639..5a3d4d0 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -9,20 +9,20 @@
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: safe.tcl,v 1.17 2008/06/25 17:40:03 andreas_kupries Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.18 2009/07/26 11:40:24 dkf Exp $
#
-# The implementation is based on namespaces. These naming conventions
-# are followed:
+# The implementation is based on namespaces. These naming conventions are
+# followed:
# Private procs starts with uppercase.
# Public procs are exported and starts with lowercase
#
# Needed utilities package
-package require opt 0.4.1;
+package require opt 0.4.1
# Create the safe namespace
namespace eval ::safe {
@@ -37,8 +37,8 @@ namespace eval ::safe {
#
####
- # Make sure that our temporary variable is local to this
- # namespace. [Bug 981733]
+ # Make sure that our temporary variable is local to this namespace. [Bug
+ # 981733]
variable temp
# Share the descriptions
@@ -55,28 +55,27 @@ namespace eval ::safe {
::tcl::OptKeyRegister {
{?slave? -name {} "name of the slave (optional)"}
} ::safe::interpCreate
- # adding the flags sub programs to the command program
- # (relying on Opt's internal implementation details)
+ # adding the flags sub programs to the command program (relying on Opt's
+ # internal implementation details)
lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
# init and configure (slave is needed)
::tcl::OptKeyRegister {
{slave -name {} "name of the slave"}
} ::safe::interpIC
- # adding the flags sub programs to the command program
- # (relying on Opt's internal implementation details)
+ # adding the flags sub programs to the command program (relying on Opt's
+ # internal implementation details)
lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
# temp not needed anymore
::tcl::OptKeyDelete $temp
-
- # Helper function to resolve the dual way of specifying staticsok
- # (either by -noStatics or -statics 0)
+ # Helper function to resolve the dual way of specifying staticsok (either
+ # by -noStatics or -statics 0)
proc InterpStatics {} {
foreach v {Args statics noStatics} {
upvar $v $v
}
- set flag [::tcl::OptProcArgGiven -noStatics];
+ set flag [::tcl::OptProcArgGiven -noStatics]
if {$flag && (!$noStatics == !$statics)
&& ([::tcl::OptProcArgGiven -statics])} {
return -code error\
@@ -95,9 +94,9 @@ namespace eval ::safe {
foreach v {Args nested nestedLoadOk} {
upvar $v $v
}
- 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)
+ 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)
&& ([::tcl::OptProcArgGiven -nested])} {
return -code error\
@@ -117,7 +116,6 @@ namespace eval ::safe {
#
####
-
# Interface/entry point function and front end for "Create"
proc interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
@@ -131,7 +129,7 @@ namespace eval ::safe {
return -code error "\"$slave\" is not an interpreter"
}
InterpInit $slave $accessPath \
- [InterpStatics] [InterpNested] $deleteHook;
+ [InterpStatics] [InterpNested] $deleteHook
}
proc CheckInterp {slave} {
@@ -141,27 +139,26 @@ namespace eval ::safe {
}
}
- # Interface/entry point function and front end for "Configure"
- # This code is awfully pedestrian because it would need
- # more coupling and support between the way we store the
- # configuration values in safe::interp's and the Opt package
- # Obviously we would like an OptConfigure
- # to avoid duplicating all this code everywhere. -> TODO
- # (the app should share or access easily the program/value
- # stored by opt)
- # This is even more complicated by the boolean flags with no values
- # that we had the bad idea to support for the sake of user simplicity
- # in create/init but which makes life hard in configure...
+ # Interface/entry point function and front end for "Configure". This code
+ # is awfully pedestrian because it would need more coupling and support
+ # between the way we store the configuration values in safe::interp's and
+ # the Opt package. Obviously we would like an OptConfigure to avoid
+ # duplicating all this code everywhere.
+ # -> TODO (the app should share or access easily the program/value stored
+ # by opt)
+
+ # This is even more complicated by the boolean flags with no values that
+ # we had the bad idea to support for the sake of user simplicity in
+ # create/init but which makes life hard in configure...
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl8.1 ?)
proc interpConfigure {args} {
switch [llength $args] {
1 {
- # If we have exactly 1 argument
- # the semantic is to return all the current configuration
- # We still call OptKeyParse though we know that "slave"
- # is our given argument because it also checks
- # for the "-help" option.
+ # If we have exactly 1 argument the semantic is to return all
+ # the current configuration. We still call OptKeyParse though
+ # we know that "slave" is our given argument because it also
+ # checks for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
set res {}
@@ -172,9 +169,10 @@ namespace eval ::safe {
join $res
}
2 {
- # If we have exactly 2 arguments
- # the semantic is a "configure get"
+ # If we have exactly 2 arguments the semantic is a "configure
+ # get"
::tcl::Lassign $args slave arg
+
# get the flag sub program (we 'know' about Opt's internal
# representation of data)
set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
@@ -201,11 +199,10 @@ namespace eval ::safe {
return [list -deleteHook [Set [DeleteHookName $slave]]]
}
-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* that it is a set action
- # that the user want, so force it to use the
- # unambigous -statics ?value? instead:
+ # it is most probably a set in fact but we would need
+ # then to jump to the set part and it is not *sure*
+ # that it is a set action that the user want, so force
+ # it to use the unambigous -statics ?value? instead:
return -code error\
"ambigous query (get or set -noStatics ?)\
use -statics instead"
@@ -221,26 +218,31 @@ namespace eval ::safe {
}
}
default {
- # Otherwise we want to parse the arguments like init and create
- # did
+ # Otherwise we want to parse the arguments like init and
+ # create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
- # Get the current (and not the default) values of
- # whatever has not been given:
+
+ # Get the current (and not the default) values of whatever has
+ # not been given:
if {![::tcl::OptProcArgGiven -accessPath]} {
set doreset 1
set accessPath [Set [PathListName $slave]]
} else {
set doreset 0
}
- if {(![::tcl::OptProcArgGiven -statics]) \
- && (![::tcl::OptProcArgGiven -noStatics]) } {
+ if {
+ ![::tcl::OptProcArgGiven -statics]
+ && ![::tcl::OptProcArgGiven -noStatics]
+ } then {
set statics [Set [StaticsOkName $slave]]
} else {
set statics [InterpStatics]
}
- if {([::tcl::OptProcArgGiven -nested]) \
- || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
+ if {
+ [::tcl::OptProcArgGiven -nested] ||
+ [::tcl::OptProcArgGiven -nestedLoadOk]
+ } then {
set nested [InterpNested]
} else {
set nested [Set [NestedOkName $slave]]
@@ -262,21 +264,19 @@ namespace eval ::safe {
}
}
-
####
#
# Functions that actually implements the exported APIs
#
####
-
#
# safe::InterpCreate : doing the real job
#
- # This procedure creates a safe slave and initializes it with the
- # safe base aliases.
- # NB: slave name must be simple alphanumeric string, no spaces,
- # no (), no {},... {because the state array is stored as part of the name}
+ # This procedure creates a safe slave and initializes it with the safe
+ # base aliases.
+ # NB: slave name must be simple alphanumeric string, no spaces, no (), no
+ # {},... {because the state array is stored as part of the name}
#
# Returns the slave name.
#
@@ -310,24 +310,22 @@ namespace eval ::safe {
InterpInit $slave $access_path $staticsok $nestedok $deletehook
}
-
#
# InterpSetConfig (was setAccessPath) :
- # Sets up slave virtual auto_path and corresponding structure
- # within the master. Also sets the tcl_library in the slave
- # to be the first directory in the path.
- # Nb: If you change the path after the slave has been initialized
- # you probably need to call "auto_reset" in the slave in order that it
- # gets the right auto_index() array values.
+ # Sets up slave virtual auto_path and corresponding structure within
+ # the master. Also sets the tcl_library in the slave to be the first
+ # directory in the path.
+ # NB: If you change the path after the slave has been initialized you
+ # probably need to call "auto_reset" in the slave in order that it gets
+ # the right auto_index() array values.
proc ::safe::InterpSetConfig {slave access_path staticsok\
nestedok deletehook} {
-
# determine and store the access path if empty
if {$access_path eq ""} {
set access_path [uplevel \#0 set auto_path]
- # Make sure that tcl_library is in auto_path
- # and at the first position (needed by setAccessPath)
+ # Make sure that tcl_library is in auto_path and at the first
+ # position (needed by setAccessPath)
set where [lsearch -exact $access_path [info library]]
if {$where == -1} {
# not found, add it.
@@ -344,8 +342,8 @@ namespace eval ::safe {
}
# Add 1st level sub dirs (will searched by auto loading from tcl
- # code in the slave using glob and thus fail, so we add them
- # here so by default it works the same).
+ # code in the slave using glob and thus fail, so we add them here
+ # so by default it works the same).
set access_path [AddSubDirs $access_path]
}
@@ -369,10 +367,10 @@ namespace eval ::safe {
lappend slave_auto_path "\$[PathToken $i]"
incr i
}
- # Extend the access list with the paths used to look for Tcl
- # Modules. We safe the virtual form separately as well, as
- # syncing it with the slave has to be defered until the
- # necessary commands are present for setup.
+ # Extend the access list with the paths used to look for Tcl Modules.
+ # We save the virtual form separately as well, as syncing it with the
+ # slave has to be defered until the necessary commands are present for
+ # setup.
foreach dir [::tcl::tm::list] {
lappend access_path $dir
Set [PathToken $i $slave] $dir
@@ -395,8 +393,8 @@ namespace eval ::safe {
#
#
# FindInAccessPath:
- # Search for a real directory and returns its virtual Id
- # (including the "$")
+ # Search for a real directory and returns its virtual Id (including the
+ # "$")
proc ::safe::interpFindInAccessPath {slave path} {
set access_path [GetAccessPath $slave]
set where [lsearch -exact $access_path $path]
@@ -408,32 +406,33 @@ proc ::safe::interpFindInAccessPath {slave path} {
#
# addToAccessPath:
- # add (if needed) a real directory to access path
- # and return its virtual token (including the "$").
+ # add (if needed) a real directory to access path and return its
+ # virtual token (including the "$").
proc ::safe::interpAddToAccessPath {slave path} {
# first check if the directory is already in there
- if {![catch {interpFindInAccessPath $slave $path} res]} {
- return $res
- }
- # new one, add it:
- set nname [PathNumberName $slave]
- set n [Set $nname]
- Set [PathToken $n $slave] $path
+ try {
+ return [interpFindInAccessPath $slave $path]
+ } on error {} {
+ # new one, add it:
+ set nname [PathNumberName $slave]
+ set n [Set $nname]
+ Set [PathToken $n $slave] $path
- set token "\$[PathToken $n]"
+ set token "\$[PathToken $n]"
- Lappend [VirtualPathListName $slave] $token
- Lappend [PathListName $slave] $path
- Set $nname [expr {$n+1}]
+ Lappend [VirtualPathListName $slave] $token
+ Lappend [PathListName $slave] $path
+ Set $nname [expr {$n+1}]
- SyncAccessPath $slave
+ SyncAccessPath $slave
- return $token
+ return $token
+ }
}
# This procedure applies the initializations to an already existing
- # interpreter. It is useful when you want to install the safe base
- # aliases into a preexisting safe interpreter.
+ # interpreter. It is useful when you want to install the safe base aliases
+ # into a preexisting safe interpreter.
proc ::safe::InterpInit {
slave
access_path
@@ -441,76 +440,77 @@ proc ::safe::interpAddToAccessPath {slave path} {
nestedok
deletehook
} {
-
- # Configure will generate an access_path when access_path is
- # empty.
+ # Configure will generate an access_path when access_path is empty.
InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
# These aliases let the slave load files to define new commands
- # NB we need to add [namespace current], aliases are always
- # absolute paths.
- ::interp alias $slave source {} [namespace current]::AliasSource $slave
- ::interp alias $slave load {} [namespace current]::AliasLoad $slave
+ # NB we need to add [namespace current], aliases are always absolute
+ # paths.
+ ::interp alias $slave source {} \
+ [namespace current]::AliasSource $slave
+ ::interp alias $slave load {} \
+ [namespace current]::AliasLoad $slave
# This alias lets the slave use the encoding names, convertfrom,
- # convertto, and system, but not "encoding system <name>" to set
- # the system encoding.
+ # convertto, and system, but not "encoding system <name>" to set the
+ # system encoding.
- ::interp alias $slave encoding {} [namespace current]::AliasEncoding \
- $slave
+ ::interp alias $slave encoding {} \
+ [namespace current]::AliasEncoding $slave
# Handling Tcl Modules, we need a restricted form of Glob.
- ::interp alias $slave glob {} [namespace current]::AliasGlob \
- $slave
+ ::interp alias $slave glob {} \
+ [namespace current]::AliasGlob $slave
# 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
+ AliasSubset $slave file \
+ file dir.* join root.* ext.* tail path.* split
# This alias interposes on the 'exit' command and cleanly terminates
# the slave.
- ::interp alias $slave exit {} [namespace current]::interpDelete $slave
+ ::interp alias $slave exit {} \
+ [namespace current]::interpDelete $slave
- # The allowed slave variables already have been set
- # by Tcl_MakeSafe(3)
+ # The allowed slave variables already have been set by Tcl_MakeSafe(3)
+ # Source init.tcl and tm.tcl into the slave, to get auto_load and
+ # other procedures defined:
- # Source init.tcl and tm.tcl into the slave, to get auto_load
- # and other procedures defined:
-
- if {[catch {::interp eval $slave\
- {source [file join $tcl_library init.tcl]}} msg]} {
+ if {[catch {::interp eval $slave {
+ source [file join $tcl_library init.tcl]
+ }} msg]} then {
Log $slave "can't source init.tcl ($msg)"
error "can't source init.tcl into slave $slave ($msg)"
}
- if {[catch {::interp eval $slave \
- {source [file join $tcl_library tm.tcl]}} msg]} {
+ if {[catch {::interp eval $slave {
+ source [file join $tcl_library tm.tcl]
+ }} msg]} then {
Log $slave "can't source tm.tcl ($msg)"
error "can't source tm.tcl into slave $slave ($msg)"
}
- # Sync the paths used to search for Tcl modules. This can be
- # done only now, after tm.tcl was loaded.
- ::interp eval $slave [list ::tcl::tm::add {*}[Set [TmPathListName $slave]]]
+ # Sync the paths used to search for Tcl modules. This can be done only
+ # now, after tm.tcl was loaded.
+ ::interp eval $slave [list \
+ ::tcl::tm::add {*}[Set [TmPathListName $slave]] ]
return $slave
}
-
- # Add (only if needed, avoid duplicates) 1 level of
- # sub directories to an existing path list.
- # Also removes non directories from the returned list.
+ # Add (only if needed, avoid duplicates) 1 level of sub directories to an
+ # existing path list. Also removes non directories from the returned
+ # list.
proc AddSubDirs {pathList} {
set res {}
foreach dir $pathList {
if {[file isdirectory $dir]} {
- # check that we don't have it yet as a children
- # of a previous dir
+ # check that we don't have it yet as a children of a previous
+ # dir
if {[lsearch -exact $res $dir]<0} {
lappend res $dir
}
@@ -526,24 +526,25 @@ proc ::safe::interpAddToAccessPath {slave path} {
return $res
}
- # This procedure deletes a safe slave managed by Safe Tcl and
- # cleans up associated state:
+ # This procedure deletes a safe slave managed by Safe Tcl and cleans up
+ # associated state:
proc ::safe::interpDelete {slave} {
-
Log $slave "About to delete" NOTICE
- # If the slave has a cleanup hook registered, call it.
- # check the existance because we might be called to delete an interp
- # which has not been registered with us at all
+ # If the slave has a cleanup hook registered, call it. Check the
+ # existance because we might be called to delete an interp which has
+ # not been registered with us at all
set hookname [DeleteHookName $slave]
if {[Exists $hookname]} {
set hook [Set $hookname]
if {![::tcl::Lempty $hook]} {
- # remove the hook now, otherwise if the hook
- # calls us somehow, we'll loop
+ # remove the hook now, otherwise if the hook calls us somehow,
+ # we'll loop
Unset $hookname
- if {[catch {{*}$hook $slave} err]} {
+ try {
+ {*}$hook $slave
+ } on error err {
Log $slave "Delete hook error ($err)"
}
}
@@ -570,27 +571,24 @@ proc ::safe::interpDelete {slave} {
# Set (or get) the loging mecanism
proc ::safe::setLogCmd {args} {
- variable Log
- if {[llength $args] == 0} {
- return $Log
- } else {
- if {[llength $args] == 1} {
+ variable Log
+ if {[llength $args] == 0} {
+ return $Log
+ } elseif {[llength $args] == 1} {
set Log [lindex $args 0]
} else {
set Log $args
}
}
-}
# internal variable
variable Log {}
# ------------------- END OF PUBLIC METHODS ------------
-
#
- # sets the slave auto_path to the master recorded value.
- # also sets tcl_library to the first token of the virtual path.
+ # Sets the slave auto_path to the master recorded value. Also sets
+ # tcl_library to the first token of the virtual path.
#
proc SyncAccessPath {slave} {
set slave_auto_path [Set [VirtualPathListName $slave]]
@@ -600,12 +598,10 @@ proc ::safe::setLogCmd {args} {
::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]
}
- # base name for storing all the slave states
- # the array variable name for slave foo is thus "Sfoo"
- # and for sub slave {foo bar} "Sfoo bar" (spaces are handled
- # ok everywhere (or should))
- # We add the S prefix to avoid that a slave interp called "Log"
- # would smash our "Log" variable.
+ # Base name for storing all the slave states. The array variable name for
+ # slave foo is thus "Sfoo" and for sub slave {foo bar} "Sfoo bar" (spaces
+ # are handled ok everywhere (or should)). We add the S prefix to avoid
+ # that a slave interp called "Log" would smash our "Log" variable.
proc InterpStateName {slave} {
return "S$slave"
}
@@ -615,16 +611,14 @@ proc ::safe::setLogCmd {args} {
expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}
}
- # returns the virtual token for directory number N
- # if the slave argument is given,
- # it will return the corresponding master global variable name
+ # Returns the virtual token for directory number N. If the slave argument
+ # is given, it will return the corresponding master global variable name
proc PathToken {n {slave ""}} {
if {$slave ne ""} {
return "[InterpStateName $slave](access_path,$n)"
} else {
- # We need to have a ":" in the token string so
- # [file join] on the mac won't turn it into a relative
- # path.
+ # We need to have a ":" in the token string so [file join] on the
+ # mac won't turn it into a relative path.
return "p(:$n:)"
}
}
@@ -693,8 +687,8 @@ proc ::safe::setLogCmd {args} {
# translate virtual path into real path
#
proc TranslatePath {slave path} {
- # somehow strip the namespaces 'functionality' out (the danger
- # is that we would strip valid macintosh "../" queries... :
+ # somehow strip the namespaces 'functionality' out (the danger is that
+ # we would strip valid macintosh "../" queries... :
if {[string match "*::*" $path] || [string match "*..*" $path]} {
error "invalid characters in path $path"
}
@@ -708,8 +702,8 @@ proc ::safe::setLogCmd {args} {
}
- # Log eventually log an error
- # to enable error logging, set Log to {puts stderr} for instance
+ # Log eventually log an error; to enable error logging, set Log to {puts
+ # stderr} for instance
proc Log {slave msg {type ERROR}} {
variable Log
if {[info exists Log] && [llength $Log]} {
@@ -718,13 +712,13 @@ proc ::safe::setLogCmd {args} {
}
- # file name control (limit access to files/ressources that should be
- # a valid tcl source file)
+ # file name control (limit access to files/resources that should be a
+ # valid tcl source file)
proc CheckFileName {slave file} {
# This used to limit what can be sourced to ".tcl" and forbid files
# with more than 1 dot and longer than 14 chars, but I changed that
- # for 8.4 as a safe interp has enough internal protection already
- # to allow sourcing anything. - hobbs
+ # for 8.4 as a safe interp has enough internal protection already to
+ # allow sourcing anything. - hobbs
if {![file exists $file]} {
# don't tell the file path
@@ -750,29 +744,37 @@ proc ::safe::setLogCmd {args} {
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
-nocomplain -
- -join { lappend cmd $opt ; incr at }
+ -join {
+ lappend cmd $opt
+ incr at
+ }
-directory {
- lappend cmd $opt ; incr at
+ lappend cmd $opt
+ incr at
set virtualdir [lindex $args $at]
# get the real path from the virtual one.
- if {[catch {set dir [TranslatePath $slave $virtualdir]} msg]} {
+ try {
+ set dir [TranslatePath $slave $virtualdir]
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# check that the path is in the access path of that slave
- if {[catch {DirInAccessPath $slave $dir} msg]} {
+ try {
+ DirInAccessPath $slave $dir
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
- lappend cmd $dir ; incr at
+ lappend cmd $dir
+ incr at
}
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.
+ # 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.
error "unknown command glob"
}
-* {
@@ -780,14 +782,17 @@ proc ::safe::setLogCmd {args} {
error "Safe base rejecting glob option '$opt'"
}
default {
- lappend cmd $opt ; incr at
+ lappend cmd $opt
+ incr at
}
}
}
Log $slave "GLOB = $cmd" NOTICE
- if {[catch {::interp invokehidden $slave glob {*}$cmd} msg]} {
+ try {
+ ::interp invokehidden $slave glob {*}$cmd
+ } on error msg {
Log $slave $msg
return -code error "script error"
}
@@ -808,11 +813,9 @@ proc ::safe::setLogCmd {args} {
# AliasSource is the target of the "source" alias in safe interpreters.
proc AliasSource {slave args} {
-
set argc [llength $args]
- # Extended for handling of Tcl Modules to allow not only
- # "source filename", but "source -encoding E filename" as
- # well.
+ # Extended for handling of Tcl Modules to allow not only "source
+ # filename", but "source -encoding E filename" as well.
if {[lindex $args 0] eq "-encoding"} {
incr argc -2
set encoding [lrange $args 0 1]
@@ -829,25 +832,34 @@ proc ::safe::setLogCmd {args} {
set file [lindex $args $at]
# get the real path from the virtual one.
- if {[catch {set file [TranslatePath $slave $file]} msg]} {
+ try {
+ set file [TranslatePath $slave $file]
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# check that the path is in the access path of that slave
- if {[catch {FileInAccessPath $slave $file} msg]} {
+ try {
+ FileInAccessPath $slave $file
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# do the checks on the filename :
- if {[catch {CheckFileName $slave $file} msg]} {
+ try {
+ CheckFileName $slave $file
+ } on error msg {
Log $slave "$file:$msg"
return -code error $msg
}
# passed all the tests , lets source it:
- if {[catch {::interp invokehidden $slave source {*}$encoding $file} msg]} {
+ if {[catch {
+ # We use catch here because we want to catch non-error/ok too
+ ::interp invokehidden $slave source {*}$encoding $file
+ } msg]} then {
Log $slave $msg
return -code error "script error"
}
@@ -857,7 +869,6 @@ proc ::safe::setLogCmd {args} {
# AliasLoad is the target of the "load" alias in safe interpreters.
proc AliasLoad {slave file args} {
-
set argc [llength $args]
if {$argc > 2} {
set msg "load error: too many arguments"
@@ -868,18 +879,17 @@ proc ::safe::setLogCmd {args} {
# package name (can be empty if file is not).
set package [lindex $args 0]
- # Determine where to load. load use a relative interp path
- # and {} means self, so we can directly and safely use passed arg.
+ # Determine where to load. load use a relative interp path and {}
+ # means self, so we can directly and safely use passed arg.
set target [lindex $args 1]
if {$target ne ""} {
- # we will try to load into a sub sub interp
- # check that we want to authorize that.
+ # we will try to load into a sub sub interp; check that we want to
+ # authorize that.
if {![NestedOk $slave]} {
Log $slave "loading to a sub interp (nestedok)\
disabled (trying to load $package to $target)"
return -code error "permission denied (nested load)"
}
-
}
# Determine what kind of load is requested
@@ -899,20 +909,25 @@ proc ::safe::setLogCmd {args} {
# file loading
# get the real path from the virtual one.
- if {[catch {set file [TranslatePath $slave $file]} msg]} {
+ try {
+ set file [TranslatePath $slave $file]
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# check the translated path
- if {[catch {FileInAccessPath $slave $file} msg]} {
+ try {
+ FileInAccessPath $slave $file
+ } on error msg {
Log $slave $msg
return -code error "permission denied (path)"
}
}
- if {[catch {::interp invokehidden\
- $slave load $file $package $target} msg]} {
+ try {
+ ::interp invokehidden $slave load $file $package $target
+ } on error msg {
Log $slave $msg
return -code error $msg
}
@@ -920,14 +935,12 @@ proc ::safe::setLogCmd {args} {
return $msg
}
- # FileInAccessPath raises an error if the file is not found in
- # the list of directories contained in the (master side recorded) slave's
- # access path.
+ # FileInAccessPath raises an error if the file is not found in the list of
+ # directories contained in the (master side recorded) slave's access path.
# the security here relies on "file dirname" answering the proper
- # result.... needs checking ?
+ # result... needs checking ?
proc FileInAccessPath {slave file} {
-
set access_path [GetAccessPath $slave]
if {[file isdirectory $file]} {
@@ -942,7 +955,7 @@ proc ::safe::setLogCmd {args} {
lappend norm_access_path [file normalize $path]
}
- if {[lsearch -exact $norm_access_path $norm_parent] == -1} {
+ if {$norm_parent ni $norm_access_path} {
error "\"$file\": not in access_path"
}
}
@@ -961,13 +974,13 @@ proc ::safe::setLogCmd {args} {
lappend norm_access_path [file normalize $path]
}
- if {[lsearch -exact $norm_access_path $norm_dir] == -1} {
+ if {$norm_dir ni $norm_access_path} {
error "\"$dir\": not in access_path"
}
}
- # This procedure enables access from a safe interpreter to only a subset of
- # the subcommands of a command:
+ # This procedure enables access from a safe interpreter to only a subset
+ # of the subcommands of a command:
proc Subset {slave command okpat args} {
set subcommand [lindex $args 0]
@@ -979,20 +992,21 @@ proc ::safe::setLogCmd {args} {
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.
+ # 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 AliasSubset {slave alias target args} {
- set pat ^(; set sep ""
+ set pat "^("
+ set sep ""
foreach sub $args {
append pat $sep$sub
set sep |
}
- append pat )\$
+ append pat ")\$"
::interp alias $slave $alias {}\
[namespace current]::Subset $slave $target $pat
}
@@ -1000,7 +1014,6 @@ proc ::safe::setLogCmd {args} {
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc AliasEncoding {slave args} {
-
set argc [llength $args]
set okpat "^(name.*|convert.*)\$"
@@ -1013,23 +1026,18 @@ proc ::safe::setLogCmd {args} {
if {[string first $subcommand system] == 0} {
if {$argc == 1} {
# passed all the tests , lets source it:
- if {[catch {::interp invokehidden \
- $slave encoding system} msg]} {
+ try {
+ return [::interp invokehidden $slave encoding system]
+ } on error msg {
Log $slave $msg
return -code error "script error"
}
- } else {
- set msg "wrong # args: should be \"encoding system\""
- Log $slave $msg
- error $msg
}
+ set msg "wrong # args: should be \"encoding system\""
} else {
set msg "wrong # args: should be \"encoding option ?arg ...?\""
- Log $slave $msg
- error $msg
}
-
- return $msg
+ Log $slave $msg
+ error $msg
}
-
}