safe.tcl

genesis 2000 v9.1软件下载

# 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 package
package require opt 0.1;

# Create the safe namespace
namespace eval ::safe {

    # Exported API:
    namespace export interp \
	    interpAddToAccessPath interpFindInAccessPath \
	    setLogCmd ;

# Proto/dummy declarations for auto_mkIndex
proc ::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)";
		}
	    }