Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/safe.tcl @ 69:33d812a61356

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
planemo upload commit 2e9511a184a1ca667c7be0c6321a36dc4e3d116d
author jpayne
date Tue, 18 Mar 2025 17:55:14 -0400
parents
children
rev   line source
jpayne@69 1 # safe.tcl --
jpayne@69 2 #
jpayne@69 3 # This file provide a safe loading/sourcing mechanism for safe interpreters.
jpayne@69 4 # It implements a virtual path mechanism to hide the real pathnames from the
jpayne@69 5 # child. It runs in a parent interpreter and sets up data structure and
jpayne@69 6 # aliases that will be invoked when used from a child interpreter.
jpayne@69 7 #
jpayne@69 8 # See the safe.n man page for details.
jpayne@69 9 #
jpayne@69 10 # Copyright (c) 1996-1997 Sun Microsystems, Inc.
jpayne@69 11 #
jpayne@69 12 # See the file "license.terms" for information on usage and redistribution of
jpayne@69 13 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
jpayne@69 14
jpayne@69 15 #
jpayne@69 16 # The implementation is based on namespaces. These naming conventions are
jpayne@69 17 # followed:
jpayne@69 18 # Private procs starts with uppercase.
jpayne@69 19 # Public procs are exported and starts with lowercase
jpayne@69 20 #
jpayne@69 21
jpayne@69 22 # Needed utilities package
jpayne@69 23 package require opt 0.4.8
jpayne@69 24
jpayne@69 25 # Create the safe namespace
jpayne@69 26 namespace eval ::safe {
jpayne@69 27 # Exported API:
jpayne@69 28 namespace export interpCreate interpInit interpConfigure interpDelete \
jpayne@69 29 interpAddToAccessPath interpFindInAccessPath setLogCmd
jpayne@69 30 }
jpayne@69 31
jpayne@69 32 # Helper function to resolve the dual way of specifying staticsok (either
jpayne@69 33 # by -noStatics or -statics 0)
jpayne@69 34 proc ::safe::InterpStatics {} {
jpayne@69 35 foreach v {Args statics noStatics} {
jpayne@69 36 upvar $v $v
jpayne@69 37 }
jpayne@69 38 set flag [::tcl::OptProcArgGiven -noStatics]
jpayne@69 39 if {$flag && (!$noStatics == !$statics)
jpayne@69 40 && ([::tcl::OptProcArgGiven -statics])} {
jpayne@69 41 return -code error\
jpayne@69 42 "conflicting values given for -statics and -noStatics"
jpayne@69 43 }
jpayne@69 44 if {$flag} {
jpayne@69 45 return [expr {!$noStatics}]
jpayne@69 46 } else {
jpayne@69 47 return $statics
jpayne@69 48 }
jpayne@69 49 }
jpayne@69 50
jpayne@69 51 # Helper function to resolve the dual way of specifying nested loading
jpayne@69 52 # (either by -nestedLoadOk or -nested 1)
jpayne@69 53 proc ::safe::InterpNested {} {
jpayne@69 54 foreach v {Args nested nestedLoadOk} {
jpayne@69 55 upvar $v $v
jpayne@69 56 }
jpayne@69 57 set flag [::tcl::OptProcArgGiven -nestedLoadOk]
jpayne@69 58 # note that the test here is the opposite of the "InterpStatics" one
jpayne@69 59 # (it is not -noNested... because of the wanted default value)
jpayne@69 60 if {$flag && (!$nestedLoadOk != !$nested)
jpayne@69 61 && ([::tcl::OptProcArgGiven -nested])} {
jpayne@69 62 return -code error\
jpayne@69 63 "conflicting values given for -nested and -nestedLoadOk"
jpayne@69 64 }
jpayne@69 65 if {$flag} {
jpayne@69 66 # another difference with "InterpStatics"
jpayne@69 67 return $nestedLoadOk
jpayne@69 68 } else {
jpayne@69 69 return $nested
jpayne@69 70 }
jpayne@69 71 }
jpayne@69 72
jpayne@69 73 ####
jpayne@69 74 #
jpayne@69 75 # API entry points that needs argument parsing :
jpayne@69 76 #
jpayne@69 77 ####
jpayne@69 78
jpayne@69 79 # Interface/entry point function and front end for "Create"
jpayne@69 80 proc ::safe::interpCreate {args} {
jpayne@69 81 set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
jpayne@69 82 RejectExcessColons $slave
jpayne@69 83 InterpCreate $slave $accessPath \
jpayne@69 84 [InterpStatics] [InterpNested] $deleteHook
jpayne@69 85 }
jpayne@69 86
jpayne@69 87 proc ::safe::interpInit {args} {
jpayne@69 88 set Args [::tcl::OptKeyParse ::safe::interpIC $args]
jpayne@69 89 if {![::interp exists $slave]} {
jpayne@69 90 return -code error "\"$slave\" is not an interpreter"
jpayne@69 91 }
jpayne@69 92 RejectExcessColons $slave
jpayne@69 93 InterpInit $slave $accessPath \
jpayne@69 94 [InterpStatics] [InterpNested] $deleteHook
jpayne@69 95 }
jpayne@69 96
jpayne@69 97 # Check that the given child is "one of us"
jpayne@69 98 proc ::safe::CheckInterp {child} {
jpayne@69 99 namespace upvar ::safe [VarName $child] state
jpayne@69 100 if {![info exists state] || ![::interp exists $child]} {
jpayne@69 101 return -code error \
jpayne@69 102 "\"$child\" is not an interpreter managed by ::safe::"
jpayne@69 103 }
jpayne@69 104 }
jpayne@69 105
jpayne@69 106 # Interface/entry point function and front end for "Configure". This code
jpayne@69 107 # is awfully pedestrian because it would need more coupling and support
jpayne@69 108 # between the way we store the configuration values in safe::interp's and
jpayne@69 109 # the Opt package. Obviously we would like an OptConfigure to avoid
jpayne@69 110 # duplicating all this code everywhere.
jpayne@69 111 # -> TODO (the app should share or access easily the program/value stored
jpayne@69 112 # by opt)
jpayne@69 113
jpayne@69 114 # This is even more complicated by the boolean flags with no values that
jpayne@69 115 # we had the bad idea to support for the sake of user simplicity in
jpayne@69 116 # create/init but which makes life hard in configure...
jpayne@69 117 # So this will be hopefully written and some integrated with opt1.0
jpayne@69 118 # (hopefully for tcl8.1 ?)
jpayne@69 119 proc ::safe::interpConfigure {args} {
jpayne@69 120 switch [llength $args] {
jpayne@69 121 1 {
jpayne@69 122 # If we have exactly 1 argument the semantic is to return all
jpayne@69 123 # the current configuration. We still call OptKeyParse though
jpayne@69 124 # we know that "child" is our given argument because it also
jpayne@69 125 # checks for the "-help" option.
jpayne@69 126 set Args [::tcl::OptKeyParse ::safe::interpIC $args]
jpayne@69 127 CheckInterp $slave
jpayne@69 128 namespace upvar ::safe [VarName $slave] state
jpayne@69 129
jpayne@69 130 return [join [list \
jpayne@69 131 [list -accessPath $state(access_path)] \
jpayne@69 132 [list -statics $state(staticsok)] \
jpayne@69 133 [list -nested $state(nestedok)] \
jpayne@69 134 [list -deleteHook $state(cleanupHook)]]]
jpayne@69 135 }
jpayne@69 136 2 {
jpayne@69 137 # If we have exactly 2 arguments the semantic is a "configure
jpayne@69 138 # get"
jpayne@69 139 lassign $args slave arg
jpayne@69 140
jpayne@69 141 # get the flag sub program (we 'know' about Opt's internal
jpayne@69 142 # representation of data)
jpayne@69 143 set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
jpayne@69 144 set hits [::tcl::OptHits desc $arg]
jpayne@69 145 if {$hits > 1} {
jpayne@69 146 return -code error [::tcl::OptAmbigous $desc $arg]
jpayne@69 147 } elseif {$hits == 0} {
jpayne@69 148 return -code error [::tcl::OptFlagUsage $desc $arg]
jpayne@69 149 }
jpayne@69 150 CheckInterp $slave
jpayne@69 151 namespace upvar ::safe [VarName $slave] state
jpayne@69 152
jpayne@69 153 set item [::tcl::OptCurDesc $desc]
jpayne@69 154 set name [::tcl::OptName $item]
jpayne@69 155 switch -exact -- $name {
jpayne@69 156 -accessPath {
jpayne@69 157 return [list -accessPath $state(access_path)]
jpayne@69 158 }
jpayne@69 159 -statics {
jpayne@69 160 return [list -statics $state(staticsok)]
jpayne@69 161 }
jpayne@69 162 -nested {
jpayne@69 163 return [list -nested $state(nestedok)]
jpayne@69 164 }
jpayne@69 165 -deleteHook {
jpayne@69 166 return [list -deleteHook $state(cleanupHook)]
jpayne@69 167 }
jpayne@69 168 -noStatics {
jpayne@69 169 # it is most probably a set in fact but we would need
jpayne@69 170 # then to jump to the set part and it is not *sure*
jpayne@69 171 # that it is a set action that the user want, so force
jpayne@69 172 # it to use the unambigous -statics ?value? instead:
jpayne@69 173 return -code error\
jpayne@69 174 "ambigous query (get or set -noStatics ?)\
jpayne@69 175 use -statics instead"
jpayne@69 176 }
jpayne@69 177 -nestedLoadOk {
jpayne@69 178 return -code error\
jpayne@69 179 "ambigous query (get or set -nestedLoadOk ?)\
jpayne@69 180 use -nested instead"
jpayne@69 181 }
jpayne@69 182 default {
jpayne@69 183 return -code error "unknown flag $name (bug)"
jpayne@69 184 }
jpayne@69 185 }
jpayne@69 186 }
jpayne@69 187 default {
jpayne@69 188 # Otherwise we want to parse the arguments like init and
jpayne@69 189 # create did
jpayne@69 190 set Args [::tcl::OptKeyParse ::safe::interpIC $args]
jpayne@69 191 CheckInterp $slave
jpayne@69 192 namespace upvar ::safe [VarName $slave] state
jpayne@69 193
jpayne@69 194 # Get the current (and not the default) values of whatever has
jpayne@69 195 # not been given:
jpayne@69 196 if {![::tcl::OptProcArgGiven -accessPath]} {
jpayne@69 197 set doreset 0
jpayne@69 198 set accessPath $state(access_path)
jpayne@69 199 } else {
jpayne@69 200 set doreset 1
jpayne@69 201 }
jpayne@69 202 if {
jpayne@69 203 ![::tcl::OptProcArgGiven -statics]
jpayne@69 204 && ![::tcl::OptProcArgGiven -noStatics]
jpayne@69 205 } then {
jpayne@69 206 set statics $state(staticsok)
jpayne@69 207 } else {
jpayne@69 208 set statics [InterpStatics]
jpayne@69 209 }
jpayne@69 210 if {
jpayne@69 211 [::tcl::OptProcArgGiven -nested] ||
jpayne@69 212 [::tcl::OptProcArgGiven -nestedLoadOk]
jpayne@69 213 } then {
jpayne@69 214 set nested [InterpNested]
jpayne@69 215 } else {
jpayne@69 216 set nested $state(nestedok)
jpayne@69 217 }
jpayne@69 218 if {![::tcl::OptProcArgGiven -deleteHook]} {
jpayne@69 219 set deleteHook $state(cleanupHook)
jpayne@69 220 }
jpayne@69 221 # we can now reconfigure :
jpayne@69 222 InterpSetConfig $slave $accessPath $statics $nested $deleteHook
jpayne@69 223 # auto_reset the child (to completly synch the new access_path)
jpayne@69 224 if {$doreset} {
jpayne@69 225 if {[catch {::interp eval $slave {auto_reset}} msg]} {
jpayne@69 226 Log $slave "auto_reset failed: $msg"
jpayne@69 227 } else {
jpayne@69 228 Log $slave "successful auto_reset" NOTICE
jpayne@69 229 }
jpayne@69 230
jpayne@69 231 # Sync the paths used to search for Tcl modules.
jpayne@69 232 ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]}
jpayne@69 233 if {[llength $state(tm_path_slave)] > 0} {
jpayne@69 234 ::interp eval $slave [list \
jpayne@69 235 ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
jpayne@69 236 }
jpayne@69 237
jpayne@69 238 # Remove stale "package ifneeded" data for non-loaded packages.
jpayne@69 239 # - Not for loaded packages, because "package forget" erases
jpayne@69 240 # data from "package provide" as well as "package ifneeded".
jpayne@69 241 # - This is OK because the script cannot reload any version of
jpayne@69 242 # the package unless it first does "package forget".
jpayne@69 243 foreach pkg [::interp eval $slave {package names}] {
jpayne@69 244 if {[::interp eval $slave [list package provide $pkg]] eq ""} {
jpayne@69 245 ::interp eval $slave [list package forget $pkg]
jpayne@69 246 }
jpayne@69 247 }
jpayne@69 248 }
jpayne@69 249 return
jpayne@69 250 }
jpayne@69 251 }
jpayne@69 252 }
jpayne@69 253
jpayne@69 254 ####
jpayne@69 255 #
jpayne@69 256 # Functions that actually implements the exported APIs
jpayne@69 257 #
jpayne@69 258 ####
jpayne@69 259
jpayne@69 260 #
jpayne@69 261 # safe::InterpCreate : doing the real job
jpayne@69 262 #
jpayne@69 263 # This procedure creates a safe interpreter and initializes it with the safe
jpayne@69 264 # base aliases.
jpayne@69 265 # NB: child name must be simple alphanumeric string, no spaces, no (), no
jpayne@69 266 # {},... {because the state array is stored as part of the name}
jpayne@69 267 #
jpayne@69 268 # Returns the child name.
jpayne@69 269 #
jpayne@69 270 # Optional Arguments :
jpayne@69 271 # + child name : if empty, generated name will be used
jpayne@69 272 # + access_path: path list controlling where load/source can occur,
jpayne@69 273 # if empty: the parent auto_path will be used.
jpayne@69 274 # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
jpayne@69 275 # if 1 :static packages are ok.
jpayne@69 276 # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
jpayne@69 277 # if 1 : multiple levels are ok.
jpayne@69 278
jpayne@69 279 # use the full name and no indent so auto_mkIndex can find us
jpayne@69 280 proc ::safe::InterpCreate {
jpayne@69 281 child
jpayne@69 282 access_path
jpayne@69 283 staticsok
jpayne@69 284 nestedok
jpayne@69 285 deletehook
jpayne@69 286 } {
jpayne@69 287 # Create the child.
jpayne@69 288 # If evaluated in ::safe, the interpreter command for foo is ::foo;
jpayne@69 289 # but for foo::bar is safe::foo::bar. So evaluate in :: instead.
jpayne@69 290 if {$child ne ""} {
jpayne@69 291 namespace eval :: [list ::interp create -safe $child]
jpayne@69 292 } else {
jpayne@69 293 # empty argument: generate child name
jpayne@69 294 set child [::interp create -safe]
jpayne@69 295 }
jpayne@69 296 Log $child "Created" NOTICE
jpayne@69 297
jpayne@69 298 # Initialize it. (returns child name)
jpayne@69 299 InterpInit $child $access_path $staticsok $nestedok $deletehook
jpayne@69 300 }
jpayne@69 301
jpayne@69 302 #
jpayne@69 303 # InterpSetConfig (was setAccessPath) :
jpayne@69 304 # Sets up child virtual auto_path and corresponding structure within
jpayne@69 305 # the parent. Also sets the tcl_library in the child to be the first
jpayne@69 306 # directory in the path.
jpayne@69 307 # NB: If you change the path after the child has been initialized you
jpayne@69 308 # probably need to call "auto_reset" in the child in order that it gets
jpayne@69 309 # the right auto_index() array values.
jpayne@69 310
jpayne@69 311 proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
jpayne@69 312 global auto_path
jpayne@69 313
jpayne@69 314 # determine and store the access path if empty
jpayne@69 315 if {$access_path eq ""} {
jpayne@69 316 set access_path $auto_path
jpayne@69 317
jpayne@69 318 # Make sure that tcl_library is in auto_path and at the first
jpayne@69 319 # position (needed by setAccessPath)
jpayne@69 320 set where [lsearch -exact $access_path [info library]]
jpayne@69 321 if {$where < 0} {
jpayne@69 322 # not found, add it.
jpayne@69 323 set access_path [linsert $access_path 0 [info library]]
jpayne@69 324 Log $child "tcl_library was not in auto_path,\
jpayne@69 325 added it to slave's access_path" NOTICE
jpayne@69 326 } elseif {$where != 0} {
jpayne@69 327 # not first, move it first
jpayne@69 328 set access_path [linsert \
jpayne@69 329 [lreplace $access_path $where $where] \
jpayne@69 330 0 [info library]]
jpayne@69 331 Log $child "tcl_libray was not in first in auto_path,\
jpayne@69 332 moved it to front of slave's access_path" NOTICE
jpayne@69 333 }
jpayne@69 334
jpayne@69 335 # Add 1st level sub dirs (will searched by auto loading from tcl
jpayne@69 336 # code in the child using glob and thus fail, so we add them here
jpayne@69 337 # so by default it works the same).
jpayne@69 338 set access_path [AddSubDirs $access_path]
jpayne@69 339 }
jpayne@69 340
jpayne@69 341 Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
jpayne@69 342 nestedok=$nestedok deletehook=($deletehook)" NOTICE
jpayne@69 343
jpayne@69 344 namespace upvar ::safe [VarName $child] state
jpayne@69 345
jpayne@69 346 # clear old autopath if it existed
jpayne@69 347 # build new one
jpayne@69 348 # Extend the access list with the paths used to look for Tcl Modules.
jpayne@69 349 # We save the virtual form separately as well, as syncing it with the
jpayne@69 350 # child has to be deferred until the necessary commands are present for
jpayne@69 351 # setup.
jpayne@69 352
jpayne@69 353 set norm_access_path {}
jpayne@69 354 set slave_access_path {}
jpayne@69 355 set map_access_path {}
jpayne@69 356 set remap_access_path {}
jpayne@69 357 set slave_tm_path {}
jpayne@69 358
jpayne@69 359 set i 0
jpayne@69 360 foreach dir $access_path {
jpayne@69 361 set token [PathToken $i]
jpayne@69 362 lappend slave_access_path $token
jpayne@69 363 lappend map_access_path $token $dir
jpayne@69 364 lappend remap_access_path $dir $token
jpayne@69 365 lappend norm_access_path [file normalize $dir]
jpayne@69 366 incr i
jpayne@69 367 }
jpayne@69 368
jpayne@69 369 set morepaths [::tcl::tm::list]
jpayne@69 370 set firstpass 1
jpayne@69 371 while {[llength $morepaths]} {
jpayne@69 372 set addpaths $morepaths
jpayne@69 373 set morepaths {}
jpayne@69 374
jpayne@69 375 foreach dir $addpaths {
jpayne@69 376 # Prevent the addition of dirs on the tm list to the
jpayne@69 377 # result if they are already known.
jpayne@69 378 if {[dict exists $remap_access_path $dir]} {
jpayne@69 379 if {$firstpass} {
jpayne@69 380 # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
jpayne@69 381 # Later passes handle subdirectories, which belong in the
jpayne@69 382 # access path but not in the module path.
jpayne@69 383 lappend slave_tm_path [dict get $remap_access_path $dir]
jpayne@69 384 }
jpayne@69 385 continue
jpayne@69 386 }
jpayne@69 387
jpayne@69 388 set token [PathToken $i]
jpayne@69 389 lappend access_path $dir
jpayne@69 390 lappend slave_access_path $token
jpayne@69 391 lappend map_access_path $token $dir
jpayne@69 392 lappend remap_access_path $dir $token
jpayne@69 393 lappend norm_access_path [file normalize $dir]
jpayne@69 394 if {$firstpass} {
jpayne@69 395 # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
jpayne@69 396 # Later passes handle subdirectories, which belong in the
jpayne@69 397 # access path but not in the module path.
jpayne@69 398 lappend slave_tm_path $token
jpayne@69 399 }
jpayne@69 400 incr i
jpayne@69 401
jpayne@69 402 # [Bug 2854929]
jpayne@69 403 # Recursively find deeper paths which may contain
jpayne@69 404 # modules. Required to handle modules with names like
jpayne@69 405 # 'platform::shell', which translate into
jpayne@69 406 # 'platform/shell-X.tm', i.e arbitrarily deep
jpayne@69 407 # subdirectories.
jpayne@69 408 lappend morepaths {*}[glob -nocomplain -directory $dir -type d *]
jpayne@69 409 }
jpayne@69 410 set firstpass 0
jpayne@69 411 }
jpayne@69 412
jpayne@69 413 set state(access_path) $access_path
jpayne@69 414 set state(access_path,map) $map_access_path
jpayne@69 415 set state(access_path,remap) $remap_access_path
jpayne@69 416 set state(access_path,norm) $norm_access_path
jpayne@69 417 set state(access_path,slave) $slave_access_path
jpayne@69 418 set state(tm_path_slave) $slave_tm_path
jpayne@69 419 set state(staticsok) $staticsok
jpayne@69 420 set state(nestedok) $nestedok
jpayne@69 421 set state(cleanupHook) $deletehook
jpayne@69 422
jpayne@69 423 SyncAccessPath $child
jpayne@69 424 return
jpayne@69 425 }
jpayne@69 426
jpayne@69 427 #
jpayne@69 428 #
jpayne@69 429 # FindInAccessPath:
jpayne@69 430 # Search for a real directory and returns its virtual Id (including the
jpayne@69 431 # "$")
jpayne@69 432 proc ::safe::interpFindInAccessPath {child path} {
jpayne@69 433 CheckInterp $child
jpayne@69 434 namespace upvar ::safe [VarName $child] state
jpayne@69 435
jpayne@69 436 if {![dict exists $state(access_path,remap) $path]} {
jpayne@69 437 return -code error "$path not found in access path"
jpayne@69 438 }
jpayne@69 439
jpayne@69 440 return [dict get $state(access_path,remap) $path]
jpayne@69 441 }
jpayne@69 442
jpayne@69 443 #
jpayne@69 444 # addToAccessPath:
jpayne@69 445 # add (if needed) a real directory to access path and return its
jpayne@69 446 # virtual token (including the "$").
jpayne@69 447 proc ::safe::interpAddToAccessPath {child path} {
jpayne@69 448 # first check if the directory is already in there
jpayne@69 449 # (inlined interpFindInAccessPath).
jpayne@69 450 CheckInterp $child
jpayne@69 451 namespace upvar ::safe [VarName $child] state
jpayne@69 452
jpayne@69 453 if {[dict exists $state(access_path,remap) $path]} {
jpayne@69 454 return [dict get $state(access_path,remap) $path]
jpayne@69 455 }
jpayne@69 456
jpayne@69 457 # new one, add it:
jpayne@69 458 set token [PathToken [llength $state(access_path)]]
jpayne@69 459
jpayne@69 460 lappend state(access_path) $path
jpayne@69 461 lappend state(access_path,slave) $token
jpayne@69 462 lappend state(access_path,map) $token $path
jpayne@69 463 lappend state(access_path,remap) $path $token
jpayne@69 464 lappend state(access_path,norm) [file normalize $path]
jpayne@69 465
jpayne@69 466 SyncAccessPath $child
jpayne@69 467 return $token
jpayne@69 468 }
jpayne@69 469
jpayne@69 470 # This procedure applies the initializations to an already existing
jpayne@69 471 # interpreter. It is useful when you want to install the safe base aliases
jpayne@69 472 # into a preexisting safe interpreter.
jpayne@69 473 proc ::safe::InterpInit {
jpayne@69 474 child
jpayne@69 475 access_path
jpayne@69 476 staticsok
jpayne@69 477 nestedok
jpayne@69 478 deletehook
jpayne@69 479 } {
jpayne@69 480 # Configure will generate an access_path when access_path is empty.
jpayne@69 481 InterpSetConfig $child $access_path $staticsok $nestedok $deletehook
jpayne@69 482
jpayne@69 483 # NB we need to add [namespace current], aliases are always absolute
jpayne@69 484 # paths.
jpayne@69 485
jpayne@69 486 # These aliases let the child load files to define new commands
jpayne@69 487 # This alias lets the child use the encoding names, convertfrom,
jpayne@69 488 # convertto, and system, but not "encoding system <name>" to set the
jpayne@69 489 # system encoding.
jpayne@69 490 # Handling Tcl Modules, we need a restricted form of Glob.
jpayne@69 491 # This alias interposes on the 'exit' command and cleanly terminates
jpayne@69 492 # the child.
jpayne@69 493
jpayne@69 494 foreach {command alias} {
jpayne@69 495 source AliasSource
jpayne@69 496 load AliasLoad
jpayne@69 497 encoding AliasEncoding
jpayne@69 498 exit interpDelete
jpayne@69 499 glob AliasGlob
jpayne@69 500 } {
jpayne@69 501 ::interp alias $child $command {} [namespace current]::$alias $child
jpayne@69 502 }
jpayne@69 503
jpayne@69 504 # This alias lets the child have access to a subset of the 'file'
jpayne@69 505 # command functionality.
jpayne@69 506
jpayne@69 507 ::interp expose $child file
jpayne@69 508 foreach subcommand {dirname extension rootname tail} {
jpayne@69 509 ::interp alias $child ::tcl::file::$subcommand {} \
jpayne@69 510 ::safe::AliasFileSubcommand $child $subcommand
jpayne@69 511 }
jpayne@69 512 foreach subcommand {
jpayne@69 513 atime attributes copy delete executable exists isdirectory isfile
jpayne@69 514 link lstat mtime mkdir nativename normalize owned readable readlink
jpayne@69 515 rename size stat tempfile type volumes writable
jpayne@69 516 } {
jpayne@69 517 ::interp alias $child ::tcl::file::$subcommand {} \
jpayne@69 518 ::safe::BadSubcommand $child file $subcommand
jpayne@69 519 }
jpayne@69 520
jpayne@69 521 # Subcommands of info
jpayne@69 522 foreach {subcommand alias} {
jpayne@69 523 nameofexecutable AliasExeName
jpayne@69 524 } {
jpayne@69 525 ::interp alias $child ::tcl::info::$subcommand \
jpayne@69 526 {} [namespace current]::$alias $child
jpayne@69 527 }
jpayne@69 528
jpayne@69 529 # The allowed child variables already have been set by Tcl_MakeSafe(3)
jpayne@69 530
jpayne@69 531 # Source init.tcl and tm.tcl into the child, to get auto_load and
jpayne@69 532 # other procedures defined:
jpayne@69 533
jpayne@69 534 if {[catch {::interp eval $child {
jpayne@69 535 source [file join $tcl_library init.tcl]
jpayne@69 536 }} msg opt]} {
jpayne@69 537 Log $child "can't source init.tcl ($msg)"
jpayne@69 538 return -options $opt "can't source init.tcl into slave $child ($msg)"
jpayne@69 539 }
jpayne@69 540
jpayne@69 541 if {[catch {::interp eval $child {
jpayne@69 542 source [file join $tcl_library tm.tcl]
jpayne@69 543 }} msg opt]} {
jpayne@69 544 Log $child "can't source tm.tcl ($msg)"
jpayne@69 545 return -options $opt "can't source tm.tcl into slave $child ($msg)"
jpayne@69 546 }
jpayne@69 547
jpayne@69 548 # Sync the paths used to search for Tcl modules. This can be done only
jpayne@69 549 # now, after tm.tcl was loaded.
jpayne@69 550 namespace upvar ::safe [VarName $child] state
jpayne@69 551 if {[llength $state(tm_path_slave)] > 0} {
jpayne@69 552 ::interp eval $child [list \
jpayne@69 553 ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
jpayne@69 554 }
jpayne@69 555 return $child
jpayne@69 556 }
jpayne@69 557
jpayne@69 558 # Add (only if needed, avoid duplicates) 1 level of sub directories to an
jpayne@69 559 # existing path list. Also removes non directories from the returned
jpayne@69 560 # list.
jpayne@69 561 proc ::safe::AddSubDirs {pathList} {
jpayne@69 562 set res {}
jpayne@69 563 foreach dir $pathList {
jpayne@69 564 if {[file isdirectory $dir]} {
jpayne@69 565 # check that we don't have it yet as a children of a previous
jpayne@69 566 # dir
jpayne@69 567 if {$dir ni $res} {
jpayne@69 568 lappend res $dir
jpayne@69 569 }
jpayne@69 570 foreach sub [glob -directory $dir -nocomplain *] {
jpayne@69 571 if {[file isdirectory $sub] && ($sub ni $res)} {
jpayne@69 572 # new sub dir, add it !
jpayne@69 573 lappend res $sub
jpayne@69 574 }
jpayne@69 575 }
jpayne@69 576 }
jpayne@69 577 }
jpayne@69 578 return $res
jpayne@69 579 }
jpayne@69 580
jpayne@69 581 # This procedure deletes a safe interpreter managed by Safe Tcl and cleans up
jpayne@69 582 # associated state.
jpayne@69 583 # - The command will also delete non-Safe-Base interpreters.
jpayne@69 584 # - This is regrettable, but to avoid breaking existing code this should be
jpayne@69 585 # amended at the next major revision by uncommenting "CheckInterp".
jpayne@69 586
jpayne@69 587 proc ::safe::interpDelete {child} {
jpayne@69 588 Log $child "About to delete" NOTICE
jpayne@69 589
jpayne@69 590 # CheckInterp $child
jpayne@69 591 namespace upvar ::safe [VarName $child] state
jpayne@69 592
jpayne@69 593 # When an interpreter is deleted with [interp delete], any sub-interpreters
jpayne@69 594 # are deleted automatically, but this leaves behind their data in the Safe
jpayne@69 595 # Base. To clean up properly, we call safe::interpDelete recursively on each
jpayne@69 596 # Safe Base sub-interpreter, so each one is deleted cleanly and not by
jpayne@69 597 # the automatic mechanism built into [interp delete].
jpayne@69 598 foreach sub [interp children $child] {
jpayne@69 599 if {[info exists ::safe::[VarName [list $child $sub]]]} {
jpayne@69 600 ::safe::interpDelete [list $child $sub]
jpayne@69 601 }
jpayne@69 602 }
jpayne@69 603
jpayne@69 604 # If the child has a cleanup hook registered, call it. Check the
jpayne@69 605 # existance because we might be called to delete an interp which has
jpayne@69 606 # not been registered with us at all
jpayne@69 607
jpayne@69 608 if {[info exists state(cleanupHook)]} {
jpayne@69 609 set hook $state(cleanupHook)
jpayne@69 610 if {[llength $hook]} {
jpayne@69 611 # remove the hook now, otherwise if the hook calls us somehow,
jpayne@69 612 # we'll loop
jpayne@69 613 unset state(cleanupHook)
jpayne@69 614 try {
jpayne@69 615 {*}$hook $child
jpayne@69 616 } on error err {
jpayne@69 617 Log $child "Delete hook error ($err)"
jpayne@69 618 }
jpayne@69 619 }
jpayne@69 620 }
jpayne@69 621
jpayne@69 622 # Discard the global array of state associated with the child, and
jpayne@69 623 # delete the interpreter.
jpayne@69 624
jpayne@69 625 if {[info exists state]} {
jpayne@69 626 unset state
jpayne@69 627 }
jpayne@69 628
jpayne@69 629 # if we have been called twice, the interp might have been deleted
jpayne@69 630 # already
jpayne@69 631 if {[::interp exists $child]} {
jpayne@69 632 ::interp delete $child
jpayne@69 633 Log $child "Deleted" NOTICE
jpayne@69 634 }
jpayne@69 635
jpayne@69 636 return
jpayne@69 637 }
jpayne@69 638
jpayne@69 639 # Set (or get) the logging mecanism
jpayne@69 640
jpayne@69 641 proc ::safe::setLogCmd {args} {
jpayne@69 642 variable Log
jpayne@69 643 set la [llength $args]
jpayne@69 644 if {$la == 0} {
jpayne@69 645 return $Log
jpayne@69 646 } elseif {$la == 1} {
jpayne@69 647 set Log [lindex $args 0]
jpayne@69 648 } else {
jpayne@69 649 set Log $args
jpayne@69 650 }
jpayne@69 651
jpayne@69 652 if {$Log eq ""} {
jpayne@69 653 # Disable logging completely. Calls to it will be compiled out
jpayne@69 654 # of all users.
jpayne@69 655 proc ::safe::Log {args} {}
jpayne@69 656 } else {
jpayne@69 657 # Activate logging, define proper command.
jpayne@69 658
jpayne@69 659 proc ::safe::Log {child msg {type ERROR}} {
jpayne@69 660 variable Log
jpayne@69 661 {*}$Log "$type for slave $child : $msg"
jpayne@69 662 return
jpayne@69 663 }
jpayne@69 664 }
jpayne@69 665 }
jpayne@69 666
jpayne@69 667 # ------------------- END OF PUBLIC METHODS ------------
jpayne@69 668
jpayne@69 669 #
jpayne@69 670 # Sets the child auto_path to the parent recorded value. Also sets
jpayne@69 671 # tcl_library to the first token of the virtual path.
jpayne@69 672 #
jpayne@69 673 proc ::safe::SyncAccessPath {child} {
jpayne@69 674 namespace upvar ::safe [VarName $child] state
jpayne@69 675
jpayne@69 676 set slave_access_path $state(access_path,slave)
jpayne@69 677 ::interp eval $child [list set auto_path $slave_access_path]
jpayne@69 678
jpayne@69 679 Log $child "auto_path in $child has been set to $slave_access_path"\
jpayne@69 680 NOTICE
jpayne@69 681
jpayne@69 682 # This code assumes that info library is the first element in the
jpayne@69 683 # list of auto_path's. See -> InterpSetConfig for the code which
jpayne@69 684 # ensures this condition.
jpayne@69 685
jpayne@69 686 ::interp eval $child [list \
jpayne@69 687 set tcl_library [lindex $slave_access_path 0]]
jpayne@69 688 }
jpayne@69 689
jpayne@69 690 # Returns the virtual token for directory number N.
jpayne@69 691 proc ::safe::PathToken {n} {
jpayne@69 692 # We need to have a ":" in the token string so [file join] on the
jpayne@69 693 # mac won't turn it into a relative path.
jpayne@69 694 return "\$p(:$n:)" ;# Form tested by case 7.2
jpayne@69 695 }
jpayne@69 696
jpayne@69 697 #
jpayne@69 698 # translate virtual path into real path
jpayne@69 699 #
jpayne@69 700 proc ::safe::TranslatePath {child path} {
jpayne@69 701 namespace upvar ::safe [VarName $child] state
jpayne@69 702
jpayne@69 703 # somehow strip the namespaces 'functionality' out (the danger is that
jpayne@69 704 # we would strip valid macintosh "../" queries... :
jpayne@69 705 if {[string match "*::*" $path] || [string match "*..*" $path]} {
jpayne@69 706 return -code error "invalid characters in path $path"
jpayne@69 707 }
jpayne@69 708
jpayne@69 709 # Use a cached map instead of computed local vars and subst.
jpayne@69 710
jpayne@69 711 return [string map $state(access_path,map) $path]
jpayne@69 712 }
jpayne@69 713
jpayne@69 714 # file name control (limit access to files/resources that should be a
jpayne@69 715 # valid tcl source file)
jpayne@69 716 proc ::safe::CheckFileName {child file} {
jpayne@69 717 # This used to limit what can be sourced to ".tcl" and forbid files
jpayne@69 718 # with more than 1 dot and longer than 14 chars, but I changed that
jpayne@69 719 # for 8.4 as a safe interp has enough internal protection already to
jpayne@69 720 # allow sourcing anything. - hobbs
jpayne@69 721
jpayne@69 722 if {![file exists $file]} {
jpayne@69 723 # don't tell the file path
jpayne@69 724 return -code error "no such file or directory"
jpayne@69 725 }
jpayne@69 726
jpayne@69 727 if {![file readable $file]} {
jpayne@69 728 # don't tell the file path
jpayne@69 729 return -code error "not readable"
jpayne@69 730 }
jpayne@69 731 }
jpayne@69 732
jpayne@69 733 # AliasFileSubcommand handles selected subcommands of [file] in safe
jpayne@69 734 # interpreters that are *almost* safe. In particular, it just acts to
jpayne@69 735 # prevent discovery of what home directories exist.
jpayne@69 736
jpayne@69 737 proc ::safe::AliasFileSubcommand {child subcommand name} {
jpayne@69 738 if {[string match ~* $name]} {
jpayne@69 739 set name ./$name
jpayne@69 740 }
jpayne@69 741 tailcall ::interp invokehidden $child tcl:file:$subcommand $name
jpayne@69 742 }
jpayne@69 743
jpayne@69 744 # AliasGlob is the target of the "glob" alias in safe interpreters.
jpayne@69 745
jpayne@69 746 proc ::safe::AliasGlob {child args} {
jpayne@69 747 Log $child "GLOB ! $args" NOTICE
jpayne@69 748 set cmd {}
jpayne@69 749 set at 0
jpayne@69 750 array set got {
jpayne@69 751 -directory 0
jpayne@69 752 -nocomplain 0
jpayne@69 753 -join 0
jpayne@69 754 -tails 0
jpayne@69 755 -- 0
jpayne@69 756 }
jpayne@69 757
jpayne@69 758 if {$::tcl_platform(platform) eq "windows"} {
jpayne@69 759 set dirPartRE {^(.*)[\\/]([^\\/]*)$}
jpayne@69 760 } else {
jpayne@69 761 set dirPartRE {^(.*)/([^/]*)$}
jpayne@69 762 }
jpayne@69 763
jpayne@69 764 set dir {}
jpayne@69 765 set virtualdir {}
jpayne@69 766
jpayne@69 767 while {$at < [llength $args]} {
jpayne@69 768 switch -glob -- [set opt [lindex $args $at]] {
jpayne@69 769 -nocomplain - -- - -tails {
jpayne@69 770 lappend cmd $opt
jpayne@69 771 set got($opt) 1
jpayne@69 772 incr at
jpayne@69 773 }
jpayne@69 774 -join {
jpayne@69 775 set got($opt) 1
jpayne@69 776 incr at
jpayne@69 777 }
jpayne@69 778 -types - -type {
jpayne@69 779 lappend cmd -types [lindex $args [incr at]]
jpayne@69 780 incr at
jpayne@69 781 }
jpayne@69 782 -directory {
jpayne@69 783 if {$got($opt)} {
jpayne@69 784 return -code error \
jpayne@69 785 {"-directory" cannot be used with "-path"}
jpayne@69 786 }
jpayne@69 787 set got($opt) 1
jpayne@69 788 set virtualdir [lindex $args [incr at]]
jpayne@69 789 incr at
jpayne@69 790 }
jpayne@69 791 -* {
jpayne@69 792 Log $child "Safe base rejecting glob option '$opt'"
jpayne@69 793 return -code error "Safe base rejecting glob option '$opt'"
jpayne@69 794 }
jpayne@69 795 default {
jpayne@69 796 break
jpayne@69 797 }
jpayne@69 798 }
jpayne@69 799 if {$got(--)} break
jpayne@69 800 }
jpayne@69 801
jpayne@69 802 # Get the real path from the virtual one and check that the path is in the
jpayne@69 803 # access path of that child. Done after basic argument processing so that
jpayne@69 804 # we know if -nocomplain is set.
jpayne@69 805 if {$got(-directory)} {
jpayne@69 806 try {
jpayne@69 807 set dir [TranslatePath $child $virtualdir]
jpayne@69 808 DirInAccessPath $child $dir
jpayne@69 809 } on error msg {
jpayne@69 810 Log $child $msg
jpayne@69 811 if {$got(-nocomplain)} return
jpayne@69 812 return -code error "permission denied"
jpayne@69 813 }
jpayne@69 814 if {$got(--)} {
jpayne@69 815 set cmd [linsert $cmd end-1 -directory $dir]
jpayne@69 816 } else {
jpayne@69 817 lappend cmd -directory $dir
jpayne@69 818 }
jpayne@69 819 } else {
jpayne@69 820 # The code after this "if ... else" block would conspire to return with
jpayne@69 821 # no results in this case, if it were allowed to proceed. Instead,
jpayne@69 822 # return now and reduce the number of cases to be considered later.
jpayne@69 823 Log $child {option -directory must be supplied}
jpayne@69 824 if {$got(-nocomplain)} return
jpayne@69 825 return -code error "permission denied"
jpayne@69 826 }
jpayne@69 827
jpayne@69 828 # Apply the -join semantics ourselves.
jpayne@69 829 if {$got(-join)} {
jpayne@69 830 set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
jpayne@69 831 }
jpayne@69 832
jpayne@69 833 # Process the pattern arguments. If we've done a join there is only one
jpayne@69 834 # pattern argument.
jpayne@69 835
jpayne@69 836 set firstPattern [llength $cmd]
jpayne@69 837 foreach opt [lrange $args $at end] {
jpayne@69 838 if {![regexp $dirPartRE $opt -> thedir thefile]} {
jpayne@69 839 set thedir .
jpayne@69 840 # The *.tm search comes here.
jpayne@69 841 }
jpayne@69 842 # "Special" treatment for (joined) argument {*/pkgIndex.tcl}.
jpayne@69 843 # Do the expansion of "*" here, and filter out any directories that are
jpayne@69 844 # not in the access path. The outcome is to lappend to cmd a path of
jpayne@69 845 # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir,
jpayne@69 846 # after removing any subdir that are not in the access path.
jpayne@69 847 if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} {
jpayne@69 848 set mapped 0
jpayne@69 849 foreach d [glob -directory [TranslatePath $child $virtualdir] \
jpayne@69 850 -types d -tails *] {
jpayne@69 851 catch {
jpayne@69 852 DirInAccessPath $child \
jpayne@69 853 [TranslatePath $child [file join $virtualdir $d]]
jpayne@69 854 lappend cmd [file join $d $thefile]
jpayne@69 855 set mapped 1
jpayne@69 856 }
jpayne@69 857 }
jpayne@69 858 if {$mapped} continue
jpayne@69 859 # Don't [continue] if */pkgIndex.tcl has no matches in the access
jpayne@69 860 # path. The pattern will now receive the same treatment as a
jpayne@69 861 # "non-special" pattern (and will fail because it includes a "*" in
jpayne@69 862 # the directory name).
jpayne@69 863 }
jpayne@69 864 # Any directory pattern that is not an exact (i.e. non-glob) match to a
jpayne@69 865 # directory in the access path will be rejected here.
jpayne@69 866 # - Rejections include any directory pattern that has glob matching
jpayne@69 867 # patterns "*", "?", backslashes, braces or square brackets, (UNLESS
jpayne@69 868 # it corresponds to a genuine directory name AND that directory is in
jpayne@69 869 # the access path).
jpayne@69 870 # - The only "special matching characters" that remain in patterns for
jpayne@69 871 # processing by glob are in the filename tail.
jpayne@69 872 # - [file join $anything ~${foo}] is ~${foo}, which is not an exact
jpayne@69 873 # match to any directory in the access path. Hence directory patterns
jpayne@69 874 # that begin with "~" are rejected here. Tests safe-16.[5-8] check
jpayne@69 875 # that "file join" remains as required and does not expand ~${foo}.
jpayne@69 876 # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is
jpayne@69 877 # how the present code avoids the bug. All tests safe-16.* relate.
jpayne@69 878 try {
jpayne@69 879 DirInAccessPath $child [TranslatePath $child \
jpayne@69 880 [file join $virtualdir $thedir]]
jpayne@69 881 } on error msg {
jpayne@69 882 Log $child $msg
jpayne@69 883 if {$got(-nocomplain)} continue
jpayne@69 884 return -code error "permission denied"
jpayne@69 885 }
jpayne@69 886 lappend cmd $opt
jpayne@69 887 }
jpayne@69 888
jpayne@69 889 Log $child "GLOB = $cmd" NOTICE
jpayne@69 890
jpayne@69 891 if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
jpayne@69 892 return
jpayne@69 893 }
jpayne@69 894 try {
jpayne@69 895 # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<<
jpayne@69 896 # - Pattern arguments added to cmd have NOT been translated from tokens.
jpayne@69 897 # Only the virtualdir is translated (to dir).
jpayne@69 898 # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments,
jpayne@69 899 # which are a list of names each with tail pkgIndex.tcl. The purpose
jpayne@69 900 # of the call to glob is to remove the names for which the file does
jpayne@69 901 # not exist.
jpayne@69 902 set entries [::interp invokehidden $child glob {*}$cmd]
jpayne@69 903 } on error msg {
jpayne@69 904 # This is the only place that a call with -nocomplain and no invalid
jpayne@69 905 # "dash-options" can return an error.
jpayne@69 906 Log $child $msg
jpayne@69 907 return -code error "script error"
jpayne@69 908 }
jpayne@69 909
jpayne@69 910 Log $child "GLOB < $entries" NOTICE
jpayne@69 911
jpayne@69 912 # Translate path back to what the child should see.
jpayne@69 913 set res {}
jpayne@69 914 set l [string length $dir]
jpayne@69 915 foreach p $entries {
jpayne@69 916 if {[string equal -length $l $dir $p]} {
jpayne@69 917 set p [string replace $p 0 [expr {$l-1}] $virtualdir]
jpayne@69 918 }
jpayne@69 919 lappend res $p
jpayne@69 920 }
jpayne@69 921
jpayne@69 922 Log $child "GLOB > $res" NOTICE
jpayne@69 923 return $res
jpayne@69 924 }
jpayne@69 925
jpayne@69 926 # AliasSource is the target of the "source" alias in safe interpreters.
jpayne@69 927
jpayne@69 928 proc ::safe::AliasSource {child args} {
jpayne@69 929 set argc [llength $args]
jpayne@69 930 # Extended for handling of Tcl Modules to allow not only "source
jpayne@69 931 # filename", but "source -encoding E filename" as well.
jpayne@69 932 if {[lindex $args 0] eq "-encoding"} {
jpayne@69 933 incr argc -2
jpayne@69 934 set encoding [lindex $args 1]
jpayne@69 935 set at 2
jpayne@69 936 if {$encoding eq "identity"} {
jpayne@69 937 Log $child "attempt to use the identity encoding"
jpayne@69 938 return -code error "permission denied"
jpayne@69 939 }
jpayne@69 940 } else {
jpayne@69 941 set at 0
jpayne@69 942 set encoding {}
jpayne@69 943 }
jpayne@69 944 if {$argc != 1} {
jpayne@69 945 set msg "wrong # args: should be \"source ?-encoding E? fileName\""
jpayne@69 946 Log $child "$msg ($args)"
jpayne@69 947 return -code error $msg
jpayne@69 948 }
jpayne@69 949 set file [lindex $args $at]
jpayne@69 950
jpayne@69 951 # get the real path from the virtual one.
jpayne@69 952 if {[catch {
jpayne@69 953 set realfile [TranslatePath $child $file]
jpayne@69 954 } msg]} {
jpayne@69 955 Log $child $msg
jpayne@69 956 return -code error "permission denied"
jpayne@69 957 }
jpayne@69 958
jpayne@69 959 # check that the path is in the access path of that child
jpayne@69 960 if {[catch {
jpayne@69 961 FileInAccessPath $child $realfile
jpayne@69 962 } msg]} {
jpayne@69 963 Log $child $msg
jpayne@69 964 return -code error "permission denied"
jpayne@69 965 }
jpayne@69 966
jpayne@69 967 # Check that the filename exists and is readable. If it is not, deliver
jpayne@69 968 # this -errorcode so that caller in tclPkgUnknown does not write a message
jpayne@69 969 # to tclLog. Has no effect on other callers of ::source, which are in
jpayne@69 970 # "package ifneeded" scripts.
jpayne@69 971 if {[catch {
jpayne@69 972 CheckFileName $child $realfile
jpayne@69 973 } msg]} {
jpayne@69 974 Log $child "$realfile:$msg"
jpayne@69 975 return -code error -errorcode {POSIX EACCES} $msg
jpayne@69 976 }
jpayne@69 977
jpayne@69 978 # Passed all the tests, lets source it. Note that we do this all manually
jpayne@69 979 # because we want to control [info script] in the child so information
jpayne@69 980 # doesn't leak so much. [Bug 2913625]
jpayne@69 981 set old [::interp eval $child {info script}]
jpayne@69 982 set replacementMsg "script error"
jpayne@69 983 set code [catch {
jpayne@69 984 set f [open $realfile]
jpayne@69 985 fconfigure $f -eofchar "\032 {}"
jpayne@69 986 if {$encoding ne ""} {
jpayne@69 987 fconfigure $f -encoding $encoding
jpayne@69 988 }
jpayne@69 989 set contents [read $f]
jpayne@69 990 close $f
jpayne@69 991 ::interp eval $child [list info script $file]
jpayne@69 992 } msg opt]
jpayne@69 993 if {$code == 0} {
jpayne@69 994 set code [catch {::interp eval $child $contents} msg opt]
jpayne@69 995 set replacementMsg $msg
jpayne@69 996 }
jpayne@69 997 catch {interp eval $child [list info script $old]}
jpayne@69 998 # Note that all non-errors are fine result codes from [source], so we must
jpayne@69 999 # take a little care to do it properly. [Bug 2923613]
jpayne@69 1000 if {$code == 1} {
jpayne@69 1001 Log $child $msg
jpayne@69 1002 return -code error $replacementMsg
jpayne@69 1003 }
jpayne@69 1004 return -code $code -options $opt $msg
jpayne@69 1005 }
jpayne@69 1006
jpayne@69 1007 # AliasLoad is the target of the "load" alias in safe interpreters.
jpayne@69 1008
jpayne@69 1009 proc ::safe::AliasLoad {child file args} {
jpayne@69 1010 set argc [llength $args]
jpayne@69 1011 if {$argc > 2} {
jpayne@69 1012 set msg "load error: too many arguments"
jpayne@69 1013 Log $child "$msg ($argc) {$file $args}"
jpayne@69 1014 return -code error $msg
jpayne@69 1015 }
jpayne@69 1016
jpayne@69 1017 # package name (can be empty if file is not).
jpayne@69 1018 set package [lindex $args 0]
jpayne@69 1019
jpayne@69 1020 namespace upvar ::safe [VarName $child] state
jpayne@69 1021
jpayne@69 1022 # Determine where to load. load use a relative interp path and {}
jpayne@69 1023 # means self, so we can directly and safely use passed arg.
jpayne@69 1024 set target [lindex $args 1]
jpayne@69 1025 if {$target ne ""} {
jpayne@69 1026 # we will try to load into a sub sub interp; check that we want to
jpayne@69 1027 # authorize that.
jpayne@69 1028 if {!$state(nestedok)} {
jpayne@69 1029 Log $child "loading to a sub interp (nestedok)\
jpayne@69 1030 disabled (trying to load $package to $target)"
jpayne@69 1031 return -code error "permission denied (nested load)"
jpayne@69 1032 }
jpayne@69 1033 }
jpayne@69 1034
jpayne@69 1035 # Determine what kind of load is requested
jpayne@69 1036 if {$file eq ""} {
jpayne@69 1037 # static package loading
jpayne@69 1038 if {$package eq ""} {
jpayne@69 1039 set msg "load error: empty filename and no package name"
jpayne@69 1040 Log $child $msg
jpayne@69 1041 return -code error $msg
jpayne@69 1042 }
jpayne@69 1043 if {!$state(staticsok)} {
jpayne@69 1044 Log $child "static packages loading disabled\
jpayne@69 1045 (trying to load $package to $target)"
jpayne@69 1046 return -code error "permission denied (static package)"
jpayne@69 1047 }
jpayne@69 1048 } else {
jpayne@69 1049 # file loading
jpayne@69 1050
jpayne@69 1051 # get the real path from the virtual one.
jpayne@69 1052 try {
jpayne@69 1053 set file [TranslatePath $child $file]
jpayne@69 1054 } on error msg {
jpayne@69 1055 Log $child $msg
jpayne@69 1056 return -code error "permission denied"
jpayne@69 1057 }
jpayne@69 1058
jpayne@69 1059 # check the translated path
jpayne@69 1060 try {
jpayne@69 1061 FileInAccessPath $child $file
jpayne@69 1062 } on error msg {
jpayne@69 1063 Log $child $msg
jpayne@69 1064 return -code error "permission denied (path)"
jpayne@69 1065 }
jpayne@69 1066 }
jpayne@69 1067
jpayne@69 1068 try {
jpayne@69 1069 return [::interp invokehidden $child load $file $package $target]
jpayne@69 1070 } on error msg {
jpayne@69 1071 # Some packages return no error message.
jpayne@69 1072 set msg0 "load of binary library for package $package failed"
jpayne@69 1073 if {$msg eq {}} {
jpayne@69 1074 set msg $msg0
jpayne@69 1075 } else {
jpayne@69 1076 set msg "$msg0: $msg"
jpayne@69 1077 }
jpayne@69 1078 Log $child $msg
jpayne@69 1079 return -code error $msg
jpayne@69 1080 }
jpayne@69 1081 }
jpayne@69 1082
jpayne@69 1083 # FileInAccessPath raises an error if the file is not found in the list of
jpayne@69 1084 # directories contained in the (parent side recorded) child's access path.
jpayne@69 1085
jpayne@69 1086 # the security here relies on "file dirname" answering the proper
jpayne@69 1087 # result... needs checking ?
jpayne@69 1088 proc ::safe::FileInAccessPath {child file} {
jpayne@69 1089 namespace upvar ::safe [VarName $child] state
jpayne@69 1090 set access_path $state(access_path)
jpayne@69 1091
jpayne@69 1092 if {[file isdirectory $file]} {
jpayne@69 1093 return -code error "\"$file\": is a directory"
jpayne@69 1094 }
jpayne@69 1095 set parent [file dirname $file]
jpayne@69 1096
jpayne@69 1097 # Normalize paths for comparison since lsearch knows nothing of
jpayne@69 1098 # potential pathname anomalies.
jpayne@69 1099 set norm_parent [file normalize $parent]
jpayne@69 1100
jpayne@69 1101 namespace upvar ::safe [VarName $child] state
jpayne@69 1102 if {$norm_parent ni $state(access_path,norm)} {
jpayne@69 1103 return -code error "\"$file\": not in access_path"
jpayne@69 1104 }
jpayne@69 1105 }
jpayne@69 1106
jpayne@69 1107 proc ::safe::DirInAccessPath {child dir} {
jpayne@69 1108 namespace upvar ::safe [VarName $child] state
jpayne@69 1109 set access_path $state(access_path)
jpayne@69 1110
jpayne@69 1111 if {[file isfile $dir]} {
jpayne@69 1112 return -code error "\"$dir\": is a file"
jpayne@69 1113 }
jpayne@69 1114
jpayne@69 1115 # Normalize paths for comparison since lsearch knows nothing of
jpayne@69 1116 # potential pathname anomalies.
jpayne@69 1117 set norm_dir [file normalize $dir]
jpayne@69 1118
jpayne@69 1119 namespace upvar ::safe [VarName $child] state
jpayne@69 1120 if {$norm_dir ni $state(access_path,norm)} {
jpayne@69 1121 return -code error "\"$dir\": not in access_path"
jpayne@69 1122 }
jpayne@69 1123 }
jpayne@69 1124
jpayne@69 1125 # This procedure is used to report an attempt to use an unsafe member of an
jpayne@69 1126 # ensemble command.
jpayne@69 1127
jpayne@69 1128 proc ::safe::BadSubcommand {child command subcommand args} {
jpayne@69 1129 set msg "not allowed to invoke subcommand $subcommand of $command"
jpayne@69 1130 Log $child $msg
jpayne@69 1131 return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
jpayne@69 1132 }
jpayne@69 1133
jpayne@69 1134 # AliasEncoding is the target of the "encoding" alias in safe interpreters.
jpayne@69 1135
jpayne@69 1136 proc ::safe::AliasEncoding {child option args} {
jpayne@69 1137 # Note that [encoding dirs] is not supported in safe children at all
jpayne@69 1138 set subcommands {convertfrom convertto names system}
jpayne@69 1139 try {
jpayne@69 1140 set option [tcl::prefix match -error [list -level 1 -errorcode \
jpayne@69 1141 [list TCL LOOKUP INDEX option $option]] $subcommands $option]
jpayne@69 1142 # Special case: [encoding system] ok, but [encoding system foo] not
jpayne@69 1143 if {$option eq "system" && [llength $args]} {
jpayne@69 1144 return -code error -errorcode {TCL WRONGARGS} \
jpayne@69 1145 "wrong # args: should be \"encoding system\""
jpayne@69 1146 }
jpayne@69 1147 } on error {msg options} {
jpayne@69 1148 Log $child $msg
jpayne@69 1149 return -options $options $msg
jpayne@69 1150 }
jpayne@69 1151 tailcall ::interp invokehidden $child encoding $option {*}$args
jpayne@69 1152 }
jpayne@69 1153
jpayne@69 1154 # Various minor hiding of platform features. [Bug 2913625]
jpayne@69 1155
jpayne@69 1156 proc ::safe::AliasExeName {child} {
jpayne@69 1157 return ""
jpayne@69 1158 }
jpayne@69 1159
jpayne@69 1160 # ------------------------------------------------------------------------------
jpayne@69 1161 # Using Interpreter Names with Namespace Qualifiers
jpayne@69 1162 # ------------------------------------------------------------------------------
jpayne@69 1163 # (1) We wish to preserve compatibility with existing code, in which Safe Base
jpayne@69 1164 # interpreter names have no namespace qualifiers.
jpayne@69 1165 # (2) safe::interpCreate and the rest of the Safe Base previously could not
jpayne@69 1166 # accept namespace qualifiers in an interpreter name.
jpayne@69 1167 # (3) The interp command will accept namespace qualifiers in an interpreter
jpayne@69 1168 # name, but accepts distinct interpreters that will have the same command
jpayne@69 1169 # name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974).
jpayne@69 1170 # (4) To satisfy these constraints, Safe Base interpreter names will be fully
jpayne@69 1171 # qualified namespace names with no excess colons and with the leading "::"
jpayne@69 1172 # omitted.
jpayne@69 1173 # (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}.
jpayne@69 1174 # Reject such names.
jpayne@69 1175 # (6) We could:
jpayne@69 1176 # (a) EITHER reject usable but non-compliant names (e.g. excess colons) in
jpayne@69 1177 # interpCreate, interpInit;
jpayne@69 1178 # (b) OR accept such names and then translate to a compliant name in every
jpayne@69 1179 # command.
jpayne@69 1180 # The problem with (b) is that the user will expect to use the name with the
jpayne@69 1181 # interp command and will find that it is not recognised.
jpayne@69 1182 # E.g "interpCreate ::foo" creates interpreter "foo", and the user's name
jpayne@69 1183 # "::foo" works with all the Safe Base commands, but "interp eval ::foo"
jpayne@69 1184 # fails.
jpayne@69 1185 # So we choose (a).
jpayne@69 1186 # (7) The command
jpayne@69 1187 # namespace upvar ::safe S$child state
jpayne@69 1188 # becomes
jpayne@69 1189 # namespace upvar ::safe [VarName $child] state
jpayne@69 1190 # ------------------------------------------------------------------------------
jpayne@69 1191
jpayne@69 1192 proc ::safe::RejectExcessColons {child} {
jpayne@69 1193 set stripped [regsub -all -- {:::*} $child ::]
jpayne@69 1194 if {[string range $stripped end-1 end] eq {::}} {
jpayne@69 1195 return -code error {interpreter name must not end in "::"}
jpayne@69 1196 }
jpayne@69 1197 if {$stripped ne $child} {
jpayne@69 1198 set msg {interpreter name has excess colons in namespace separators}
jpayne@69 1199 return -code error $msg
jpayne@69 1200 }
jpayne@69 1201 if {[string range $stripped 0 1] eq {::}} {
jpayne@69 1202 return -code error {interpreter name must not begin "::"}
jpayne@69 1203 }
jpayne@69 1204 return
jpayne@69 1205 }
jpayne@69 1206
jpayne@69 1207 proc ::safe::VarName {child} {
jpayne@69 1208 # return S$child
jpayne@69 1209 return S[string map {:: @N @ @A} $child]
jpayne@69 1210 }
jpayne@69 1211
jpayne@69 1212 proc ::safe::Setup {} {
jpayne@69 1213 ####
jpayne@69 1214 #
jpayne@69 1215 # Setup the arguments parsing
jpayne@69 1216 #
jpayne@69 1217 ####
jpayne@69 1218
jpayne@69 1219 # Share the descriptions
jpayne@69 1220 set temp [::tcl::OptKeyRegister {
jpayne@69 1221 {-accessPath -list {} "access path for the slave"}
jpayne@69 1222 {-noStatics "prevent loading of statically linked pkgs"}
jpayne@69 1223 {-statics true "loading of statically linked pkgs"}
jpayne@69 1224 {-nestedLoadOk "allow nested loading"}
jpayne@69 1225 {-nested false "nested loading"}
jpayne@69 1226 {-deleteHook -script {} "delete hook"}
jpayne@69 1227 }]
jpayne@69 1228
jpayne@69 1229 # create case (slave is optional)
jpayne@69 1230 ::tcl::OptKeyRegister {
jpayne@69 1231 {?slave? -name {} "name of the slave (optional)"}
jpayne@69 1232 } ::safe::interpCreate
jpayne@69 1233
jpayne@69 1234 # adding the flags sub programs to the command program (relying on Opt's
jpayne@69 1235 # internal implementation details)
jpayne@69 1236 lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
jpayne@69 1237
jpayne@69 1238 # init and configure (slave is needed)
jpayne@69 1239 ::tcl::OptKeyRegister {
jpayne@69 1240 {slave -name {} "name of the slave"}
jpayne@69 1241 } ::safe::interpIC
jpayne@69 1242
jpayne@69 1243 # adding the flags sub programs to the command program (relying on Opt's
jpayne@69 1244 # internal implementation details)
jpayne@69 1245 lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
jpayne@69 1246
jpayne@69 1247 # temp not needed anymore
jpayne@69 1248 ::tcl::OptKeyDelete $temp
jpayne@69 1249
jpayne@69 1250 ####
jpayne@69 1251 #
jpayne@69 1252 # Default: No logging.
jpayne@69 1253 #
jpayne@69 1254 ####
jpayne@69 1255
jpayne@69 1256 setLogCmd {}
jpayne@69 1257
jpayne@69 1258 # Log eventually.
jpayne@69 1259 # To enable error logging, set Log to {puts stderr} for instance,
jpayne@69 1260 # via setLogCmd.
jpayne@69 1261 return
jpayne@69 1262 }
jpayne@69 1263
jpayne@69 1264 namespace eval ::safe {
jpayne@69 1265 # internal variables
jpayne@69 1266
jpayne@69 1267 # Log command, set via 'setLogCmd'. Logging is disabled when empty.
jpayne@69 1268 variable Log {}
jpayne@69 1269
jpayne@69 1270 # The package maintains a state array per child interp under its
jpayne@69 1271 # control. The name of this array is S<interp-name>. This array is
jpayne@69 1272 # brought into scope where needed, using 'namespace upvar'. The S
jpayne@69 1273 # prefix is used to avoid that a child interp called "Log" smashes
jpayne@69 1274 # the "Log" variable.
jpayne@69 1275 #
jpayne@69 1276 # The array's elements are:
jpayne@69 1277 #
jpayne@69 1278 # access_path : List of paths accessible to the child.
jpayne@69 1279 # access_path,norm : Ditto, in normalized form.
jpayne@69 1280 # access_path,slave : Ditto, as the path tokens as seen by the child.
jpayne@69 1281 # access_path,map : dict ( token -> path )
jpayne@69 1282 # access_path,remap : dict ( path -> token )
jpayne@69 1283 # tm_path_slave : List of TM root directories, as tokens seen by the child.
jpayne@69 1284 # staticsok : Value of option -statics
jpayne@69 1285 # nestedok : Value of option -nested
jpayne@69 1286 # cleanupHook : Value of option -deleteHook
jpayne@69 1287 }
jpayne@69 1288
jpayne@69 1289 ::safe::Setup