[Summary view] [Print] [Text view]

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