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