CELLLINUX64/util/CELLLINUX64/lib/tcl8.4/safe.tcl

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