Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | # safe.tcl -- |
2 | # | |
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. | |
7 | # | |
8 | # See the safe.n man page for details. | |
9 | # | |
10 | # Copyright (c) 1996-1997 Sun Microsystems, Inc. | |
11 | # | |
12 | # See the file "license.terms" for information on usage and redistribution | |
13 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
14 | # | |
15 | # RCS: @(#) $Id: safe.tcl,v 1.9.2.2 2004/06/29 09:39:01 dkf Exp $ | |
16 | ||
17 | # | |
18 | # The implementation is based on namespaces. These naming conventions | |
19 | # are followed: | |
20 | # Private procs starts with uppercase. | |
21 | # Public procs are exported and starts with lowercase | |
22 | # | |
23 | ||
24 | # Needed utilities package | |
25 | package require opt 0.4.1; | |
26 | ||
27 | # Create the safe namespace | |
28 | namespace eval ::safe { | |
29 | ||
30 | # Exported API: | |
31 | namespace export interpCreate interpInit interpConfigure interpDelete \ | |
32 | interpAddToAccessPath interpFindInAccessPath setLogCmd | |
33 | ||
34 | #### | |
35 | # | |
36 | # Setup the arguments parsing | |
37 | # | |
38 | #### | |
39 | ||
40 | # Make sure that our temporary variable is local to this | |
41 | # namespace. [Bug 981733] | |
42 | variable temp | |
43 | ||
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"} | |
52 | }] | |
53 | ||
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) | |
61 | ||
62 | # init and configure (slave is needed) | |
63 | ::tcl::OptKeyRegister { | |
64 | {slave -name {} "name of the slave"} | |
65 | } ::safe::interpIC | |
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 | |
71 | ||
72 | ||
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} { | |
77 | upvar $v $v | |
78 | } | |
79 | set flag [::tcl::OptProcArgGiven -noStatics]; | |
80 | if {$flag && ($noStatics == $statics) | |
81 | && ([::tcl::OptProcArgGiven -statics])} { | |
82 | return -code error\ | |
83 | "conflicting values given for -statics and -noStatics" | |
84 | } | |
85 | if {$flag} { | |
86 | return [expr {!$noStatics}] | |
87 | } else { | |
88 | return $statics | |
89 | } | |
90 | } | |
91 | ||
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} { | |
96 | upvar $v $v | |
97 | } | |
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])} { | |
103 | return -code error\ | |
104 | "conflicting values given for -nested and -nestedLoadOk" | |
105 | } | |
106 | if {$flag} { | |
107 | # another difference with "InterpStatics" | |
108 | return $nestedLoadOk | |
109 | } else { | |
110 | return $nested | |
111 | } | |
112 | } | |
113 | ||
114 | #### | |
115 | # | |
116 | # API entry points that needs argument parsing : | |
117 | # | |
118 | #### | |
119 | ||
120 | ||
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 | |
126 | } | |
127 | ||
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" | |
132 | } | |
133 | InterpInit $slave $accessPath \ | |
134 | [InterpStatics] [InterpNested] $deleteHook; | |
135 | } | |
136 | ||
137 | proc CheckInterp {slave} { | |
138 | if {![IsInterp $slave]} { | |
139 | return -code error \ | |
140 | "\"$slave\" is not an interpreter managed by ::safe::" | |
141 | } | |
142 | } | |
143 | ||
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 | |
151 | # stored by opt) | |
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] { | |
159 | 1 { | |
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] | |
166 | CheckInterp $slave | |
167 | set res {} | |
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]]] | |
172 | join $res | |
173 | } | |
174 | 2 { | |
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] | |
182 | if {$hits > 1} { | |
183 | return -code error [::tcl::OptAmbigous $desc $arg] | |
184 | } elseif {$hits == 0} { | |
185 | return -code error [::tcl::OptFlagUsage $desc $arg] | |
186 | } | |
187 | CheckInterp $slave | |
188 | set item [::tcl::OptCurDesc $desc] | |
189 | set name [::tcl::OptName $item] | |
190 | switch -exact -- $name { | |
191 | -accessPath { | |
192 | return [list -accessPath [Set [PathListName $slave]]] | |
193 | } | |
194 | -statics { | |
195 | return [list -statics [Set [StaticsOkName $slave]]] | |
196 | } | |
197 | -nested { | |
198 | return [list -nested [Set [NestedOkName $slave]]] | |
199 | } | |
200 | -deleteHook { | |
201 | return [list -deleteHook [Set [DeleteHookName $slave]]] | |
202 | } | |
203 | -noStatics { | |
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: | |
209 | return -code error\ | |
210 | "ambigous query (get or set -noStatics ?)\ | |
211 | use -statics instead" | |
212 | } | |
213 | -nestedLoadOk { | |
214 | return -code error\ | |
215 | "ambigous query (get or set -nestedLoadOk ?)\ | |
216 | use -nested instead" | |
217 | } | |
218 | default { | |
219 | return -code error "unknown flag $name (bug)" | |
220 | } | |
221 | } | |
222 | } | |
223 | default { | |
224 | # Otherwise we want to parse the arguments like init and create | |
225 | # did | |
226 | set Args [::tcl::OptKeyParse ::safe::interpIC $args] | |
227 | CheckInterp $slave | |
228 | # Get the current (and not the default) values of | |
229 | # whatever has not been given: | |
230 | if {![::tcl::OptProcArgGiven -accessPath]} { | |
231 | set doreset 1 | |
232 | set accessPath [Set [PathListName $slave]] | |
233 | } else { | |
234 | set doreset 0 | |
235 | } | |
236 | if {(![::tcl::OptProcArgGiven -statics]) \ | |
237 | && (![::tcl::OptProcArgGiven -noStatics]) } { | |
238 | set statics [Set [StaticsOkName $slave]] | |
239 | } else { | |
240 | set statics [InterpStatics] | |
241 | } | |
242 | if {([::tcl::OptProcArgGiven -nested]) \ | |
243 | || ([::tcl::OptProcArgGiven -nestedLoadOk]) } { | |
244 | set nested [InterpNested] | |
245 | } else { | |
246 | set nested [Set [NestedOkName $slave]] | |
247 | } | |
248 | if {![::tcl::OptProcArgGiven -deleteHook]} { | |
249 | set deleteHook [Set [DeleteHookName $slave]] | |
250 | } | |
251 | # we can now reconfigure : | |
252 | InterpSetConfig $slave $accessPath $statics $nested $deleteHook | |
253 | # auto_reset the slave (to completly synch the new access_path) | |
254 | if {$doreset} { | |
255 | if {[catch {::interp eval $slave {auto_reset}} msg]} { | |
256 | Log $slave "auto_reset failed: $msg" | |
257 | } else { | |
258 | Log $slave "successful auto_reset" NOTICE | |
259 | } | |
260 | } | |
261 | } | |
262 | } | |
263 | } | |
264 | ||
265 | ||
266 | #### | |
267 | # | |
268 | # Functions that actually implements the exported APIs | |
269 | # | |
270 | #### | |
271 | ||
272 | ||
273 | # | |
274 | # safe::InterpCreate : doing the real job | |
275 | # | |
276 | # This procedure creates a safe slave and initializes it with the | |
277 | # safe base aliases. | |
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} | |
280 | # | |
281 | # Returns the slave name. | |
282 | # | |
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. | |
291 | ||
292 | # use the full name and no indent so auto_mkIndex can find us | |
293 | proc ::safe::InterpCreate { | |
294 | slave | |
295 | access_path | |
296 | staticsok | |
297 | nestedok | |
298 | deletehook | |
299 | } { | |
300 | # Create the slave. | |
301 | if {$slave ne ""} { | |
302 | ::interp create -safe $slave | |
303 | } else { | |
304 | # empty argument: generate slave name | |
305 | set slave [::interp create -safe] | |
306 | } | |
307 | Log $slave "Created" NOTICE | |
308 | ||
309 | # Initialize it. (returns slave name) | |
310 | InterpInit $slave $access_path $staticsok $nestedok $deletehook | |
311 | } | |
312 | ||
313 | ||
314 | # | |
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. | |
322 | ||
323 | proc ::safe::InterpSetConfig {slave access_path staticsok\ | |
324 | nestedok deletehook} { | |
325 | ||
326 | # determine and store the access path if empty | |
327 | if {[string equal "" $access_path]} { | |
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]] | |
332 | if {$where == -1} { | |
333 | # not found, add it. | |
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 | |
343 | ||
344 | } | |
345 | ||
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] | |
350 | } | |
351 | ||
352 | Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ | |
353 | nestedok=$nestedok deletehook=($deletehook)" NOTICE | |
354 | ||
355 | # clear old autopath if it existed | |
356 | set nname [PathNumberName $slave] | |
357 | if {[Exists $nname]} { | |
358 | set n [Set $nname] | |
359 | for {set i 0} {$i<$n} {incr i} { | |
360 | Unset [PathToken $i $slave] | |
361 | } | |
362 | } | |
363 | ||
364 | # build new one | |
365 | set slave_auto_path {} | |
366 | set i 0 | |
367 | foreach dir $access_path { | |
368 | Set [PathToken $i $slave] $dir | |
369 | lappend slave_auto_path "\$[PathToken $i]" | |
370 | incr i | |
371 | } | |
372 | Set $nname $i | |
373 | Set [PathListName $slave] $access_path | |
374 | Set [VirtualPathListName $slave] $slave_auto_path | |
375 | ||
376 | Set [StaticsOkName $slave] $staticsok | |
377 | Set [NestedOkName $slave] $nestedok | |
378 | Set [DeleteHookName $slave] $deletehook | |
379 | ||
380 | SyncAccessPath $slave | |
381 | } | |
382 | ||
383 | # | |
384 | # | |
385 | # FindInAccessPath: | |
386 | # Search for a real directory and returns its virtual Id | |
387 | # (including the "$") | |
388 | proc ::safe::interpFindInAccessPath {slave path} { | |
389 | set access_path [GetAccessPath $slave] | |
390 | set where [lsearch -exact $access_path $path] | |
391 | if {$where == -1} { | |
392 | return -code error "$path not found in access path $access_path" | |
393 | } | |
394 | return "\$[PathToken $where]" | |
395 | } | |
396 | ||
397 | # | |
398 | # addToAccessPath: | |
399 | # add (if needed) a real directory to access path | |
400 | # and return its virtual token (including the "$"). | |
401 | proc ::safe::interpAddToAccessPath {slave path} { | |
402 | # first check if the directory is already in there | |
403 | if {![catch {interpFindInAccessPath $slave $path} res]} { | |
404 | return $res | |
405 | } | |
406 | # new one, add it: | |
407 | set nname [PathNumberName $slave] | |
408 | set n [Set $nname] | |
409 | Set [PathToken $n $slave] $path | |
410 | ||
411 | set token "\$[PathToken $n]" | |
412 | ||
413 | Lappend [VirtualPathListName $slave] $token | |
414 | Lappend [PathListName $slave] $path | |
415 | Set $nname [expr {$n+1}] | |
416 | ||
417 | SyncAccessPath $slave | |
418 | ||
419 | return $token | |
420 | } | |
421 | ||
422 | # This procedure applies the initializations to an already existing | |
423 | # interpreter. It is useful when you want to install the safe base | |
424 | # aliases into a preexisting safe interpreter. | |
425 | proc ::safe::InterpInit { | |
426 | slave | |
427 | access_path | |
428 | staticsok | |
429 | nestedok | |
430 | deletehook | |
431 | } { | |
432 | ||
433 | # Configure will generate an access_path when access_path is | |
434 | # empty. | |
435 | InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook | |
436 | ||
437 | # These aliases let the slave load files to define new commands | |
438 | ||
439 | # NB we need to add [namespace current], aliases are always | |
440 | # absolute paths. | |
441 | ::interp alias $slave source {} [namespace current]::AliasSource $slave | |
442 | ::interp alias $slave load {} [namespace current]::AliasLoad $slave | |
443 | ||
444 | # This alias lets the slave use the encoding names, convertfrom, | |
445 | # convertto, and system, but not "encoding system <name>" to set | |
446 | # the system encoding. | |
447 | ||
448 | ::interp alias $slave encoding {} [namespace current]::AliasEncoding \ | |
449 | $slave | |
450 | ||
451 | # This alias lets the slave have access to a subset of the 'file' | |
452 | # command functionality. | |
453 | ||
454 | AliasSubset $slave file file dir.* join root.* ext.* tail \ | |
455 | path.* split | |
456 | ||
457 | # This alias interposes on the 'exit' command and cleanly terminates | |
458 | # the slave. | |
459 | ||
460 | ::interp alias $slave exit {} [namespace current]::interpDelete $slave | |
461 | ||
462 | # The allowed slave variables already have been set | |
463 | # by Tcl_MakeSafe(3) | |
464 | ||
465 | ||
466 | # Source init.tcl into the slave, to get auto_load and other | |
467 | # procedures defined: | |
468 | ||
469 | # We don't try to use the -rsrc on the mac because it would get | |
470 | # confusing if you would want to customize init.tcl | |
471 | # for a given set of safe slaves, on all the platforms | |
472 | # you just need to give a specific access_path and | |
473 | # the mac should be no exception. As there is no | |
474 | # obvious full "safe ressources" design nor implementation | |
475 | # for the mac, safe interps there will just don't | |
476 | # have that ability. (A specific app can still reenable | |
477 | # that using custom aliases if they want to). | |
478 | # It would also make the security analysis and the Safe Tcl security | |
479 | # model platform dependant and thus more error prone. | |
480 | ||
481 | if {[catch {::interp eval $slave\ | |
482 | {source [file join $tcl_library init.tcl]}} msg]} { | |
483 | Log $slave "can't source init.tcl ($msg)" | |
484 | error "can't source init.tcl into slave $slave ($msg)" | |
485 | } | |
486 | ||
487 | return $slave | |
488 | } | |
489 | ||
490 | ||
491 | # Add (only if needed, avoid duplicates) 1 level of | |
492 | # sub directories to an existing path list. | |
493 | # Also removes non directories from the returned list. | |
494 | proc AddSubDirs {pathList} { | |
495 | set res {} | |
496 | foreach dir $pathList { | |
497 | if {[file isdirectory $dir]} { | |
498 | # check that we don't have it yet as a children | |
499 | # of a previous dir | |
500 | if {[lsearch -exact $res $dir]<0} { | |
501 | lappend res $dir | |
502 | } | |
503 | foreach sub [glob -directory $dir -nocomplain *] { | |
504 | if {([file isdirectory $sub]) \ | |
505 | && ([lsearch -exact $res $sub]<0) } { | |
506 | # new sub dir, add it ! | |
507 | lappend res $sub | |
508 | } | |
509 | } | |
510 | } | |
511 | } | |
512 | return $res | |
513 | } | |
514 | ||
515 | # This procedure deletes a safe slave managed by Safe Tcl and | |
516 | # cleans up associated state: | |
517 | ||
518 | proc ::safe::interpDelete {slave} { | |
519 | ||
520 | Log $slave "About to delete" NOTICE | |
521 | ||
522 | # If the slave has a cleanup hook registered, call it. | |
523 | # check the existance because we might be called to delete an interp | |
524 | # which has not been registered with us at all | |
525 | set hookname [DeleteHookName $slave] | |
526 | if {[Exists $hookname]} { | |
527 | set hook [Set $hookname] | |
528 | if {![::tcl::Lempty $hook]} { | |
529 | # remove the hook now, otherwise if the hook | |
530 | # calls us somehow, we'll loop | |
531 | Unset $hookname | |
532 | if {[catch {eval $hook [list $slave]} err]} { | |
533 | Log $slave "Delete hook error ($err)" | |
534 | } | |
535 | } | |
536 | } | |
537 | ||
538 | # Discard the global array of state associated with the slave, and | |
539 | # delete the interpreter. | |
540 | ||
541 | set statename [InterpStateName $slave] | |
542 | if {[Exists $statename]} { | |
543 | Unset $statename | |
544 | } | |
545 | ||
546 | # if we have been called twice, the interp might have been deleted | |
547 | # already | |
548 | if {[::interp exists $slave]} { | |
549 | ::interp delete $slave | |
550 | Log $slave "Deleted" NOTICE | |
551 | } | |
552 | ||
553 | return | |
554 | } | |
555 | ||
556 | # Set (or get) the loging mecanism | |
557 | ||
558 | proc ::safe::setLogCmd {args} { | |
559 | variable Log | |
560 | if {[llength $args] == 0} { | |
561 | return $Log | |
562 | } else { | |
563 | if {[llength $args] == 1} { | |
564 | set Log [lindex $args 0] | |
565 | } else { | |
566 | set Log $args | |
567 | } | |
568 | } | |
569 | } | |
570 | ||
571 | # internal variable | |
572 | variable Log {} | |
573 | ||
574 | # ------------------- END OF PUBLIC METHODS ------------ | |
575 | ||
576 | ||
577 | # | |
578 | # sets the slave auto_path to the master recorded value. | |
579 | # also sets tcl_library to the first token of the virtual path. | |
580 | # | |
581 | proc SyncAccessPath {slave} { | |
582 | set slave_auto_path [Set [VirtualPathListName $slave]] | |
583 | ::interp eval $slave [list set auto_path $slave_auto_path] | |
584 | Log $slave "auto_path in $slave has been set to $slave_auto_path"\ | |
585 | NOTICE | |
586 | ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]] | |
587 | } | |
588 | ||
589 | # base name for storing all the slave states | |
590 | # the array variable name for slave foo is thus "Sfoo" | |
591 | # and for sub slave {foo bar} "Sfoo bar" (spaces are handled | |
592 | # ok everywhere (or should)) | |
593 | # We add the S prefix to avoid that a slave interp called "Log" | |
594 | # would smash our "Log" variable. | |
595 | proc InterpStateName {slave} { | |
596 | return "S$slave" | |
597 | } | |
598 | ||
599 | # Check that the given slave is "one of us" | |
600 | proc IsInterp {slave} { | |
601 | expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]} | |
602 | } | |
603 | ||
604 | # returns the virtual token for directory number N | |
605 | # if the slave argument is given, | |
606 | # it will return the corresponding master global variable name | |
607 | proc PathToken {n {slave ""}} { | |
608 | if {$slave ne ""} { | |
609 | return "[InterpStateName $slave](access_path,$n)" | |
610 | } else { | |
611 | # We need to have a ":" in the token string so | |
612 | # [file join] on the mac won't turn it into a relative | |
613 | # path. | |
614 | return "p(:$n:)" | |
615 | } | |
616 | } | |
617 | # returns the variable name of the complete path list | |
618 | proc PathListName {slave} { | |
619 | return "[InterpStateName $slave](access_path)" | |
620 | } | |
621 | # returns the variable name of the complete path list | |
622 | proc VirtualPathListName {slave} { | |
623 | return "[InterpStateName $slave](access_path_slave)" | |
624 | } | |
625 | # returns the variable name of the number of items | |
626 | proc PathNumberName {slave} { | |
627 | return "[InterpStateName $slave](access_path,n)" | |
628 | } | |
629 | # returns the staticsok flag var name | |
630 | proc StaticsOkName {slave} { | |
631 | return "[InterpStateName $slave](staticsok)" | |
632 | } | |
633 | # returns the nestedok flag var name | |
634 | proc NestedOkName {slave} { | |
635 | return "[InterpStateName $slave](nestedok)" | |
636 | } | |
637 | # Run some code at the namespace toplevel | |
638 | proc Toplevel {args} { | |
639 | namespace eval [namespace current] $args | |
640 | } | |
641 | # set/get values | |
642 | proc Set {args} { | |
643 | eval [list Toplevel set] $args | |
644 | } | |
645 | # lappend on toplevel vars | |
646 | proc Lappend {args} { | |
647 | eval [list Toplevel lappend] $args | |
648 | } | |
649 | # unset a var/token (currently just an global level eval) | |
650 | proc Unset {args} { | |
651 | eval [list Toplevel unset] $args | |
652 | } | |
653 | # test existance | |
654 | proc Exists {varname} { | |
655 | Toplevel info exists $varname | |
656 | } | |
657 | # short cut for access path getting | |
658 | proc GetAccessPath {slave} { | |
659 | Set [PathListName $slave] | |
660 | } | |
661 | # short cut for statics ok flag getting | |
662 | proc StaticsOk {slave} { | |
663 | Set [StaticsOkName $slave] | |
664 | } | |
665 | # short cut for getting the multiples interps sub loading ok flag | |
666 | proc NestedOk {slave} { | |
667 | Set [NestedOkName $slave] | |
668 | } | |
669 | # interp deletion storing hook name | |
670 | proc DeleteHookName {slave} { | |
671 | return [InterpStateName $slave](cleanupHook) | |
672 | } | |
673 | ||
674 | # | |
675 | # translate virtual path into real path | |
676 | # | |
677 | proc TranslatePath {slave path} { | |
678 | # somehow strip the namespaces 'functionality' out (the danger | |
679 | # is that we would strip valid macintosh "../" queries... : | |
680 | if {[regexp {(::)|(\.\.)} $path]} { | |
681 | error "invalid characters in path $path" | |
682 | } | |
683 | set n [expr {[Set [PathNumberName $slave]]-1}] | |
684 | for {} {$n>=0} {incr n -1} { | |
685 | # fill the token virtual names with their real value | |
686 | set [PathToken $n] [Set [PathToken $n $slave]] | |
687 | } | |
688 | # replaces the token by their value | |
689 | subst -nobackslashes -nocommands $path | |
690 | } | |
691 | ||
692 | ||
693 | # Log eventually log an error | |
694 | # to enable error logging, set Log to {puts stderr} for instance | |
695 | proc Log {slave msg {type ERROR}} { | |
696 | variable Log | |
697 | if {[info exists Log] && [llength $Log]} { | |
698 | eval $Log [list "$type for slave $slave : $msg"] | |
699 | } | |
700 | } | |
701 | ||
702 | ||
703 | # file name control (limit access to files/ressources that should be | |
704 | # a valid tcl source file) | |
705 | proc CheckFileName {slave file} { | |
706 | # This used to limit what can be sourced to ".tcl" and forbid files | |
707 | # with more than 1 dot and longer than 14 chars, but I changed that | |
708 | # for 8.4 as a safe interp has enough internal protection already | |
709 | # to allow sourcing anything. - hobbs | |
710 | ||
711 | if {![file exists $file]} { | |
712 | # don't tell the file path | |
713 | error "no such file or directory" | |
714 | } | |
715 | ||
716 | if {![file readable $file]} { | |
717 | # don't tell the file path | |
718 | error "not readable" | |
719 | } | |
720 | } | |
721 | ||
722 | ||
723 | # AliasSource is the target of the "source" alias in safe interpreters. | |
724 | ||
725 | proc AliasSource {slave args} { | |
726 | ||
727 | set argc [llength $args] | |
728 | # Allow only "source filename" | |
729 | # (and not mac specific -rsrc for instance - see comment in ::init | |
730 | # for current rationale) | |
731 | if {$argc != 1} { | |
732 | set msg "wrong # args: should be \"source fileName\"" | |
733 | Log $slave "$msg ($args)" | |
734 | return -code error $msg | |
735 | } | |
736 | set file [lindex $args 0] | |
737 | ||
738 | # get the real path from the virtual one. | |
739 | if {[catch {set file [TranslatePath $slave $file]} msg]} { | |
740 | Log $slave $msg | |
741 | return -code error "permission denied" | |
742 | } | |
743 | ||
744 | # check that the path is in the access path of that slave | |
745 | if {[catch {FileInAccessPath $slave $file} msg]} { | |
746 | Log $slave $msg | |
747 | return -code error "permission denied" | |
748 | } | |
749 | ||
750 | # do the checks on the filename : | |
751 | if {[catch {CheckFileName $slave $file} msg]} { | |
752 | Log $slave "$file:$msg" | |
753 | return -code error $msg | |
754 | } | |
755 | ||
756 | # passed all the tests , lets source it: | |
757 | if {[catch {::interp invokehidden $slave source $file} msg]} { | |
758 | Log $slave $msg | |
759 | return -code error "script error" | |
760 | } | |
761 | return $msg | |
762 | } | |
763 | ||
764 | # AliasLoad is the target of the "load" alias in safe interpreters. | |
765 | ||
766 | proc AliasLoad {slave file args} { | |
767 | ||
768 | set argc [llength $args] | |
769 | if {$argc > 2} { | |
770 | set msg "load error: too many arguments" | |
771 | Log $slave "$msg ($argc) {$file $args}" | |
772 | return -code error $msg | |
773 | } | |
774 | ||
775 | # package name (can be empty if file is not). | |
776 | set package [lindex $args 0] | |
777 | ||
778 | # Determine where to load. load use a relative interp path | |
779 | # and {} means self, so we can directly and safely use passed arg. | |
780 | set target [lindex $args 1] | |
781 | if {[string length $target]} { | |
782 | # we will try to load into a sub sub interp | |
783 | # check that we want to authorize that. | |
784 | if {![NestedOk $slave]} { | |
785 | Log $slave "loading to a sub interp (nestedok)\ | |
786 | disabled (trying to load $package to $target)" | |
787 | return -code error "permission denied (nested load)" | |
788 | } | |
789 | ||
790 | } | |
791 | ||
792 | # Determine what kind of load is requested | |
793 | if {[string length $file] == 0} { | |
794 | # static package loading | |
795 | if {[string length $package] == 0} { | |
796 | set msg "load error: empty filename and no package name" | |
797 | Log $slave $msg | |
798 | return -code error $msg | |
799 | } | |
800 | if {![StaticsOk $slave]} { | |
801 | Log $slave "static packages loading disabled\ | |
802 | (trying to load $package to $target)" | |
803 | return -code error "permission denied (static package)" | |
804 | } | |
805 | } else { | |
806 | # file loading | |
807 | ||
808 | # get the real path from the virtual one. | |
809 | if {[catch {set file [TranslatePath $slave $file]} msg]} { | |
810 | Log $slave $msg | |
811 | return -code error "permission denied" | |
812 | } | |
813 | ||
814 | # check the translated path | |
815 | if {[catch {FileInAccessPath $slave $file} msg]} { | |
816 | Log $slave $msg | |
817 | return -code error "permission denied (path)" | |
818 | } | |
819 | } | |
820 | ||
821 | if {[catch {::interp invokehidden\ | |
822 | $slave load $file $package $target} msg]} { | |
823 | Log $slave $msg | |
824 | return -code error $msg | |
825 | } | |
826 | ||
827 | return $msg | |
828 | } | |
829 | ||
830 | # FileInAccessPath raises an error if the file is not found in | |
831 | # the list of directories contained in the (master side recorded) slave's | |
832 | # access path. | |
833 | ||
834 | # the security here relies on "file dirname" answering the proper | |
835 | # result.... needs checking ? | |
836 | proc FileInAccessPath {slave file} { | |
837 | ||
838 | set access_path [GetAccessPath $slave] | |
839 | ||
840 | if {[file isdirectory $file]} { | |
841 | error "\"$file\": is a directory" | |
842 | } | |
843 | set parent [file dirname $file] | |
844 | ||
845 | # Normalize paths for comparison since lsearch knows nothing of | |
846 | # potential pathname anomalies. | |
847 | set norm_parent [file normalize $parent] | |
848 | foreach path $access_path { | |
849 | lappend norm_access_path [file normalize $path] | |
850 | } | |
851 | ||
852 | if {[lsearch -exact $norm_access_path $norm_parent] == -1} { | |
853 | error "\"$file\": not in access_path" | |
854 | } | |
855 | } | |
856 | ||
857 | # This procedure enables access from a safe interpreter to only a subset of | |
858 | # the subcommands of a command: | |
859 | ||
860 | proc Subset {slave command okpat args} { | |
861 | set subcommand [lindex $args 0] | |
862 | if {[regexp $okpat $subcommand]} { | |
863 | return [eval [list $command $subcommand] [lrange $args 1 end]] | |
864 | } | |
865 | set msg "not allowed to invoke subcommand $subcommand of $command" | |
866 | Log $slave $msg | |
867 | error $msg | |
868 | } | |
869 | ||
870 | # This procedure installs an alias in a slave that invokes "safesubset" | |
871 | # in the master to execute allowed subcommands. It precomputes the pattern | |
872 | # of allowed subcommands; you can use wildcards in the pattern if you wish | |
873 | # to allow subcommand abbreviation. | |
874 | # | |
875 | # Syntax is: AliasSubset slave alias target subcommand1 subcommand2... | |
876 | ||
877 | proc AliasSubset {slave alias target args} { | |
878 | set pat ^(; set sep "" | |
879 | foreach sub $args { | |
880 | append pat $sep$sub | |
881 | set sep | | |
882 | } | |
883 | append pat )\$ | |
884 | ::interp alias $slave $alias {}\ | |
885 | [namespace current]::Subset $slave $target $pat | |
886 | } | |
887 | ||
888 | # AliasEncoding is the target of the "encoding" alias in safe interpreters. | |
889 | ||
890 | proc AliasEncoding {slave args} { | |
891 | ||
892 | set argc [llength $args] | |
893 | ||
894 | set okpat "^(name.*|convert.*)\$" | |
895 | set subcommand [lindex $args 0] | |
896 | ||
897 | if {[regexp $okpat $subcommand]} { | |
898 | return [eval ::interp invokehidden $slave encoding $subcommand \ | |
899 | [lrange $args 1 end]] | |
900 | } | |
901 | ||
902 | if {[string match $subcommand system]} { | |
903 | if {$argc == 1} { | |
904 | # passed all the tests , lets source it: | |
905 | if {[catch {::interp invokehidden \ | |
906 | $slave encoding system} msg]} { | |
907 | Log $slave $msg | |
908 | return -code error "script error" | |
909 | } | |
910 | } else { | |
911 | set msg "wrong # args: should be \"encoding system\"" | |
912 | Log $slave $msg | |
913 | error $msg | |
914 | } | |
915 | } else { | |
916 | set msg "wrong # args: should be \"encoding option ?arg ...?\"" | |
917 | Log $slave $msg | |
918 | error $msg | |
919 | } | |
920 | ||
921 | return $msg | |
922 | } | |
923 | ||
924 | } |