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