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