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
13 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 # RCS: @(#) $Id: safe.tcl,v 1.16.4.2 2009/11/04 04:47:59 dgp Exp $
18 # The implementation is based on namespaces. These naming conventions
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 {
31 namespace export interpCreate interpInit interpConfigure interpDelete
\
32 interpAddToAccessPath interpFindInAccessPath setLogCmd
36 # Setup the arguments parsing
40 # Make sure that our temporary variable is local to this
41 # namespace. [Bug 981733]
44 # Share the descriptions
45 set temp
[::tcl::OptKeyRegister {
46 {-accessPath -list {} "access path for the slave"}
47 {-noStatics "prevent loading of statically linked pkgs"}
48 {-statics true
"loading of statically linked pkgs"}
49 {-nestedLoadOk "allow nested loading"}
50 {-nested false
"nested loading"}
51 {-deleteHook -script {} "delete hook"}
54 # create case (slave is optional)
55 ::tcl::OptKeyRegister {
56 {?slave?
-name {} "name of the slave (optional)"}
57 } ::safe::interpCreate
58 # adding the flags sub programs to the command program
59 # (relying on Opt's internal implementation details)
60 lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
62 # init and configure (slave is needed)
63 ::tcl::OptKeyRegister {
64 {slave
-name {} "name of the slave"}
66 # adding the flags sub programs to the command program
67 # (relying on Opt's internal implementation details)
68 lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
69 # temp not needed anymore
70 ::tcl::OptKeyDelete $temp
73 # Helper function to resolve the dual way of specifying staticsok
74 # (either by -noStatics or -statics 0)
75 proc InterpStatics
{} {
76 foreach v
{Args statics noStatics
} {
79 set flag
[::tcl::OptProcArgGiven -noStatics];
80 if {$flag && (!$noStatics == !$statics)
81 && ([::tcl::OptProcArgGiven -statics])} {
83 "conflicting values given for -statics and -noStatics"
86 return [expr {!$noStatics}]
92 # Helper function to resolve the dual way of specifying nested loading
93 # (either by -nestedLoadOk or -nested 1)
94 proc InterpNested
{} {
95 foreach v
{Args nested nestedLoadOk
} {
98 set flag
[::tcl::OptProcArgGiven -nestedLoadOk];
99 # note that the test here is the opposite of the "InterpStatics"
100 # one (it is not -noNested... because of the wanted default value)
101 if {$flag && (!$nestedLoadOk != !$nested)
102 && ([::tcl::OptProcArgGiven -nested])} {
104 "conflicting values given for -nested and -nestedLoadOk"
107 # another difference with "InterpStatics"
116 # API entry points that needs argument parsing :
121 # Interface/entry point function and front end for "Create"
122 proc interpCreate
{args
} {
123 set Args
[::tcl::OptKeyParse ::safe::interpCreate $args]
124 InterpCreate
$slave $accessPath \
125 [InterpStatics
] [InterpNested
] $deleteHook
128 proc interpInit
{args
} {
129 set Args
[::tcl::OptKeyParse ::safe::interpIC $args]
130 if {![::interp exists
$slave]} {
131 return -code error "\"$slave\" is not an interpreter"
133 InterpInit
$slave $accessPath \
134 [InterpStatics
] [InterpNested
] $deleteHook;
137 proc CheckInterp
{slave
} {
138 if {![IsInterp
$slave]} {
140 "\"$slave\" is not an interpreter managed by ::safe::"
144 # Interface/entry point function and front end for "Configure"
145 # This code is awfully pedestrian because it would need
146 # more coupling and support between the way we store the
147 # configuration values in safe::interp's and the Opt package
148 # Obviously we would like an OptConfigure
149 # to avoid duplicating all this code everywhere. -> TODO
150 # (the app should share or access easily the program/value
152 # This is even more complicated by the boolean flags with no values
153 # that we had the bad idea to support for the sake of user simplicity
154 # in create/init but which makes life hard in configure...
155 # So this will be hopefully written and some integrated with opt1.0
156 # (hopefully for tcl8.1 ?)
157 proc interpConfigure
{args
} {
158 switch [llength $args] {
160 # If we have exactly 1 argument
161 # the semantic is to return all the current configuration
162 # We still call OptKeyParse though we know that "slave"
163 # is our given argument because it also checks
164 # for the "-help" option.
165 set Args
[::tcl::OptKeyParse ::safe::interpIC $args]
168 lappend res
[list -accessPath [Set
[PathListName
$slave]]]
169 lappend res
[list -statics [Set
[StaticsOkName
$slave]]]
170 lappend res
[list -nested [Set
[NestedOkName
$slave]]]
171 lappend res
[list -deleteHook [Set
[DeleteHookName
$slave]]]
175 # If we have exactly 2 arguments
176 # the semantic is a "configure get"
177 ::tcl::Lassign $args slave arg
178 # get the flag sub program (we 'know' about Opt's internal
179 # representation of data)
180 set desc
[lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
181 set hits
[::tcl::OptHits desc
$arg]
183 return -code error [::tcl::OptAmbigous $desc $arg]
184 } elseif
{$hits == 0} {
185 return -code error [::tcl::OptFlagUsage $desc $arg]
188 set item
[::tcl::OptCurDesc $desc]
189 set name
[::tcl::OptName $item]
190 switch -exact -- $name {
192 return [list -accessPath [Set
[PathListName
$slave]]]
195 return [list -statics [Set
[StaticsOkName
$slave]]]
198 return [list -nested [Set
[NestedOkName
$slave]]]
201 return [list -deleteHook [Set
[DeleteHookName
$slave]]]
204 # it is most probably a set in fact
205 # but we would need then to jump to the set part
206 # and it is not *sure* that it is a set action
207 # that the user want, so force it to use the
208 # unambigous -statics ?value? instead:
210 "ambigous query (get or set -noStatics ?)\
211 use -statics instead"
215 "ambigous query (get or set -nestedLoadOk ?)\
219 return -code error "unknown flag $name (bug)"
224 # Otherwise we want to parse the arguments like init and create
226 set Args
[::tcl::OptKeyParse ::safe::interpIC $args]
228 # Get the current (and not the default) values of
229 # whatever has not been given:
230 if {![::tcl::OptProcArgGiven -accessPath]} {
232 set accessPath
[Set
[PathListName
$slave]]
236 if {(![::tcl::OptProcArgGiven -statics]) \
237 && (![::tcl::OptProcArgGiven -noStatics]) } {
238 set statics
[Set
[StaticsOkName
$slave]]
240 set statics
[InterpStatics
]
242 if {([::tcl::OptProcArgGiven -nested]) \
243 ||
([::tcl::OptProcArgGiven -nestedLoadOk]) } {
244 set nested
[InterpNested
]
246 set nested
[Set
[NestedOkName
$slave]]
248 if {![::tcl::OptProcArgGiven -deleteHook]} {
249 set deleteHook
[Set
[DeleteHookName
$slave]]
251 # we can now reconfigure :
252 InterpSetConfig
$slave $accessPath $statics $nested $deleteHook
253 # auto_reset the slave (to completly synch the new access_path)
255 if {[catch {::interp eval $slave {auto_reset}} msg
]} {
256 Log
$slave "auto_reset failed: $msg"
258 Log
$slave "successful auto_reset" NOTICE
268 # Functions that actually implements the exported APIs
274 # safe::InterpCreate : doing the real job
276 # This procedure creates a safe slave and initializes it with the
278 # NB: slave name must be simple alphanumeric string, no spaces,
279 # no (), no {},... {because the state array is stored as part of the name}
281 # Returns the slave name.
283 # Optional Arguments :
284 # + slave name : if empty, generated name will be used
285 # + access_path: path list controlling where load/source can occur,
286 # if empty: the master auto_path will be used.
287 # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
288 # if 1 :static packages are ok.
289 # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
290 # if 1 : multiple levels are ok.
292 # use the full name and no indent so auto_mkIndex can find us
293 proc ::safe::InterpCreate {
302 ::interp create
-safe $slave
304 # empty argument: generate slave name
305 set slave
[::interp create
-safe]
307 Log
$slave "Created" NOTICE
309 # Initialize it. (returns slave name)
310 InterpInit
$slave $access_path $staticsok $nestedok $deletehook
315 # InterpSetConfig (was setAccessPath) :
316 # Sets up slave virtual auto_path and corresponding structure
317 # within the master. Also sets the tcl_library in the slave
318 # to be the first directory in the path.
319 # Nb: If you change the path after the slave has been initialized
320 # you probably need to call "auto_reset" in the slave in order that it
321 # gets the right auto_index() array values.
323 proc ::safe::InterpSetConfig {slave access_path staticsok
\
324 nestedok deletehook
} {
326 # determine and store the access path if empty
327 if {$access_path eq
""} {
328 set access_path
[uplevel \#0 set auto_path]
329 # Make sure that tcl_library is in auto_path
330 # and at the first position (needed by setAccessPath)
331 set where
[lsearch -exact $access_path [info library
]]
334 set access_path
[concat [list [info library
]] $access_path]
335 Log
$slave "tcl_library was not in auto_path,\
336 added it to slave's access_path" NOTICE
337 } elseif
{$where != 0} {
338 # not first, move it first
339 set access_path
[concat [list [info library
]]\
340 [lreplace $access_path $where $where]]
341 Log
$slave "tcl_libray was not in first in auto_path,\
342 moved it to front of slave's access_path" NOTICE
346 # Add 1st level sub dirs (will searched by auto loading from tcl
347 # code in the slave using glob and thus fail, so we add them
348 # here so by default it works the same).
349 set access_path
[AddSubDirs
$access_path]
352 Log
$slave "Setting accessPath=($access_path) staticsok=$staticsok\
353 nestedok=$nestedok deletehook=($deletehook)" NOTICE
355 # clear old autopath if it existed
356 set nname
[PathNumberName
$slave]
357 if {[Exists
$nname]} {
359 for {set i
0} {$i<$n} {incr i
} {
360 Unset
[PathToken
$i $slave]
365 set slave_auto_path
{}
367 foreach dir
$access_path {
368 Set
[PathToken
$i $slave] $dir
369 lappend slave_auto_path
"\$[PathToken $i]"
372 # Extend the access list with the paths used to look for Tcl
373 # Modules. We safe the virtual form separately as well, as
374 # syncing it with the slave has to be defered until the
375 # necessary commands are present for setup.
377 set morepaths
[::tcl::tm::list]
378 while {[llength $morepaths]} {
379 set addpaths
$morepaths
382 foreach dir
$addpaths {
383 lappend access_path
$dir
384 Set
[PathToken
$i $slave] $dir
385 lappend slave_auto_path
"\$[PathToken $i]"
386 lappend slave_tm_path
"\$[PathToken $i]"
390 # Recursively find deeper paths which may contain
391 # modules. Required to handle modules with names like
392 # 'platform::shell', which translate into
393 # 'platform/shell-X.tm', i.e arbitrarily deep
394 # subdirectories. The catch prevents complaints when
395 # no paths are added. Do nothing gracefully is 8.6+.
398 lappend morepaths
{*}[glob -nocomplain -directory $dir -type d
*]
403 Set
[TmPathListName
$slave] $slave_tm_path
405 Set
[PathListName
$slave] $access_path
406 Set
[VirtualPathListName
$slave] $slave_auto_path
408 Set
[StaticsOkName
$slave] $staticsok
409 Set
[NestedOkName
$slave] $nestedok
410 Set
[DeleteHookName
$slave] $deletehook
412 SyncAccessPath
$slave
418 # Search for a real directory and returns its virtual Id
419 # (including the "$")
420 proc ::safe::interpFindInAccessPath {slave path
} {
421 set access_path
[GetAccessPath
$slave]
422 set where
[lsearch -exact $access_path $path]
424 return -code error "$path not found in access path $access_path"
426 return "\$[PathToken $where]"
431 # add (if needed) a real directory to access path
432 # and return its virtual token (including the "$").
433 proc ::safe::interpAddToAccessPath {slave path
} {
434 # first check if the directory is already in there
435 if {![catch {interpFindInAccessPath
$slave $path} res
]} {
439 set nname
[PathNumberName
$slave]
441 Set
[PathToken
$n $slave] $path
443 set token
"\$[PathToken $n]"
445 Lappend
[VirtualPathListName
$slave] $token
446 Lappend
[PathListName
$slave] $path
447 Set
$nname [expr {$n+1}]
449 SyncAccessPath
$slave
454 # This procedure applies the initializations to an already existing
455 # interpreter. It is useful when you want to install the safe base
456 # aliases into a preexisting safe interpreter.
457 proc ::safe::InterpInit {
465 # Configure will generate an access_path when access_path is
467 InterpSetConfig
$slave $access_path $staticsok $nestedok $deletehook
469 # These aliases let the slave load files to define new commands
471 # NB we need to add [namespace current], aliases are always
473 ::interp alias
$slave source {} [namespace current
]::AliasSource $slave
474 ::interp alias
$slave load {} [namespace current
]::AliasLoad $slave
476 # This alias lets the slave use the encoding names, convertfrom,
477 # convertto, and system, but not "encoding system <name>" to set
478 # the system encoding.
480 ::interp alias
$slave encoding {} [namespace current
]::AliasEncoding \
483 # Handling Tcl Modules, we need a restricted form of Glob.
484 ::interp alias
$slave glob {} [namespace current
]::AliasGlob \
487 # This alias lets the slave have access to a subset of the 'file'
488 # command functionality.
490 AliasSubset
$slave file file dir.
* join root.
* ext.
* tail
\
493 # This alias interposes on the 'exit' command and cleanly terminates
496 ::interp alias
$slave exit {} [namespace current
]::interpDelete $slave
498 # The allowed slave variables already have been set
502 # Source init.tcl and tm.tcl into the slave, to get auto_load
503 # and other procedures defined:
505 if {[catch {::interp eval $slave \
506 {source [file join $tcl_library init.tcl
]}} msg
]} {
507 Log
$slave "can't source init.tcl ($msg)"
508 error "can't source init.tcl into slave $slave ($msg)"
511 if {[catch {::interp eval $slave \
512 {source [file join $tcl_library tm.tcl
]}} msg
]} {
513 Log
$slave "can't source tm.tcl ($msg)"
514 error "can't source tm.tcl into slave $slave ($msg)"
517 # Sync the paths used to search for Tcl modules. This can be
518 # done only now, after tm.tcl was loaded.
519 ::interp eval $slave [list ::tcl::tm::add {*}[Set
[TmPathListName
$slave]]]
525 # Add (only if needed, avoid duplicates) 1 level of
526 # sub directories to an existing path list.
527 # Also removes non directories from the returned list.
528 proc AddSubDirs
{pathList
} {
530 foreach dir
$pathList {
531 if {[file isdirectory
$dir]} {
532 # check that we don't have it yet as a children
534 if {[lsearch -exact $res $dir]<0} {
537 foreach sub
[glob -directory $dir -nocomplain *] {
538 if {([file isdirectory
$sub]) \
539 && ([lsearch -exact $res $sub]<0) } {
540 # new sub dir, add it !
549 # This procedure deletes a safe slave managed by Safe Tcl and
550 # cleans up associated state:
552 proc ::safe::interpDelete {slave
} {
554 Log
$slave "About to delete" NOTICE
556 # If the slave has a cleanup hook registered, call it.
557 # check the existance because we might be called to delete an interp
558 # which has not been registered with us at all
559 set hookname
[DeleteHookName
$slave]
560 if {[Exists
$hookname]} {
561 set hook
[Set
$hookname]
562 if {![::tcl::Lempty $hook]} {
563 # remove the hook now, otherwise if the hook
564 # calls us somehow, we'll loop
566 if {[catch {{*}$hook $slave} err
]} {
567 Log
$slave "Delete hook error ($err)"
572 # Discard the global array of state associated with the slave, and
573 # delete the interpreter.
575 set statename
[InterpStateName
$slave]
576 if {[Exists
$statename]} {
580 # if we have been called twice, the interp might have been deleted
582 if {[::interp exists
$slave]} {
583 ::interp delete
$slave
584 Log
$slave "Deleted" NOTICE
590 # Set (or get) the loging mecanism
592 proc ::safe::setLogCmd {args
} {
594 if {[llength $args] == 0} {
597 if {[llength $args] == 1} {
598 set Log
[lindex $args 0]
608 # ------------------- END OF PUBLIC METHODS ------------
612 # sets the slave auto_path to the master recorded value.
613 # also sets tcl_library to the first token of the virtual path.
615 proc SyncAccessPath
{slave
} {
616 set slave_auto_path
[Set
[VirtualPathListName
$slave]]
617 ::interp eval $slave [list set auto_path
$slave_auto_path]
618 Log
$slave "auto_path in $slave has been set to $slave_auto_path"\
620 ::interp eval $slave [list set tcl_library
[lindex $slave_auto_path 0]]
623 # base name for storing all the slave states
624 # the array variable name for slave foo is thus "Sfoo"
625 # and for sub slave {foo bar} "Sfoo bar" (spaces are handled
626 # ok everywhere (or should))
627 # We add the S prefix to avoid that a slave interp called "Log"
628 # would smash our "Log" variable.
629 proc InterpStateName
{slave
} {
633 # Check that the given slave is "one of us"
634 proc IsInterp
{slave
} {
635 expr {[Exists
[InterpStateName
$slave]] && [::interp exists
$slave]}
638 # returns the virtual token for directory number N
639 # if the slave argument is given,
640 # it will return the corresponding master global variable name
641 proc PathToken
{n
{slave
""}} {
643 return "[InterpStateName $slave](access_path,$n)"
645 # We need to have a ":" in the token string so
646 # [file join] on the mac won't turn it into a relative
651 # returns the variable name of the complete path list
652 proc PathListName
{slave
} {
653 return "[InterpStateName $slave](access_path)"
655 # returns the variable name of the complete path list
656 proc VirtualPathListName
{slave
} {
657 return "[InterpStateName $slave](access_path_slave)"
659 # returns the variable name of the complete tm path list
660 proc TmPathListName
{slave
} {
661 return "[InterpStateName $slave](tm_path_slave)"
663 # returns the variable name of the number of items
664 proc PathNumberName
{slave
} {
665 return "[InterpStateName $slave](access_path,n)"
667 # returns the staticsok flag var name
668 proc StaticsOkName
{slave
} {
669 return "[InterpStateName $slave](staticsok)"
671 # returns the nestedok flag var name
672 proc NestedOkName
{slave
} {
673 return "[InterpStateName $slave](nestedok)"
675 # Run some code at the namespace toplevel
676 proc Toplevel
{args
} {
677 namespace eval [namespace current
] $args
681 Toplevel
set {*}$args
683 # lappend on toplevel vars
684 proc Lappend
{args
} {
685 Toplevel
lappend {*}$args
687 # unset a var/token (currently just an global level eval)
689 Toplevel
unset {*}$args
692 proc Exists
{varname
} {
693 Toplevel
info exists
$varname
695 # short cut for access path getting
696 proc GetAccessPath
{slave
} {
697 Set
[PathListName
$slave]
699 # short cut for statics ok flag getting
700 proc StaticsOk
{slave
} {
701 Set
[StaticsOkName
$slave]
703 # short cut for getting the multiples interps sub loading ok flag
704 proc NestedOk
{slave
} {
705 Set
[NestedOkName
$slave]
707 # interp deletion storing hook name
708 proc DeleteHookName
{slave
} {
709 return [InterpStateName
$slave](cleanupHook
)
713 # translate virtual path into real path
715 proc TranslatePath
{slave path
} {
716 # somehow strip the namespaces 'functionality' out (the danger
717 # is that we would strip valid macintosh "../" queries... :
718 if {[string match
"*::*" $path] ||
[string match
"*..*" $path]} {
719 error "invalid characters in path $path"
721 set n
[expr {[Set
[PathNumberName
$slave]]-1}]
722 for {} {$n>=0} {incr n
-1} {
723 # fill the token virtual names with their real value
724 set [PathToken
$n] [Set
[PathToken
$n $slave]]
726 # replaces the token by their value
727 subst -nobackslashes -nocommands $path
731 # Log eventually log an error
732 # to enable error logging, set Log to {puts stderr} for instance
733 proc Log
{slave msg
{type ERROR
}} {
735 if {[info exists Log
] && [llength $Log]} {
736 {*}$Log "$type for slave $slave : $msg"
741 # file name control (limit access to files/ressources that should be
742 # a valid tcl source file)
743 proc CheckFileName
{slave
file} {
744 # This used to limit what can be sourced to ".tcl" and forbid files
745 # with more than 1 dot and longer than 14 chars, but I changed that
746 # for 8.4 as a safe interp has enough internal protection already
747 # to allow sourcing anything. - hobbs
749 if {![file exists
$file]} {
750 # don't tell the file path
751 error "no such file or directory"
754 if {![file readable
$file]} {
755 # don't tell the file path
760 # AliasGlob is the target of the "glob" alias in safe interpreters.
762 proc AliasGlob
{slave args
} {
763 Log
$slave "GLOB ! $args" NOTICE
770 while {$at < [llength $args]} {
771 switch -glob -- [set opt
[lindex $args $at]] {
773 -join { lappend cmd
$opt ; incr at
}
775 lappend cmd
$opt ; incr at
776 set virtualdir
[lindex $args $at]
778 # get the real path from the virtual one.
779 if {[catch {set dir
[TranslatePath
$slave $virtualdir]} msg
]} {
781 return -code error "permission denied"
783 # check that the path is in the access path of that slave
784 if {[catch {DirInAccessPath
$slave $dir} msg
]} {
786 return -code error "permission denied"
788 lappend cmd
$dir ; incr at
791 # Oops, this is globbing a subdirectory in regular
792 # package search. That is not wanted. Abort,
793 # handler does catch already (because glob was not
794 # defined before). See package.tcl, lines 484ff in
796 error "unknown command glob"
799 Log
$slave "Safe base rejecting glob option '$opt'"
800 error "Safe base rejecting glob option '$opt'"
803 lappend cmd
$opt ; incr at
808 Log
$slave "GLOB = $cmd" NOTICE
810 if {[catch {::interp invokehidden
$slave glob {*}$cmd} msg
]} {
812 return -code error "script error"
815 Log
$slave "GLOB @ $msg" NOTICE
817 # Translate path back to what the slave should see.
820 regsub -- ^
$dir $p $virtualdir p
824 Log
$slave "GLOB @ $res" NOTICE
828 # AliasSource is the target of the "source" alias in safe interpreters.
830 proc AliasSource
{slave args
} {
832 set argc
[llength $args]
833 # Extended for handling of Tcl Modules to allow not only
834 # "source filename", but "source -encoding E filename" as
836 if {[lindex $args 0] eq
"-encoding"} {
838 set encoding [lrange $args 0 1]
845 set msg
"wrong # args: should be \"source ?-encoding E? fileName\""
846 Log
$slave "$msg ($args)"
847 return -code error $msg
849 set file [lindex $args $at]
851 # get the real path from the virtual one.
852 if {[catch {set file [TranslatePath
$slave $file]} msg
]} {
854 return -code error "permission denied"
857 # check that the path is in the access path of that slave
858 if {[catch {FileInAccessPath
$slave $file} msg
]} {
860 return -code error "permission denied"
863 # do the checks on the filename :
864 if {[catch {CheckFileName
$slave $file} msg
]} {
865 Log
$slave "$file:$msg"
866 return -code error $msg
869 # passed all the tests , lets source it:
870 if {[catch {::interp invokehidden
$slave source {*}$encoding $file} msg
]} {
872 return -code error "script error"
877 # AliasLoad is the target of the "load" alias in safe interpreters.
879 proc AliasLoad
{slave
file args
} {
881 set argc
[llength $args]
883 set msg
"load error: too many arguments"
884 Log
$slave "$msg ($argc) {$file $args}"
885 return -code error $msg
888 # package name (can be empty if file is not).
889 set package [lindex $args 0]
891 # Determine where to load. load use a relative interp path
892 # and {} means self, so we can directly and safely use passed arg.
893 set target
[lindex $args 1]
895 # we will try to load into a sub sub interp
896 # check that we want to authorize that.
897 if {![NestedOk
$slave]} {
898 Log
$slave "loading to a sub interp (nestedok)\
899 disabled (trying to load $package to $target)"
900 return -code error "permission denied (nested load)"
905 # Determine what kind of load is requested
907 # static package loading
908 if {$package eq
""} {
909 set msg
"load error: empty filename and no package name"
911 return -code error $msg
913 if {![StaticsOk
$slave]} {
914 Log
$slave "static packages loading disabled\
915 (trying to load $package to $target)"
916 return -code error "permission denied (static package)"
921 # get the real path from the virtual one.
922 if {[catch {set file [TranslatePath
$slave $file]} msg
]} {
924 return -code error "permission denied"
927 # check the translated path
928 if {[catch {FileInAccessPath
$slave $file} msg
]} {
930 return -code error "permission denied (path)"
934 if {[catch {::interp invokehidden
\
935 $slave load $file $package $target} msg
]} {
937 return -code error $msg
943 # FileInAccessPath raises an error if the file is not found in
944 # the list of directories contained in the (master side recorded) slave's
947 # the security here relies on "file dirname" answering the proper
948 # result.... needs checking ?
949 proc FileInAccessPath
{slave
file} {
951 set access_path
[GetAccessPath
$slave]
953 if {[file isdirectory
$file]} {
954 error "\"$file\": is a directory"
956 set parent
[file dirname
$file]
958 # Normalize paths for comparison since lsearch knows nothing of
959 # potential pathname anomalies.
960 set norm_parent
[file normalize
$parent]
961 foreach path
$access_path {
962 lappend norm_access_path
[file normalize
$path]
965 if {[lsearch -exact $norm_access_path $norm_parent] == -1} {
966 error "\"$file\": not in access_path"
970 proc DirInAccessPath
{slave dir
} {
971 set access_path
[GetAccessPath
$slave]
973 if {[file isfile
$dir]} {
974 error "\"$dir\": is a file"
977 # Normalize paths for comparison since lsearch knows nothing of
978 # potential pathname anomalies.
979 set norm_dir
[file normalize
$dir]
980 foreach path
$access_path {
981 lappend norm_access_path
[file normalize
$path]
984 if {[lsearch -exact $norm_access_path $norm_dir] == -1} {
985 error "\"$dir\": not in access_path"
989 # This procedure enables access from a safe interpreter to only a subset of
990 # the subcommands of a command:
992 proc Subset
{slave command okpat args
} {
993 set subcommand
[lindex $args 0]
994 if {[regexp $okpat $subcommand]} {
995 return [$command {*}$args]
997 set msg
"not allowed to invoke subcommand $subcommand of $command"
1002 # This procedure installs an alias in a slave that invokes "safesubset"
1003 # in the master to execute allowed subcommands. It precomputes the pattern
1004 # of allowed subcommands; you can use wildcards in the pattern if you wish
1005 # to allow subcommand abbreviation.
1007 # Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
1009 proc AliasSubset
{slave alias target args
} {
1010 set pat ^
(; set sep
""
1016 ::interp alias
$slave $alias {}\
1017 [namespace current
]::Subset $slave $target $pat
1020 # AliasEncoding is the target of the "encoding" alias in safe interpreters.
1022 proc AliasEncoding
{slave args
} {
1024 set argc
[llength $args]
1026 set okpat
"^(name.*|convert.*)\$"
1027 set subcommand
[lindex $args 0]
1029 if {[regexp $okpat $subcommand]} {
1030 return [::interp invokehidden
$slave encoding {*}$args]
1033 if {[string first
$subcommand system
] == 0} {
1035 # passed all the tests , lets source it:
1036 if {[catch {::interp invokehidden
\
1037 $slave encoding system
} msg
]} {
1039 return -code error "script error"
1042 set msg
"wrong # args: should be \"encoding system\""
1047 set msg
"wrong # args: should be \"encoding option ?arg ...?\""