3 # This file provide a safe loading/sourcing mechanism for safe interpreters.
4 # It implements a virtual path mecanism to hide the real pathnames from the
5 # slave. It runs in a master interpreter and sets up data structure and
6 # aliases that will be invoked when used from a slave interpreter.
8 # See the safe.n man page for details.
10 # Copyright (c) 1996-1997 Sun Microsystems, Inc.
12 # See the file "license.terms" for information on usage and redistribution of
13 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 # RCS: @(#) $Id: safe.tcl,v 1.16.4.8 2010/09/02 18:30:29 andreas_kupries Exp $
18 # The implementation is based on namespaces. These naming conventions are
20 # Private procs starts with uppercase.
21 # Public procs are exported and starts with lowercase
24 # Needed utilities package
25 package require opt
0.4.1
27 # Create the safe namespace
28 namespace eval ::safe {
30 namespace export interpCreate interpInit interpConfigure interpDelete
\
31 interpAddToAccessPath interpFindInAccessPath setLogCmd
34 # Helper function to resolve the dual way of specifying staticsok (either
35 # by -noStatics or -statics 0)
36 proc ::safe::InterpStatics {} {
37 foreach v
{Args statics noStatics
} {
40 set flag
[::tcl::OptProcArgGiven -noStatics]
41 if {$flag && (!$noStatics == !$statics)
42 && ([::tcl::OptProcArgGiven -statics])} {
44 "conflicting values given for -statics and -noStatics"
47 return [expr {!$noStatics}]
53 # Helper function to resolve the dual way of specifying nested loading
54 # (either by -nestedLoadOk or -nested 1)
55 proc ::safe::InterpNested {} {
56 foreach v
{Args nested nestedLoadOk
} {
59 set flag
[::tcl::OptProcArgGiven -nestedLoadOk]
60 # note that the test here is the opposite of the "InterpStatics" one
61 # (it is not -noNested... because of the wanted default value)
62 if {$flag && (!$nestedLoadOk != !$nested)
63 && ([::tcl::OptProcArgGiven -nested])} {
65 "conflicting values given for -nested and -nestedLoadOk"
68 # another difference with "InterpStatics"
77 # API entry points that needs argument parsing :
81 # Interface/entry point function and front end for "Create"
82 proc ::safe::interpCreate {args
} {
83 set Args
[::tcl::OptKeyParse ::safe::interpCreate $args]
84 InterpCreate
$slave $accessPath \
85 [InterpStatics
] [InterpNested
] $deleteHook
88 proc ::safe::interpInit {args
} {
89 set Args
[::tcl::OptKeyParse ::safe::interpIC $args]
90 if {![::interp exists
$slave]} {
91 return -code error "\"$slave\" is not an interpreter"
93 InterpInit
$slave $accessPath \
94 [InterpStatics
] [InterpNested
] $deleteHook
97 # Check that the given slave is "one of us"
98 proc ::safe::CheckInterp {slave
} {
99 namespace upvar ::safe S
$slave state
100 if {![info exists state
] ||
![::interp exists
$slave]} {
102 "\"$slave\" is not an interpreter managed by ::safe::"
106 # Interface/entry point function and front end for "Configure". This code
107 # is awfully pedestrian because it would need more coupling and support
108 # between the way we store the configuration values in safe::interp's and
109 # the Opt package. Obviously we would like an OptConfigure to avoid
110 # duplicating all this code everywhere.
111 # -> TODO (the app should share or access easily the program/value stored
114 # This is even more complicated by the boolean flags with no values that
115 # we had the bad idea to support for the sake of user simplicity in
116 # create/init but which makes life hard in configure...
117 # So this will be hopefully written and some integrated with opt1.0
118 # (hopefully for tcl8.1 ?)
119 proc ::safe::interpConfigure {args
} {
120 switch [llength $args] {
122 # If we have exactly 1 argument the semantic is to return all
123 # the current configuration. We still call OptKeyParse though
124 # we know that "slave" is our given argument because it also
125 # checks for the "-help" option.
126 set Args
[::tcl::OptKeyParse ::safe::interpIC $args]
128 namespace upvar ::safe S
$slave state
131 [list -accessPath $state(access_path
)] \
132 [list -statics $state(staticsok
)] \
133 [list -nested $state(nestedok
)] \
134 [list -deleteHook $state(cleanupHook
)]]]
137 # If we have exactly 2 arguments the semantic is a "configure
139 lassign
$args slave arg
141 # get the flag sub program (we 'know' about Opt's internal
142 # representation of data)
143 set desc
[lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
144 set hits
[::tcl::OptHits desc
$arg]
146 return -code error [::tcl::OptAmbigous $desc $arg]
147 } elseif
{$hits == 0} {
148 return -code error [::tcl::OptFlagUsage $desc $arg]
151 namespace upvar ::safe S
$slave state
153 set item
[::tcl::OptCurDesc $desc]
154 set name
[::tcl::OptName $item]
155 switch -exact -- $name {
156 -accessPath {return [list -accessPath $state(access_path
)]}
157 -statics {return [list -statics $state(staticsok
)]}
158 -nested {return [list -nested $state(nestedok
)]}
159 -deleteHook {return [list -deleteHook $state(cleanupHook
)]}
161 # it is most probably a set in fact but we would need
162 # then to jump to the set part and it is not *sure*
163 # that it is a set action that the user want, so force
164 # it to use the unambigous -statics ?value? instead:
166 "ambigous query (get or set -noStatics ?)\
167 use -statics instead"
171 "ambigous query (get or set -nestedLoadOk ?)\
175 return -code error "unknown flag $name (bug)"
180 # Otherwise we want to parse the arguments like init and
182 set Args
[::tcl::OptKeyParse ::safe::interpIC $args]
184 namespace upvar ::safe S
$slave state
186 # Get the current (and not the default) values of whatever has
188 if {![::tcl::OptProcArgGiven -accessPath]} {
190 set accessPath
$state(access_path
)
195 ![::tcl::OptProcArgGiven -statics]
196 && ![::tcl::OptProcArgGiven -noStatics]
198 set statics
$state(staticsok
)
200 set statics
[InterpStatics
]
203 [::tcl::OptProcArgGiven -nested] ||
204 [::tcl::OptProcArgGiven -nestedLoadOk]
206 set nested
[InterpNested
]
208 set nested
$state(nestedok
)
210 if {![::tcl::OptProcArgGiven -deleteHook]} {
211 set deleteHook
$state(cleanupHook
)
213 # we can now reconfigure :
214 InterpSetConfig
$slave $accessPath $statics $nested $deleteHook
215 # auto_reset the slave (to completly synch the new access_path)
217 if {[catch {::interp eval $slave {auto_reset}} msg
]} {
218 Log
$slave "auto_reset failed: $msg"
220 Log
$slave "successful auto_reset" NOTICE
229 # Functions that actually implements the exported APIs
234 # safe::InterpCreate : doing the real job
236 # This procedure creates a safe slave and initializes it with the safe
238 # NB: slave name must be simple alphanumeric string, no spaces, no (), no
239 # {},... {because the state array is stored as part of the name}
241 # Returns the slave name.
243 # Optional Arguments :
244 # + slave name : if empty, generated name will be used
245 # + access_path: path list controlling where load/source can occur,
246 # if empty: the master auto_path will be used.
247 # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
248 # if 1 :static packages are ok.
249 # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
250 # if 1 : multiple levels are ok.
252 # use the full name and no indent so auto_mkIndex can find us
253 proc ::safe::InterpCreate {
262 ::interp create
-safe $slave
264 # empty argument: generate slave name
265 set slave
[::interp create
-safe]
267 Log
$slave "Created" NOTICE
269 # Initialize it. (returns slave name)
270 InterpInit
$slave $access_path $staticsok $nestedok $deletehook
274 # InterpSetConfig (was setAccessPath) :
275 # Sets up slave virtual auto_path and corresponding structure within
276 # the master. Also sets the tcl_library in the slave to be the first
277 # directory in the path.
278 # NB: If you change the path after the slave has been initialized you
279 # probably need to call "auto_reset" in the slave in order that it gets
280 # the right auto_index() array values.
282 proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook
} {
285 # determine and store the access path if empty
286 if {$access_path eq
""} {
287 set access_path
$auto_path
289 # Make sure that tcl_library is in auto_path and at the first
290 # position (needed by setAccessPath)
291 set where
[lsearch -exact $access_path [info library
]]
294 set access_path
[linsert $access_path 0 [info library
]]
295 Log
$slave "tcl_library was not in auto_path,\
296 added it to slave's access_path" NOTICE
297 } elseif
{$where != 0} {
298 # not first, move it first
299 set access_path
[linsert \
300 [lreplace $access_path $where $where] \
302 Log
$slave "tcl_libray was not in first in auto_path,\
303 moved it to front of slave's access_path" NOTICE
306 # Add 1st level sub dirs (will searched by auto loading from tcl
307 # code in the slave using glob and thus fail, so we add them here
308 # so by default it works the same).
309 set access_path
[AddSubDirs
$access_path]
312 Log
$slave "Setting accessPath=($access_path) staticsok=$staticsok\
313 nestedok=$nestedok deletehook=($deletehook)" NOTICE
315 namespace upvar ::safe S
$slave state
317 # clear old autopath if it existed
319 # Extend the access list with the paths used to look for Tcl Modules.
320 # We save the virtual form separately as well, as syncing it with the
321 # slave has to be defered until the necessary commands are present for
324 set norm_access_path
{}
325 set slave_access_path
{}
326 set map_access_path
{}
327 set remap_access_path
{}
331 foreach dir
$access_path {
332 set token
[PathToken
$i]
333 lappend slave_access_path
$token
334 lappend map_access_path
$token $dir
335 lappend remap_access_path
$dir $token
336 lappend norm_access_path
[file normalize
$dir]
340 set morepaths
[::tcl::tm::list]
341 while {[llength $morepaths]} {
342 set addpaths
$morepaths
345 foreach dir
$addpaths {
346 # Prevent the addition of dirs on the tm list to the
347 # result if they are already known.
348 if {[dict exists
$remap_access_path $dir]} {
352 set token
[PathToken
$i]
353 lappend access_path
$dir
354 lappend slave_access_path
$token
355 lappend map_access_path
$token $dir
356 lappend remap_access_path
$dir $token
357 lappend norm_access_path
[file normalize
$dir]
358 lappend slave_tm_path
$token
362 # Recursively find deeper paths which may contain
363 # modules. Required to handle modules with names like
364 # 'platform::shell', which translate into
365 # 'platform/shell-X.tm', i.e arbitrarily deep
367 lappend morepaths
{*}[glob -nocomplain -directory $dir -type d
*]
371 set state
(access_path
) $access_path
372 set state
(access_path
,map
) $map_access_path
373 set state
(access_path
,remap
) $remap_access_path
374 set state
(access_path
,norm
) $norm_access_path
375 set state
(access_path
,slave
) $slave_access_path
376 set state
(tm_path_slave
) $slave_tm_path
377 set state
(staticsok
) $staticsok
378 set state
(nestedok
) $nestedok
379 set state
(cleanupHook
) $deletehook
381 SyncAccessPath
$slave
387 # Search for a real directory and returns its virtual Id (including the
389 proc ::safe::interpFindInAccessPath {slave path
} {
390 namespace upvar ::safe S
$slave state
392 if {![dict exists
$state(access_path
,remap
) $path]} {
393 return -code error "$path not found in access path $access_path"
396 return [dict get
$state(access_path
,remap
) $path]
401 # add (if needed) a real directory to access path and return its
402 # virtual token (including the "$").
403 proc ::safe::interpAddToAccessPath {slave path
} {
404 # first check if the directory is already in there
405 # (inlined interpFindInAccessPath).
406 namespace upvar ::safe S
$slave state
408 if {[dict exists
$state(access_path
,remap
) $path]} {
409 return [dict get
$state(access_path
,remap
) $path]
413 set token
[PathToken
[llength $state(access_path
)]]
415 lappend state
(access_path
) $path
416 lappend state
(access_path
,slave
) $token
417 lappend state
(access_path
,map
) $token $path
418 lappend state
(access_path
,remap
) $path $token
419 lappend state
(access_path
,norm
) [file normalize
$path]
421 SyncAccessPath
$slave
425 # This procedure applies the initializations to an already existing
426 # interpreter. It is useful when you want to install the safe base aliases
427 # into a preexisting safe interpreter.
428 proc ::safe::InterpInit {
435 # Configure will generate an access_path when access_path is empty.
436 InterpSetConfig
$slave $access_path $staticsok $nestedok $deletehook
438 # NB we need to add [namespace current], aliases are always absolute
441 # These aliases let the slave load files to define new commands
442 # This alias lets the slave use the encoding names, convertfrom,
443 # convertto, and system, but not "encoding system <name>" to set the
445 # Handling Tcl Modules, we need a restricted form of Glob.
446 # This alias interposes on the 'exit' command and cleanly terminates
449 foreach {command alias
} {
452 encoding AliasEncoding
456 ::interp alias
$slave $command {} [namespace current
]::$alias $slave
459 # This alias lets the slave have access to a subset of the 'file'
460 # command functionality.
462 AliasSubset
$slave file \
463 file dir.
* join root.
* ext.
* tail path.
* split
465 # Subcommands of info
466 foreach {subcommand alias
} {
467 nameofexecutable AliasExeName
469 ::interp alias
$slave ::tcl::info::$subcommand \
470 {} [namespace current
]::$alias $slave
473 # The allowed slave variables already have been set by Tcl_MakeSafe(3)
475 # Source init.tcl and tm.tcl into the slave, to get auto_load and
476 # other procedures defined:
478 if {[catch {::interp eval $slave {
479 source [file join $tcl_library init.tcl
]
481 Log
$slave "can't source init.tcl ($msg)"
482 return -code error "can't source init.tcl into slave $slave ($msg)"
485 if {[catch {::interp eval $slave {
486 source [file join $tcl_library tm.tcl
]
488 Log
$slave "can't source tm.tcl ($msg)"
489 return -code error "can't source tm.tcl into slave $slave ($msg)"
492 # Sync the paths used to search for Tcl modules. This can be done only
493 # now, after tm.tcl was loaded.
494 namespace upvar ::safe S
$slave state
495 ::interp eval $slave [list \
496 ::tcl::tm::add {*}$state(tm_path_slave
)]
501 # Add (only if needed, avoid duplicates) 1 level of sub directories to an
502 # existing path list. Also removes non directories from the returned
504 proc ::safe::AddSubDirs {pathList
} {
506 foreach dir
$pathList {
507 if {[file isdirectory
$dir]} {
508 # check that we don't have it yet as a children of a previous
513 foreach sub
[glob -directory $dir -nocomplain *] {
514 if {[file isdirectory
$sub] && ($sub ni
$res)} {
515 # new sub dir, add it !
524 # This procedure deletes a safe slave managed by Safe Tcl and cleans up
527 proc ::safe::interpDelete {slave
} {
528 Log
$slave "About to delete" NOTICE
530 namespace upvar ::safe S
$slave state
532 # If the slave has a cleanup hook registered, call it. Check the
533 # existance because we might be called to delete an interp which has
534 # not been registered with us at all
536 if {[info exists state
(cleanupHook
)]} {
537 set hook
$state(cleanupHook
)
538 if {[llength $hook]} {
539 # remove the hook now, otherwise if the hook calls us somehow,
541 unset state
(cleanupHook
)
545 Log
$slave "Delete hook error ($err)"
550 # Discard the global array of state associated with the slave, and
551 # delete the interpreter.
553 if {[info exists state
]} {
557 # if we have been called twice, the interp might have been deleted
559 if {[::interp exists
$slave]} {
560 ::interp delete
$slave
561 Log
$slave "Deleted" NOTICE
567 # Set (or get) the logging mecanism
569 proc ::safe::setLogCmd {args
} {
571 set la
[llength $args]
574 } elseif
{$la == 1} {
575 set Log
[lindex $args 0]
581 # Disable logging completely. Calls to it will be compiled out
583 proc ::safe::Log {args
} {}
585 # Activate logging, define proper command.
587 proc ::safe::Log {slave msg
{type ERROR
}} {
589 {*}$Log "$type for slave $slave : $msg"
595 # ------------------- END OF PUBLIC METHODS ------------
598 # Sets the slave auto_path to the master recorded value. Also sets
599 # tcl_library to the first token of the virtual path.
601 proc ::safe::SyncAccessPath {slave
} {
602 namespace upvar ::safe S
$slave state
604 set slave_access_path
$state(access_path
,slave
)
605 ::interp eval $slave [list set auto_path
$slave_access_path]
607 Log
$slave "auto_path in $slave has been set to $slave_access_path"\
610 # This code assumes that info library is the first element in the
611 # list of auto_path's. See -> InterpSetConfig for the code which
612 # ensures this condition.
614 ::interp eval $slave [list \
615 set tcl_library
[lindex $slave_access_path 0]]
618 # Returns the virtual token for directory number N.
619 proc ::safe::PathToken {n
} {
620 # We need to have a ":" in the token string so [file join] on the
621 # mac won't turn it into a relative path.
622 return "\$p(:$n:)" ;# Form tested by case 7.2
626 # translate virtual path into real path
628 proc ::safe::TranslatePath {slave path
} {
629 namespace upvar ::safe S
$slave state
631 # somehow strip the namespaces 'functionality' out (the danger is that
632 # we would strip valid macintosh "../" queries... :
633 if {[string match
"*::*" $path] ||
[string match
"*..*" $path]} {
634 return -code error "invalid characters in path $path"
637 # Use a cached map instead of computed local vars and subst.
639 return [string map
$state(access_path
,map
) $path]
642 # file name control (limit access to files/resources that should be a
643 # valid tcl source file)
644 proc ::safe::CheckFileName {slave
file} {
645 # This used to limit what can be sourced to ".tcl" and forbid files
646 # with more than 1 dot and longer than 14 chars, but I changed that
647 # for 8.4 as a safe interp has enough internal protection already to
648 # allow sourcing anything. - hobbs
650 if {![file exists
$file]} {
651 # don't tell the file path
652 return -code error "no such file or directory"
655 if {![file readable
$file]} {
656 # don't tell the file path
657 return -code error "not readable"
661 # AliasGlob is the target of the "glob" alias in safe interpreters.
662 proc ::safe::AliasGlob {slave args
} {
663 Log
$slave "GLOB ! $args" NOTICE
674 if {$::tcl_platform(platform
) eq
"windows"} {
675 set dirPartRE
{^
(.
*)[\\/]}
677 set dirPartRE
{^
(.
*)/}
683 while {$at < [llength $args]} {
684 switch -glob -- [set opt
[lindex $args $at]] {
685 -nocomplain - -- - -join - -tails {
691 lappend cmd
-types [lindex $args [incr at
]]
697 {"-directory" cannot be used with
"-path"}
700 set virtualdir
[lindex $args [incr at
]]
704 # Oops, this is globbing a subdirectory in regular package
705 # search. That is not wanted. Abort, handler does catch
706 # already (because glob was not defined before). See
707 # package.tcl, lines 484ff in tclPkgUnknown.
708 return -code error "unknown command glob"
711 Log
$slave "Safe base rejecting glob option '$opt'"
712 return -code error "Safe base rejecting glob option '$opt'"
721 # Get the real path from the virtual one and check that the path is in the
722 # access path of that slave. Done after basic argument processing so that
723 # we know if -nocomplain is set.
724 if {$got(-directory)} {
726 set dir
[TranslatePath
$slave $virtualdir]
727 DirInAccessPath
$slave $dir
730 if {!$got(-nocomplain)} {
731 return -code error "permission denied"
736 lappend cmd
-directory $dir
739 # Apply the -join semantics ourselves
741 set args
[lreplace $args $at end
[join [lrange $args $at end
] "/"]]
744 # Process remaining pattern arguments
745 set firstPattern
[llength $cmd]
746 while {$at < [llength $args]} {
747 set opt
[lindex $args $at]
749 if {[regexp $dirPartRE $opt -> thedir
] && [catch {
750 set thedir
[file join $virtualdir $thedir]
751 DirInAccessPath
$slave [TranslatePath
$slave $thedir]
754 if {$got(-nocomplain)} {
757 return -code error "permission denied"
763 Log
$slave "GLOB = $cmd" NOTICE
765 if {$got(-nocomplain) && [llength $cmd] eq
$firstPattern} {
769 ::interp invokehidden
$slave glob {*}$cmd
772 return -code error "script error"
775 Log
$slave "GLOB @ $msg" NOTICE
777 # Translate path back to what the slave should see.
779 set l
[string length
$dir]
781 if {[string equal
-length $l $dir $p]} {
782 set p
[string replace
$p 0 [expr {$l-1}] $virtualdir]
787 Log
$slave "GLOB @ $res" NOTICE
791 # AliasSource is the target of the "source" alias in safe interpreters.
793 proc ::safe::AliasSource {slave args
} {
794 set argc
[llength $args]
795 # Extended for handling of Tcl Modules to allow not only "source
796 # filename", but "source -encoding E filename" as well.
797 if {[lindex $args 0] eq
"-encoding"} {
799 set encoding [lindex $args 1]
801 if {$encoding eq
"identity"} {
802 Log
$slave "attempt to use the identity encoding"
803 return -code error "permission denied"
810 set msg
"wrong # args: should be \"source ?-encoding E? fileName\""
811 Log
$slave "$msg ($args)"
812 return -code error $msg
814 set file [lindex $args $at]
816 # get the real path from the virtual one.
818 set realfile
[TranslatePath
$slave $file]
821 return -code error "permission denied"
824 # check that the path is in the access path of that slave
826 FileInAccessPath
$slave $realfile
829 return -code error "permission denied"
832 # do the checks on the filename :
834 CheckFileName
$slave $realfile
836 Log
$slave "$realfile:$msg"
837 return -code error $msg
840 # Passed all the tests, lets source it. Note that we do this all manually
841 # because we want to control [info script] in the slave so information
842 # doesn't leak so much. [Bug 2913625]
843 set old
[::interp eval $slave {info script
}]
845 set f
[open $realfile]
846 fconfigure $f -eofchar \032
847 if {$encoding ne
""} {
848 fconfigure $f -encoding $encoding
850 set contents
[read $f]
852 ::interp eval $slave [list info script
$file]
853 ::interp eval $slave $contents
855 catch {interp eval $slave [list info script
$old]}
856 # Note that all non-errors are fine result codes from [source], so we must
857 # take a little care to do it properly. [Bug 2923613]
860 return -code error "script error"
862 return -code $code -options $opt $msg
865 # AliasLoad is the target of the "load" alias in safe interpreters.
867 proc ::safe::AliasLoad {slave
file args
} {
868 set argc
[llength $args]
870 set msg
"load error: too many arguments"
871 Log
$slave "$msg ($argc) {$file $args}"
872 return -code error $msg
875 # package name (can be empty if file is not).
876 set package [lindex $args 0]
878 namespace upvar ::safe S
$slave state
880 # Determine where to load. load use a relative interp path and {}
881 # means self, so we can directly and safely use passed arg.
882 set target
[lindex $args 1]
884 # we will try to load into a sub sub interp; check that we want to
886 if {!$state(nestedok
)} {
887 Log
$slave "loading to a sub interp (nestedok)\
888 disabled (trying to load $package to $target)"
889 return -code error "permission denied (nested load)"
893 # Determine what kind of load is requested
895 # static package loading
896 if {$package eq
""} {
897 set msg
"load error: empty filename and no package name"
899 return -code error $msg
901 if {!$state(staticsok
)} {
902 Log
$slave "static packages loading disabled\
903 (trying to load $package to $target)"
904 return -code error "permission denied (static package)"
909 # get the real path from the virtual one.
911 set file [TranslatePath
$slave $file]
914 return -code error "permission denied"
917 # check the translated path
919 FileInAccessPath
$slave $file
922 return -code error "permission denied (path)"
927 ::interp invokehidden
$slave load $file $package $target
930 return -code error $msg
936 # FileInAccessPath raises an error if the file is not found in the list of
937 # directories contained in the (master side recorded) slave's access path.
939 # the security here relies on "file dirname" answering the proper
940 # result... needs checking ?
941 proc ::safe::FileInAccessPath {slave
file} {
942 namespace upvar ::safe S
$slave state
943 set access_path
$state(access_path
)
945 if {[file isdirectory
$file]} {
946 return -code error "\"$file\": is a directory"
948 set parent
[file dirname
$file]
950 # Normalize paths for comparison since lsearch knows nothing of
951 # potential pathname anomalies.
952 set norm_parent
[file normalize
$parent]
954 namespace upvar ::safe S
$slave state
955 if {$norm_parent ni
$state(access_path
,norm
)} {
956 return -code error "\"$file\": not in access_path"
960 proc ::safe::DirInAccessPath {slave dir
} {
961 namespace upvar ::safe S
$slave state
962 set access_path
$state(access_path
)
964 if {[file isfile
$dir]} {
965 return -code error "\"$dir\": is a file"
968 # Normalize paths for comparison since lsearch knows nothing of
969 # potential pathname anomalies.
970 set norm_dir
[file normalize
$dir]
972 namespace upvar ::safe S
$slave state
973 if {$norm_dir ni
$state(access_path
,norm
)} {
974 return -code error "\"$dir\": not in access_path"
978 # This procedure enables access from a safe interpreter to only a subset
979 # of the subcommands of a command:
981 proc ::safe::Subset {slave command okpat args
} {
982 set subcommand
[lindex $args 0]
983 if {[regexp $okpat $subcommand]} {
984 return [$command {*}$args]
986 set msg
"not allowed to invoke subcommand $subcommand of $command"
988 return -code error $msg
991 # This procedure installs an alias in a slave that invokes "safesubset" in
992 # the master to execute allowed subcommands. It precomputes the pattern of
993 # allowed subcommands; you can use wildcards in the pattern if you wish to
994 # allow subcommand abbreviation.
996 # Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
998 proc ::safe::AliasSubset {slave alias target args
} {
999 set pat
"^([join $args |])\$"
1000 ::interp alias
$slave $alias {}\
1001 [namespace current
]::Subset $slave $target $pat
1004 # AliasEncoding is the target of the "encoding" alias in safe interpreters.
1006 proc ::safe::AliasEncoding {slave
option args
} {
1007 # Careful; do not want empty option to get through to the [string equal]
1008 if {[regexp {^
(name.
*|convert.
*|
)$} $option]} {
1009 return [::interp invokehidden
$slave encoding $option {*}$args]
1012 if {[string equal
-length [string length
$option] $option "system"]} {
1013 if {[llength $args] == 0} {
1014 # passed all the tests , lets source it:
1016 set sysenc
[::interp invokehidden
$slave encoding system
]
1019 return -code error "script error"
1023 set msg
"wrong # args: should be \"encoding system\""
1024 set code
{TCL WRONGARGS
}
1026 set msg
"bad option \"$option\": must be convertfrom, convertto, names, or system"
1027 set code
[list TCL LOOKUP INDEX
option $option]
1030 return -code error -errorcode $code $msg
1033 # Various minor hiding of platform features. [Bug 2913625]
1035 proc ::safe::AliasExeName {slave
} {
1039 proc ::safe::Setup {} {
1042 # Setup the arguments parsing
1046 # Share the descriptions
1047 set temp
[::tcl::OptKeyRegister {
1048 {-accessPath -list {} "access path for the slave"}
1049 {-noStatics "prevent loading of statically linked pkgs"}
1050 {-statics true
"loading of statically linked pkgs"}
1051 {-nestedLoadOk "allow nested loading"}
1052 {-nested false
"nested loading"}
1053 {-deleteHook -script {} "delete hook"}
1056 # create case (slave is optional)
1057 ::tcl::OptKeyRegister {
1058 {?slave?
-name {} "name of the slave (optional)"}
1059 } ::safe::interpCreate
1061 # adding the flags sub programs to the command program (relying on Opt's
1062 # internal implementation details)
1063 lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
1065 # init and configure (slave is needed)
1066 ::tcl::OptKeyRegister {
1067 {slave
-name {} "name of the slave"}
1070 # adding the flags sub programs to the command program (relying on Opt's
1071 # internal implementation details)
1072 lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
1074 # temp not needed anymore
1075 ::tcl::OptKeyDelete $temp
1079 # Default: No logging.
1086 # To enable error logging, set Log to {puts stderr} for instance,
1091 namespace eval ::safe {
1092 # internal variables
1094 # Log command, set via 'setLogCmd'. Logging is disabled when empty.
1097 # The package maintains a state array per slave interp under its
1098 # control. The name of this array is S<interp-name>. This array is
1099 # brought into scope where needed, using 'namespace upvar'. The S
1100 # prefix is used to avoid that a slave interp called "Log" smashes
1101 # the "Log" variable.
1103 # The array's elements are:
1105 # access_path : List of paths accessible to the slave.
1106 # access_path,norm : Ditto, in normalized form.
1107 # access_path,slave : Ditto, as the path tokens as seen by the slave.
1108 # access_path,map : dict ( token -> path )
1109 # access_path,remap : dict ( path -> token )
1110 # tm_path_slave : List of TM root directories, as tokens seen by the slave.
1111 # staticsok : Value of option -statics
1112 # nestedok : Value of option -nested
1113 # cleanupHook : Value of option -deleteHook