# safe.tcl --## This file provide a safe loading/sourcing mechanism for safe interpreters.# It implements a virtual path mecanism to hide the real pathnames from the# slave. It runs in a master interpreter and sets up data structure and# aliases that will be invoked when used from a slave interpreter.# # See the safe.n man page for details.## Copyright (c) 1996-1997 Sun Microsystems, Inc.## See the file "license.terms" for information on usage and redistribution# of this file, and for a DISCLAIMER OF ALL WARRANTIES.## SCCS: @(#) safe.tcl 1.21 97/08/13 15:37:22## 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 packagepackage require opt 0.1;# Create the safe namespacenamespace eval ::safe {    # Exported API:    namespace export interp \	    interpAddToAccessPath interpFindInAccessPath \	    setLogCmd ;# Proto/dummy declarations for auto_mkIndexproc ::safe::interpCreate {} {}proc ::safe::interpInit {} {}proc ::safe::interpConfigure {} {}proc ::safe::interpDelete {} {}    # Interface/entry point function and front end for "Create"    ::tcl::OptProc interpCreate {	{?slave? -name {} "name of the slave (optional)"}	{-accessPath -list {} "access path for the slave"}	{-noStatics "prevent loading of statically linked pkgs"}	{-nestedLoadOk "allow nested loading"}	{-deleteHook -script {} "delete hook"}    } {	InterpCreate $slave $accessPath \		[expr {!$noStatics}] $nestedLoadOk $deleteHook;    }    # Interface/entry point function and front end for "Init"    ::tcl::OptProc interpInit {	{slave -name {} "name of the slave"}	{-accessPath -list {} "access path for the slave"}	{-noStatics "prevent loading of statically linked pkgs"}	{-nestedLoadOk "allow nested loading"}	{-deleteHook -script {} "delete hook"}    } {	InterpInit $slave $accessPath \		[expr {!$noStatics}] $nestedLoadOk $deleteHook;    }    # Interface/entry point function and front end for "Configure"    ::tcl::OptProc interpConfigure {	{slave -name {} "name of the slave"}	{-accessPath -list {} "access path for the slave"}	{-noStatics "prevent loading of statically linked pkgs"}	{-nestedLoadOk "allow nested loading"}	{-deleteHook -script {} "delete hook"}    } {	# Check that at least one flag was given:	if {[string match "*-*" $Args]} {	    # reconfigure everything (because otherwise you can't	    # change -noStatics for instance)	    InterpConfigure $slave $accessPath \		    [expr {!$noStatics}] $nestedLoadOk $deleteHook;	    # auto_reset the slave (to completly synch the new access_path)	    if {[catch {::interp eval $slave {auto_reset}} msg]} {		Log $slave "auto_reset failed: $msg";	    }	} else {	    # none was given, lets return current values instead	    set res {}	    lappend res [list -accessPath [Set [PathListName $slave]]]	    if {![Set [StaticsOkName $slave]]} {		lappend res "-noStatics"	    }	    if {[Set [NestedOkName $slave]]} {		lappend res "-nestedLoadOk"	    }	    lappend res [list -deleteHook [Set [DeleteHookName $slave]]]	    join $res	}    }    #    # 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 {[string compare "" $slave]} {	    ::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;    }    #    # InterpConfigure (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::InterpConfigure {slave access_path staticsok\	    nestedok deletehook} {	# determine and store the access path if empty	if {[string match "" $access_path]} {	    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,\			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,\			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\		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];	    }	}	# 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 [StaticsOkName $slave] $staticsok	Set [NestedOkName $slave] $nestedok	Set [DeleteHookName $slave] $deletehook	SyncAccessPath $slave;    }    #    #    # 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";	}	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];	SyncAccessPath $slave;	return $token;    }    # This procedure applies the initializations to an already existing    # interpreter. It is useful when you want to install the safe base    # aliases into a preexisting safe interpreter.    proc ::safe::InterpInit {	slave 	access_path	staticsok	nestedok	deletehook    } {	# Configure will generate an access_path when access_path is	# empty.	InterpConfigure $slave $access_path $staticsok $nestedok $deletehook;	# These aliases let the slave load files to define new commands	# NB we need to add [namespace current], aliases are always	# absolute paths.	::interp alias $slave source {} [namespace current]::AliasSource $slave	::interp alias $slave load {} [namespace current]::AliasLoad $slave	# This alias lets the slave have access to a subset of the 'file'	# command functionality.	AliasSubset $slave file file dir.* join root.* ext.* tail \		path.* split	# This alias interposes on the 'exit' command and cleanly terminates	# the slave.	::interp alias $slave exit {} [namespace current]::interpDelete $slave	# The allowed slave variables already have been set	# by Tcl_MakeSafe(3)	# Source init.tcl into the slave, to get auto_load and other	# procedures defined:	# 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.	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)"	}	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 -nocomplain -- [file join $dir *]] {		    if {    ([file isdirectory $sub])		         && ([lsearch -exact $res $sub]<0) } {			# new sub dir, add it !	                lappend res $sub;	            }		}	    }	}	return $res;    }    # 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 $slave} err]} {		    Log $slave "Delete hook error ($err)";		}	    }