Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/safe.tcl @ 68:5028fdace37b

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