home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / safe.tcl < prev    next >
Text File  |  2003-09-01  |  27KB  |  913 lines

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