6 $Safe::VERSION = "2.12";
8 # *** Don't declare any lexicals above this point ***
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)
13 sub lexless_anon_sub {
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
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)
24 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
25 $_[0], $_[1] ? 'use' : 'no';
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
37 *ops_to_opset = \&opset; # Temporary alias for old Penguins
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[
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
71 &utf8::native_to_unicode
72 &utf8::unicode_to_native
92 my($class, $root, $mask) = @_;
97 croak "Can't use \"$root\" as root name"
98 if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
103 $obj->{Root} = "Safe::Root".$default_root++;
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');
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);
125 $obj->erase('DESTROY') if $obj->{Erase};
129 my ($obj, $action) = @_;
130 my $pkg = $obj->root();
134 $pkg = "main::$pkg\::"; # expand to full symbol table name
135 ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
137 # The 'my $foo' is needed! Without it you get an
138 # 'Attempt to free unreferenced scalar' warning!
139 my $stem_symtab = *{$stem}{HASH};
141 #warn "erase($pkg) stem=$stem, leaf=$leaf";
142 #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
143 # ", join(', ', %$stem_symtab),"\n";
145 # delete $stem_symtab->{$leaf};
147 my $leaf_glob = $stem_symtab->{$leaf};
148 my $leaf_symtab = *{$leaf_glob}{HASH};
149 # warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
151 #delete $leaf_symtab->{'__ANON__'};
152 #delete $leaf_symtab->{'foo'};
153 #delete $leaf_symtab->{'main::'};
154 # my $foo = undef ${"$stem\::"}{"$leaf\::"};
156 if ($action and $action eq 'DESTROY') {
157 delete $stem_symtab->{$leaf};
159 $obj->share_from('main', $default_share);
173 croak("Safe root method now read-only") if @_;
180 return $obj->{Mask} unless @_;
184 # v1 compatibility methods
185 sub trap { shift->deny(@_) }
186 sub untrap { shift->permit(@_) }
190 $obj->{Mask} |= opset(@_);
194 $obj->{Mask} = opset(@_);
200 $obj->{Mask} &= invert_opset opset(@_);
204 $obj->{Mask} = invert_opset opset(@_);
210 print opset_to_hex($obj->{Mask}),"\n";
216 my($obj, @vars) = @_;
217 $obj->share_from(scalar(caller), \@vars);
224 my $no_record = shift || 0;
225 my $root = $obj->root();
226 croak("vars not an array ref") unless ref $vars eq 'ARRAY';
228 # Check that 'from' package actually exists
229 croak("Package \"$pkg\" does not exist")
230 unless keys %{"$pkg\::"};
232 foreach $arg (@$vars) {
233 # catch some $safe->share($var) errors:
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));
245 $obj->share_record($pkg, $vars) unless $no_record or !$vars;
252 my $shares = \%{$obj->{Shares} ||= {}};
253 # Record shares using keys of $obj->{Shares}. See reinit.
254 @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
258 my $shares = \%{$obj->{Shares} ||= {}};
260 while(($var, $pkg) = each %$shares) {
261 # warn "share_redo $pkg\:: $var";
262 $obj->share_from($pkg, [ $var ], 1);
266 delete shift->{Shares};
270 my ($obj, $var) = @_;
272 return *{$obj->root()."::$var"};
277 my ($obj, $expr, $strict) = @_;
278 my $root = $obj->{Root};
280 my $evalsub = lexless_anon_sub($root,$strict, $expr);
281 return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
285 my ($obj, $file) = @_;
286 my $root = $obj->{Root};
289 sprintf('package %s; sub { @_ = (); do $file }', $root);
290 return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
300 Safe - Compile and execute code in restricted compartments
306 $compartment = new Safe;
308 $compartment->permit(qw(time sort :browse));
310 $result = $compartment->reval($unsafe_code);
314 The Safe extension module allows the creation of compartments
315 in which perl code can be evaluated. Each compartment has
319 =item a new namespace
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.
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
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.
337 =item an operator mask
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.
349 The default operator mask for a newly created compartment is
350 the ':default' optag.
352 It is important that you read the L<Opcode> module documentation
353 for more information, especially for detailed definitions of opnames,
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,
363 # vet arguments and perform potentially unsafe operations
365 $cpt->share('&wrapper');
372 The authors make B<no warranty>, implied or otherwise, about the
373 suitability of this software for safety or security purposes.
375 The authors shall not in any case be liable for special, incidental,
376 consequential, indirect or other similar damages arising from the use
379 Your mileage will vary. If in any doubt B<do not use it>.
382 =head2 RECENT CHANGES
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
390 =head2 Methods in class Safe
392 To create a new compartment, use
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).
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.
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.
411 =item permit (OP, ...)
413 Permit the listed operators to be used when compiling code in the
414 compartment (in I<addition> to any operators already permitted).
416 You can list opcodes by names, or use a tag name; see
417 L<Opcode/"Predefined Opcode Tags">.
419 =item permit_only (OP, ...)
421 Permit I<only> the listed operators to be used when compiling code in
422 the compartment (I<no> other operators are permitted).
426 Deny the listed operators from being used when compiling code in the
427 compartment (other operators may still be permitted).
429 =item deny_only (OP, ...)
431 Deny I<only> the listed operators from being used when compiling code
432 in the compartment (I<all> other operators will be permitted).
436 =item untrap (OP, ...)
438 The trap and untrap methods are synonyms for deny and permit
441 =item share (NAME, ...)
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>
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
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).
456 Each NAME is assumed to be in the calling package. See share_from
457 for an alternative method (which share uses).
459 =item share_from (PACKAGE, ARRAYREF)
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.
465 $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
468 =item varglob (VARNAME)
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,
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";
482 This evaluates STRING as perl code inside the compartment.
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.
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...".
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
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.
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.
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
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
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.
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.
538 A similar effect applies to I<all> runtime symbol lookups in code
539 called from a compartment but not compiled within it.
545 This evaluates the contents of file FILENAME inside the compartment.
546 See above documentation on the B<reval> method for further details.
548 =item root (NAMESPACE)
550 This method returns the name of the package that is the root of the
551 compartment's namespace.
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.
559 This is a get-or-set method for the compartment's operator mask.
561 With no MASK argument present, it returns the current operator mask of
564 With the MASK argument present, it sets the operator mask for the
565 compartment (equivalent to calling the deny_only method).
570 =head2 Some Safety Issues
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.
580 Consuming all (or nearly all) available memory.
584 Causing infinite loops etc.
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.
594 Causing signals (especially SIGFPE and SIGALARM) to affect your process.
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
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.
614 Originally designed and implemented by Malcolm Beattie.
616 Reworked to use the Opcode module and other changes added by Tim Bunce.
618 Currently maintained by the Perl 5 Porters, <perl5-porters@perl.org>.