diff options
Diffstat (limited to 'library/safe.tcl')
| -rw-r--r-- | library/safe.tcl | 1682 |
1 files changed, 937 insertions, 745 deletions
diff --git a/library/safe.tcl b/library/safe.tcl index 9c8aff5..57c3619 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -9,916 +9,1108 @@ # # 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.9.2.3 2005/07/22 21:59:41 dgp Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.16.4.9 2010/11/02 21:57:19 stwo 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 { - # Exported API: namespace export interpCreate interpInit interpConfigure interpDelete \ - interpAddToAccessPath interpFindInAccessPath setLogCmd - - #### - # - # Setup the arguments parsing - # - #### - - # Make sure that our temporary variable is local to this - # namespace. [Bug 981733] - variable temp - - # Share the descriptions - set temp [::tcl::OptKeyRegister { - {-accessPath -list {} "access path for the slave"} - {-noStatics "prevent loading of statically linked pkgs"} - {-statics true "loading of statically linked pkgs"} - {-nestedLoadOk "allow nested loading"} - {-nested false "nested loading"} - {-deleteHook -script {} "delete hook"} - }] - - # create case (slave is optional) - ::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) - 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) - lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp) - # temp not needed anymore - ::tcl::OptKeyDelete $temp - + interpAddToAccessPath interpFindInAccessPath setLogCmd +} - # 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]; - if {$flag && (!$noStatics == !$statics) - && ([::tcl::OptProcArgGiven -statics])} { - return -code error\ - "conflicting values given for -statics and -noStatics" - } - if {$flag} { - return [expr {!$noStatics}] - } else { - return $statics - } +# Helper function to resolve the dual way of specifying staticsok (either +# by -noStatics or -statics 0) +proc ::safe::InterpStatics {} { + foreach v {Args statics noStatics} { + upvar $v $v + } + set flag [::tcl::OptProcArgGiven -noStatics] + if {$flag && (!$noStatics == !$statics) + && ([::tcl::OptProcArgGiven -statics])} { + return -code error\ + "conflicting values given for -statics and -noStatics" } + if {$flag} { + return [expr {!$noStatics}] + } else { + return $statics + } +} - # Helper function to resolve the dual way of specifying nested loading - # (either by -nestedLoadOk or -nested 1) - proc InterpNested {} { - 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) - if {$flag && (!$nestedLoadOk != !$nested) - && ([::tcl::OptProcArgGiven -nested])} { - return -code error\ - "conflicting values given for -nested and -nestedLoadOk" - } - if {$flag} { - # another difference with "InterpStatics" - return $nestedLoadOk - } else { - return $nested - } +# Helper function to resolve the dual way of specifying nested loading +# (either by -nestedLoadOk or -nested 1) +proc ::safe::InterpNested {} { + 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) + if {$flag && (!$nestedLoadOk != !$nested) + && ([::tcl::OptProcArgGiven -nested])} { + return -code error\ + "conflicting values given for -nested and -nestedLoadOk" + } + if {$flag} { + # another difference with "InterpStatics" + return $nestedLoadOk + } else { + return $nested } +} - #### - # - # API entry points that needs argument parsing : - # - #### +#### +# +# API entry points that needs argument parsing : +# +#### +# Interface/entry point function and front end for "Create" +proc ::safe::interpCreate {args} { + set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + InterpCreate $slave $accessPath \ + [InterpStatics] [InterpNested] $deleteHook +} - # Interface/entry point function and front end for "Create" - proc interpCreate {args} { - set Args [::tcl::OptKeyParse ::safe::interpCreate $args] - InterpCreate $slave $accessPath \ - [InterpStatics] [InterpNested] $deleteHook +proc ::safe::interpInit {args} { + set Args [::tcl::OptKeyParse ::safe::interpIC $args] + if {![::interp exists $slave]} { + return -code error "\"$slave\" is not an interpreter" } + InterpInit $slave $accessPath \ + [InterpStatics] [InterpNested] $deleteHook +} - proc interpInit {args} { - set Args [::tcl::OptKeyParse ::safe::interpIC $args] - if {![::interp exists $slave]} { - return -code error "\"$slave\" is not an interpreter" - } - InterpInit $slave $accessPath \ - [InterpStatics] [InterpNested] $deleteHook; +# Check that the given slave is "one of us" +proc ::safe::CheckInterp {slave} { + namespace upvar ::safe S$slave state + if {![info exists state] || ![::interp exists $slave]} { + return -code error \ + "\"$slave\" is not an interpreter managed by ::safe::" } +} - proc CheckInterp {slave} { - if {![IsInterp $slave]} { - return -code error \ - "\"$slave\" is not an interpreter managed by ::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... +# So this will be hopefully written and some integrated with opt1.0 +# (hopefully for tcl8.1 ?) +proc ::safe::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. + set Args [::tcl::OptKeyParse ::safe::interpIC $args] + CheckInterp $slave + namespace upvar ::safe S$slave state + + return [join [list \ + [list -accessPath $state(access_path)] \ + [list -statics $state(staticsok)] \ + [list -nested $state(nestedok)] \ + [list -deleteHook $state(cleanupHook)]]] } - } - - # 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. - set Args [::tcl::OptKeyParse ::safe::interpIC $args] - CheckInterp $slave - set res {} - lappend res [list -accessPath [Set [PathListName $slave]]] - lappend res [list -statics [Set [StaticsOkName $slave]]] - lappend res [list -nested [Set [NestedOkName $slave]]] - lappend res [list -deleteHook [Set [DeleteHookName $slave]]] - join $res + 2 { + # If we have exactly 2 arguments the semantic is a "configure + # get" + 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] + set hits [::tcl::OptHits desc $arg] + if {$hits > 1} { + return -code error [::tcl::OptAmbigous $desc $arg] + } elseif {$hits == 0} { + return -code error [::tcl::OptFlagUsage $desc $arg] } - 2 { - # 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] - set hits [::tcl::OptHits desc $arg] - if {$hits > 1} { - return -code error [::tcl::OptAmbigous $desc $arg] - } elseif {$hits == 0} { - return -code error [::tcl::OptFlagUsage $desc $arg] - } - CheckInterp $slave - set item [::tcl::OptCurDesc $desc] - set name [::tcl::OptName $item] - switch -exact -- $name { - -accessPath { - return [list -accessPath [Set [PathListName $slave]]] - } - -statics { - return [list -statics [Set [StaticsOkName $slave]]] - } - -nested { - return [list -nested [Set [NestedOkName $slave]]] - } - -deleteHook { - 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: - return -code error\ - "ambigous query (get or set -noStatics ?)\ + CheckInterp $slave + namespace upvar ::safe S$slave state + + 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)]} + -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: + return -code error\ + "ambigous query (get or set -noStatics ?)\ use -statics instead" - } - -nestedLoadOk { - return -code error\ - "ambigous query (get or set -nestedLoadOk ?)\ + } + -nestedLoadOk { + return -code error\ + "ambigous query (get or set -nestedLoadOk ?)\ use -nested instead" - } - default { - return -code error "unknown flag $name (bug)" - } } - } - default { - # 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: - if {![::tcl::OptProcArgGiven -accessPath]} { - set doreset 1 - set accessPath [Set [PathListName $slave]] - } else { - set doreset 0 + default { + return -code error "unknown flag $name (bug)" } - if {(![::tcl::OptProcArgGiven -statics]) \ - && (![::tcl::OptProcArgGiven -noStatics]) } { - set statics [Set [StaticsOkName $slave]] - } else { - set statics [InterpStatics] - } - if {([::tcl::OptProcArgGiven -nested]) \ - || ([::tcl::OptProcArgGiven -nestedLoadOk]) } { - set nested [InterpNested] + } + } + default { + # Otherwise we want to parse the arguments like init and + # create did + set Args [::tcl::OptKeyParse ::safe::interpIC $args] + CheckInterp $slave + namespace upvar ::safe S$slave state + + # Get the current (and not the default) values of whatever has + # not been given: + if {![::tcl::OptProcArgGiven -accessPath]} { + set doreset 1 + set accessPath $state(access_path) + } else { + set doreset 0 + } + if { + ![::tcl::OptProcArgGiven -statics] + && ![::tcl::OptProcArgGiven -noStatics] + } { + set statics $state(staticsok) + } else { + set statics [InterpStatics] + } + if { + [::tcl::OptProcArgGiven -nested] || + [::tcl::OptProcArgGiven -nestedLoadOk] + } { + set nested [InterpNested] + } else { + set nested $state(nestedok) + } + if {![::tcl::OptProcArgGiven -deleteHook]} { + set deleteHook $state(cleanupHook) + } + # we can now reconfigure : + InterpSetConfig $slave $accessPath $statics $nested $deleteHook + # auto_reset the slave (to completly synch the new access_path) + if {$doreset} { + if {[catch {::interp eval $slave {auto_reset}} msg]} { + Log $slave "auto_reset failed: $msg" } else { - set nested [Set [NestedOkName $slave]] - } - if {![::tcl::OptProcArgGiven -deleteHook]} { - set deleteHook [Set [DeleteHookName $slave]] - } - # we can now reconfigure : - InterpSetConfig $slave $accessPath $statics $nested $deleteHook - # auto_reset the slave (to completly synch the new access_path) - if {$doreset} { - if {[catch {::interp eval $slave {auto_reset}} msg]} { - Log $slave "auto_reset failed: $msg" - } else { - Log $slave "successful auto_reset" NOTICE - } + Log $slave "successful auto_reset" NOTICE } } } } +} +#### +# +# Functions that actually implements the exported APIs +# +#### - #### - # - # 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} - # - # Returns the slave name. - # - # 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. - # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) - # if 1 :static packages are ok. - # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) - # if 1 : multiple levels are ok. - - # use the full name and no indent so auto_mkIndex can find us - proc ::safe::InterpCreate { - slave - access_path - staticsok - nestedok - deletehook - } { - # Create the slave. - if {$slave ne ""} { - ::interp create -safe $slave - } else { - # empty argument: generate slave name - set slave [::interp create -safe] - } - Log $slave "Created" NOTICE - - # Initialize it. (returns slave name) - InterpInit $slave $access_path $staticsok $nestedok $deletehook +# +# 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} +# +# Returns the slave name. +# +# 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. +# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) +# if 1 :static packages are ok. +# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) +# if 1 : multiple levels are ok. + +# use the full name and no indent so auto_mkIndex can find us +proc ::safe::InterpCreate { + slave + access_path + staticsok + nestedok + deletehook + } { + # Create the slave. + if {$slave ne ""} { + ::interp create -safe $slave + } else { + # empty argument: generate slave name + set slave [::interp create -safe] } + Log $slave "Created" NOTICE + # Initialize it. (returns slave name) + 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. - - 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) - set where [lsearch -exact $access_path [info library]] - if {$where == -1} { - # not found, add it. - set access_path [concat [list [info library]] $access_path] - Log $slave "tcl_library was not in auto_path,\ +# +# 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. + +proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { + global auto_path + + # determine and store the access path if empty + if {$access_path eq ""} { + set access_path $auto_path + + # 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. + set access_path [linsert $access_path 0 [info library]] + Log $slave "tcl_library was not in auto_path,\ added it to slave's access_path" NOTICE - } elseif {$where != 0} { - # not first, move it first - set access_path [concat [list [info library]]\ - [lreplace $access_path $where $where]] - Log $slave "tcl_libray was not in first in auto_path,\ + } elseif {$where != 0} { + # not first, move it first + set access_path [linsert \ + [lreplace $access_path $where $where] \ + 0 [info library]] + Log $slave "tcl_libray was not in first in auto_path,\ moved it to front of slave's access_path" NOTICE - - } - - # 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). - set access_path [AddSubDirs $access_path] } - Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ + # 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). + set access_path [AddSubDirs $access_path] + } + + Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE - # clear old autopath if it existed - set nname [PathNumberName $slave] - if {[Exists $nname]} { - set n [Set $nname] - for {set i 0} {$i<$n} {incr i} { - Unset [PathToken $i $slave] - } - } + namespace upvar ::safe S$slave state + + # clear old autopath if it existed + # build new one + # 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. + + set norm_access_path {} + set slave_access_path {} + set map_access_path {} + set remap_access_path {} + set slave_tm_path {} + + set i 0 + foreach dir $access_path { + set token [PathToken $i] + lappend slave_access_path $token + lappend map_access_path $token $dir + lappend remap_access_path $dir $token + lappend norm_access_path [file normalize $dir] + incr i + } - # build new one - set slave_auto_path {} - set i 0 - foreach dir $access_path { - Set [PathToken $i $slave] $dir - lappend slave_auto_path "\$[PathToken $i]" - incr i - } - Set $nname $i - Set [PathListName $slave] $access_path - Set [VirtualPathListName $slave] $slave_auto_path + set morepaths [::tcl::tm::list] + while {[llength $morepaths]} { + set addpaths $morepaths + set morepaths {} - Set [StaticsOkName $slave] $staticsok - Set [NestedOkName $slave] $nestedok - Set [DeleteHookName $slave] $deletehook + foreach dir $addpaths { + # Prevent the addition of dirs on the tm list to the + # result if they are already known. + if {[dict exists $remap_access_path $dir]} { + continue + } - SyncAccessPath $slave - } + set token [PathToken $i] + lappend access_path $dir + lappend slave_access_path $token + lappend map_access_path $token $dir + lappend remap_access_path $dir $token + lappend norm_access_path [file normalize $dir] + lappend slave_tm_path $token + incr i - # - # - # FindInAccessPath: - # 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] - if {$where == -1} { - return -code error "$path not found in access path $access_path" + # [Bug 2854929] + # Recursively find deeper paths which may contain + # modules. Required to handle modules with names like + # 'platform::shell', which translate into + # 'platform/shell-X.tm', i.e arbitrarily deep + # subdirectories. + lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] } - return "\$[PathToken $where]" } - # - # addToAccessPath: - # 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 - - set token "\$[PathToken $n]" - - Lappend [VirtualPathListName $slave] $token - Lappend [PathListName $slave] $path - Set $nname [expr {$n+1}] + set state(access_path) $access_path + set state(access_path,map) $map_access_path + set state(access_path,remap) $remap_access_path + set state(access_path,norm) $norm_access_path + set state(access_path,slave) $slave_access_path + set state(tm_path_slave) $slave_tm_path + set state(staticsok) $staticsok + set state(nestedok) $nestedok + set state(cleanupHook) $deletehook + + SyncAccessPath $slave +} - SyncAccessPath $slave +# +# +# FindInAccessPath: +# Search for a real directory and returns its virtual Id (including the +# "$") +proc ::safe::interpFindInAccessPath {slave path} { + namespace upvar ::safe S$slave state - return $token + if {![dict exists $state(access_path,remap) $path]} { + return -code error "$path not found in access path $access_path" } - # 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. - proc ::safe::InterpInit { - slave - access_path - staticsok - nestedok - deletehook - } { - - # 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 + return [dict get $state(access_path,remap) $path] +} - # 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 +# +# addToAccessPath: +# 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 + # (inlined interpFindInAccessPath). + namespace upvar ::safe S$slave state - # This alias lets the slave use the encoding names, convertfrom, - # convertto, and system, but not "encoding system <name>" to set - # the system encoding. + if {[dict exists $state(access_path,remap) $path]} { + return [dict get $state(access_path,remap) $path] + } - ::interp alias $slave encoding {} [namespace current]::AliasEncoding \ - $slave + # new one, add it: + set token [PathToken [llength $state(access_path)]] - # This alias lets the slave have access to a subset of the 'file' - # command functionality. + lappend state(access_path) $path + lappend state(access_path,slave) $token + lappend state(access_path,map) $token $path + lappend state(access_path,remap) $path $token + lappend state(access_path,norm) [file normalize $path] - AliasSubset $slave file file dir.* join root.* ext.* tail \ - path.* split + SyncAccessPath $slave + return $token +} - # This alias interposes on the 'exit' command and cleanly terminates - # the slave. +# 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. +proc ::safe::InterpInit { + slave + access_path + staticsok + nestedok + deletehook + } { + # Configure will generate an access_path when access_path is empty. + InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook + + # NB we need to add [namespace current], aliases are always absolute + # paths. + + # These aliases let the slave load files to define new commands + # This alias lets the slave use the encoding names, convertfrom, + # convertto, and system, but not "encoding system <name>" to set the + # system encoding. + # Handling Tcl Modules, we need a restricted form of Glob. + # This alias interposes on the 'exit' command and cleanly terminates + # the slave. + + foreach {command alias} { + source AliasSource + load AliasLoad + encoding AliasEncoding + exit interpDelete + glob AliasGlob + } { + ::interp alias $slave $command {} [namespace current]::$alias $slave + } - ::interp alias $slave exit {} [namespace current]::interpDelete $slave + # This alias lets the slave have access to a subset of the 'file' + # command functionality. - # The allowed slave variables already have been set - # by Tcl_MakeSafe(3) + AliasSubset $slave file \ + file dir.* join root.* ext.* tail path.* split + # Subcommands of info + foreach {subcommand alias} { + nameofexecutable AliasExeName + } { + ::interp alias $slave ::tcl::info::$subcommand \ + {} [namespace current]::$alias $slave + } - # Source init.tcl into the slave, to get auto_load and other - # procedures defined: + # The allowed slave variables already have been set by Tcl_MakeSafe(3) - # We don't try to use the -rsrc on the mac because it would get - # confusing if you would want to customize init.tcl - # for a given set of safe slaves, on all the platforms - # you just need to give a specific access_path and - # the mac should be no exception. As there is no - # obvious full "safe ressources" design nor implementation - # for the mac, safe interps there will just don't - # have that ability. (A specific app can still reenable - # that using custom aliases if they want to). - # It would also make the security analysis and the Safe Tcl security - # model platform dependant and thus more error prone. + # 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]} { - 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 init.tcl] + }} msg]} { + Log $slave "can't source init.tcl ($msg)" + return -code error "can't source init.tcl into slave $slave ($msg)" + } - return $slave + if {[catch {::interp eval $slave { + source [file join $tcl_library tm.tcl] + }} msg]} { + Log $slave "can't source tm.tcl ($msg)" + return -code 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. + namespace upvar ::safe S$slave state + if {[llength $state(tm_path_slave)] > 0} { + ::interp eval $slave [list ::tcl::tm::add {*}$state(tm_path_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. - 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 - if {[lsearch -exact $res $dir]<0} { - lappend res $dir - } - foreach sub [glob -directory $dir -nocomplain *] { - if {([file isdirectory $sub]) \ - && ([lsearch -exact $res $sub]<0) } { - # new sub dir, add it ! - lappend res $sub - } +# 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 ::safe::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 + if {$dir ni $res} { + lappend res $dir + } + foreach sub [glob -directory $dir -nocomplain *] { + if {[file isdirectory $sub] && ($sub ni $res)} { + # new sub dir, add it ! + lappend res $sub } } } - return $res } + 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 - 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 - Unset $hookname - if {[catch {eval $hook [list $slave]} err]} { - Log $slave "Delete hook error ($err)" - } + Log $slave "About to delete" NOTICE + + namespace upvar ::safe S$slave state + + # 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 {[info exists state(cleanupHook)]} { + set hook $state(cleanupHook) + if {[llength $hook]} { + # remove the hook now, otherwise if the hook calls us somehow, + # we'll loop + unset state(cleanupHook) + if {[catch { + {*}$hook $slave + } err]} { + Log $slave "Delete hook error ($err)" } } + } - # Discard the global array of state associated with the slave, and - # delete the interpreter. + # Discard the global array of state associated with the slave, and + # delete the interpreter. - set statename [InterpStateName $slave] - if {[Exists $statename]} { - Unset $statename - } - - # if we have been called twice, the interp might have been deleted - # already - if {[::interp exists $slave]} { - ::interp delete $slave - Log $slave "Deleted" NOTICE - } + if {[info exists state]} { + unset state + } - return + # if we have been called twice, the interp might have been deleted + # already + if {[::interp exists $slave]} { + ::interp delete $slave + Log $slave "Deleted" NOTICE } - # Set (or get) the loging mecanism + return +} + +# Set (or get) the logging mecanism proc ::safe::setLogCmd {args} { variable Log - if {[llength $args] == 0} { + set la [llength $args] + if {$la == 0} { return $Log + } elseif {$la == 1} { + set Log [lindex $args 0] } else { - if {[llength $args] == 1} { - set Log [lindex $args 0] - } else { - set Log $args + set Log $args + } + + if {$Log eq ""} { + # Disable logging completely. Calls to it will be compiled out + # of all users. + proc ::safe::Log {args} {} + } else { + # Activate logging, define proper command. + + proc ::safe::Log {slave msg {type ERROR}} { + variable Log + {*}$Log "$type for slave $slave : $msg" + return } } } - # internal variable - variable Log {} +# ------------------- END OF PUBLIC METHODS ------------ - # ------------------- 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. +# +proc ::safe::SyncAccessPath {slave} { + namespace upvar ::safe S$slave state + set slave_access_path $state(access_path,slave) + ::interp eval $slave [list set auto_path $slave_access_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]] - ::interp eval $slave [list set auto_path $slave_auto_path] - Log $slave "auto_path in $slave has been set to $slave_auto_path"\ - NOTICE - ::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. - proc InterpStateName {slave} { - return "S$slave" - } - - # Check that the given slave is "one of us" - proc IsInterp {slave} { - 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 - 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. - return "p(:$n:)" - } - } - # returns the variable name of the complete path list - proc PathListName {slave} { - return "[InterpStateName $slave](access_path)" - } - # returns the variable name of the complete path list - proc VirtualPathListName {slave} { - return "[InterpStateName $slave](access_path_slave)" - } - # returns the variable name of the number of items - proc PathNumberName {slave} { - return "[InterpStateName $slave](access_path,n)" - } - # returns the staticsok flag var name - proc StaticsOkName {slave} { - return "[InterpStateName $slave](staticsok)" + Log $slave "auto_path in $slave has been set to $slave_access_path"\ + NOTICE + + # This code assumes that info library is the first element in the + # list of auto_path's. See -> InterpSetConfig for the code which + # ensures this condition. + + ::interp eval $slave [list \ + set tcl_library [lindex $slave_access_path 0]] +} + +# Returns the virtual token for directory number N. +proc ::safe::PathToken {n} { + # 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:)" ;# Form tested by case 7.2 +} + +# +# translate virtual path into real path +# +proc ::safe::TranslatePath {slave path} { + namespace upvar ::safe S$slave state + + # somehow strip the namespaces 'functionality' out (the danger is that + # we would strip valid macintosh "../" queries... : + if {[string match "*::*" $path] || [string match "*..*" $path]} { + return -code error "invalid characters in path $path" } - # returns the nestedok flag var name - proc NestedOkName {slave} { - return "[InterpStateName $slave](nestedok)" + + # Use a cached map instead of computed local vars and subst. + + return [string map $state(access_path,map) $path] +} + +# file name control (limit access to files/resources that should be a +# valid tcl source file) +proc ::safe::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 + + if {![file exists $file]} { + # don't tell the file path + return -code error "no such file or directory" } - # Run some code at the namespace toplevel - proc Toplevel {args} { - namespace eval [namespace current] $args + + if {![file readable $file]} { + # don't tell the file path + return -code error "not readable" } - # set/get values - proc Set {args} { - eval [linsert $args 0 Toplevel set] +} + +# AliasGlob is the target of the "glob" alias in safe interpreters. +proc ::safe::AliasGlob {slave args} { + Log $slave "GLOB ! $args" NOTICE + set cmd {} + set at 0 + array set got { + -directory 0 + -nocomplain 0 + -join 0 + -tails 0 + -- 0 } - # lappend on toplevel vars - proc Lappend {args} { - eval [linsert $args 0 Toplevel lappend] + + if {$::tcl_platform(platform) eq "windows"} { + set dirPartRE {^(.*)[\\/]} + } else { + set dirPartRE {^(.*)/} } - # unset a var/token (currently just an global level eval) - proc Unset {args} { - eval [linsert $args 0 Toplevel unset] + + set dir {} + set virtualdir {} + + while {$at < [llength $args]} { + switch -glob -- [set opt [lindex $args $at]] { + -nocomplain - -- - -join - -tails { + lappend cmd $opt + set got($opt) 1 + incr at + } + -types - -type { + lappend cmd -types [lindex $args [incr at]] + incr at + } + -directory { + if {$got($opt)} { + return -code error \ + {"-directory" cannot be used with "-path"} + } + set got($opt) 1 + set virtualdir [lindex $args [incr at]] + 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. + return -code error "unknown command glob" + } + -* { + Log $slave "Safe base rejecting glob option '$opt'" + return -code error "Safe base rejecting glob option '$opt'" + } + default { + break + } + } + if {$got(--)} break } - # test existance - proc Exists {varname} { - Toplevel info exists $varname + + # 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 + } + } + lappend cmd -directory $dir } - # short cut for access path getting - proc GetAccessPath {slave} { - Set [PathListName $slave] + + # Apply the -join semantics ourselves + if {$got(-join)} { + set args [lreplace $args $at end [join [lrange $args $at end] "/"]] } - # short cut for statics ok flag getting - proc StaticsOk {slave} { - Set [StaticsOkName $slave] + + # 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 } - # short cut for getting the multiples interps sub loading ok flag - proc NestedOk {slave} { - Set [NestedOkName $slave] + + Log $slave "GLOB = $cmd" NOTICE + + if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { + return } - # interp deletion storing hook name - proc DeleteHookName {slave} { - return [InterpStateName $slave](cleanupHook) + if {[catch { + ::interp invokehidden $slave glob {*}$cmd + } msg]} { + Log $slave $msg + return -code error "script error" } - # - # 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... : - if {[regexp {(::)|(\.\.)} $path]} { - error "invalid characters in path $path" - } - set n [expr {[Set [PathNumberName $slave]]-1}] - for {} {$n>=0} {incr n -1} { - # fill the token virtual names with their real value - set [PathToken $n] [Set [PathToken $n $slave]] + Log $slave "GLOB @ $msg" NOTICE + + # Translate path back to what the slave should see. + set res {} + set l [string length $dir] + foreach p $msg { + if {[string equal -length $l $dir $p]} { + set p [string replace $p 0 [expr {$l-1}] $virtualdir] } - # replaces the token by their value - subst -nobackslashes -nocommands $path + lappend res $p } + Log $slave "GLOB @ $res" NOTICE + return $res +} - # 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]} { - eval $Log [list "$type for slave $slave : $msg"] +# AliasSource is the target of the "source" alias in safe interpreters. + +proc ::safe::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. + if {[lindex $args 0] eq "-encoding"} { + incr argc -2 + set encoding [lindex $args 1] + set at 2 + if {$encoding eq "identity"} { + Log $slave "attempt to use the identity encoding" + return -code error "permission denied" } + } else { + set at 0 + set encoding {} + } + if {$argc != 1} { + set msg "wrong # args: should be \"source ?-encoding E? fileName\"" + Log $slave "$msg ($args)" + return -code error $msg + } + set file [lindex $args $at] + + # get the real path from the virtual one. + if {[catch { + set realfile [TranslatePath $slave $file] + } 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 $realfile + } msg]} { + Log $slave $msg + return -code error "permission denied" } + # do the checks on the filename : + if {[catch { + CheckFileName $slave $realfile + } msg]} { + Log $slave "$realfile:$msg" + return -code error $msg + } - # file name control (limit access to files/ressources 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 - - if {![file exists $file]} { - # don't tell the file path - error "no such file or directory" + # Passed all the tests, lets source it. Note that we do this all manually + # 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 code [catch { + set f [open $realfile] + fconfigure $f -eofchar \032 + if {$encoding ne ""} { + fconfigure $f -encoding $encoding } + set contents [read $f] + close $f + ::interp eval $slave [list info script $file] + ::interp eval $slave $contents + } msg opt] + 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 $code -options $opt $msg +} - if {![file readable $file]} { - # don't tell the file path - error "not readable" - } +# AliasLoad is the target of the "load" alias in safe interpreters. + +proc ::safe::AliasLoad {slave file args} { + set argc [llength $args] + if {$argc > 2} { + set msg "load error: too many arguments" + Log $slave "$msg ($argc) {$file $args}" + return -code error $msg } + # package name (can be empty if file is not). + set package [lindex $args 0] - # AliasSource is the target of the "source" alias in safe interpreters. + namespace upvar ::safe S$slave state - proc AliasSource {slave args} { + # 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. + if {!$state(nestedok)} { + Log $slave "loading to a sub interp (nestedok)\ + disabled (trying to load $package to $target)" + return -code error "permission denied (nested load)" + } + } - set argc [llength $args] - # Allow only "source filename" - # (and not mac specific -rsrc for instance - see comment in ::init - # for current rationale) - if {$argc != 1} { - set msg "wrong # args: should be \"source fileName\"" - Log $slave "$msg ($args)" + # Determine what kind of load is requested + if {$file eq ""} { + # static package loading + if {$package eq ""} { + set msg "load error: empty filename and no package name" + Log $slave $msg return -code error $msg } - set file [lindex $args 0] - - # get the real path from the virtual one. - if {[catch {set file [TranslatePath $slave $file]} msg]} { - Log $slave $msg - return -code error "permission denied" + if {!$state(staticsok)} { + Log $slave "static packages loading disabled\ + (trying to load $package to $target)" + return -code error "permission denied (static package)" } - - # check that the path is in the access path of that slave - if {[catch {FileInAccessPath $slave $file} msg]} { + } else { + # file loading + + # get the real path from the virtual one. + if {[catch { + set file [TranslatePath $slave $file] + } msg]} { Log $slave $msg return -code error "permission denied" } - # do the checks on the filename : - if {[catch {CheckFileName $slave $file} msg]} { - Log $slave "$file:$msg" - return -code error $msg - } - - # passed all the tests , lets source it: - if {[catch {::interp invokehidden $slave source $file} msg]} { + # check the translated path + if {[catch { + FileInAccessPath $slave $file + } msg]} { Log $slave $msg - return -code error "script error" + return -code error "permission denied (path)" } - return $msg } - # AliasLoad is the target of the "load" alias in safe interpreters. + if {[catch { + ::interp invokehidden $slave load $file $package $target + } msg]} { + Log $slave $msg + return -code error $msg + } - proc AliasLoad {slave file args} { + return $msg +} - set argc [llength $args] - if {$argc > 2} { - set msg "load error: too many arguments" - Log $slave "$msg ($argc) {$file $args}" - return -code error $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. - # 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. - 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. - 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)" - } - - } +# the security here relies on "file dirname" answering the proper +# result... needs checking ? +proc ::safe::FileInAccessPath {slave file} { + namespace upvar ::safe S$slave state + set access_path $state(access_path) - # Determine what kind of load is requested - if {$file eq ""} { - # static package loading - if {$package eq ""} { - set msg "load error: empty filename and no package name" - Log $slave $msg - return -code error $msg - } - if {![StaticsOk $slave]} { - Log $slave "static packages loading disabled\ - (trying to load $package to $target)" - return -code error "permission denied (static package)" - } - } else { - # file loading + if {[file isdirectory $file]} { + return -code error "\"$file\": is a directory" + } + set parent [file dirname $file] - # get the real path from the virtual one. - if {[catch {set file [TranslatePath $slave $file]} msg]} { - Log $slave $msg - return -code error "permission denied" - } + # Normalize paths for comparison since lsearch knows nothing of + # potential pathname anomalies. + set norm_parent [file normalize $parent] - # check the translated path - if {[catch {FileInAccessPath $slave $file} msg]} { - Log $slave $msg - return -code error "permission denied (path)" - } - } + namespace upvar ::safe S$slave state + if {$norm_parent ni $state(access_path,norm)} { + return -code error "\"$file\": not in access_path" + } +} - if {[catch {::interp invokehidden\ - $slave load $file $package $target} msg]} { - Log $slave $msg - return -code error $msg - } +proc ::safe::DirInAccessPath {slave dir} { + namespace upvar ::safe S$slave state + set access_path $state(access_path) - return $msg + if {[file isfile $dir]} { + return -code error "\"$dir\": is a file" } - # 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. + # Normalize paths for comparison since lsearch knows nothing of + # potential pathname anomalies. + set norm_dir [file normalize $dir] - # the security here relies on "file dirname" answering the proper - # result.... needs checking ? - proc FileInAccessPath {slave file} { + namespace upvar ::safe S$slave state + if {$norm_dir ni $state(access_path,norm)} { + return -code error "\"$dir\": not in access_path" + } +} - set access_path [GetAccessPath $slave] +# This procedure enables access from a safe interpreter to only a subset +# of the subcommands of a command: - if {[file isdirectory $file]} { - error "\"$file\": is a directory" - } - set parent [file dirname $file] +proc ::safe::Subset {slave command okpat args} { + set subcommand [lindex $args 0] + if {[regexp $okpat $subcommand]} { + return [$command {*}$args] + } + set msg "not allowed to invoke subcommand $subcommand of $command" + Log $slave $msg + return -code error $msg +} - # Normalize paths for comparison since lsearch knows nothing of - # potential pathname anomalies. - set norm_parent [file normalize $parent] - foreach path $access_path { - lappend norm_access_path [file normalize $path] - } +# 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... - if {[lsearch -exact $norm_access_path $norm_parent] == -1} { - error "\"$file\": not in access_path" - } - } +proc ::safe::AliasSubset {slave alias target args} { + set pat "^([join $args |])\$" + ::interp alias $slave $alias {}\ + [namespace current]::Subset $slave $target $pat +} - # This procedure enables access from a safe interpreter to only a subset of - # the subcommands of a command: +# AliasEncoding is the target of the "encoding" alias in safe interpreters. - proc Subset {slave command okpat args} { - set subcommand [lindex $args 0] - if {[regexp $okpat $subcommand]} { - return [eval [linsert $args 0 $command]] +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 } - set msg "not allowed to invoke subcommand $subcommand of $command" - Log $slave $msg - error $msg + 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] } + Log $slave $msg + return -code error -errorcode $code $msg +} + +# Various minor hiding of platform features. [Bug 2913625] + +proc ::safe::AliasExeName {slave} { + return "" +} - # 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. +proc ::safe::Setup {} { + #### + # + # Setup the arguments parsing # - # Syntax is: AliasSubset slave alias target subcommand1 subcommand2... + #### - proc AliasSubset {slave alias target args} { - set pat ^(; set sep "" - foreach sub $args { - append pat $sep$sub - set sep | - } - append pat )\$ - ::interp alias $slave $alias {}\ - [namespace current]::Subset $slave $target $pat - } + # Share the descriptions + set temp [::tcl::OptKeyRegister { + {-accessPath -list {} "access path for the slave"} + {-noStatics "prevent loading of statically linked pkgs"} + {-statics true "loading of statically linked pkgs"} + {-nestedLoadOk "allow nested loading"} + {-nested false "nested loading"} + {-deleteHook -script {} "delete hook"} + }] - # AliasEncoding is the target of the "encoding" alias in safe interpreters. + # create case (slave is optional) + ::tcl::OptKeyRegister { + {?slave? -name {} "name of the slave (optional)"} + } ::safe::interpCreate - proc AliasEncoding {slave args} { + # adding the flags sub programs to the command program (relying on Opt's + # internal implementation details) + lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp) - set argc [llength $args] + # init and configure (slave is needed) + ::tcl::OptKeyRegister { + {slave -name {} "name of the slave"} + } ::safe::interpIC - set okpat "^(name.*|convert.*)\$" - set subcommand [lindex $args 0] + # adding the flags sub programs to the command program (relying on Opt's + # internal implementation details) + lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp) - if {[regexp $okpat $subcommand]} { - return [eval [linsert $args 0 \ - ::interp invokehidden $slave encoding]] - } + # temp not needed anymore + ::tcl::OptKeyDelete $temp - if {[string first $subcommand system] == 0} { - if {$argc == 1} { - # passed all the tests , lets source it: - if {[catch {::interp invokehidden \ - $slave encoding system} msg]} { - Log $slave $msg - return -code error "script error" - } - } else { - set msg "wrong # args: should be \"encoding system\"" - Log $slave $msg - error $msg - } - } else { - set msg "wrong # args: should be \"encoding option ?arg ...?\"" - Log $slave $msg - error $msg - } + #### + # + # Default: No logging. + # + #### - return $msg - } + setLogCmd {} + + # Log eventually. + # To enable error logging, set Log to {puts stderr} for instance, + # via setLogCmd. + return +} + +namespace eval ::safe { + # internal variables + # Log command, set via 'setLogCmd'. Logging is disabled when empty. + variable Log {} + + # The package maintains a state array per slave interp under its + # control. The name of this array is S<interp-name>. This array is + # brought into scope where needed, using 'namespace upvar'. The S + # prefix is used to avoid that a slave interp called "Log" smashes + # the "Log" variable. + # + # The array's elements are: + # + # access_path : List of paths accessible to the slave. + # access_path,norm : Ditto, in normalized form. + # 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. + # staticsok : Value of option -statics + # nestedok : Value of option -nested + # cleanupHook : Value of option -deleteHook } + +::safe::Setup |