os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/safe.tcl
changeset 0 bde4ae8d615e
     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 +}