ext/Opcode/Safe.pm

   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