Commit | Line | Data |
---|---|---|
2ded1cc1 | 1 | package Safe; |
2 | ||
5f05dabc | 3 | use 5.003_11; |
7650682f | 4 | use Scalar::Util qw(reftype refaddr); |
2ded1cc1 | 5 | |
7279e368 | 6 | $Safe::VERSION = "2.39"; |
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 | ||
13 | sub lexless_anon_sub { | |
27c4ce72 TB |
14 | # $_[0] is package; |
15 | # $_[1] is strict flag; | |
35ed0d3c | 16 | my $__ExPr__ = $_[2]; # must be a lexical to create the closure that |
27c4ce72 TB |
17 | # can be used to pass the value into the safe |
18 | # world | |
35ed0d3c DM |
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 | |
ac4ec33e | 24 | 'package %s; %s sub { @_=(); eval q[local *SIG; my $__ExPr__;] . $__ExPr__; }', |
25dc25e7 | 25 | $_[0], $_[1] ? 'use strict;' : ''; |
35ed0d3c | 26 | } |
2ded1cc1 | 27 | |
25dc25e7 | 28 | use strict; |
5f05dabc | 29 | use Carp; |
bda6a610 RGS |
30 | BEGIN { eval q{ |
31 | use Carp::Heavy; | |
32 | } } | |
5f05dabc | 33 | |
40a34d2a RGS |
34 | use B (); |
35 | BEGIN { | |
36 | no strict 'refs'; | |
37 | if (defined &B::sub_generation) { | |
38 | *sub_generation = \&B::sub_generation; | |
39 | } | |
40 | else { | |
41 | # fake sub generation changing for perls < 5.8.9 | |
42 | my $sg; *sub_generation = sub { ++$sg }; | |
43 | } | |
44 | } | |
45 | ||
2ded1cc1 | 46 | use Opcode 1.01, qw( |
47 | opset opset_to_ops opmask_add | |
48 | empty_opset full_opset invert_opset verify_opset | |
49 | opdesc opcodes opmask define_optag opset_to_hex | |
50 | ); | |
51 | ||
52 | *ops_to_opset = \&opset; # Temporary alias for old Penguins | |
53 | ||
90066512 TB |
54 | # Regular expressions and other unicode-aware code may need to call |
55 | # utf8->SWASHNEW (via perl's utf8.c). That will fail unless we share the | |
56 | # SWASHNEW method. | |
57 | # Sadly we can't just add utf8::SWASHNEW to $default_share because perl's | |
58 | # utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded, | |
59 | # and sharing makes it look like the method exists. | |
60 | # The simplest and most robust fix is to ensure the utf8 module is loaded when | |
61 | # Safe is loaded. Then we can add utf8::SWASHNEW to $default_share. | |
62 | require utf8; | |
63 | # we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded | |
0540b90b KW |
64 | # but without depending on too much knowledge of that implementation detail. |
65 | # This code (//i on a unicode string) should ensure utf8 is fully loaded | |
66 | # and also loads the ToFold SWASH, unless things change so that these | |
67 | # particular code points don't cause it to load. | |
90066512 TB |
68 | # (Swashes are cached internally by perl in PL_utf8_* variables |
69 | # independent of being inside/outside of Safe. So once loaded they can be) | |
0540b90b | 70 | do { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i }; |
90066512 | 71 | # now we can safely include utf8::SWASHNEW in $default_share defined below. |
2ded1cc1 | 72 | |
73 | my $default_root = 0; | |
096e1543 RGS |
74 | # share *_ and functions defined in universal.c |
75 | # Don't share stuff like *UNIVERSAL:: otherwise code from the | |
76 | # compartment can 0wn functions in UNIVERSAL | |
77 | my $default_share = [qw[ | |
78 | *_ | |
79 | &PerlIO::get_layers | |
bb9fb662 NC |
80 | &UNIVERSAL::isa |
81 | &UNIVERSAL::can | |
82 | &UNIVERSAL::VERSION | |
83 | &utf8::is_utf8 | |
84 | &utf8::valid | |
85 | &utf8::encode | |
86 | &utf8::decode | |
87 | &utf8::upgrade | |
88 | &utf8::downgrade | |
89 | &utf8::native_to_unicode | |
90 | &utf8::unicode_to_native | |
90066512 | 91 | &utf8::SWASHNEW |
1c92ff99 RGS |
92 | $version::VERSION |
93 | $version::CLASS | |
91152fc1 DG |
94 | $version::STRICT |
95 | $version::LAX | |
cd6d5856 | 96 | @version::ISA |
d2177bdf RGS |
97 | ], ($] < 5.010 && qw[ |
98 | &utf8::SWASHGET | |
99 | ]), ($] >= 5.008001 && qw[ | |
81d4a902 RGS |
100 | &Regexp::DESTROY |
101 | ]), ($] >= 5.010 && qw[ | |
096e1543 RGS |
102 | &re::is_regexp |
103 | &re::regname | |
104 | &re::regnames | |
105 | &re::regnames_count | |
096e1543 | 106 | &UNIVERSAL::DOES |
096e1543 RGS |
107 | &version::() |
108 | &version::new | |
109 | &version::("" | |
110 | &version::stringify | |
111 | &version::(0+ | |
112 | &version::numify | |
113 | &version::normal | |
114 | &version::(cmp | |
115 | &version::(<=> | |
116 | &version::vcmp | |
117 | &version::(bool | |
118 | &version::boolean | |
119 | &version::(nomethod | |
120 | &version::noop | |
121 | &version::is_alpha | |
122 | &version::qv | |
404e3cec RGS |
123 | &version::vxs::declare |
124 | &version::vxs::qv | |
125 | &version::vxs::_VERSION | |
4e26ee16 | 126 | &version::vxs::stringify |
e4e65250 RGS |
127 | &version::vxs::new |
128 | &version::vxs::parse | |
45c3e378 | 129 | &version::vxs::VCMP |
bb9fb662 NC |
130 | ]), ($] >= 5.011 && qw[ |
131 | &re::regexp_pattern | |
ad084f51 RGS |
132 | ]), ($] >= 5.010 && $] < 5.014 && qw[ |
133 | &Tie::Hash::NamedCapture::FETCH | |
134 | &Tie::Hash::NamedCapture::STORE | |
135 | &Tie::Hash::NamedCapture::DELETE | |
136 | &Tie::Hash::NamedCapture::CLEAR | |
137 | &Tie::Hash::NamedCapture::EXISTS | |
138 | &Tie::Hash::NamedCapture::FIRSTKEY | |
139 | &Tie::Hash::NamedCapture::NEXTKEY | |
140 | &Tie::Hash::NamedCapture::SCALAR | |
141 | &Tie::Hash::NamedCapture::flags | |
bb9fb662 | 142 | ])]; |
5df103ab CBW |
143 | if (defined $Devel::Cover::VERSION) { |
144 | push @$default_share, '&Devel::Cover::use_file'; | |
145 | } | |
2ded1cc1 | 146 | |
147 | sub new { | |
148 | my($class, $root, $mask) = @_; | |
149 | my $obj = {}; | |
150 | bless $obj, $class; | |
151 | ||
152 | if (defined($root)) { | |
27c4ce72 TB |
153 | croak "Can't use \"$root\" as root name" |
154 | if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/; | |
155 | $obj->{Root} = $root; | |
156 | $obj->{Erase} = 0; | |
2ded1cc1 | 157 | } |
158 | else { | |
27c4ce72 TB |
159 | $obj->{Root} = "Safe::Root".$default_root++; |
160 | $obj->{Erase} = 1; | |
2ded1cc1 | 161 | } |
162 | ||
163 | # use permit/deny methods instead till interface issues resolved | |
164 | # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...; | |
165 | croak "Mask parameter to new no longer supported" if defined $mask; | |
166 | $obj->permit_only(':default'); | |
167 | ||
168 | # We must share $_ and @_ with the compartment or else ops such | |
169 | # as split, length and so on won't default to $_ properly, nor | |
170 | # will passing argument to subroutines work (via @_). In fact, | |
171 | # for reasons I don't completely understand, we need to share | |
172 | # the whole glob *_ rather than $_ and @_ separately, otherwise | |
173 | # @_ in non default packages within the compartment don't work. | |
174 | $obj->share_from('main', $default_share); | |
27c4ce72 | 175 | |
ac5e3691 | 176 | Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); |
27c4ce72 | 177 | |
2ded1cc1 | 178 | return $obj; |
179 | } | |
180 | ||
181 | sub DESTROY { | |
182 | my $obj = shift; | |
4d8e9581 | 183 | $obj->erase('DESTROY') if $obj->{Erase}; |
2ded1cc1 | 184 | } |
185 | ||
186 | sub erase { | |
4d8e9581 | 187 | my ($obj, $action) = @_; |
2ded1cc1 | 188 | my $pkg = $obj->root(); |
189 | my ($stem, $leaf); | |
190 | ||
191 | no strict 'refs'; | |
27c4ce72 | 192 | $pkg = "main::$pkg\::"; # expand to full symbol table name |
2ded1cc1 | 193 | ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; |
194 | ||
195 | # The 'my $foo' is needed! Without it you get an | |
196 | # 'Attempt to free unreferenced scalar' warning! | |
197 | my $stem_symtab = *{$stem}{HASH}; | |
198 | ||
199 | #warn "erase($pkg) stem=$stem, leaf=$leaf"; | |
200 | #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n"; | |
27c4ce72 | 201 | # ", join(', ', %$stem_symtab),"\n"; |
2ded1cc1 | 202 | |
4d8e9581 | 203 | # delete $stem_symtab->{$leaf}; |
2ded1cc1 | 204 | |
4d8e9581 GS |
205 | my $leaf_glob = $stem_symtab->{$leaf}; |
206 | my $leaf_symtab = *{$leaf_glob}{HASH}; | |
2ded1cc1 | 207 | # warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; |
4d8e9581 | 208 | %$leaf_symtab = (); |
2ded1cc1 | 209 | #delete $leaf_symtab->{'__ANON__'}; |
210 | #delete $leaf_symtab->{'foo'}; | |
211 | #delete $leaf_symtab->{'main::'}; | |
212 | # my $foo = undef ${"$stem\::"}{"$leaf\::"}; | |
213 | ||
4d8e9581 GS |
214 | if ($action and $action eq 'DESTROY') { |
215 | delete $stem_symtab->{$leaf}; | |
216 | } else { | |
217 | $obj->share_from('main', $default_share); | |
218 | } | |
2ded1cc1 | 219 | 1; |
220 | } | |
221 | ||
222 | ||
223 | sub reinit { | |
224 | my $obj= shift; | |
225 | $obj->erase; | |
226 | $obj->share_redo; | |
227 | } | |
228 | ||
229 | sub root { | |
230 | my $obj = shift; | |
231 | croak("Safe root method now read-only") if @_; | |
232 | return $obj->{Root}; | |
233 | } | |
234 | ||
235 | ||
236 | sub mask { | |
237 | my $obj = shift; | |
238 | return $obj->{Mask} unless @_; | |
239 | $obj->deny_only(@_); | |
240 | } | |
241 | ||
242 | # v1 compatibility methods | |
243 | sub trap { shift->deny(@_) } | |
244 | sub untrap { shift->permit(@_) } | |
245 | ||
246 | sub deny { | |
247 | my $obj = shift; | |
248 | $obj->{Mask} |= opset(@_); | |
249 | } | |
250 | sub deny_only { | |
251 | my $obj = shift; | |
252 | $obj->{Mask} = opset(@_); | |
253 | } | |
254 | ||
255 | sub permit { | |
256 | my $obj = shift; | |
257 | # XXX needs testing | |
258 | $obj->{Mask} &= invert_opset opset(@_); | |
259 | } | |
260 | sub permit_only { | |
261 | my $obj = shift; | |
262 | $obj->{Mask} = invert_opset opset(@_); | |
263 | } | |
264 | ||
265 | ||
266 | sub dump_mask { | |
267 | my $obj = shift; | |
268 | print opset_to_hex($obj->{Mask}),"\n"; | |
269 | } | |
270 | ||
271 | ||
2ded1cc1 | 272 | sub share { |
273 | my($obj, @vars) = @_; | |
274 | $obj->share_from(scalar(caller), \@vars); | |
275 | } | |
276 | ||
27c4ce72 | 277 | |
2ded1cc1 | 278 | sub share_from { |
279 | my $obj = shift; | |
280 | my $pkg = shift; | |
281 | my $vars = shift; | |
282 | my $no_record = shift || 0; | |
50fc18f7 | 283 | my $root = $obj->root(); |
2ded1cc1 | 284 | croak("vars not an array ref") unless ref $vars eq 'ARRAY'; |
d00660f4 | 285 | no strict 'refs'; |
2ded1cc1 | 286 | # Check that 'from' package actually exists |
287 | croak("Package \"$pkg\" does not exist") | |
27c4ce72 | 288 | unless keys %{"$pkg\::"}; |
3fe9a6f1 | 289 | my $arg; |
2ded1cc1 | 290 | foreach $arg (@$vars) { |
27c4ce72 TB |
291 | # catch some $safe->share($var) errors: |
292 | my ($var, $type); | |
293 | $type = $1 if ($var = $arg) =~ s/^(\W)//; | |
294 | # warn "share_from $pkg $type $var"; | |
295 | for (1..2) { # assign twice to avoid any 'used once' warnings | |
296 | *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"} | |
297 | : ($type eq '&') ? \&{$pkg."::$var"} | |
298 | : ($type eq '$') ? \${$pkg."::$var"} | |
299 | : ($type eq '@') ? \@{$pkg."::$var"} | |
300 | : ($type eq '%') ? \%{$pkg."::$var"} | |
301 | : ($type eq '*') ? *{$pkg."::$var"} | |
302 | : croak(qq(Can't share "$type$var" of unknown type)); | |
303 | } | |
2ded1cc1 | 304 | } |
305 | $obj->share_record($pkg, $vars) unless $no_record or !$vars; | |
306 | } | |
307 | ||
27c4ce72 | 308 | |
2ded1cc1 | 309 | sub share_record { |
310 | my $obj = shift; | |
311 | my $pkg = shift; | |
312 | my $vars = shift; | |
313 | my $shares = \%{$obj->{Shares} ||= {}}; | |
314 | # Record shares using keys of $obj->{Shares}. See reinit. | |
315 | @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; | |
316 | } | |
27c4ce72 TB |
317 | |
318 | ||
2ded1cc1 | 319 | sub share_redo { |
320 | my $obj = shift; | |
321 | my $shares = \%{$obj->{Shares} ||= {}}; | |
d00660f4 | 322 | my($var, $pkg); |
2ded1cc1 | 323 | while(($var, $pkg) = each %$shares) { |
27c4ce72 TB |
324 | # warn "share_redo $pkg\:: $var"; |
325 | $obj->share_from($pkg, [ $var ], 1); | |
2ded1cc1 | 326 | } |
327 | } | |
27c4ce72 TB |
328 | |
329 | ||
2ded1cc1 | 330 | sub share_forget { |
331 | delete shift->{Shares}; | |
332 | } | |
333 | ||
27c4ce72 | 334 | |
2ded1cc1 | 335 | sub varglob { |
336 | my ($obj, $var) = @_; | |
337 | no strict 'refs'; | |
338 | return *{$obj->root()."::$var"}; | |
339 | } | |
340 | ||
16ac9e9a | 341 | sub _clean_stash { |
305aa7ae NC |
342 | my ($root, $saved_refs) = @_; |
343 | $saved_refs ||= []; | |
16ac9e9a | 344 | no strict 'refs'; |
305aa7ae NC |
345 | foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) { |
346 | push @$saved_refs, \*{$root.$hook}; | |
347 | delete ${$root}{$hook}; | |
348 | } | |
16ac9e9a RGS |
349 | |
350 | for (grep /::$/, keys %$root) { | |
305aa7ae NC |
351 | next if \%{$root.$_} eq \%$root; |
352 | _clean_stash($root.$_, $saved_refs); | |
16ac9e9a RGS |
353 | } |
354 | } | |
2ded1cc1 | 355 | |
356 | sub reval { | |
357 | my ($obj, $expr, $strict) = @_; | |
ac4ec33e RGS |
358 | die "Bad Safe object" unless $obj->isa('Safe'); |
359 | ||
50fc18f7 | 360 | my $root = $obj->{Root}; |
2ded1cc1 | 361 | |
576b33a1 | 362 | my $evalsub = lexless_anon_sub($root, $strict, $expr); |
27c4ce72 | 363 | # propagate context |
16ac9e9a | 364 | my $sg = sub_generation(); |
2e4af4cf FC |
365 | my @subret; |
366 | if (defined wantarray) { | |
367 | @subret = (wantarray) | |
16ac9e9a RGS |
368 | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub) |
369 | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); | |
2e4af4cf FC |
370 | } |
371 | else { | |
372 | Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); | |
373 | } | |
16ac9e9a | 374 | _clean_stash($root.'::') if $sg != sub_generation(); |
55454543 | 375 | $obj->wrap_code_refs_within(@subret); |
16ac9e9a | 376 | return (wantarray) ? @subret : $subret[0]; |
27c4ce72 | 377 | } |
576b33a1 | 378 | |
7650682f | 379 | my %OID; |
27c4ce72 TB |
380 | |
381 | sub wrap_code_refs_within { | |
382 | my $obj = shift; | |
383 | ||
7650682f | 384 | %OID = (); |
27c4ce72 TB |
385 | $obj->_find_code_refs('wrap_code_ref', @_); |
386 | } | |
387 | ||
388 | ||
389 | sub _find_code_refs { | |
390 | my $obj = shift; | |
391 | my $visitor = shift; | |
392 | ||
393 | for my $item (@_) { | |
394 | my $reftype = $item && reftype $item | |
395 | or next; | |
7650682f RGS |
396 | |
397 | # skip references already seen | |
398 | next if ++$OID{refaddr $item} > 1; | |
399 | ||
27c4ce72 TB |
400 | if ($reftype eq 'ARRAY') { |
401 | $obj->_find_code_refs($visitor, @$item); | |
402 | } | |
403 | elsif ($reftype eq 'HASH') { | |
404 | $obj->_find_code_refs($visitor, values %$item); | |
405 | } | |
406 | # XXX GLOBs? | |
407 | elsif ($reftype eq 'CODE') { | |
408 | $item = $obj->$visitor($item); | |
576b33a1 TB |
409 | } |
410 | } | |
27c4ce72 TB |
411 | } |
412 | ||
413 | ||
414 | sub wrap_code_ref { | |
415 | my ($obj, $sub) = @_; | |
ac4ec33e | 416 | die "Bad safe object" unless $obj->isa('Safe'); |
27c4ce72 TB |
417 | |
418 | # wrap code ref $sub with _safe_call_sv so that, when called, the | |
419 | # execution will happen with the compartment fully 'in effect'. | |
576b33a1 | 420 | |
27c4ce72 TB |
421 | croak "Not a CODE reference" |
422 | if reftype $sub ne 'CODE'; | |
423 | ||
424 | my $ret = sub { | |
425 | my @args = @_; # lexical to close over | |
426 | my $sub_with_args = sub { $sub->(@args) }; | |
427 | ||
428 | my @subret; | |
429 | my $error; | |
430 | do { | |
431 | local $@; # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR) | |
16ac9e9a | 432 | my $sg = sub_generation(); |
27c4ce72 TB |
433 | @subret = (wantarray) |
434 | ? Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args) | |
435 | : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args); | |
436 | $error = $@; | |
16ac9e9a | 437 | _clean_stash($obj->{Root}.'::') if $sg != sub_generation(); |
27c4ce72 TB |
438 | }; |
439 | if ($error) { # rethrow exception | |
440 | $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR | |
441 | die $error; | |
442 | } | |
443 | return (wantarray) ? @subret : $subret[0]; | |
444 | }; | |
445 | ||
446 | return $ret; | |
2ded1cc1 | 447 | } |
448 | ||
27c4ce72 | 449 | |
2ded1cc1 | 450 | sub rdo { |
451 | my ($obj, $file) = @_; | |
ac4ec33e RGS |
452 | die "Bad Safe object" unless $obj->isa('Safe'); |
453 | ||
50fc18f7 JH |
454 | my $root = $obj->{Root}; |
455 | ||
16ac9e9a | 456 | my $sg = sub_generation(); |
50fc18f7 | 457 | my $evalsub = eval |
27c4ce72 | 458 | sprintf('package %s; sub { @_ = (); do $file }', $root); |
16ac9e9a RGS |
459 | my @subret = (wantarray) |
460 | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub) | |
461 | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); | |
462 | _clean_stash($root.'::') if $sg != sub_generation(); | |
55454543 | 463 | $obj->wrap_code_refs_within(@subret); |
16ac9e9a | 464 | return (wantarray) ? @subret : $subret[0]; |
2ded1cc1 | 465 | } |
466 | ||
467 | ||
468 | 1; | |
469 | ||
3e92a254 | 470 | __END__ |
2ded1cc1 | 471 | |
472 | =head1 NAME | |
473 | ||
474 | Safe - Compile and execute code in restricted compartments | |
475 | ||
476 | =head1 SYNOPSIS | |
477 | ||
478 | use Safe; | |
479 | ||
480 | $compartment = new Safe; | |
481 | ||
482 | $compartment->permit(qw(time sort :browse)); | |
483 | ||
484 | $result = $compartment->reval($unsafe_code); | |
485 | ||
486 | =head1 DESCRIPTION | |
487 | ||
488 | The Safe extension module allows the creation of compartments | |
489 | in which perl code can be evaluated. Each compartment has | |
490 | ||
491 | =over 8 | |
492 | ||
493 | =item a new namespace | |
494 | ||
495 | The "root" of the namespace (i.e. "main::") is changed to a | |
496 | different package and code evaluated in the compartment cannot | |
497 | refer to variables outside this namespace, even with run-time | |
498 | glob lookups and other tricks. | |
499 | ||
500 | Code which is compiled outside the compartment can choose to place | |
501 | variables into (or I<share> variables with) the compartment's namespace | |
502 | and only that data will be visible to code evaluated in the | |
503 | compartment. | |
504 | ||
505 | By default, the only variables shared with compartments are the | |
506 | "underscore" variables $_ and @_ (and, technically, the less frequently | |
507 | used %_, the _ filehandle and so on). This is because otherwise perl | |
508 | operators which default to $_ will not work and neither will the | |
509 | assignment of arguments to @_ on subroutine entry. | |
510 | ||
511 | =item an operator mask | |
512 | ||
513 | Each compartment has an associated "operator mask". Recall that | |
514 | perl code is compiled into an internal format before execution. | |
515 | Evaluating perl code (e.g. via "eval" or "do 'file'") causes | |
516 | the code to be compiled into an internal format and then, | |
517 | provided there was no error in the compilation, executed. | |
f610777f A |
518 | Code evaluated in a compartment compiles subject to the |
519 | compartment's operator mask. Attempting to evaluate code in a | |
2ded1cc1 | 520 | compartment which contains a masked operator will cause the |
521 | compilation to fail with an error. The code will not be executed. | |
522 | ||
523 | The default operator mask for a newly created compartment is | |
524 | the ':default' optag. | |
525 | ||
86780939 | 526 | It is important that you read the L<Opcode> module documentation |
1fef88e7 | 527 | for more information, especially for detailed definitions of opnames, |
2ded1cc1 | 528 | optags and opsets. |
529 | ||
530 | Since it is only at the compilation stage that the operator mask | |
531 | applies, controlled access to potentially unsafe operations can | |
532 | be achieved by having a handle to a wrapper subroutine (written | |
533 | outside the compartment) placed into the compartment. For example, | |
534 | ||
535 | $cpt = new Safe; | |
536 | sub wrapper { | |
555bd962 | 537 | # vet arguments and perform potentially unsafe operations |
2ded1cc1 | 538 | } |
539 | $cpt->share('&wrapper'); | |
540 | ||
541 | =back | |
542 | ||
543 | ||
544 | =head1 WARNING | |
545 | ||
546 | The authors make B<no warranty>, implied or otherwise, about the | |
547 | suitability of this software for safety or security purposes. | |
548 | ||
549 | The authors shall not in any case be liable for special, incidental, | |
550 | consequential, indirect or other similar damages arising from the use | |
551 | of this software. | |
552 | ||
553 | Your mileage will vary. If in any doubt B<do not use it>. | |
554 | ||
555 | ||
27c4ce72 | 556 | =head1 METHODS |
2ded1cc1 | 557 | |
558 | To create a new compartment, use | |
559 | ||
560 | $cpt = new Safe; | |
561 | ||
562 | Optional argument is (NAMESPACE), where NAMESPACE is the root namespace | |
563 | to use for the compartment (defaults to "Safe::Root0", incremented for | |
564 | each new compartment). | |
565 | ||
566 | Note that version 1.00 of the Safe module supported a second optional | |
567 | parameter, MASK. That functionality has been withdrawn pending deeper | |
568 | consideration. Use the permit and deny methods described below. | |
569 | ||
570 | The following methods can then be used on the compartment | |
571 | object returned by the above constructor. The object argument | |
572 | is implicit in each case. | |
573 | ||
574 | ||
27c4ce72 | 575 | =head2 permit (OP, ...) |
2ded1cc1 | 576 | |
577 | Permit the listed operators to be used when compiling code in the | |
578 | compartment (in I<addition> to any operators already permitted). | |
579 | ||
86f9b3f5 RGS |
580 | You can list opcodes by names, or use a tag name; see |
581 | L<Opcode/"Predefined Opcode Tags">. | |
582 | ||
27c4ce72 | 583 | =head2 permit_only (OP, ...) |
2ded1cc1 | 584 | |
585 | Permit I<only> the listed operators to be used when compiling code in | |
586 | the compartment (I<no> other operators are permitted). | |
587 | ||
27c4ce72 | 588 | =head2 deny (OP, ...) |
2ded1cc1 | 589 | |
590 | Deny the listed operators from being used when compiling code in the | |
591 | compartment (other operators may still be permitted). | |
592 | ||
27c4ce72 | 593 | =head2 deny_only (OP, ...) |
2ded1cc1 | 594 | |
595 | Deny I<only> the listed operators from being used when compiling code | |
27c4ce72 TB |
596 | in the compartment (I<all> other operators will be permitted, so you probably |
597 | don't want to use this method). | |
2ded1cc1 | 598 | |
3d6c5fec | 599 | =head2 trap (OP, ...), untrap (OP, ...) |
2ded1cc1 | 600 | |
601 | The trap and untrap methods are synonyms for deny and permit | |
602 | respectfully. | |
603 | ||
27c4ce72 | 604 | =head2 share (NAME, ...) |
2ded1cc1 | 605 | |
606 | This shares the variable(s) in the argument list with the compartment. | |
5f944aa8 | 607 | This is almost identical to exporting variables using the L<Exporter> |
2ded1cc1 | 608 | module. |
609 | ||
5c3cfe29 SR |
610 | Each NAME must be the B<name> of a non-lexical variable, typically |
611 | with the leading type identifier included. A bareword is treated as a | |
612 | function name. | |
2ded1cc1 | 613 | |
614 | Examples of legal names are '$foo' for a scalar, '@foo' for an | |
615 | array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo' | |
616 | for a glob (i.e. all symbol table entries associated with "foo", | |
617 | including scalar, array, hash, sub and filehandle). | |
618 | ||
619 | Each NAME is assumed to be in the calling package. See share_from | |
27c4ce72 | 620 | for an alternative method (which C<share> uses). |
2ded1cc1 | 621 | |
27c4ce72 | 622 | =head2 share_from (PACKAGE, ARRAYREF) |
2ded1cc1 | 623 | |
624 | This method is similar to share() but allows you to explicitly name the | |
625 | package that symbols should be shared from. The symbol names (including | |
626 | type characters) are supplied as an array reference. | |
627 | ||
628 | $safe->share_from('main', [ '$foo', '%bar', 'func' ]); | |
629 | ||
27c4ce72 TB |
630 | Names can include package names, which are relative to the specified PACKAGE. |
631 | So these two calls have the same effect: | |
2ded1cc1 | 632 | |
27c4ce72 TB |
633 | $safe->share_from('Scalar::Util', [ 'reftype' ]); |
634 | $safe->share_from('main', [ 'Scalar::Util::reftype' ]); | |
635 | ||
636 | =head2 varglob (VARNAME) | |
2ded1cc1 | 637 | |
638 | This returns a glob reference for the symbol table entry of VARNAME in | |
639 | the package of the compartment. VARNAME must be the B<name> of a | |
27c4ce72 TB |
640 | variable without any leading type marker. For example: |
641 | ||
642 | ${$cpt->varglob('foo')} = "Hello world"; | |
643 | ||
644 | has the same effect as: | |
2ded1cc1 | 645 | |
646 | $cpt = new Safe 'Root'; | |
647 | $Root::foo = "Hello world"; | |
2ded1cc1 | 648 | |
27c4ce72 | 649 | but avoids the need to know $cpt's package name. |
2ded1cc1 | 650 | |
27c4ce72 TB |
651 | |
652 | =head2 reval (STRING, STRICT) | |
2ded1cc1 | 653 | |
654 | This evaluates STRING as perl code inside the compartment. | |
655 | ||
656 | The code can only see the compartment's namespace (as returned by the | |
657 | B<root> method). The compartment's root package appears to be the | |
658 | C<main::> package to the code inside the compartment. | |
659 | ||
660 | Any attempt by the code in STRING to use an operator which is not permitted | |
661 | by the compartment will cause an error (at run-time of the main program | |
662 | but at compile-time for the code in STRING). The error is of the form | |
cb77fdf0 | 663 | "'%s' trapped by operation mask...". |
2ded1cc1 | 664 | |
665 | If an operation is trapped in this way, then the code in STRING will | |
666 | not be executed. If such a trapped operation occurs or any other | |
667 | compile-time or return error, then $@ is set to the error message, just | |
668 | as with an eval(). | |
669 | ||
670 | If there is no error, then the method returns the value of the last | |
671 | expression evaluated, or a return statement may be used, just as with | |
672 | subroutines and B<eval()>. The context (list or scalar) is determined | |
673 | by the caller as usual. | |
674 | ||
167906a2 RGS |
675 | If the return value of reval() is (or contains) any code reference, |
676 | those code references are wrapped to be themselves executed always | |
677 | in the compartment. See L</wrap_code_refs_within>. | |
2ded1cc1 | 678 | |
fd8ebd06 RGS |
679 | The formerly undocumented STRICT argument sets strictness: if true |
680 | 'use strict;' is used, otherwise it uses 'no strict;'. B<Note>: if | |
681 | STRICT is omitted 'no strict;' is the default. | |
682 | ||
2ded1cc1 | 683 | Some points to note: |
684 | ||
685 | If the entereval op is permitted then the code can use eval "..." to | |
686 | 'hide' code which might use denied ops. This is not a major problem | |
687 | since when the code tries to execute the eval it will fail because the | |
688 | opmask is still in effect. However this technique would allow clever, | |
689 | and possibly harmful, code to 'probe' the boundaries of what is | |
690 | possible. | |
691 | ||
692 | Any string eval which is executed by code executing in a compartment, | |
693 | or by code called from code executing in a compartment, will be eval'd | |
694 | in the namespace of the compartment. This is potentially a serious | |
695 | problem. | |
696 | ||
697 | Consider a function foo() in package pkg compiled outside a compartment | |
698 | but shared with it. Assume the compartment has a root package called | |
1fef88e7 | 699 | 'Root'. If foo() contains an eval statement like eval '$foo = 1' then, |
2ded1cc1 | 700 | normally, $pkg::foo will be set to 1. If foo() is called from the |
701 | compartment (by whatever means) then instead of setting $pkg::foo, the | |
702 | eval will actually set $Root::pkg::foo. | |
703 | ||
704 | This can easily be demonstrated by using a module, such as the Socket | |
705 | module, which uses eval "..." as part of an AUTOLOAD function. You can | |
706 | 'use' the module outside the compartment and share an (autoloaded) | |
707 | function with the compartment. If an autoload is triggered by code in | |
708 | the compartment, or by any code anywhere that is called by any means | |
709 | from the compartment, then the eval in the Socket module's AUTOLOAD | |
710 | function happens in the namespace of the compartment. Any variables | |
711 | created or used by the eval'd code are now under the control of | |
712 | the code in the compartment. | |
713 | ||
714 | A similar effect applies to I<all> runtime symbol lookups in code | |
715 | called from a compartment but not compiled within it. | |
716 | ||
27c4ce72 | 717 | =head2 rdo (FILENAME) |
2ded1cc1 | 718 | |
719 | This evaluates the contents of file FILENAME inside the compartment. | |
720 | See above documentation on the B<reval> method for further details. | |
721 | ||
27c4ce72 | 722 | =head2 root (NAMESPACE) |
2ded1cc1 | 723 | |
724 | This method returns the name of the package that is the root of the | |
725 | compartment's namespace. | |
726 | ||
727 | Note that this behaviour differs from version 1.00 of the Safe module | |
728 | where the root module could be used to change the namespace. That | |
729 | functionality has been withdrawn pending deeper consideration. | |
730 | ||
27c4ce72 | 731 | =head2 mask (MASK) |
2ded1cc1 | 732 | |
733 | This is a get-or-set method for the compartment's operator mask. | |
734 | ||
735 | With no MASK argument present, it returns the current operator mask of | |
736 | the compartment. | |
737 | ||
738 | With the MASK argument present, it sets the operator mask for the | |
739 | compartment (equivalent to calling the deny_only method). | |
740 | ||
27c4ce72 TB |
741 | =head2 wrap_code_ref (CODEREF) |
742 | ||
743 | Returns a reference to an anonymous subroutine that, when executed, will call | |
744 | CODEREF with the Safe compartment 'in effect'. In other words, with the | |
745 | package namespace adjusted and the opmask enabled. | |
2ded1cc1 | 746 | |
27c4ce72 TB |
747 | Note that the opmask doesn't affect the already compiled code, it only affects |
748 | any I<further> compilation that the already compiled code may try to perform. | |
2ded1cc1 | 749 | |
27c4ce72 | 750 | This is particularly useful when applied to code references returned from reval(). |
2ded1cc1 | 751 | |
27c4ce72 TB |
752 | (It also provides a kind of workaround for RT#60374: "Safe.pm sort {} bug with |
753 | -Dusethreads". See L<http://rt.perl.org/rt3//Public/Bug/Display.html?id=60374> | |
754 | for I<much> more detail.) | |
755 | ||
756 | =head2 wrap_code_refs_within (...) | |
757 | ||
758 | Wraps any CODE references found within the arguments by replacing each with the | |
759 | result of calling L</wrap_code_ref> on the CODE reference. Any ARRAY or HASH | |
760 | references in the arguments are inspected recursively. | |
761 | ||
762 | Returns nothing. | |
763 | ||
764 | =head1 RISKS | |
765 | ||
766 | This section is just an outline of some of the things code in a compartment | |
767 | might do (intentionally or unintentionally) which can have an effect outside | |
768 | the compartment. | |
2ded1cc1 | 769 | |
770 | =over 8 | |
771 | ||
772 | =item Memory | |
773 | ||
774 | Consuming all (or nearly all) available memory. | |
775 | ||
776 | =item CPU | |
777 | ||
778 | Causing infinite loops etc. | |
779 | ||
780 | =item Snooping | |
781 | ||
782 | Copying private information out of your system. Even something as | |
783 | simple as your user name is of value to others. Much useful information | |
784 | could be gleaned from your environment variables for example. | |
785 | ||
786 | =item Signals | |
787 | ||
788 | Causing signals (especially SIGFPE and SIGALARM) to affect your process. | |
789 | ||
790 | Setting up a signal handler will need to be carefully considered | |
791 | and controlled. What mask is in effect when a signal handler | |
792 | gets called? If a user can get an imported function to get an | |
793 | exception and call the user's signal handler, does that user's | |
794 | restricted mask get re-instated before the handler is called? | |
795 | Does an imported handler get called with its original mask or | |
796 | the user's one? | |
797 | ||
798 | =item State Changes | |
799 | ||
800 | Ops such as chdir obviously effect the process as a whole and not just | |
801 | the code in the compartment. Ops such as rand and srand have a similar | |
802 | but more subtle effect. | |
803 | ||
804 | =back | |
805 | ||
27c4ce72 | 806 | =head1 AUTHOR |
2ded1cc1 | 807 | |
25ff8439 | 808 | Originally designed and implemented by Malcolm Beattie. |
2ded1cc1 | 809 | |
25ff8439 RGS |
810 | Reworked to use the Opcode module and other changes added by Tim Bunce. |
811 | ||
812 | Currently maintained by the Perl 5 Porters, <perl5-porters@perl.org>. | |
2ded1cc1 | 813 | |
814 | =cut | |
815 |