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
CommitLineData
2ded1cc1
PP
1package Safe;
2
5f05dabc 3use 5.003_11;
2ded1cc1 4use strict;
2ded1cc1 5
bb9fb662 6$Safe::VERSION = "2.15";
35ed0d3c
DM
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
13sub 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}
2ded1cc1 27
5f05dabc 28use Carp;
bda6a610
RGS
29BEGIN { eval q{
30 use Carp::Heavy;
31} }
5f05dabc 32
2ded1cc1
PP
33use 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
42my $default_root = 0;
096e1543
RGS
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
46my $default_share = [qw[
47 *_
48 &PerlIO::get_layers
49 &Regexp::DESTROY
bb9fb662
NC
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[
096e1543
RGS
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
096e1543 75 &UNIVERSAL::DOES
096e1543
RGS
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
bb9fb662
NC
92]), ($] >= 5.011 && qw[
93 &re::regexp_pattern
94])];
2ded1cc1
PP
95
96sub 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);
ac5e3691 124 Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
2ded1cc1
PP
125 return $obj;
126}
127
128sub DESTROY {
129 my $obj = shift;
4d8e9581 130 $obj->erase('DESTROY') if $obj->{Erase};
2ded1cc1
PP
131}
132
133sub erase {
4d8e9581 134 my ($obj, $action) = @_;
2ded1cc1
PP
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
4d8e9581 150# delete $stem_symtab->{$leaf};
2ded1cc1 151
4d8e9581
GS
152 my $leaf_glob = $stem_symtab->{$leaf};
153 my $leaf_symtab = *{$leaf_glob}{HASH};
2ded1cc1 154# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
4d8e9581 155 %$leaf_symtab = ();
2ded1cc1
PP
156 #delete $leaf_symtab->{'__ANON__'};
157 #delete $leaf_symtab->{'foo'};
158 #delete $leaf_symtab->{'main::'};
159# my $foo = undef ${"$stem\::"}{"$leaf\::"};
160
4d8e9581
GS
161 if ($action and $action eq 'DESTROY') {
162 delete $stem_symtab->{$leaf};
163 } else {
164 $obj->share_from('main', $default_share);
165 }
2ded1cc1
PP
166 1;
167}
168
169
170sub reinit {
171 my $obj= shift;
172 $obj->erase;
173 $obj->share_redo;
174}
175
176sub root {
177 my $obj = shift;
178 croak("Safe root method now read-only") if @_;
179 return $obj->{Root};
180}
181
182
183sub mask {
184 my $obj = shift;
185 return $obj->{Mask} unless @_;
186 $obj->deny_only(@_);
187}
188
189# v1 compatibility methods
190sub trap { shift->deny(@_) }
191sub untrap { shift->permit(@_) }
192
193sub deny {
194 my $obj = shift;
195 $obj->{Mask} |= opset(@_);
196}
197sub deny_only {
198 my $obj = shift;
199 $obj->{Mask} = opset(@_);
200}
201
202sub permit {
203 my $obj = shift;
204 # XXX needs testing
205 $obj->{Mask} &= invert_opset opset(@_);
206}
207sub permit_only {
208 my $obj = shift;
209 $obj->{Mask} = invert_opset opset(@_);
210}
211
212
213sub dump_mask {
214 my $obj = shift;
215 print opset_to_hex($obj->{Mask}),"\n";
216}
217
218
219
220sub share {
221 my($obj, @vars) = @_;
222 $obj->share_from(scalar(caller), \@vars);
223}
224
225sub share_from {
226 my $obj = shift;
227 my $pkg = shift;
228 my $vars = shift;
229 my $no_record = shift || 0;
50fc18f7 230 my $root = $obj->root();
2ded1cc1 231 croak("vars not an array ref") unless ref $vars eq 'ARRAY';
d00660f4 232 no strict 'refs';
2ded1cc1
PP
233 # Check that 'from' package actually exists
234 croak("Package \"$pkg\" does not exist")
235 unless keys %{"$pkg\::"};
3fe9a6f1 236 my $arg;
2ded1cc1
PP
237 foreach $arg (@$vars) {
238 # catch some $safe->share($var) errors:
3fe9a6f1
PP
239 my ($var, $type);
240 $type = $1 if ($var = $arg) =~ s/^(\W)//;
241 # warn "share_from $pkg $type $var";
50fc18f7 242 *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
3fe9a6f1
PP
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));
2ded1cc1
PP
249 }
250 $obj->share_record($pkg, $vars) unless $no_record or !$vars;
251}
252
253sub 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}
261sub share_redo {
262 my $obj = shift;
263 my $shares = \%{$obj->{Shares} ||= {}};
d00660f4 264 my($var, $pkg);
2ded1cc1
PP
265 while(($var, $pkg) = each %$shares) {
266 # warn "share_redo $pkg\:: $var";
267 $obj->share_from($pkg, [ $var ], 1);
268 }
269}
270sub share_forget {
271 delete shift->{Shares};
272}
273
274sub varglob {
275 my ($obj, $var) = @_;
276 no strict 'refs';
277 return *{$obj->root()."::$var"};
278}
279
280
281sub reval {
282 my ($obj, $expr, $strict) = @_;
50fc18f7 283 my $root = $obj->{Root};
2ded1cc1 284
35ed0d3c 285 my $evalsub = lexless_anon_sub($root,$strict, $expr);
50fc18f7 286 return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
2ded1cc1
PP
287}
288
289sub rdo {
290 my ($obj, $file) = @_;
50fc18f7
JH
291 my $root = $obj->{Root};
292
293 my $evalsub = eval
d00660f4 294 sprintf('package %s; sub { @_ = (); do $file }', $root);
50fc18f7 295 return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
2ded1cc1
PP
296}
297
298
2991;
300
3e92a254 301__END__
2ded1cc1
PP
302
303=head1 NAME
304
305Safe - 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
319The Safe extension module allows the creation of compartments
320in which perl code can be evaluated. Each compartment has
321
322=over 8
323
324=item a new namespace
325
326The "root" of the namespace (i.e. "main::") is changed to a
327different package and code evaluated in the compartment cannot
328refer to variables outside this namespace, even with run-time
329glob lookups and other tricks.
330
331Code which is compiled outside the compartment can choose to place
332variables into (or I<share> variables with) the compartment's namespace
333and only that data will be visible to code evaluated in the
334compartment.
335
336By default, the only variables shared with compartments are the
337"underscore" variables $_ and @_ (and, technically, the less frequently
338used %_, the _ filehandle and so on). This is because otherwise perl
339operators which default to $_ will not work and neither will the
340assignment of arguments to @_ on subroutine entry.
341
342=item an operator mask
343
344Each compartment has an associated "operator mask". Recall that
345perl code is compiled into an internal format before execution.
346Evaluating perl code (e.g. via "eval" or "do 'file'") causes
347the code to be compiled into an internal format and then,
348provided there was no error in the compilation, executed.
f610777f
A
349Code evaluated in a compartment compiles subject to the
350compartment's operator mask. Attempting to evaluate code in a
2ded1cc1
PP
351compartment which contains a masked operator will cause the
352compilation to fail with an error. The code will not be executed.
353
354The default operator mask for a newly created compartment is
355the ':default' optag.
356
86780939 357It is important that you read the L<Opcode> module documentation
1fef88e7 358for more information, especially for detailed definitions of opnames,
2ded1cc1
PP
359optags and opsets.
360
361Since it is only at the compilation stage that the operator mask
362applies, controlled access to potentially unsafe operations can
363be achieved by having a handle to a wrapper subroutine (written
364outside 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
377The authors make B<no warranty>, implied or otherwise, about the
378suitability of this software for safety or security purposes.
379
380The authors shall not in any case be liable for special, incidental,
381consequential, indirect or other similar damages arising from the use
382of this software.
383
384Your mileage will vary. If in any doubt B<do not use it>.
385
386
387=head2 RECENT CHANGES
388
389The interface to the Safe module has changed quite dramatically since
390version 1 (as supplied with Perl5.002). Study these pages carefully if
391you have code written to use Safe version 1 because you will need to
392makes changes.
393
394
395=head2 Methods in class Safe
396
397To create a new compartment, use
398
399 $cpt = new Safe;
400
401Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
402to use for the compartment (defaults to "Safe::Root0", incremented for
403each new compartment).
404
405Note that version 1.00 of the Safe module supported a second optional
406parameter, MASK. That functionality has been withdrawn pending deeper
407consideration. Use the permit and deny methods described below.
408
409The following methods can then be used on the compartment
410object returned by the above constructor. The object argument
411is implicit in each case.
412
413
414=over 8
415
416=item permit (OP, ...)
417
418Permit the listed operators to be used when compiling code in the
419compartment (in I<addition> to any operators already permitted).
420
86f9b3f5
RGS
421You can list opcodes by names, or use a tag name; see
422L<Opcode/"Predefined Opcode Tags">.
423
2ded1cc1
PP
424=item permit_only (OP, ...)
425
426Permit I<only> the listed operators to be used when compiling code in
427the compartment (I<no> other operators are permitted).
428
429=item deny (OP, ...)
430
431Deny the listed operators from being used when compiling code in the
432compartment (other operators may still be permitted).
433
434=item deny_only (OP, ...)
435
436Deny I<only> the listed operators from being used when compiling code
437in the compartment (I<all> other operators will be permitted).
438
439=item trap (OP, ...)
440
441=item untrap (OP, ...)
442
443The trap and untrap methods are synonyms for deny and permit
444respectfully.
445
446=item share (NAME, ...)
447
448This shares the variable(s) in the argument list with the compartment.
5f944aa8 449This is almost identical to exporting variables using the L<Exporter>
2ded1cc1
PP
450module.
451
5c3cfe29
SR
452Each NAME must be the B<name> of a non-lexical variable, typically
453with the leading type identifier included. A bareword is treated as a
454function name.
2ded1cc1
PP
455
456Examples of legal names are '$foo' for a scalar, '@foo' for an
457array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
458for a glob (i.e. all symbol table entries associated with "foo",
459including scalar, array, hash, sub and filehandle).
460
461Each NAME is assumed to be in the calling package. See share_from
462for an alternative method (which share uses).
463
464=item share_from (PACKAGE, ARRAYREF)
465
466This method is similar to share() but allows you to explicitly name the
467package that symbols should be shared from. The symbol names (including
468type characters) are supplied as an array reference.
469
470 $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
471
472
473=item varglob (VARNAME)
474
475This returns a glob reference for the symbol table entry of VARNAME in
476the package of the compartment. VARNAME must be the B<name> of a
477variable 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
487This evaluates STRING as perl code inside the compartment.
488
489The code can only see the compartment's namespace (as returned by the
490B<root> method). The compartment's root package appears to be the
491C<main::> package to the code inside the compartment.
492
493Any attempt by the code in STRING to use an operator which is not permitted
494by the compartment will cause an error (at run-time of the main program
495but at compile-time for the code in STRING). The error is of the form
cb77fdf0 496"'%s' trapped by operation mask...".
2ded1cc1
PP
497
498If an operation is trapped in this way, then the code in STRING will
499not be executed. If such a trapped operation occurs or any other
500compile-time or return error, then $@ is set to the error message, just
501as with an eval().
502
503If there is no error, then the method returns the value of the last
504expression evaluated, or a return statement may be used, just as with
505subroutines and B<eval()>. The context (list or scalar) is determined
506by the caller as usual.
507
508This behaviour differs from the beta distribution of the Safe extension
509where earlier versions of perl made it hard to mimic the return
510behaviour of the eval() command and the context was always scalar.
511
512Some points to note:
513
514If 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
516since when the code tries to execute the eval it will fail because the
517opmask is still in effect. However this technique would allow clever,
518and possibly harmful, code to 'probe' the boundaries of what is
519possible.
520
521Any string eval which is executed by code executing in a compartment,
522or by code called from code executing in a compartment, will be eval'd
523in the namespace of the compartment. This is potentially a serious
524problem.
525
526Consider a function foo() in package pkg compiled outside a compartment
527but shared with it. Assume the compartment has a root package called
1fef88e7 528'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
2ded1cc1
PP
529normally, $pkg::foo will be set to 1. If foo() is called from the
530compartment (by whatever means) then instead of setting $pkg::foo, the
531eval will actually set $Root::pkg::foo.
532
533This can easily be demonstrated by using a module, such as the Socket
534module, which uses eval "..." as part of an AUTOLOAD function. You can
535'use' the module outside the compartment and share an (autoloaded)
536function with the compartment. If an autoload is triggered by code in
537the compartment, or by any code anywhere that is called by any means
538from the compartment, then the eval in the Socket module's AUTOLOAD
539function happens in the namespace of the compartment. Any variables
540created or used by the eval'd code are now under the control of
541the code in the compartment.
542
543A similar effect applies to I<all> runtime symbol lookups in code
544called from a compartment but not compiled within it.
545
546
547
548=item rdo (FILENAME)
549
550This evaluates the contents of file FILENAME inside the compartment.
551See above documentation on the B<reval> method for further details.
552
553=item root (NAMESPACE)
554
555This method returns the name of the package that is the root of the
556compartment's namespace.
557
558Note that this behaviour differs from version 1.00 of the Safe module
559where the root module could be used to change the namespace. That
560functionality has been withdrawn pending deeper consideration.
561
562=item mask (MASK)
563
564This is a get-or-set method for the compartment's operator mask.
565
566With no MASK argument present, it returns the current operator mask of
567the compartment.
568
569With the MASK argument present, it sets the operator mask for the
570compartment (equivalent to calling the deny_only method).
571
572=back
573
574
575=head2 Some Safety Issues
576
577This section is currently just an outline of some of the things code in
578a compartment might do (intentionally or unintentionally) which can
579have an effect outside the compartment.
580
581=over 8
582
583=item Memory
584
585Consuming all (or nearly all) available memory.
586
587=item CPU
588
589Causing infinite loops etc.
590
591=item Snooping
592
593Copying private information out of your system. Even something as
594simple as your user name is of value to others. Much useful information
595could be gleaned from your environment variables for example.
596
597=item Signals
598
599Causing signals (especially SIGFPE and SIGALARM) to affect your process.
600
601Setting up a signal handler will need to be carefully considered
602and controlled. What mask is in effect when a signal handler
603gets called? If a user can get an imported function to get an
604exception and call the user's signal handler, does that user's
605restricted mask get re-instated before the handler is called?
606Does an imported handler get called with its original mask or
607the user's one?
608
609=item State Changes
610
611Ops such as chdir obviously effect the process as a whole and not just
612the code in the compartment. Ops such as rand and srand have a similar
613but more subtle effect.
614
615=back
616
617=head2 AUTHOR
618
25ff8439 619Originally designed and implemented by Malcolm Beattie.
2ded1cc1 620
25ff8439
RGS
621Reworked to use the Opcode module and other changes added by Tim Bunce.
622
623Currently maintained by the Perl 5 Porters, <perl5-porters@perl.org>.
2ded1cc1
PP
624
625=cut
626