Return to Safe.pm CVS log

Up to [LON-CAPA] / loncom / xml

Added missing CVS Ids for automatic version numbering to script header
(Irrespective if the script is still in use or not)

    1: # $Id: Safe.pm,v 1.9 2009/02/13 17:20:38 bisitz Exp $
    2: 
    3: package Safe;
    4: 
    5: use 5.003_11;
    6: use strict;
    7: 
    8: $Safe::VERSION = "2.09";
    9: 
   10: use Carp;
   11: 
   12: use Opcode 1.01, qw(
   13:     opset opset_to_ops opmask_add
   14:     empty_opset full_opset invert_opset verify_opset
   15:     opdesc opcodes opmask define_optag opset_to_hex
   16: );
   17: 
   18: *ops_to_opset = \&opset;   # Temporary alias for old Penguins
   19: 
   20: 
   21: my $default_root  = 0;
   22: my $default_share = ['*_']; #, '*main::'];
   23: 
   24: sub new {
   25:     my($class, $root, $mask) = @_;
   26:     my $obj = {};
   27:     bless $obj, $class;
   28: 
   29:     if (defined($root)) {
   30: 	croak "Can't use \"$root\" as root name"
   31: 	    if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
   32: 	$obj->{Root}  = $root;
   33: 	$obj->{Erase} = 0;
   34:     }
   35:     else {
   36: 	$obj->{Root}  = "Safe::Root".$default_root++;
   37: 	$obj->{Erase} = 1;
   38:     }
   39: 
   40:     # use permit/deny methods instead till interface issues resolved
   41:     # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
   42:     croak "Mask parameter to new no longer supported" if defined $mask;
   43:     $obj->permit_only(':default');
   44: 
   45:     # We must share $_ and @_ with the compartment or else ops such
   46:     # as split, length and so on won't default to $_ properly, nor
   47:     # will passing argument to subroutines work (via @_). In fact,
   48:     # for reasons I don't completely understand, we need to share
   49:     # the whole glob *_ rather than $_ and @_ separately, otherwise
   50:     # @_ in non default packages within the compartment don't work.
   51:     $obj->share_from('main', $default_share);
   52:     Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
   53:     return $obj;
   54: }
   55: 
   56: sub DESTROY {
   57:     my $obj = shift;
   58:     $obj->erase('DESTROY') if $obj->{Erase};
   59: }
   60: 
   61: sub erase {
   62:     my ($obj, $action) = @_;
   63:     my $pkg = $obj->root();
   64:     my ($stem, $leaf);
   65: 
   66:     no strict 'refs';
   67:     $pkg = "main::$pkg\::";	# expand to full symbol table name
   68:     ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
   69: 
   70:     # The 'my $foo' is needed! Without it you get an
   71:     # 'Attempt to free unreferenced scalar' warning!
   72:     my $stem_symtab = *{$stem}{HASH};
   73: 
   74:     #warn "erase($pkg) stem=$stem, leaf=$leaf";
   75:     #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
   76: 	# ", join(', ', %$stem_symtab),"\n";
   77: 
   78: #    delete $stem_symtab->{$leaf};
   79: 
   80:     my $leaf_glob   = $stem_symtab->{$leaf};
   81:     my $leaf_symtab = *{$leaf_glob}{HASH};
   82: #    warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
   83:     %$leaf_symtab = ();
   84:     #delete $leaf_symtab->{'__ANON__'};
   85:     #delete $leaf_symtab->{'foo'};
   86:     #delete $leaf_symtab->{'main::'};
   87: #    my $foo = undef ${"$stem\::"}{"$leaf\::"};
   88: 
   89:     if ($action and $action eq 'DESTROY') {
   90:         delete $stem_symtab->{$leaf};
   91:     } else {
   92:         $obj->share_from('main', $default_share);
   93:     }
   94:     1;
   95: }
   96: 
   97: 
   98: sub reinit {
   99:     my $obj= shift;
  100:     $obj->erase;
  101:     $obj->share_redo;
  102: }
  103: 
  104: sub root {
  105:     my $obj = shift;
  106:     croak("Safe root method now read-only") if @_;
  107:     return $obj->{Root};
  108: }
  109: 
  110: 
  111: sub mask {
  112:     my $obj = shift;
  113:     return $obj->{Mask} unless @_;
  114:     $obj->deny_only(@_);
  115: }
  116: 
  117: # v1 compatibility methods
  118: sub trap   { shift->deny(@_)   }
  119: sub untrap { shift->permit(@_) }
  120: 
  121: sub deny {
  122:     my $obj = shift;
  123:     $obj->{Mask} |= opset(@_);
  124: }
  125: sub deny_only {
  126:     my $obj = shift;
  127:     $obj->{Mask} = opset(@_);
  128: }
  129: 
  130: sub permit {
  131:     my $obj = shift;
  132:     # XXX needs testing
  133:     $obj->{Mask} &= invert_opset opset(@_);
  134: }
  135: sub permit_only {
  136:     my $obj = shift;
  137:     $obj->{Mask} = invert_opset opset(@_);
  138: }
  139: 
  140: 
  141: sub dump_mask {
  142:     my $obj = shift;
  143:     print opset_to_hex($obj->{Mask}),"\n";
  144: }
  145: 
  146: 
  147: 
  148: sub share {
  149:     my($obj, @vars) = @_;
  150:     $obj->share_from(scalar(caller), \@vars);
  151: }
  152: 
  153: sub share_from {
  154:     my $obj = shift;
  155:     my $pkg = shift;
  156:     my $vars = shift;
  157:     my $no_record = shift || 0;
  158:     my $root = $obj->root();
  159:     croak("vars not an array ref") unless ref $vars eq 'ARRAY';
  160:     no strict 'refs';
  161:     # Check that 'from' package actually exists
  162:     croak("Package \"$pkg\" does not exist")
  163: 	unless keys %{"$pkg\::"};
  164:     my $arg;
  165:     foreach $arg (@$vars) {
  166: 	# catch some $safe->share($var) errors:
  167: 	croak("'$arg' not a valid symbol table name")
  168: 	    unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/
  169: 	    	or $arg =~ /^\$\W$/;
  170: 	my ($var, $type);
  171: 	$type = $1 if ($var = $arg) =~ s/^(\W)//;
  172: 	# warn "share_from $pkg $type $var";
  173: 	*{$root."::$var"} = (!$type)       ? \&{$pkg."::$var"}
  174: 			  : ($type eq '&') ? \&{$pkg."::$var"}
  175: 			  : ($type eq '$') ? \${$pkg."::$var"}
  176: 			  : ($type eq '@') ? \@{$pkg."::$var"}
  177: 			  : ($type eq '%') ? \%{$pkg."::$var"}
  178: 			  : ($type eq '*') ?  *{$pkg."::$var"}
  179: 			  : croak(qq(Can't share "$type$var" of unknown type));
  180:     }
  181:     $obj->share_record($pkg, $vars) unless $no_record or !$vars;
  182: }
  183: 
  184: sub share_record {
  185:     my $obj = shift;
  186:     my $pkg = shift;
  187:     my $vars = shift;
  188:     my $shares = \%{$obj->{Shares} ||= {}};
  189:     # Record shares using keys of $obj->{Shares}. See reinit.
  190:     @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
  191: }
  192: sub share_redo {
  193:     my $obj = shift;
  194:     my $shares = \%{$obj->{Shares} ||= {}};
  195:     my($var, $pkg);
  196:     while(($var, $pkg) = each %$shares) {
  197: 	# warn "share_redo $pkg\:: $var";
  198: 	$obj->share_from($pkg,  [ $var ], 1);
  199:     }
  200: }
  201: sub share_forget {
  202:     delete shift->{Shares};
  203: }
  204: 
  205: sub varglob {
  206:     my ($obj, $var) = @_;
  207:     no strict 'refs';
  208:     return *{$obj->root()."::$var"};
  209: }
  210: 
  211: 
  212: sub reval {
  213:     undef($Safe::evalsub);
  214:     {
  215: 	my ($obj, $expr, $strict) = @_;
  216: 	my $root = $obj->{Root};
  217: 
  218: 	# Create anon sub ref in root of compartment.
  219: 	# Uses a closure (on $expr) to pass in the code to be executed.
  220: 	# (eval on one line to keep line numbers as expected by caller)
  221: 	my $evalcode = sprintf('package %s; sub { @_ = (\'\'); eval $expr; }', $obj->{Root});
  222: 	
  223: 	if ($strict) { use strict; $Safe::evalsub = eval $evalcode; }
  224: 	else         {  no strict; $Safe::evalsub = eval $evalcode; }
  225:     }
  226:     return Opcode::_safe_call_sv($_[0]->{Root}, $_[0]->{Mask}, $Safe::evalsub);
  227: }
  228: 
  229: sub rdo {
  230:     my ($obj, $file) = @_;
  231:     my $root = $obj->{Root};
  232: 
  233:     my $evalsub = eval
  234: 	    sprintf('package %s; sub { @_ = (\'\'); do $file }', $root);
  235:     return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
  236: }
  237: 
  238: 
  239: 1;
  240: 
  241: __END__
  242: 
  243: =head1 NAME
  244: 
  245: Safe - Compile and execute code in restricted compartments
  246: 
  247: =head1 SYNOPSIS
  248: 
  249:   use Safe;
  250: 
  251:   $compartment = new Safe;
  252: 
  253:   $compartment->permit(qw(time sort :browse));
  254: 
  255:   $result = $compartment->reval($unsafe_code);
  256: 
  257: =head1 DESCRIPTION
  258: 
  259: The Safe extension module allows the creation of compartments
  260: in which perl code can be evaluated. Each compartment has
  261: 
  262: =over 8
  263: 
  264: =item a new namespace
  265: 
  266: The "root" of the namespace (i.e. "main::") is changed to a
  267: different package and code evaluated in the compartment cannot
  268: refer to variables outside this namespace, even with run-time
  269: glob lookups and other tricks.
  270: 
  271: Code which is compiled outside the compartment can choose to place
  272: variables into (or I<share> variables with) the compartment's namespace
  273: and only that data will be visible to code evaluated in the
  274: compartment.
  275: 
  276: By default, the only variables shared with compartments are the
  277: "underscore" variables $_ and @_ (and, technically, the less frequently
  278: used %_, the _ filehandle and so on). This is because otherwise perl
  279: operators which default to $_ will not work and neither will the
  280: assignment of arguments to @_ on subroutine entry.
  281: 
  282: =item an operator mask
  283: 
  284: Each compartment has an associated "operator mask". Recall that
  285: perl code is compiled into an internal format before execution.
  286: Evaluating perl code (e.g. via "eval" or "do 'file'") causes
  287: the code to be compiled into an internal format and then,
  288: provided there was no error in the compilation, executed.
  289: Code evaluated in a compartment compiles subject to the
  290: compartment's operator mask. Attempting to evaluate code in a
  291: compartment which contains a masked operator will cause the
  292: compilation to fail with an error. The code will not be executed.
  293: 
  294: The default operator mask for a newly created compartment is
  295: the ':default' optag.
  296: 
  297: It is important that you read the Opcode(3) module documentation
  298: for more information, especially for detailed definitions of opnames,
  299: optags and opsets.
  300: 
  301: Since it is only at the compilation stage that the operator mask
  302: applies, controlled access to potentially unsafe operations can
  303: be achieved by having a handle to a wrapper subroutine (written
  304: outside the compartment) placed into the compartment. For example,
  305: 
  306:     $cpt = new Safe;
  307:     sub wrapper {
  308:         # vet arguments and perform potentially unsafe operations
  309:     }
  310:     $cpt->share('&wrapper');
  311: 
  312: =back
  313: 
  314: 
  315: =head1 WARNING
  316: 
  317: The authors make B<no warranty>, implied or otherwise, about the
  318: suitability of this software for safety or security purposes.
  319: 
  320: The authors shall not in any case be liable for special, incidental,
  321: consequential, indirect or other similar damages arising from the use
  322: of this software.
  323: 
  324: Your mileage will vary. If in any doubt B<do not use it>.
  325: 
  326: 
  327: =head2 RECENT CHANGES
  328: 
  329: The interface to the Safe module has changed quite dramatically since
  330: version 1 (as supplied with Perl5.002). Study these pages carefully if
  331: you have code written to use Safe version 1 because you will need to
  332: makes changes.
  333: 
  334: 
  335: =head2 Methods in class Safe
  336: 
  337: To create a new compartment, use
  338: 
  339:     $cpt = new Safe;
  340: 
  341: Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
  342: to use for the compartment (defaults to "Safe::Root0", incremented for
  343: each new compartment).
  344: 
  345: Note that version 1.00 of the Safe module supported a second optional
  346: parameter, MASK.  That functionality has been withdrawn pending deeper
  347: consideration. Use the permit and deny methods described below.
  348: 
  349: The following methods can then be used on the compartment
  350: object returned by the above constructor. The object argument
  351: is implicit in each case.
  352: 
  353: 
  354: =over 8
  355: 
  356: =item permit (OP, ...)
  357: 
  358: Permit the listed operators to be used when compiling code in the
  359: compartment (in I<addition> to any operators already permitted).
  360: 
  361: =item permit_only (OP, ...)
  362: 
  363: Permit I<only> the listed operators to be used when compiling code in
  364: the compartment (I<no> other operators are permitted).
  365: 
  366: =item deny (OP, ...)
  367: 
  368: Deny the listed operators from being used when compiling code in the
  369: compartment (other operators may still be permitted).
  370: 
  371: =item deny_only (OP, ...)
  372: 
  373: Deny I<only> the listed operators from being used when compiling code
  374: in the compartment (I<all> other operators will be permitted).
  375: 
  376: =item trap (OP, ...)
  377: 
  378: =item untrap (OP, ...)
  379: 
  380: The trap and untrap methods are synonyms for deny and permit
  381: respectfully.
  382: 
  383: =item share (NAME, ...)
  384: 
  385: This shares the variable(s) in the argument list with the compartment.
  386: This is almost identical to exporting variables using the L<Exporter>
  387: module.
  388: 
  389: Each NAME must be the B<name> of a non-lexical variable, typically
  390: with the leading type identifier included. A bareword is treated as a
  391: function name.
  392: 
  393: Examples of legal names are '$foo' for a scalar, '@foo' for an
  394: array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
  395: for a glob (i.e.  all symbol table entries associated with "foo",
  396: including scalar, array, hash, sub and filehandle).
  397: 
  398: Each NAME is assumed to be in the calling package. See share_from
  399: for an alternative method (which share uses).
  400: 
  401: =item share_from (PACKAGE, ARRAYREF)
  402: 
  403: This method is similar to share() but allows you to explicitly name the
  404: package that symbols should be shared from. The symbol names (including
  405: type characters) are supplied as an array reference.
  406: 
  407:     $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
  408: 
  409: 
  410: =item varglob (VARNAME)
  411: 
  412: This returns a glob reference for the symbol table entry of VARNAME in
  413: the package of the compartment. VARNAME must be the B<name> of a
  414: variable without any leading type marker. For example,
  415: 
  416:     $cpt = new Safe 'Root';
  417:     $Root::foo = "Hello world";
  418:     # Equivalent version which doesn't need to know $cpt's package name:
  419:     ${$cpt->varglob('foo')} = "Hello world";
  420: 
  421: 
  422: =item reval (STRING)
  423: 
  424: This evaluates STRING as perl code inside the compartment.
  425: 
  426: The code can only see the compartment's namespace (as returned by the
  427: B<root> method). The compartment's root package appears to be the
  428: C<main::> package to the code inside the compartment.
  429: 
  430: Any attempt by the code in STRING to use an operator which is not permitted
  431: by the compartment will cause an error (at run-time of the main program
  432: but at compile-time for the code in STRING).  The error is of the form
  433: "'%s' trapped by operation mask...".
  434: 
  435: If an operation is trapped in this way, then the code in STRING will
  436: not be executed. If such a trapped operation occurs or any other
  437: compile-time or return error, then $@ is set to the error message, just
  438: as with an eval().
  439: 
  440: If there is no error, then the method returns the value of the last
  441: expression evaluated, or a return statement may be used, just as with
  442: subroutines and B<eval()>. The context (list or scalar) is determined
  443: by the caller as usual.
  444: 
  445: This behaviour differs from the beta distribution of the Safe extension
  446: where earlier versions of perl made it hard to mimic the return
  447: behaviour of the eval() command and the context was always scalar.
  448: 
  449: Some points to note:
  450: 
  451: If the entereval op is permitted then the code can use eval "..." to
  452: 'hide' code which might use denied ops. This is not a major problem
  453: since when the code tries to execute the eval it will fail because the
  454: opmask is still in effect. However this technique would allow clever,
  455: and possibly harmful, code to 'probe' the boundaries of what is
  456: possible.
  457: 
  458: Any string eval which is executed by code executing in a compartment,
  459: or by code called from code executing in a compartment, will be eval'd
  460: in the namespace of the compartment. This is potentially a serious
  461: problem.
  462: 
  463: Consider a function foo() in package pkg compiled outside a compartment
  464: but shared with it. Assume the compartment has a root package called
  465: 'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
  466: normally, $pkg::foo will be set to 1.  If foo() is called from the
  467: compartment (by whatever means) then instead of setting $pkg::foo, the
  468: eval will actually set $Root::pkg::foo.
  469: 
  470: This can easily be demonstrated by using a module, such as the Socket
  471: module, which uses eval "..." as part of an AUTOLOAD function. You can
  472: 'use' the module outside the compartment and share an (autoloaded)
  473: function with the compartment. If an autoload is triggered by code in
  474: the compartment, or by any code anywhere that is called by any means
  475: from the compartment, then the eval in the Socket module's AUTOLOAD
  476: function happens in the namespace of the compartment. Any variables
  477: created or used by the eval'd code are now under the control of
  478: the code in the compartment.
  479: 
  480: A similar effect applies to I<all> runtime symbol lookups in code
  481: called from a compartment but not compiled within it.
  482: 
  483: 
  484: 
  485: =item rdo (FILENAME)
  486: 
  487: This evaluates the contents of file FILENAME inside the compartment.
  488: See above documentation on the B<reval> method for further details.
  489: 
  490: =item root (NAMESPACE)
  491: 
  492: This method returns the name of the package that is the root of the
  493: compartment's namespace.
  494: 
  495: Note that this behaviour differs from version 1.00 of the Safe module
  496: where the root module could be used to change the namespace. That
  497: functionality has been withdrawn pending deeper consideration.
  498: 
  499: =item mask (MASK)
  500: 
  501: This is a get-or-set method for the compartment's operator mask.
  502: 
  503: With no MASK argument present, it returns the current operator mask of
  504: the compartment.
  505: 
  506: With the MASK argument present, it sets the operator mask for the
  507: compartment (equivalent to calling the deny_only method).
  508: 
  509: =back
  510: 
  511: 
  512: =head2 Some Safety Issues
  513: 
  514: This section is currently just an outline of some of the things code in
  515: a compartment might do (intentionally or unintentionally) which can
  516: have an effect outside the compartment.
  517: 
  518: =over 8
  519: 
  520: =item Memory
  521: 
  522: Consuming all (or nearly all) available memory.
  523: 
  524: =item CPU
  525: 
  526: Causing infinite loops etc.
  527: 
  528: =item Snooping
  529: 
  530: Copying private information out of your system. Even something as
  531: simple as your user name is of value to others. Much useful information
  532: could be gleaned from your environment variables for example.
  533: 
  534: =item Signals
  535: 
  536: Causing signals (especially SIGFPE and SIGALARM) to affect your process.
  537: 
  538: Setting up a signal handler will need to be carefully considered
  539: and controlled.  What mask is in effect when a signal handler
  540: gets called?  If a user can get an imported function to get an
  541: exception and call the user's signal handler, does that user's
  542: restricted mask get re-instated before the handler is called?
  543: Does an imported handler get called with its original mask or
  544: the user's one?
  545: 
  546: =item State Changes
  547: 
  548: Ops such as chdir obviously effect the process as a whole and not just
  549: the code in the compartment. Ops such as rand and srand have a similar
  550: but more subtle effect.
  551: 
  552: =back
  553: 
  554: =head2 AUTHOR
  555: 
  556: Originally designed and implemented by Malcolm Beattie,
  557: mbeattie@sable.ox.ac.uk.
  558: 
  559: Reworked to use the Opcode module and other changes added by Tim Bunce
  560: E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
  561: 
  562: =cut
  563: