Integrate mainline
[p5sagit/p5-mst-13.2.git] / ext / Opcode / Safe.pm
CommitLineData
2ded1cc1 1package Safe;
2
5f05dabc 3use 5.003_11;
2ded1cc1 4use strict;
2ded1cc1 5
d6a466d7 6our $VERSION = "2.07";
2ded1cc1 7
5f05dabc 8use Carp;
9
2ded1cc1 10use 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
19my $default_root = 0;
20my $default_share = ['*_']; #, '*main::'];
21
22sub 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);
8c7314f9 50 Opcode::_safe_pkg_prep($obj->{Root});
2ded1cc1 51 return $obj;
52}
53
54sub DESTROY {
55 my $obj = shift;
4d8e9581 56 $obj->erase('DESTROY') if $obj->{Erase};
2ded1cc1 57}
58
59sub erase {
4d8e9581 60 my ($obj, $action) = @_;
2ded1cc1 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
4d8e9581 76# delete $stem_symtab->{$leaf};
2ded1cc1 77
4d8e9581 78 my $leaf_glob = $stem_symtab->{$leaf};
79 my $leaf_symtab = *{$leaf_glob}{HASH};
2ded1cc1 80# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
4d8e9581 81 %$leaf_symtab = ();
2ded1cc1 82 #delete $leaf_symtab->{'__ANON__'};
83 #delete $leaf_symtab->{'foo'};
84 #delete $leaf_symtab->{'main::'};
85# my $foo = undef ${"$stem\::"}{"$leaf\::"};
86
4d8e9581 87 if ($action and $action eq 'DESTROY') {
88 delete $stem_symtab->{$leaf};
89 } else {
90 $obj->share_from('main', $default_share);
91 }
2ded1cc1 92 1;
93}
94
95
96sub reinit {
97 my $obj= shift;
98 $obj->erase;
99 $obj->share_redo;
100}
101
102sub root {
103 my $obj = shift;
104 croak("Safe root method now read-only") if @_;
105 return $obj->{Root};
106}
107
108
109sub mask {
110 my $obj = shift;
111 return $obj->{Mask} unless @_;
112 $obj->deny_only(@_);
113}
114
115# v1 compatibility methods
116sub trap { shift->deny(@_) }
117sub untrap { shift->permit(@_) }
118
119sub deny {
120 my $obj = shift;
121 $obj->{Mask} |= opset(@_);
122}
123sub deny_only {
124 my $obj = shift;
125 $obj->{Mask} = opset(@_);
126}
127
128sub permit {
129 my $obj = shift;
130 # XXX needs testing
131 $obj->{Mask} &= invert_opset opset(@_);
132}
133sub permit_only {
134 my $obj = shift;
135 $obj->{Mask} = invert_opset opset(@_);
136}
137
138
139sub dump_mask {
140 my $obj = shift;
141 print opset_to_hex($obj->{Mask}),"\n";
142}
143
144
145
146sub share {
147 my($obj, @vars) = @_;
148 $obj->share_from(scalar(caller), \@vars);
149}
150
151sub share_from {
152 my $obj = shift;
153 my $pkg = shift;
154 my $vars = shift;
155 my $no_record = shift || 0;
50fc18f7 156 my $root = $obj->root();
2ded1cc1 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\::"};
3fe9a6f1 162 my $arg;
2ded1cc1 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$/;
3fe9a6f1 168 my ($var, $type);
169 $type = $1 if ($var = $arg) =~ s/^(\W)//;
170 # warn "share_from $pkg $type $var";
50fc18f7 171 *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
3fe9a6f1 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));
2ded1cc1 178 }
179 $obj->share_record($pkg, $vars) unless $no_record or !$vars;
180}
181
182sub 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}
190sub 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}
199sub share_forget {
200 delete shift->{Shares};
201}
202
203sub varglob {
204 my ($obj, $var) = @_;
205 no strict 'refs';
206 return *{$obj->root()."::$var"};
207}
208
209
210sub reval {
211 my ($obj, $expr, $strict) = @_;
50fc18f7 212 my $root = $obj->{Root};
2ded1cc1 213
50fc18f7 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);
2ded1cc1 224}
225
226sub rdo {
227 my ($obj, $file) = @_;
50fc18f7 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);
2ded1cc1 233}
234
235
2361;
237
3e92a254 238__END__
2ded1cc1 239
240=head1 NAME
241
242Safe - 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
256The Safe extension module allows the creation of compartments
257in which perl code can be evaluated. Each compartment has
258
259=over 8
260
261=item a new namespace
262
263The "root" of the namespace (i.e. "main::") is changed to a
264different package and code evaluated in the compartment cannot
265refer to variables outside this namespace, even with run-time
266glob lookups and other tricks.
267
268Code which is compiled outside the compartment can choose to place
269variables into (or I<share> variables with) the compartment's namespace
270and only that data will be visible to code evaluated in the
271compartment.
272
273By default, the only variables shared with compartments are the
274"underscore" variables $_ and @_ (and, technically, the less frequently
275used %_, the _ filehandle and so on). This is because otherwise perl
276operators which default to $_ will not work and neither will the
277assignment of arguments to @_ on subroutine entry.
278
279=item an operator mask
280
281Each compartment has an associated "operator mask". Recall that
282perl code is compiled into an internal format before execution.
283Evaluating perl code (e.g. via "eval" or "do 'file'") causes
284the code to be compiled into an internal format and then,
285provided there was no error in the compilation, executed.
f610777f 286Code evaluated in a compartment compiles subject to the
287compartment's operator mask. Attempting to evaluate code in a
2ded1cc1 288compartment which contains a masked operator will cause the
289compilation to fail with an error. The code will not be executed.
290
291The default operator mask for a newly created compartment is
292the ':default' optag.
293
1fef88e7 294It is important that you read the Opcode(3) module documentation
295for more information, especially for detailed definitions of opnames,
2ded1cc1 296optags and opsets.
297
298Since it is only at the compilation stage that the operator mask
299applies, controlled access to potentially unsafe operations can
300be achieved by having a handle to a wrapper subroutine (written
301outside 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
314The authors make B<no warranty>, implied or otherwise, about the
315suitability of this software for safety or security purposes.
316
317The authors shall not in any case be liable for special, incidental,
318consequential, indirect or other similar damages arising from the use
319of this software.
320
321Your mileage will vary. If in any doubt B<do not use it>.
322
323
324=head2 RECENT CHANGES
325
326The interface to the Safe module has changed quite dramatically since
327version 1 (as supplied with Perl5.002). Study these pages carefully if
328you have code written to use Safe version 1 because you will need to
329makes changes.
330
331
332=head2 Methods in class Safe
333
334To create a new compartment, use
335
336 $cpt = new Safe;
337
338Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
339to use for the compartment (defaults to "Safe::Root0", incremented for
340each new compartment).
341
342Note that version 1.00 of the Safe module supported a second optional
343parameter, MASK. That functionality has been withdrawn pending deeper
344consideration. Use the permit and deny methods described below.
345
346The following methods can then be used on the compartment
347object returned by the above constructor. The object argument
348is implicit in each case.
349
350
351=over 8
352
353=item permit (OP, ...)
354
355Permit the listed operators to be used when compiling code in the
356compartment (in I<addition> to any operators already permitted).
357
358=item permit_only (OP, ...)
359
360Permit I<only> the listed operators to be used when compiling code in
361the compartment (I<no> other operators are permitted).
362
363=item deny (OP, ...)
364
365Deny the listed operators from being used when compiling code in the
366compartment (other operators may still be permitted).
367
368=item deny_only (OP, ...)
369
370Deny I<only> the listed operators from being used when compiling code
371in the compartment (I<all> other operators will be permitted).
372
373=item trap (OP, ...)
374
375=item untrap (OP, ...)
376
377The trap and untrap methods are synonyms for deny and permit
378respectfully.
379
380=item share (NAME, ...)
381
382This shares the variable(s) in the argument list with the compartment.
5f944aa8 383This is almost identical to exporting variables using the L<Exporter>
2ded1cc1 384module.
385
386Each NAME must be the B<name> of a variable, typically with the leading
387type identifier included. A bareword is treated as a function name.
388
389Examples of legal names are '$foo' for a scalar, '@foo' for an
390array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
391for a glob (i.e. all symbol table entries associated with "foo",
392including scalar, array, hash, sub and filehandle).
393
394Each NAME is assumed to be in the calling package. See share_from
395for an alternative method (which share uses).
396
397=item share_from (PACKAGE, ARRAYREF)
398
399This method is similar to share() but allows you to explicitly name the
400package that symbols should be shared from. The symbol names (including
401type characters) are supplied as an array reference.
402
403 $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
404
405
406=item varglob (VARNAME)
407
408This returns a glob reference for the symbol table entry of VARNAME in
409the package of the compartment. VARNAME must be the B<name> of a
410variable 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
420This evaluates STRING as perl code inside the compartment.
421
422The code can only see the compartment's namespace (as returned by the
423B<root> method). The compartment's root package appears to be the
424C<main::> package to the code inside the compartment.
425
426Any attempt by the code in STRING to use an operator which is not permitted
427by the compartment will cause an error (at run-time of the main program
428but at compile-time for the code in STRING). The error is of the form
429"%s trapped by operation mask operation...".
430
431If an operation is trapped in this way, then the code in STRING will
432not be executed. If such a trapped operation occurs or any other
433compile-time or return error, then $@ is set to the error message, just
434as with an eval().
435
436If there is no error, then the method returns the value of the last
437expression evaluated, or a return statement may be used, just as with
438subroutines and B<eval()>. The context (list or scalar) is determined
439by the caller as usual.
440
441This behaviour differs from the beta distribution of the Safe extension
442where earlier versions of perl made it hard to mimic the return
443behaviour of the eval() command and the context was always scalar.
444
445Some points to note:
446
447If 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
449since when the code tries to execute the eval it will fail because the
450opmask is still in effect. However this technique would allow clever,
451and possibly harmful, code to 'probe' the boundaries of what is
452possible.
453
454Any string eval which is executed by code executing in a compartment,
455or by code called from code executing in a compartment, will be eval'd
456in the namespace of the compartment. This is potentially a serious
457problem.
458
459Consider a function foo() in package pkg compiled outside a compartment
460but shared with it. Assume the compartment has a root package called
1fef88e7 461'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
2ded1cc1 462normally, $pkg::foo will be set to 1. If foo() is called from the
463compartment (by whatever means) then instead of setting $pkg::foo, the
464eval will actually set $Root::pkg::foo.
465
466This can easily be demonstrated by using a module, such as the Socket
467module, which uses eval "..." as part of an AUTOLOAD function. You can
468'use' the module outside the compartment and share an (autoloaded)
469function with the compartment. If an autoload is triggered by code in
470the compartment, or by any code anywhere that is called by any means
471from the compartment, then the eval in the Socket module's AUTOLOAD
472function happens in the namespace of the compartment. Any variables
473created or used by the eval'd code are now under the control of
474the code in the compartment.
475
476A similar effect applies to I<all> runtime symbol lookups in code
477called from a compartment but not compiled within it.
478
479
480
481=item rdo (FILENAME)
482
483This evaluates the contents of file FILENAME inside the compartment.
484See above documentation on the B<reval> method for further details.
485
486=item root (NAMESPACE)
487
488This method returns the name of the package that is the root of the
489compartment's namespace.
490
491Note that this behaviour differs from version 1.00 of the Safe module
492where the root module could be used to change the namespace. That
493functionality has been withdrawn pending deeper consideration.
494
495=item mask (MASK)
496
497This is a get-or-set method for the compartment's operator mask.
498
499With no MASK argument present, it returns the current operator mask of
500the compartment.
501
502With the MASK argument present, it sets the operator mask for the
503compartment (equivalent to calling the deny_only method).
504
505=back
506
507
508=head2 Some Safety Issues
509
510This section is currently just an outline of some of the things code in
511a compartment might do (intentionally or unintentionally) which can
512have an effect outside the compartment.
513
514=over 8
515
516=item Memory
517
518Consuming all (or nearly all) available memory.
519
520=item CPU
521
522Causing infinite loops etc.
523
524=item Snooping
525
526Copying private information out of your system. Even something as
527simple as your user name is of value to others. Much useful information
528could be gleaned from your environment variables for example.
529
530=item Signals
531
532Causing signals (especially SIGFPE and SIGALARM) to affect your process.
533
534Setting up a signal handler will need to be carefully considered
535and controlled. What mask is in effect when a signal handler
536gets called? If a user can get an imported function to get an
537exception and call the user's signal handler, does that user's
538restricted mask get re-instated before the handler is called?
539Does an imported handler get called with its original mask or
540the user's one?
541
542=item State Changes
543
544Ops such as chdir obviously effect the process as a whole and not just
545the code in the compartment. Ops such as rand and srand have a similar
546but more subtle effect.
547
548=back
549
550=head2 AUTHOR
551
552Originally designed and implemented by Malcolm Beattie,
553mbeattie@sable.ox.ac.uk.
554
555Reworked to use the Opcode module and other changes added by Tim Bunce
1fef88e7 556E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
2ded1cc1 557
558=cut
559