dist/Safe/Safe.pm

   1 package Safe;
   2
   3 use 5.003_11;
   4 use strict;
   5 use Scalar::Util qw(reftype);
   6
   7 $Safe::VERSION = "2.27";
   8
   9 # *** Don't declare any lexicals above this point ***
  10 #
  11 # This function should return a closure which contains an eval that can't
  12 # see any lexicals in scope (apart from __ExPr__ which is unavoidable)
  13
  14 sub lexless_anon_sub {
  15                  # $_[0] is package;
  16                  # $_[1] is strict flag;
  17     my $__ExPr__ = $_[2];   # must be a lexical to create the closure that
  18                             # can be used to pass the value into the safe
  19                             # world
  20
  21     # Create anon sub ref in root of compartment.
  22     # Uses a closure (on $__ExPr__) to pass in the code to be executed.
  23     # (eval on one line to keep line numbers as expected by caller)
  24     eval sprintf
  25     'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
  26                 $_[0], $_[1] ? 'use' : 'no';
  27 }
  28
  29 use Carp;
  30 BEGIN { eval q{
  31     use Carp::Heavy;
  32 } }
  33
  34 use B ();
  35 BEGIN {
  36     no strict 'refs';
  37     if (defined &B::sub_generation) {
  38         *sub_generation = \&B::sub_generation;
  39     }
  40     else {
  41         # fake sub generation changing for perls < 5.8.9
  42         my $sg; *sub_generation = sub { ++$sg };
  43     }
  44 }
  45
  46 use Opcode 1.01, qw(
  47     opset opset_to_ops opmask_add
  48     empty_opset full_opset invert_opset verify_opset
  49     opdesc opcodes opmask define_optag opset_to_hex
  50 );
  51
  52 *ops_to_opset = \&opset;   # Temporary alias for old Penguins
  53
  54 # Regular expressions and other unicode-aware code may need to call
  55 # utf8->SWASHNEW (via perl's utf8.c).  That will fail unless we share the
  56 # SWASHNEW method.
  57 # Sadly we can't just add utf8::SWASHNEW to $default_share because perl's
  58 # utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded,
  59 # and sharing makes it look like the method exists.
  60 # The simplest and most robust fix is to ensure the utf8 module is loaded when
  61 # Safe is loaded. Then we can add utf8::SWASHNEW to $default_share.
  62 require utf8;
  63 # we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded
  64 # but without depending on knowledge of that implementation detail.
  65 # This code (//i on a unicode string) ensures utf8 is fully loaded
  66 # and also loads the ToFold SWASH.
  67 # (Swashes are cached internally by perl in PL_utf8_* variables
  68 # independent of being inside/outside of Safe. So once loaded they can be)
  69 do { my $a = pack('U',0xC4); my $b = chr 0xE4; utf8::upgrade $b; $a =~ /$b/i };
  70 # now we can safely include utf8::SWASHNEW in $default_share defined below.
  71
  72 my $default_root  = 0;
  73 # share *_ and functions defined in universal.c
  74 # Don't share stuff like *UNIVERSAL:: otherwise code from the
  75 # compartment can 0wn functions in UNIVERSAL
  76 my $default_share = [qw[
  77     *_
  78     &PerlIO::get_layers
  79     &UNIVERSAL::isa
  80     &UNIVERSAL::can
  81     &UNIVERSAL::VERSION
  82     &utf8::is_utf8
  83     &utf8::valid
  84     &utf8::encode
  85     &utf8::decode
  86     &utf8::upgrade
  87     &utf8::downgrade
  88     &utf8::native_to_unicode
  89     &utf8::unicode_to_native
  90     &utf8::SWASHNEW
  91     $version::VERSION
  92     $version::CLASS
  93     $version::STRICT
  94     $version::LAX
  95     @version::ISA
  96 ], ($] < 5.010 && qw[
  97     &utf8::SWASHGET
  98 ]), ($] >= 5.008001 && qw[
  99     &Regexp::DESTROY
 100 ]), ($] >= 5.010 && qw[
 101     &re::is_regexp
 102     &re::regname
 103     &re::regnames
 104     &re::regnames_count
 105     &Tie::Hash::NamedCapture::FETCH
 106     &Tie::Hash::NamedCapture::STORE
 107     &Tie::Hash::NamedCapture::DELETE
 108     &Tie::Hash::NamedCapture::CLEAR
 109     &Tie::Hash::NamedCapture::EXISTS
 110     &Tie::Hash::NamedCapture::FIRSTKEY
 111     &Tie::Hash::NamedCapture::NEXTKEY
 112     &Tie::Hash::NamedCapture::SCALAR
 113     &Tie::Hash::NamedCapture::flags
 114     &UNIVERSAL::DOES
 115     &version::()
 116     &version::new
 117     &version::(""
 118     &version::stringify
 119     &version::(0+
 120     &version::numify
 121     &version::normal
 122     &version::(cmp
 123     &version::(<=>
 124     &version::vcmp
 125     &version::(bool
 126     &version::boolean
 127     &version::(nomethod
 128     &version::noop
 129     &version::is_alpha
 130     &version::qv
 131     &version::vxs::declare
 132     &version::vxs::qv
 133     &version::vxs::_VERSION
 134     &version::vxs::stringify
 135     &version::vxs::new
 136     &version::vxs::parse
 137 ]), ($] >= 5.011 && qw[
 138     &re::regexp_pattern
 139 ])];
 140
 141 sub new {
 142     my($class, $root, $mask) = @_;
 143     my $obj = {};
 144     bless $obj, $class;
 145
 146     if (defined($root)) {
 147         croak "Can't use \"$root\" as root name"
 148             if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
 149         $obj->{Root}  = $root;
 150         $obj->{Erase} = 0;
 151     }
 152     else {
 153         $obj->{Root}  = "Safe::Root".$default_root++;
 154         $obj->{Erase} = 1;
 155     }
 156
 157     # use permit/deny methods instead till interface issues resolved
 158     # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
 159     croak "Mask parameter to new no longer supported" if defined $mask;
 160     $obj->permit_only(':default');
 161
 162     # We must share $_ and @_ with the compartment or else ops such
 163     # as split, length and so on won't default to $_ properly, nor
 164     # will passing argument to subroutines work (via @_). In fact,
 165     # for reasons I don't completely understand, we need to share
 166     # the whole glob *_ rather than $_ and @_ separately, otherwise
 167     # @_ in non default packages within the compartment don't work.
 168     $obj->share_from('main', $default_share);
 169
 170     Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
 171
 172     return $obj;
 173 }
 174
 175 sub DESTROY {
 176     my $obj = shift;
 177     $obj->erase('DESTROY') if $obj->{Erase};
 178 }
 179
 180 sub erase {
 181     my ($obj, $action) = @_;
 182     my $pkg = $obj->root();
 183     my ($stem, $leaf);
 184
 185     no strict 'refs';
 186     $pkg = "main::$pkg\::";     # expand to full symbol table name
 187     ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
 188
 189     # The 'my $foo' is needed! Without it you get an
 190     # 'Attempt to free unreferenced scalar' warning!
 191     my $stem_symtab = *{$stem}{HASH};
 192
 193     #warn "erase($pkg) stem=$stem, leaf=$leaf";
 194     #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
 195     # ", join(', ', %$stem_symtab),"\n";
 196
 197 #    delete $stem_symtab->{$leaf};
 198
 199     my $leaf_glob   = $stem_symtab->{$leaf};
 200     my $leaf_symtab = *{$leaf_glob}{HASH};
 201 #    warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
 202     %$leaf_symtab = ();
 203     #delete $leaf_symtab->{'__ANON__'};
 204     #delete $leaf_symtab->{'foo'};
 205     #delete $leaf_symtab->{'main::'};
 206 #    my $foo = undef ${"$stem\::"}{"$leaf\::"};
 207
 208     if ($action and $action eq 'DESTROY') {
 209         delete $stem_symtab->{$leaf};
 210     } else {
 211         $obj->share_from('main', $default_share);
 212     }
 213     1;
 214 }
 215
 216
 217 sub reinit {
 218     my $obj= shift;
 219     $obj->erase;
 220     $obj->share_redo;
 221 }
 222
 223 sub root {
 224     my $obj = shift;
 225     croak("Safe root method now read-only") if @_;
 226     return $obj->{Root};
 227 }
 228
 229
 230 sub mask {
 231     my $obj = shift;
 232     return $obj->{Mask} unless @_;
 233     $obj->deny_only(@_);
 234 }
 235
 236 # v1 compatibility methods
 237 sub trap   { shift->deny(@_)   }
 238 sub untrap { shift->permit(@_) }
 239
 240 sub deny {
 241     my $obj = shift;
 242     $obj->{Mask} |= opset(@_);
 243 }
 244 sub deny_only {
 245     my $obj = shift;
 246     $obj->{Mask} = opset(@_);
 247 }
 248
 249 sub permit {
 250     my $obj = shift;
 251     # XXX needs testing
 252     $obj->{Mask} &= invert_opset opset(@_);
 253 }
 254 sub permit_only {
 255     my $obj = shift;
 256     $obj->{Mask} = invert_opset opset(@_);
 257 }
 258
 259
 260 sub dump_mask {
 261     my $obj = shift;
 262     print opset_to_hex($obj->{Mask}),"\n";
 263 }
 264
 265
 266 sub share {
 267     my($obj, @vars) = @_;
 268     $obj->share_from(scalar(caller), \@vars);
 269 }
 270
 271
 272 sub share_from {
 273     my $obj = shift;
 274     my $pkg = shift;
 275     my $vars = shift;
 276     my $no_record = shift || 0;
 277     my $root = $obj->root();
 278     croak("vars not an array ref") unless ref $vars eq 'ARRAY';
 279     no strict 'refs';
 280     # Check that 'from' package actually exists
 281     croak("Package \"$pkg\" does not exist")
 282         unless keys %{"$pkg\::"};
 283     my $arg;
 284     foreach $arg (@$vars) {
 285         # catch some $safe->share($var) errors:
 286         my ($var, $type);
 287         $type = $1 if ($var = $arg) =~ s/^(\W)//;
 288         # warn "share_from $pkg $type $var";
 289         for (1..2) { # assign twice to avoid any 'used once' warnings
 290             *{$root."::$var"} = (!$type)   ? \&{$pkg."::$var"}
 291                           : ($type eq '&') ? \&{$pkg."::$var"}
 292                           : ($type eq '$') ? \${$pkg."::$var"}
 293                           : ($type eq '@') ? \@{$pkg."::$var"}
 294                           : ($type eq '%') ? \%{$pkg."::$var"}
 295                           : ($type eq '*') ?  *{$pkg."::$var"}
 296                           : croak(qq(Can't share "$type$var" of unknown type));
 297         }
 298     }
 299     $obj->share_record($pkg, $vars) unless $no_record or !$vars;
 300 }
 301
 302
 303 sub share_record {
 304     my $obj = shift;
 305     my $pkg = shift;
 306     my $vars = shift;
 307     my $shares = \%{$obj->{Shares} ||= {}};
 308     # Record shares using keys of $obj->{Shares}. See reinit.
 309     @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
 310 }
 311
 312
 313 sub share_redo {
 314     my $obj = shift;
 315     my $shares = \%{$obj->{Shares} ||= {}};
 316     my($var, $pkg);
 317     while(($var, $pkg) = each %$shares) {
 318         # warn "share_redo $pkg\:: $var";
 319         $obj->share_from($pkg,  [ $var ], 1);
 320     }
 321 }
 322
 323
 324 sub share_forget {
 325     delete shift->{Shares};
 326 }
 327
 328
 329 sub varglob {
 330     my ($obj, $var) = @_;
 331     no strict 'refs';
 332     return *{$obj->root()."::$var"};
 333 }
 334
 335 sub _clean_stash {
 336     my ($root, $saved_refs) = @_;
 337     $saved_refs ||= [];
 338     no strict 'refs';
 339     foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) {
 340         push @$saved_refs, \*{$root.$hook};
 341         delete ${$root}{$hook};
 342     }
 343
 344     for (grep /::$/, keys %$root) {
 345         next if \%{$root.$_} eq \%$root;
 346         _clean_stash($root.$_, $saved_refs);
 347     }
 348 }
 349
 350 sub reval {
 351     my ($obj, $expr, $strict) = @_;
 352     my $root = $obj->{Root};
 353
 354     my $evalsub = lexless_anon_sub($root, $strict, $expr);
 355     # propagate context
 356     my $sg = sub_generation();
 357     my @subret = (wantarray)
 358                ?        Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
 359                : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
 360     _clean_stash($root.'::') if $sg != sub_generation();
 361     $obj->wrap_code_refs_within(@subret);
 362     return (wantarray) ? @subret : $subret[0];
 363 }
 364
 365
 366 sub wrap_code_refs_within {
 367     my $obj = shift;
 368
 369     $obj->_find_code_refs('wrap_code_ref', @_);
 370 }
 371
 372
 373 sub _find_code_refs {
 374     my $obj = shift;
 375     my $visitor = shift;
 376
 377     for my $item (@_) {
 378         my $reftype = $item && reftype $item
 379             or next;
 380         if ($reftype eq 'ARRAY') {
 381             $obj->_find_code_refs($visitor, @$item);
 382         }
 383         elsif ($reftype eq 'HASH') {
 384             $obj->_find_code_refs($visitor, values %$item);
 385         }
 386         # XXX GLOBs?
 387         elsif ($reftype eq 'CODE') {
 388             $item = $obj->$visitor($item);
 389         }
 390     }
 391 }
 392
 393
 394 sub wrap_code_ref {
 395     my ($obj, $sub) = @_;
 396
 397     # wrap code ref $sub with _safe_call_sv so that, when called, the
 398     # execution will happen with the compartment fully 'in effect'.
 399
 400     croak "Not a CODE reference"
 401         if reftype $sub ne 'CODE';
 402
 403     my $ret = sub {
 404         my @args = @_; # lexical to close over
 405         my $sub_with_args = sub { $sub->(@args) };
 406
 407         my @subret;
 408         my $error;
 409         do {
 410             local $@;  # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR)
 411             my $sg = sub_generation();
 412             @subret = (wantarray)
 413                 ?        Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
 414                 : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
 415             $error = $@;
 416             _clean_stash($obj->{Root}.'::') if $sg != sub_generation();
 417         };
 418         if ($error) { # rethrow exception
 419             $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR
 420             die $error;
 421         }
 422         return (wantarray) ? @subret : $subret[0];
 423     };
 424
 425     return $ret;
 426 }
 427
 428
 429 sub rdo {
 430     my ($obj, $file) = @_;
 431     my $root = $obj->{Root};
 432
 433     my $sg = sub_generation();
 434     my $evalsub = eval
 435             sprintf('package %s; sub { @_ = (); do $file }', $root);
 436     my @subret = (wantarray)
 437                ?        Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
 438                : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
 439     _clean_stash($root.'::') if $sg != sub_generation();
 440     $obj->wrap_code_refs_within(@subret);
 441     return (wantarray) ? @subret : $subret[0];
 442 }
 443
 444
 445 1;
 446
 447 __END__
 448
 449 =head1 NAME
 450
 451 Safe - Compile and execute code in restricted compartments
 452
 453 =head1 SYNOPSIS
 454
 455   use Safe;
 456
 457   $compartment = new Safe;
 458
 459   $compartment->permit(qw(time sort :browse));
 460
 461   $result = $compartment->reval($unsafe_code);
 462
 463 =head1 DESCRIPTION
 464
 465 The Safe extension module allows the creation of compartments
 466 in which perl code can be evaluated. Each compartment has
 467
 468 =over 8
 469
 470 =item a new namespace
 471
 472 The "root" of the namespace (i.e. "main::") is changed to a
 473 different package and code evaluated in the compartment cannot
 474 refer to variables outside this namespace, even with run-time
 475 glob lookups and other tricks.
 476
 477 Code which is compiled outside the compartment can choose to place
 478 variables into (or I<share> variables with) the compartment's namespace
 479 and only that data will be visible to code evaluated in the
 480 compartment.
 481
 482 By default, the only variables shared with compartments are the
 483 "underscore" variables $_ and @_ (and, technically, the less frequently
 484 used %_, the _ filehandle and so on). This is because otherwise perl
 485 operators which default to $_ will not work and neither will the
 486 assignment of arguments to @_ on subroutine entry.
 487
 488 =item an operator mask
 489
 490 Each compartment has an associated "operator mask". Recall that
 491 perl code is compiled into an internal format before execution.
 492 Evaluating perl code (e.g. via "eval" or "do 'file'") causes
 493 the code to be compiled into an internal format and then,
 494 provided there was no error in the compilation, executed.
 495 Code evaluated in a compartment compiles subject to the
 496 compartment's operator mask. Attempting to evaluate code in a
 497 compartment which contains a masked operator will cause the
 498 compilation to fail with an error. The code will not be executed.
 499
 500 The default operator mask for a newly created compartment is
 501 the ':default' optag.
 502
 503 It is important that you read the L<Opcode> module documentation
 504 for more information, especially for detailed definitions of opnames,
 505 optags and opsets.
 506
 507 Since it is only at the compilation stage that the operator mask
 508 applies, controlled access to potentially unsafe operations can
 509 be achieved by having a handle to a wrapper subroutine (written
 510 outside the compartment) placed into the compartment. For example,
 511
 512     $cpt = new Safe;
 513     sub wrapper {
 514         # vet arguments and perform potentially unsafe operations
 515     }
 516     $cpt->share('&wrapper');
 517
 518 =back
 519
 520
 521 =head1 WARNING
 522
 523 The authors make B<no warranty>, implied or otherwise, about the
 524 suitability of this software for safety or security purposes.
 525
 526 The authors shall not in any case be liable for special, incidental,
 527 consequential, indirect or other similar damages arising from the use
 528 of this software.
 529
 530 Your mileage will vary. If in any doubt B<do not use it>.
 531
 532
 533 =head1 METHODS
 534
 535 To create a new compartment, use
 536
 537     $cpt = new Safe;
 538
 539 Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
 540 to use for the compartment (defaults to "Safe::Root0", incremented for
 541 each new compartment).
 542
 543 Note that version 1.00 of the Safe module supported a second optional
 544 parameter, MASK.  That functionality has been withdrawn pending deeper
 545 consideration. Use the permit and deny methods described below.
 546
 547 The following methods can then be used on the compartment
 548 object returned by the above constructor. The object argument
 549 is implicit in each case.
 550
 551
 552 =head2 permit (OP, ...)
 553
 554 Permit the listed operators to be used when compiling code in the
 555 compartment (in I<addition> to any operators already permitted).
 556
 557 You can list opcodes by names, or use a tag name; see
 558 L<Opcode/"Predefined Opcode Tags">.
 559
 560 =head2 permit_only (OP, ...)
 561
 562 Permit I<only> the listed operators to be used when compiling code in
 563 the compartment (I<no> other operators are permitted).
 564
 565 =head2 deny (OP, ...)
 566
 567 Deny the listed operators from being used when compiling code in the
 568 compartment (other operators may still be permitted).
 569
 570 =head2 deny_only (OP, ...)
 571
 572 Deny I<only> the listed operators from being used when compiling code
 573 in the compartment (I<all> other operators will be permitted, so you probably
 574 don't want to use this method).
 575
 576 =head2 trap (OP, ...)
 577
 578 =head2 untrap (OP, ...)
 579
 580 The trap and untrap methods are synonyms for deny and permit
 581 respectfully.
 582
 583 =head2 share (NAME, ...)
 584
 585 This shares the variable(s) in the argument list with the compartment.
 586 This is almost identical to exporting variables using the L<Exporter>
 587 module.
 588
 589 Each NAME must be the B<name> of a non-lexical variable, typically
 590 with the leading type identifier included. A bareword is treated as a
 591 function name.
 592
 593 Examples of legal names are '$foo' for a scalar, '@foo' for an
 594 array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
 595 for a glob (i.e.  all symbol table entries associated with "foo",
 596 including scalar, array, hash, sub and filehandle).
 597
 598 Each NAME is assumed to be in the calling package. See share_from
 599 for an alternative method (which C<share> uses).
 600
 601 =head2 share_from (PACKAGE, ARRAYREF)
 602
 603 This method is similar to share() but allows you to explicitly name the
 604 package that symbols should be shared from. The symbol names (including
 605 type characters) are supplied as an array reference.
 606
 607     $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
 608
 609 Names can include package names, which are relative to the specified PACKAGE.
 610 So these two calls have the same effect:
 611
 612     $safe->share_from('Scalar::Util', [ 'reftype' ]);
 613     $safe->share_from('main', [ 'Scalar::Util::reftype' ]);
 614
 615 =head2 varglob (VARNAME)
 616
 617 This returns a glob reference for the symbol table entry of VARNAME in
 618 the package of the compartment. VARNAME must be the B<name> of a
 619 variable without any leading type marker. For example:
 620
 621     ${$cpt->varglob('foo')} = "Hello world";
 622
 623 has the same effect as:
 624
 625     $cpt = new Safe 'Root';
 626     $Root::foo = "Hello world";
 627
 628 but avoids the need to know $cpt's package name.
 629
 630
 631 =head2 reval (STRING, STRICT)
 632
 633 This evaluates STRING as perl code inside the compartment.
 634
 635 The code can only see the compartment's namespace (as returned by the
 636 B<root> method). The compartment's root package appears to be the
 637 C<main::> package to the code inside the compartment.
 638
 639 Any attempt by the code in STRING to use an operator which is not permitted
 640 by the compartment will cause an error (at run-time of the main program
 641 but at compile-time for the code in STRING).  The error is of the form
 642 "'%s' trapped by operation mask...".
 643
 644 If an operation is trapped in this way, then the code in STRING will
 645 not be executed. If such a trapped operation occurs or any other
 646 compile-time or return error, then $@ is set to the error message, just
 647 as with an eval().
 648
 649 If there is no error, then the method returns the value of the last
 650 expression evaluated, or a return statement may be used, just as with
 651 subroutines and B<eval()>. The context (list or scalar) is determined
 652 by the caller as usual.
 653
 654 If the return value of reval() is (or contains) any code reference,
 655 those code references are wrapped to be themselves executed always
 656 in the compartment. See L</wrap_code_refs_within>.
 657
 658 The formerly undocumented STRICT argument sets strictness: if true
 659 'use strict;' is used, otherwise it uses 'no strict;'. B<Note>: if
 660 STRICT is omitted 'no strict;' is the default.
 661
 662 Some points to note:
 663
 664 If the entereval op is permitted then the code can use eval "..." to
 665 'hide' code which might use denied ops. This is not a major problem
 666 since when the code tries to execute the eval it will fail because the
 667 opmask is still in effect. However this technique would allow clever,
 668 and possibly harmful, code to 'probe' the boundaries of what is
 669 possible.
 670
 671 Any string eval which is executed by code executing in a compartment,
 672 or by code called from code executing in a compartment, will be eval'd
 673 in the namespace of the compartment. This is potentially a serious
 674 problem.
 675
 676 Consider a function foo() in package pkg compiled outside a compartment
 677 but shared with it. Assume the compartment has a root package called
 678 'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
 679 normally, $pkg::foo will be set to 1.  If foo() is called from the
 680 compartment (by whatever means) then instead of setting $pkg::foo, the
 681 eval will actually set $Root::pkg::foo.
 682
 683 This can easily be demonstrated by using a module, such as the Socket
 684 module, which uses eval "..." as part of an AUTOLOAD function. You can
 685 'use' the module outside the compartment and share an (autoloaded)
 686 function with the compartment. If an autoload is triggered by code in
 687 the compartment, or by any code anywhere that is called by any means
 688 from the compartment, then the eval in the Socket module's AUTOLOAD
 689 function happens in the namespace of the compartment. Any variables
 690 created or used by the eval'd code are now under the control of
 691 the code in the compartment.
 692
 693 A similar effect applies to I<all> runtime symbol lookups in code
 694 called from a compartment but not compiled within it.
 695
 696 =head2 rdo (FILENAME)
 697
 698 This evaluates the contents of file FILENAME inside the compartment.
 699 See above documentation on the B<reval> method for further details.
 700
 701 =head2 root (NAMESPACE)
 702
 703 This method returns the name of the package that is the root of the
 704 compartment's namespace.
 705
 706 Note that this behaviour differs from version 1.00 of the Safe module
 707 where the root module could be used to change the namespace. That
 708 functionality has been withdrawn pending deeper consideration.
 709
 710 =head2 mask (MASK)
 711
 712 This is a get-or-set method for the compartment's operator mask.
 713
 714 With no MASK argument present, it returns the current operator mask of
 715 the compartment.
 716
 717 With the MASK argument present, it sets the operator mask for the
 718 compartment (equivalent to calling the deny_only method).
 719
 720 =head2 wrap_code_ref (CODEREF)
 721
 722 Returns a reference to an anonymous subroutine that, when executed, will call
 723 CODEREF with the Safe compartment 'in effect'.  In other words, with the
 724 package namespace adjusted and the opmask enabled.
 725
 726 Note that the opmask doesn't affect the already compiled code, it only affects
 727 any I<further> compilation that the already compiled code may try to perform.
 728
 729 This is particularly useful when applied to code references returned from reval().
 730
 731 (It also provides a kind of workaround for RT#60374: "Safe.pm sort {} bug with
 732 -Dusethreads". See L<http://rt.perl.org/rt3//Public/Bug/Display.html?id=60374>
 733 for I<much> more detail.)
 734
 735 =head2 wrap_code_refs_within (...)
 736
 737 Wraps any CODE references found within the arguments by replacing each with the
 738 result of calling L</wrap_code_ref> on the CODE reference. Any ARRAY or HASH
 739 references in the arguments are inspected recursively.
 740
 741 Returns nothing.
 742
 743 =head1 RISKS
 744
 745 This section is just an outline of some of the things code in a compartment
 746 might do (intentionally or unintentionally) which can have an effect outside
 747 the compartment.
 748
 749 =over 8
 750
 751 =item Memory
 752
 753 Consuming all (or nearly all) available memory.
 754
 755 =item CPU
 756
 757 Causing infinite loops etc.
 758
 759 =item Snooping
 760
 761 Copying private information out of your system. Even something as
 762 simple as your user name is of value to others. Much useful information
 763 could be gleaned from your environment variables for example.
 764
 765 =item Signals
 766
 767 Causing signals (especially SIGFPE and SIGALARM) to affect your process.
 768
 769 Setting up a signal handler will need to be carefully considered
 770 and controlled.  What mask is in effect when a signal handler
 771 gets called?  If a user can get an imported function to get an
 772 exception and call the user's signal handler, does that user's
 773 restricted mask get re-instated before the handler is called?
 774 Does an imported handler get called with its original mask or
 775 the user's one?
 776
 777 =item State Changes
 778
 779 Ops such as chdir obviously effect the process as a whole and not just
 780 the code in the compartment. Ops such as rand and srand have a similar
 781 but more subtle effect.
 782
 783 =back
 784
 785 =head1 AUTHOR
 786
 787 Originally designed and implemented by Malcolm Beattie.
 788
 789 Reworked to use the Opcode module and other changes added by Tim Bunce.
 790
 791 Currently maintained by the Perl 5 Porters, <perl5-porters@perl.org>.
 792
 793 =cut
 794