os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/safe.tcl
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/safe.tcl Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,924 @@
1.4 +# safe.tcl --
1.5 +#
1.6 +# This file provide a safe loading/sourcing mechanism for safe interpreters.
1.7 +# It implements a virtual path mecanism to hide the real pathnames from the
1.8 +# slave. It runs in a master interpreter and sets up data structure and
1.9 +# aliases that will be invoked when used from a slave interpreter.
1.10 +#
1.11 +# See the safe.n man page for details.
1.12 +#
1.13 +# Copyright (c) 1996-1997 Sun Microsystems, Inc.
1.14 +#
1.15 +# See the file "license.terms" for information on usage and redistribution
1.16 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 +#
1.18 +# RCS: @(#) $Id: safe.tcl,v 1.9.2.3 2005/07/22 21:59:41 dgp Exp $
1.19 +
1.20 +#
1.21 +# The implementation is based on namespaces. These naming conventions
1.22 +# are followed:
1.23 +# Private procs starts with uppercase.
1.24 +# Public procs are exported and starts with lowercase
1.25 +#
1.26 +
1.27 +# Needed utilities package
1.28 +package require opt 0.4.1;
1.29 +
1.30 +# Create the safe namespace
1.31 +namespace eval ::safe {
1.32 +
1.33 + # Exported API:
1.34 + namespace export interpCreate interpInit interpConfigure interpDelete \
1.35 + interpAddToAccessPath interpFindInAccessPath setLogCmd
1.36 +
1.37 + ####
1.38 + #
1.39 + # Setup the arguments parsing
1.40 + #
1.41 + ####
1.42 +
1.43 + # Make sure that our temporary variable is local to this
1.44 + # namespace. [Bug 981733]
1.45 + variable temp
1.46 +
1.47 + # Share the descriptions
1.48 + set temp [::tcl::OptKeyRegister {
1.49 + {-accessPath -list {} "access path for the slave"}
1.50 + {-noStatics "prevent loading of statically linked pkgs"}
1.51 + {-statics true "loading of statically linked pkgs"}
1.52 + {-nestedLoadOk "allow nested loading"}
1.53 + {-nested false "nested loading"}
1.54 + {-deleteHook -script {} "delete hook"}
1.55 + }]
1.56 +
1.57 + # create case (slave is optional)
1.58 + ::tcl::OptKeyRegister {
1.59 + {?slave? -name {} "name of the slave (optional)"}
1.60 + } ::safe::interpCreate
1.61 + # adding the flags sub programs to the command program
1.62 + # (relying on Opt's internal implementation details)
1.63 + lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
1.64 +
1.65 + # init and configure (slave is needed)
1.66 + ::tcl::OptKeyRegister {
1.67 + {slave -name {} "name of the slave"}
1.68 + } ::safe::interpIC
1.69 + # adding the flags sub programs to the command program
1.70 + # (relying on Opt's internal implementation details)
1.71 + lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
1.72 + # temp not needed anymore
1.73 + ::tcl::OptKeyDelete $temp
1.74 +
1.75 +
1.76 + # Helper function to resolve the dual way of specifying staticsok
1.77 + # (either by -noStatics or -statics 0)
1.78 + proc InterpStatics {} {
1.79 + foreach v {Args statics noStatics} {
1.80 + upvar $v $v
1.81 + }
1.82 + set flag [::tcl::OptProcArgGiven -noStatics];
1.83 + if {$flag && (!$noStatics == !$statics)
1.84 + && ([::tcl::OptProcArgGiven -statics])} {
1.85 + return -code error\
1.86 + "conflicting values given for -statics and -noStatics"
1.87 + }
1.88 + if {$flag} {
1.89 + return [expr {!$noStatics}]
1.90 + } else {
1.91 + return $statics
1.92 + }
1.93 + }
1.94 +
1.95 + # Helper function to resolve the dual way of specifying nested loading
1.96 + # (either by -nestedLoadOk or -nested 1)
1.97 + proc InterpNested {} {
1.98 + foreach v {Args nested nestedLoadOk} {
1.99 + upvar $v $v
1.100 + }
1.101 + set flag [::tcl::OptProcArgGiven -nestedLoadOk];
1.102 + # note that the test here is the opposite of the "InterpStatics"
1.103 + # one (it is not -noNested... because of the wanted default value)
1.104 + if {$flag && (!$nestedLoadOk != !$nested)
1.105 + && ([::tcl::OptProcArgGiven -nested])} {
1.106 + return -code error\
1.107 + "conflicting values given for -nested and -nestedLoadOk"
1.108 + }
1.109 + if {$flag} {
1.110 + # another difference with "InterpStatics"
1.111 + return $nestedLoadOk
1.112 + } else {
1.113 + return $nested
1.114 + }
1.115 + }
1.116 +
1.117 + ####
1.118 + #
1.119 + # API entry points that needs argument parsing :
1.120 + #
1.121 + ####
1.122 +
1.123 +
1.124 + # Interface/entry point function and front end for "Create"
1.125 + proc interpCreate {args} {
1.126 + set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
1.127 + InterpCreate $slave $accessPath \
1.128 + [InterpStatics] [InterpNested] $deleteHook
1.129 + }
1.130 +
1.131 + proc interpInit {args} {
1.132 + set Args [::tcl::OptKeyParse ::safe::interpIC $args]
1.133 + if {![::interp exists $slave]} {
1.134 + return -code error "\"$slave\" is not an interpreter"
1.135 + }
1.136 + InterpInit $slave $accessPath \
1.137 + [InterpStatics] [InterpNested] $deleteHook;
1.138 + }
1.139 +
1.140 + proc CheckInterp {slave} {
1.141 + if {![IsInterp $slave]} {
1.142 + return -code error \
1.143 + "\"$slave\" is not an interpreter managed by ::safe::"
1.144 + }
1.145 + }
1.146 +
1.147 + # Interface/entry point function and front end for "Configure"
1.148 + # This code is awfully pedestrian because it would need
1.149 + # more coupling and support between the way we store the
1.150 + # configuration values in safe::interp's and the Opt package
1.151 + # Obviously we would like an OptConfigure
1.152 + # to avoid duplicating all this code everywhere. -> TODO
1.153 + # (the app should share or access easily the program/value
1.154 + # stored by opt)
1.155 + # This is even more complicated by the boolean flags with no values
1.156 + # that we had the bad idea to support for the sake of user simplicity
1.157 + # in create/init but which makes life hard in configure...
1.158 + # So this will be hopefully written and some integrated with opt1.0
1.159 + # (hopefully for tcl8.1 ?)
1.160 + proc interpConfigure {args} {
1.161 + switch [llength $args] {
1.162 + 1 {
1.163 + # If we have exactly 1 argument
1.164 + # the semantic is to return all the current configuration
1.165 + # We still call OptKeyParse though we know that "slave"
1.166 + # is our given argument because it also checks
1.167 + # for the "-help" option.
1.168 + set Args [::tcl::OptKeyParse ::safe::interpIC $args]
1.169 + CheckInterp $slave
1.170 + set res {}
1.171 + lappend res [list -accessPath [Set [PathListName $slave]]]
1.172 + lappend res [list -statics [Set [StaticsOkName $slave]]]
1.173 + lappend res [list -nested [Set [NestedOkName $slave]]]
1.174 + lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
1.175 + join $res
1.176 + }
1.177 + 2 {
1.178 + # If we have exactly 2 arguments
1.179 + # the semantic is a "configure get"
1.180 + ::tcl::Lassign $args slave arg
1.181 + # get the flag sub program (we 'know' about Opt's internal
1.182 + # representation of data)
1.183 + set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
1.184 + set hits [::tcl::OptHits desc $arg]
1.185 + if {$hits > 1} {
1.186 + return -code error [::tcl::OptAmbigous $desc $arg]
1.187 + } elseif {$hits == 0} {
1.188 + return -code error [::tcl::OptFlagUsage $desc $arg]
1.189 + }
1.190 + CheckInterp $slave
1.191 + set item [::tcl::OptCurDesc $desc]
1.192 + set name [::tcl::OptName $item]
1.193 + switch -exact -- $name {
1.194 + -accessPath {
1.195 + return [list -accessPath [Set [PathListName $slave]]]
1.196 + }
1.197 + -statics {
1.198 + return [list -statics [Set [StaticsOkName $slave]]]
1.199 + }
1.200 + -nested {
1.201 + return [list -nested [Set [NestedOkName $slave]]]
1.202 + }
1.203 + -deleteHook {
1.204 + return [list -deleteHook [Set [DeleteHookName $slave]]]
1.205 + }
1.206 + -noStatics {
1.207 + # it is most probably a set in fact
1.208 + # but we would need then to jump to the set part
1.209 + # and it is not *sure* that it is a set action
1.210 + # that the user want, so force it to use the
1.211 + # unambigous -statics ?value? instead:
1.212 + return -code error\
1.213 + "ambigous query (get or set -noStatics ?)\
1.214 + use -statics instead"
1.215 + }
1.216 + -nestedLoadOk {
1.217 + return -code error\
1.218 + "ambigous query (get or set -nestedLoadOk ?)\
1.219 + use -nested instead"
1.220 + }
1.221 + default {
1.222 + return -code error "unknown flag $name (bug)"
1.223 + }
1.224 + }
1.225 + }
1.226 + default {
1.227 + # Otherwise we want to parse the arguments like init and create
1.228 + # did
1.229 + set Args [::tcl::OptKeyParse ::safe::interpIC $args]
1.230 + CheckInterp $slave
1.231 + # Get the current (and not the default) values of
1.232 + # whatever has not been given:
1.233 + if {![::tcl::OptProcArgGiven -accessPath]} {
1.234 + set doreset 1
1.235 + set accessPath [Set [PathListName $slave]]
1.236 + } else {
1.237 + set doreset 0
1.238 + }
1.239 + if {(![::tcl::OptProcArgGiven -statics]) \
1.240 + && (![::tcl::OptProcArgGiven -noStatics]) } {
1.241 + set statics [Set [StaticsOkName $slave]]
1.242 + } else {
1.243 + set statics [InterpStatics]
1.244 + }
1.245 + if {([::tcl::OptProcArgGiven -nested]) \
1.246 + || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
1.247 + set nested [InterpNested]
1.248 + } else {
1.249 + set nested [Set [NestedOkName $slave]]
1.250 + }
1.251 + if {![::tcl::OptProcArgGiven -deleteHook]} {
1.252 + set deleteHook [Set [DeleteHookName $slave]]
1.253 + }
1.254 + # we can now reconfigure :
1.255 + InterpSetConfig $slave $accessPath $statics $nested $deleteHook
1.256 + # auto_reset the slave (to completly synch the new access_path)
1.257 + if {$doreset} {
1.258 + if {[catch {::interp eval $slave {auto_reset}} msg]} {
1.259 + Log $slave "auto_reset failed: $msg"
1.260 + } else {
1.261 + Log $slave "successful auto_reset" NOTICE
1.262 + }
1.263 + }
1.264 + }
1.265 + }
1.266 + }
1.267 +
1.268 +
1.269 + ####
1.270 + #
1.271 + # Functions that actually implements the exported APIs
1.272 + #
1.273 + ####
1.274 +
1.275 +
1.276 + #
1.277 + # safe::InterpCreate : doing the real job
1.278 + #
1.279 + # This procedure creates a safe slave and initializes it with the
1.280 + # safe base aliases.
1.281 + # NB: slave name must be simple alphanumeric string, no spaces,
1.282 + # no (), no {},... {because the state array is stored as part of the name}
1.283 + #
1.284 + # Returns the slave name.
1.285 + #
1.286 + # Optional Arguments :
1.287 + # + slave name : if empty, generated name will be used
1.288 + # + access_path: path list controlling where load/source can occur,
1.289 + # if empty: the master auto_path will be used.
1.290 + # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
1.291 + # if 1 :static packages are ok.
1.292 + # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
1.293 + # if 1 : multiple levels are ok.
1.294 +
1.295 + # use the full name and no indent so auto_mkIndex can find us
1.296 + proc ::safe::InterpCreate {
1.297 + slave
1.298 + access_path
1.299 + staticsok
1.300 + nestedok
1.301 + deletehook
1.302 + } {
1.303 + # Create the slave.
1.304 + if {$slave ne ""} {
1.305 + ::interp create -safe $slave
1.306 + } else {
1.307 + # empty argument: generate slave name
1.308 + set slave [::interp create -safe]
1.309 + }
1.310 + Log $slave "Created" NOTICE
1.311 +
1.312 + # Initialize it. (returns slave name)
1.313 + InterpInit $slave $access_path $staticsok $nestedok $deletehook
1.314 + }
1.315 +
1.316 +
1.317 + #
1.318 + # InterpSetConfig (was setAccessPath) :
1.319 + # Sets up slave virtual auto_path and corresponding structure
1.320 + # within the master. Also sets the tcl_library in the slave
1.321 + # to be the first directory in the path.
1.322 + # Nb: If you change the path after the slave has been initialized
1.323 + # you probably need to call "auto_reset" in the slave in order that it
1.324 + # gets the right auto_index() array values.
1.325 +
1.326 + proc ::safe::InterpSetConfig {slave access_path staticsok\
1.327 + nestedok deletehook} {
1.328 +
1.329 + # determine and store the access path if empty
1.330 + if {$access_path eq ""} {
1.331 + set access_path [uplevel \#0 set auto_path]
1.332 + # Make sure that tcl_library is in auto_path
1.333 + # and at the first position (needed by setAccessPath)
1.334 + set where [lsearch -exact $access_path [info library]]
1.335 + if {$where == -1} {
1.336 + # not found, add it.
1.337 + set access_path [concat [list [info library]] $access_path]
1.338 + Log $slave "tcl_library was not in auto_path,\
1.339 + added it to slave's access_path" NOTICE
1.340 + } elseif {$where != 0} {
1.341 + # not first, move it first
1.342 + set access_path [concat [list [info library]]\
1.343 + [lreplace $access_path $where $where]]
1.344 + Log $slave "tcl_libray was not in first in auto_path,\
1.345 + moved it to front of slave's access_path" NOTICE
1.346 +
1.347 + }
1.348 +
1.349 + # Add 1st level sub dirs (will searched by auto loading from tcl
1.350 + # code in the slave using glob and thus fail, so we add them
1.351 + # here so by default it works the same).
1.352 + set access_path [AddSubDirs $access_path]
1.353 + }
1.354 +
1.355 + Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
1.356 + nestedok=$nestedok deletehook=($deletehook)" NOTICE
1.357 +
1.358 + # clear old autopath if it existed
1.359 + set nname [PathNumberName $slave]
1.360 + if {[Exists $nname]} {
1.361 + set n [Set $nname]
1.362 + for {set i 0} {$i<$n} {incr i} {
1.363 + Unset [PathToken $i $slave]
1.364 + }
1.365 + }
1.366 +
1.367 + # build new one
1.368 + set slave_auto_path {}
1.369 + set i 0
1.370 + foreach dir $access_path {
1.371 + Set [PathToken $i $slave] $dir
1.372 + lappend slave_auto_path "\$[PathToken $i]"
1.373 + incr i
1.374 + }
1.375 + Set $nname $i
1.376 + Set [PathListName $slave] $access_path
1.377 + Set [VirtualPathListName $slave] $slave_auto_path
1.378 +
1.379 + Set [StaticsOkName $slave] $staticsok
1.380 + Set [NestedOkName $slave] $nestedok
1.381 + Set [DeleteHookName $slave] $deletehook
1.382 +
1.383 + SyncAccessPath $slave
1.384 + }
1.385 +
1.386 + #
1.387 + #
1.388 + # FindInAccessPath:
1.389 + # Search for a real directory and returns its virtual Id
1.390 + # (including the "$")
1.391 +proc ::safe::interpFindInAccessPath {slave path} {
1.392 + set access_path [GetAccessPath $slave]
1.393 + set where [lsearch -exact $access_path $path]
1.394 + if {$where == -1} {
1.395 + return -code error "$path not found in access path $access_path"
1.396 + }
1.397 + return "\$[PathToken $where]"
1.398 + }
1.399 +
1.400 + #
1.401 + # addToAccessPath:
1.402 + # add (if needed) a real directory to access path
1.403 + # and return its virtual token (including the "$").
1.404 +proc ::safe::interpAddToAccessPath {slave path} {
1.405 + # first check if the directory is already in there
1.406 + if {![catch {interpFindInAccessPath $slave $path} res]} {
1.407 + return $res
1.408 + }
1.409 + # new one, add it:
1.410 + set nname [PathNumberName $slave]
1.411 + set n [Set $nname]
1.412 + Set [PathToken $n $slave] $path
1.413 +
1.414 + set token "\$[PathToken $n]"
1.415 +
1.416 + Lappend [VirtualPathListName $slave] $token
1.417 + Lappend [PathListName $slave] $path
1.418 + Set $nname [expr {$n+1}]
1.419 +
1.420 + SyncAccessPath $slave
1.421 +
1.422 + return $token
1.423 + }
1.424 +
1.425 + # This procedure applies the initializations to an already existing
1.426 + # interpreter. It is useful when you want to install the safe base
1.427 + # aliases into a preexisting safe interpreter.
1.428 + proc ::safe::InterpInit {
1.429 + slave
1.430 + access_path
1.431 + staticsok
1.432 + nestedok
1.433 + deletehook
1.434 + } {
1.435 +
1.436 + # Configure will generate an access_path when access_path is
1.437 + # empty.
1.438 + InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
1.439 +
1.440 + # These aliases let the slave load files to define new commands
1.441 +
1.442 + # NB we need to add [namespace current], aliases are always
1.443 + # absolute paths.
1.444 + ::interp alias $slave source {} [namespace current]::AliasSource $slave
1.445 + ::interp alias $slave load {} [namespace current]::AliasLoad $slave
1.446 +
1.447 + # This alias lets the slave use the encoding names, convertfrom,
1.448 + # convertto, and system, but not "encoding system <name>" to set
1.449 + # the system encoding.
1.450 +
1.451 + ::interp alias $slave encoding {} [namespace current]::AliasEncoding \
1.452 + $slave
1.453 +
1.454 + # This alias lets the slave have access to a subset of the 'file'
1.455 + # command functionality.
1.456 +
1.457 + AliasSubset $slave file file dir.* join root.* ext.* tail \
1.458 + path.* split
1.459 +
1.460 + # This alias interposes on the 'exit' command and cleanly terminates
1.461 + # the slave.
1.462 +
1.463 + ::interp alias $slave exit {} [namespace current]::interpDelete $slave
1.464 +
1.465 + # The allowed slave variables already have been set
1.466 + # by Tcl_MakeSafe(3)
1.467 +
1.468 +
1.469 + # Source init.tcl into the slave, to get auto_load and other
1.470 + # procedures defined:
1.471 +
1.472 + # We don't try to use the -rsrc on the mac because it would get
1.473 + # confusing if you would want to customize init.tcl
1.474 + # for a given set of safe slaves, on all the platforms
1.475 + # you just need to give a specific access_path and
1.476 + # the mac should be no exception. As there is no
1.477 + # obvious full "safe ressources" design nor implementation
1.478 + # for the mac, safe interps there will just don't
1.479 + # have that ability. (A specific app can still reenable
1.480 + # that using custom aliases if they want to).
1.481 + # It would also make the security analysis and the Safe Tcl security
1.482 + # model platform dependant and thus more error prone.
1.483 +
1.484 + if {[catch {::interp eval $slave\
1.485 + {source [file join $tcl_library init.tcl]}} msg]} {
1.486 + Log $slave "can't source init.tcl ($msg)"
1.487 + error "can't source init.tcl into slave $slave ($msg)"
1.488 + }
1.489 +
1.490 + return $slave
1.491 + }
1.492 +
1.493 +
1.494 + # Add (only if needed, avoid duplicates) 1 level of
1.495 + # sub directories to an existing path list.
1.496 + # Also removes non directories from the returned list.
1.497 + proc AddSubDirs {pathList} {
1.498 + set res {}
1.499 + foreach dir $pathList {
1.500 + if {[file isdirectory $dir]} {
1.501 + # check that we don't have it yet as a children
1.502 + # of a previous dir
1.503 + if {[lsearch -exact $res $dir]<0} {
1.504 + lappend res $dir
1.505 + }
1.506 + foreach sub [glob -directory $dir -nocomplain *] {
1.507 + if {([file isdirectory $sub]) \
1.508 + && ([lsearch -exact $res $sub]<0) } {
1.509 + # new sub dir, add it !
1.510 + lappend res $sub
1.511 + }
1.512 + }
1.513 + }
1.514 + }
1.515 + return $res
1.516 + }
1.517 +
1.518 + # This procedure deletes a safe slave managed by Safe Tcl and
1.519 + # cleans up associated state:
1.520 +
1.521 +proc ::safe::interpDelete {slave} {
1.522 +
1.523 + Log $slave "About to delete" NOTICE
1.524 +
1.525 + # If the slave has a cleanup hook registered, call it.
1.526 + # check the existance because we might be called to delete an interp
1.527 + # which has not been registered with us at all
1.528 + set hookname [DeleteHookName $slave]
1.529 + if {[Exists $hookname]} {
1.530 + set hook [Set $hookname]
1.531 + if {![::tcl::Lempty $hook]} {
1.532 + # remove the hook now, otherwise if the hook
1.533 + # calls us somehow, we'll loop
1.534 + Unset $hookname
1.535 + if {[catch {eval $hook [list $slave]} err]} {
1.536 + Log $slave "Delete hook error ($err)"
1.537 + }
1.538 + }
1.539 + }
1.540 +
1.541 + # Discard the global array of state associated with the slave, and
1.542 + # delete the interpreter.
1.543 +
1.544 + set statename [InterpStateName $slave]
1.545 + if {[Exists $statename]} {
1.546 + Unset $statename
1.547 + }
1.548 +
1.549 + # if we have been called twice, the interp might have been deleted
1.550 + # already
1.551 + if {[::interp exists $slave]} {
1.552 + ::interp delete $slave
1.553 + Log $slave "Deleted" NOTICE
1.554 + }
1.555 +
1.556 + return
1.557 + }
1.558 +
1.559 + # Set (or get) the loging mecanism
1.560 +
1.561 +proc ::safe::setLogCmd {args} {
1.562 + variable Log
1.563 + if {[llength $args] == 0} {
1.564 + return $Log
1.565 + } else {
1.566 + if {[llength $args] == 1} {
1.567 + set Log [lindex $args 0]
1.568 + } else {
1.569 + set Log $args
1.570 + }
1.571 + }
1.572 +}
1.573 +
1.574 + # internal variable
1.575 + variable Log {}
1.576 +
1.577 + # ------------------- END OF PUBLIC METHODS ------------
1.578 +
1.579 +
1.580 + #
1.581 + # sets the slave auto_path to the master recorded value.
1.582 + # also sets tcl_library to the first token of the virtual path.
1.583 + #
1.584 + proc SyncAccessPath {slave} {
1.585 + set slave_auto_path [Set [VirtualPathListName $slave]]
1.586 + ::interp eval $slave [list set auto_path $slave_auto_path]
1.587 + Log $slave "auto_path in $slave has been set to $slave_auto_path"\
1.588 + NOTICE
1.589 + ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]
1.590 + }
1.591 +
1.592 + # base name for storing all the slave states
1.593 + # the array variable name for slave foo is thus "Sfoo"
1.594 + # and for sub slave {foo bar} "Sfoo bar" (spaces are handled
1.595 + # ok everywhere (or should))
1.596 + # We add the S prefix to avoid that a slave interp called "Log"
1.597 + # would smash our "Log" variable.
1.598 + proc InterpStateName {slave} {
1.599 + return "S$slave"
1.600 + }
1.601 +
1.602 + # Check that the given slave is "one of us"
1.603 + proc IsInterp {slave} {
1.604 + expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}
1.605 + }
1.606 +
1.607 + # returns the virtual token for directory number N
1.608 + # if the slave argument is given,
1.609 + # it will return the corresponding master global variable name
1.610 + proc PathToken {n {slave ""}} {
1.611 + if {$slave ne ""} {
1.612 + return "[InterpStateName $slave](access_path,$n)"
1.613 + } else {
1.614 + # We need to have a ":" in the token string so
1.615 + # [file join] on the mac won't turn it into a relative
1.616 + # path.
1.617 + return "p(:$n:)"
1.618 + }
1.619 + }
1.620 + # returns the variable name of the complete path list
1.621 + proc PathListName {slave} {
1.622 + return "[InterpStateName $slave](access_path)"
1.623 + }
1.624 + # returns the variable name of the complete path list
1.625 + proc VirtualPathListName {slave} {
1.626 + return "[InterpStateName $slave](access_path_slave)"
1.627 + }
1.628 + # returns the variable name of the number of items
1.629 + proc PathNumberName {slave} {
1.630 + return "[InterpStateName $slave](access_path,n)"
1.631 + }
1.632 + # returns the staticsok flag var name
1.633 + proc StaticsOkName {slave} {
1.634 + return "[InterpStateName $slave](staticsok)"
1.635 + }
1.636 + # returns the nestedok flag var name
1.637 + proc NestedOkName {slave} {
1.638 + return "[InterpStateName $slave](nestedok)"
1.639 + }
1.640 + # Run some code at the namespace toplevel
1.641 + proc Toplevel {args} {
1.642 + namespace eval [namespace current] $args
1.643 + }
1.644 + # set/get values
1.645 + proc Set {args} {
1.646 + eval [linsert $args 0 Toplevel set]
1.647 + }
1.648 + # lappend on toplevel vars
1.649 + proc Lappend {args} {
1.650 + eval [linsert $args 0 Toplevel lappend]
1.651 + }
1.652 + # unset a var/token (currently just an global level eval)
1.653 + proc Unset {args} {
1.654 + eval [linsert $args 0 Toplevel unset]
1.655 + }
1.656 + # test existance
1.657 + proc Exists {varname} {
1.658 + Toplevel info exists $varname
1.659 + }
1.660 + # short cut for access path getting
1.661 + proc GetAccessPath {slave} {
1.662 + Set [PathListName $slave]
1.663 + }
1.664 + # short cut for statics ok flag getting
1.665 + proc StaticsOk {slave} {
1.666 + Set [StaticsOkName $slave]
1.667 + }
1.668 + # short cut for getting the multiples interps sub loading ok flag
1.669 + proc NestedOk {slave} {
1.670 + Set [NestedOkName $slave]
1.671 + }
1.672 + # interp deletion storing hook name
1.673 + proc DeleteHookName {slave} {
1.674 + return [InterpStateName $slave](cleanupHook)
1.675 + }
1.676 +
1.677 + #
1.678 + # translate virtual path into real path
1.679 + #
1.680 + proc TranslatePath {slave path} {
1.681 + # somehow strip the namespaces 'functionality' out (the danger
1.682 + # is that we would strip valid macintosh "../" queries... :
1.683 + if {[regexp {(::)|(\.\.)} $path]} {
1.684 + error "invalid characters in path $path"
1.685 + }
1.686 + set n [expr {[Set [PathNumberName $slave]]-1}]
1.687 + for {} {$n>=0} {incr n -1} {
1.688 + # fill the token virtual names with their real value
1.689 + set [PathToken $n] [Set [PathToken $n $slave]]
1.690 + }
1.691 + # replaces the token by their value
1.692 + subst -nobackslashes -nocommands $path
1.693 + }
1.694 +
1.695 +
1.696 + # Log eventually log an error
1.697 + # to enable error logging, set Log to {puts stderr} for instance
1.698 + proc Log {slave msg {type ERROR}} {
1.699 + variable Log
1.700 + if {[info exists Log] && [llength $Log]} {
1.701 + eval $Log [list "$type for slave $slave : $msg"]
1.702 + }
1.703 + }
1.704 +
1.705 +
1.706 + # file name control (limit access to files/ressources that should be
1.707 + # a valid tcl source file)
1.708 + proc CheckFileName {slave file} {
1.709 + # This used to limit what can be sourced to ".tcl" and forbid files
1.710 + # with more than 1 dot and longer than 14 chars, but I changed that
1.711 + # for 8.4 as a safe interp has enough internal protection already
1.712 + # to allow sourcing anything. - hobbs
1.713 +
1.714 + if {![file exists $file]} {
1.715 + # don't tell the file path
1.716 + error "no such file or directory"
1.717 + }
1.718 +
1.719 + if {![file readable $file]} {
1.720 + # don't tell the file path
1.721 + error "not readable"
1.722 + }
1.723 + }
1.724 +
1.725 +
1.726 + # AliasSource is the target of the "source" alias in safe interpreters.
1.727 +
1.728 + proc AliasSource {slave args} {
1.729 +
1.730 + set argc [llength $args]
1.731 + # Allow only "source filename"
1.732 + # (and not mac specific -rsrc for instance - see comment in ::init
1.733 + # for current rationale)
1.734 + if {$argc != 1} {
1.735 + set msg "wrong # args: should be \"source fileName\""
1.736 + Log $slave "$msg ($args)"
1.737 + return -code error $msg
1.738 + }
1.739 + set file [lindex $args 0]
1.740 +
1.741 + # get the real path from the virtual one.
1.742 + if {[catch {set file [TranslatePath $slave $file]} msg]} {
1.743 + Log $slave $msg
1.744 + return -code error "permission denied"
1.745 + }
1.746 +
1.747 + # check that the path is in the access path of that slave
1.748 + if {[catch {FileInAccessPath $slave $file} msg]} {
1.749 + Log $slave $msg
1.750 + return -code error "permission denied"
1.751 + }
1.752 +
1.753 + # do the checks on the filename :
1.754 + if {[catch {CheckFileName $slave $file} msg]} {
1.755 + Log $slave "$file:$msg"
1.756 + return -code error $msg
1.757 + }
1.758 +
1.759 + # passed all the tests , lets source it:
1.760 + if {[catch {::interp invokehidden $slave source $file} msg]} {
1.761 + Log $slave $msg
1.762 + return -code error "script error"
1.763 + }
1.764 + return $msg
1.765 + }
1.766 +
1.767 + # AliasLoad is the target of the "load" alias in safe interpreters.
1.768 +
1.769 + proc AliasLoad {slave file args} {
1.770 +
1.771 + set argc [llength $args]
1.772 + if {$argc > 2} {
1.773 + set msg "load error: too many arguments"
1.774 + Log $slave "$msg ($argc) {$file $args}"
1.775 + return -code error $msg
1.776 + }
1.777 +
1.778 + # package name (can be empty if file is not).
1.779 + set package [lindex $args 0]
1.780 +
1.781 + # Determine where to load. load use a relative interp path
1.782 + # and {} means self, so we can directly and safely use passed arg.
1.783 + set target [lindex $args 1]
1.784 + if {$target ne ""} {
1.785 + # we will try to load into a sub sub interp
1.786 + # check that we want to authorize that.
1.787 + if {![NestedOk $slave]} {
1.788 + Log $slave "loading to a sub interp (nestedok)\
1.789 + disabled (trying to load $package to $target)"
1.790 + return -code error "permission denied (nested load)"
1.791 + }
1.792 +
1.793 + }
1.794 +
1.795 + # Determine what kind of load is requested
1.796 + if {$file eq ""} {
1.797 + # static package loading
1.798 + if {$package eq ""} {
1.799 + set msg "load error: empty filename and no package name"
1.800 + Log $slave $msg
1.801 + return -code error $msg
1.802 + }
1.803 + if {![StaticsOk $slave]} {
1.804 + Log $slave "static packages loading disabled\
1.805 + (trying to load $package to $target)"
1.806 + return -code error "permission denied (static package)"
1.807 + }
1.808 + } else {
1.809 + # file loading
1.810 +
1.811 + # get the real path from the virtual one.
1.812 + if {[catch {set file [TranslatePath $slave $file]} msg]} {
1.813 + Log $slave $msg
1.814 + return -code error "permission denied"
1.815 + }
1.816 +
1.817 + # check the translated path
1.818 + if {[catch {FileInAccessPath $slave $file} msg]} {
1.819 + Log $slave $msg
1.820 + return -code error "permission denied (path)"
1.821 + }
1.822 + }
1.823 +
1.824 + if {[catch {::interp invokehidden\
1.825 + $slave load $file $package $target} msg]} {
1.826 + Log $slave $msg
1.827 + return -code error $msg
1.828 + }
1.829 +
1.830 + return $msg
1.831 + }
1.832 +
1.833 + # FileInAccessPath raises an error if the file is not found in
1.834 + # the list of directories contained in the (master side recorded) slave's
1.835 + # access path.
1.836 +
1.837 + # the security here relies on "file dirname" answering the proper
1.838 + # result.... needs checking ?
1.839 + proc FileInAccessPath {slave file} {
1.840 +
1.841 + set access_path [GetAccessPath $slave]
1.842 +
1.843 + if {[file isdirectory $file]} {
1.844 + error "\"$file\": is a directory"
1.845 + }
1.846 + set parent [file dirname $file]
1.847 +
1.848 + # Normalize paths for comparison since lsearch knows nothing of
1.849 + # potential pathname anomalies.
1.850 + set norm_parent [file normalize $parent]
1.851 + foreach path $access_path {
1.852 + lappend norm_access_path [file normalize $path]
1.853 + }
1.854 +
1.855 + if {[lsearch -exact $norm_access_path $norm_parent] == -1} {
1.856 + error "\"$file\": not in access_path"
1.857 + }
1.858 + }
1.859 +
1.860 + # This procedure enables access from a safe interpreter to only a subset of
1.861 + # the subcommands of a command:
1.862 +
1.863 + proc Subset {slave command okpat args} {
1.864 + set subcommand [lindex $args 0]
1.865 + if {[regexp $okpat $subcommand]} {
1.866 + return [eval [linsert $args 0 $command]]
1.867 + }
1.868 + set msg "not allowed to invoke subcommand $subcommand of $command"
1.869 + Log $slave $msg
1.870 + error $msg
1.871 + }
1.872 +
1.873 + # This procedure installs an alias in a slave that invokes "safesubset"
1.874 + # in the master to execute allowed subcommands. It precomputes the pattern
1.875 + # of allowed subcommands; you can use wildcards in the pattern if you wish
1.876 + # to allow subcommand abbreviation.
1.877 + #
1.878 + # Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
1.879 +
1.880 + proc AliasSubset {slave alias target args} {
1.881 + set pat ^(; set sep ""
1.882 + foreach sub $args {
1.883 + append pat $sep$sub
1.884 + set sep |
1.885 + }
1.886 + append pat )\$
1.887 + ::interp alias $slave $alias {}\
1.888 + [namespace current]::Subset $slave $target $pat
1.889 + }
1.890 +
1.891 + # AliasEncoding is the target of the "encoding" alias in safe interpreters.
1.892 +
1.893 + proc AliasEncoding {slave args} {
1.894 +
1.895 + set argc [llength $args]
1.896 +
1.897 + set okpat "^(name.*|convert.*)\$"
1.898 + set subcommand [lindex $args 0]
1.899 +
1.900 + if {[regexp $okpat $subcommand]} {
1.901 + return [eval [linsert $args 0 \
1.902 + ::interp invokehidden $slave encoding]]
1.903 + }
1.904 +
1.905 + if {[string first $subcommand system] == 0} {
1.906 + if {$argc == 1} {
1.907 + # passed all the tests , lets source it:
1.908 + if {[catch {::interp invokehidden \
1.909 + $slave encoding system} msg]} {
1.910 + Log $slave $msg
1.911 + return -code error "script error"
1.912 + }
1.913 + } else {
1.914 + set msg "wrong # args: should be \"encoding system\""
1.915 + Log $slave $msg
1.916 + error $msg
1.917 + }
1.918 + } else {
1.919 + set msg "wrong # args: should be \"encoding option ?arg ...?\""
1.920 + Log $slave $msg
1.921 + error $msg
1.922 + }
1.923 +
1.924 + return $msg
1.925 + }
1.926 +
1.927 +}