perl5.002beta3
[perl.git] / ext / Safe / Safe.pm
1 package Safe;
2 require Exporter;
3 require DynaLoader;
4 use Carp;
5 $VERSION = $VERSION = "1.00";
6 @ISA = qw(Exporter DynaLoader);
7 @EXPORT_OK = qw(op_mask ops_to_mask mask_to_ops opcode opname opdesc
8                 MAXO emptymask fullmask);
9
10 =head1 NAME
11
12 Safe - Safe extension module for Perl
13
14 =head1 DESCRIPTION
15
16 The Safe extension module allows the creation of compartments
17 in which perl code can be evaluated. Each compartment has
18
19 =over 8
20
21 =item a new namespace
22
23 The "root" of the namespace (i.e. "main::") is changed to a
24 different package and code evaluated in the compartment cannot
25 refer to variables outside this namespace, even with run-time
26 glob lookups and other tricks. Code which is compiled outside
27 the compartment can choose to place variables into (or share
28 variables with) the compartment's namespace and only that
29 data will be visible to code evaluated in the compartment.
30
31 By default, the only variables shared with compartments are the
32 "underscore" variables $_ and @_ (and, technically, the much less
33 frequently used %_, the _ filehandle and so on). This is because
34 otherwise perl operators which default to $_ will not work and neither
35 will the assignment of arguments to @_ on subroutine entry.
36
37 =item an operator mask
38
39 Each compartment has an associated "operator mask". Recall that
40 perl code is compiled into an internal format before execution.
41 Evaluating perl code (e.g. via "eval" or "do 'file'") causes
42 the code to be compiled into an internal format and then,
43 provided there was no error in the compilation, executed.
44 Code evaulated in a compartment compiles subject to the
45 compartment's operator mask. Attempting to evaulate code in a
46 compartment which contains a masked operator will cause the
47 compilation to fail with an error. The code will not be executed.
48
49 By default, the operator mask for a newly created compartment masks
50 out all operations which give "access to the system" in some sense.
51 This includes masking off operators such as I<system>, I<open>,
52 I<chown>, and I<shmget> but does not mask off operators such as
53 I<print>, I<sysread> and I<E<lt>HANDLE<gt>>. Those file operators
54 are allowed since for the code in the compartment to have access
55 to a filehandle, the code outside the compartment must have explicitly
56 placed the filehandle variable inside the compartment.
57
58 Since it is only at the compilation stage that the operator mask
59 applies, controlled access to potentially unsafe operations can
60 be achieved by having a handle to a wrapper subroutine (written
61 outside the compartment) placed into the compartment. For example,
62
63     $cpt = new Safe;
64     sub wrapper {
65         # vet arguments and perform potentially unsafe operations
66     }
67     $cpt->share('&wrapper');
68
69 =back
70
71 =head2 Operator masks
72
73 An operator mask exists at user-level as a string of bytes of length
74 MAXO, each of which is either 0x00 or 0x01. Here, MAXO is the number
75 of operators in the current version of perl. The subroutine MAXO()
76 (available for export by package Safe) returns the number of operators
77 in the current version of perl. Note that, unlike the beta versions of
78 the Safe extension, this is a reliable count of the number of
79 operators in the currently running perl executable. The presence of a
80 0x01 byte at offset B<n> of the string indicates that operator number
81 B<n> should be masked (i.e. disallowed).  The Safe extension makes
82 available routines for converting from operator names to operator
83 numbers (and I<vice versa>) and for converting from a list of operator
84 names to the corresponding mask (and I<vice versa>).
85
86 =head2 Methods in class Safe
87
88 To create a new compartment, use
89
90     $cpt = new Safe;
91
92 Optional arguments are (NAMESPACE, MASK), where
93
94 =over 8
95
96 =item NAMESPACE
97
98 is the root namespace to use for the compartment (defaults to
99 "Safe::Root000000000", auto-incremented for each new compartment); and
100
101 =item MASK
102
103 is the operator mask to use (defaults to a fairly restrictive set).
104
105 =back
106
107 The following methods can then be used on the compartment
108 object returned by the above constructor. The object argument
109 is implicit in each case.
110
111 =over 8
112
113 =item root (NAMESPACE)
114
115 This is a get-or-set method for the compartment's namespace. With the
116 NAMESPACE argument present, it sets the root namespace for the
117 compartment. With no NAMESPACE argument present, it returns the
118 current root namespace of the compartment.
119
120 =item mask (MASK)
121
122 This is a get-or-set method for the compartment's operator mask.
123 With the MASK argument present, it sets the operator mask for the
124 compartment. With no MASK argument present, it returns the
125 current operator mask of the compartment.
126
127 =item trap (OP, ...)
128
129 This sets bits in the compartment's operator mask corresponding
130 to each operator named in the list of arguments. Each OP can be
131 either the name of an operation or its number. See opcode.h or
132 opcode.pl in the main perl distribution for a canonical list of
133 operator names.
134
135 =item untrap (OP, ...)
136
137 This resets bits in the compartment's operator mask corresponding
138 to each operator named in the list of arguments. Each OP can be
139 either the name of an operation or its number. See opcode.h or
140 opcode.pl in the main perl distribution for a canonical list of
141 operator names.
142
143 =item share (VARNAME, ...)
144
145 This shares the variable(s) in the argument list with the compartment.
146 Each VARNAME must be the B<name> of a variable with a leading type
147 identifier included. Examples of legal variable names are '$foo' for
148 a scalar, '@foo' for an array, '%foo' for a hash, '&foo' for a
149 subroutine and '*foo' for a glob (i.e. all symbol table entries
150 associated with "foo", including scalar, array, hash, sub and filehandle).
151
152 =item varglob (VARNAME)
153
154 This returns a glob for the symbol table entry of VARNAME in the package
155 of the compartment. VARNAME must be the B<name> of a variable without
156 any leading type marker. For example,
157
158     $cpt = new Safe 'Root';
159     $Root::foo = "Hello world";
160     # Equivalent version which doesn't need to know $cpt's package name:
161     ${$cpt->varglob('foo')} = "Hello world";
162
163
164 =item reval (STRING)
165
166 This evaluates STRING as perl code inside the compartment. The code
167 can only see the compartment's namespace (as returned by the B<root>
168 method). Any attempt by code in STRING to use an operator which is
169 in the compartment's mask will cause an error (at run-time of the
170 main program but at compile-time for the code in STRING). The error
171 is of the form "%s trapped by operation mask operation...". If an
172 operation is trapped in this way, then the code in STRING will not
173 be executed. If such a trapped operation occurs or any other
174 compile-time or return error, then $@ is set to the error message,
175 just as with an eval(). If there is no error, then the method returns
176 the value of the last expression evaluated, or a return statement may
177 be used, just as with subroutines and B<eval()>. Note that this
178 behaviour differs from the beta distribution of the Safe extension
179 where earlier versions of perl made it hard to mimic the return
180 behaviour of the eval() command.
181
182 =item rdo (FILENAME)
183
184 This evaluates the contents of file FILENAME inside the compartment.
185 See above documentation on the B<reval> method for further details.
186
187 =back
188
189 =head2 Subroutines in package Safe
190
191 The Safe package contains subroutines for manipulating operator
192 names and operator masks. All are available for export by the package.
193 The canonical list of operator names is the contents of the array
194 op_name defined and initialised in file F<opcode.h> of the Perl
195 source distribution.
196
197 =over 8
198
199 =item ops_to_mask (OP, ...)
200
201 This takes a list of operator names and returns an operator mask
202 with precisely those operators masked.
203
204 =item mask_to_ops (MASK)
205
206 This takes an operator mask and returns a list of operator names
207 corresponding to those operators which are masked in MASK.
208
209 =item opcode (OP, ...)
210
211 This takes a list of operator names and returns the corresponding
212 list of opcodes (which can then be used as byte offsets into a mask).
213
214 =item opname (OP, ...)
215
216 This takes a list of opcodes and returns the corresponding list of
217 operator names.
218
219 =item fullmask
220
221 This just returns a mask which has all operators masked.
222 It returns the string "\1" x MAXO().
223
224 =item emptymask
225
226 This just returns a mask which has all operators unmasked.
227 It returns the string "\0" x MAXO(). This is useful if you
228 want a compartment to make use of the namespace protection
229 features but do not want the default restrictive mask.
230
231 =item MAXO
232
233 This returns the number of operators (and hence the length of an
234 operator mask). Note that, unlike the beta distributions of the
235 Safe extension, this is derived from a genuine integer variable
236 in the perl executable and not from a preprocessor constant.
237 This means that the Safe extension is more robust in the presence
238 of mismatched versions of the perl executable and the Safe extension.
239
240 =item op_mask
241
242 This returns the operator mask which is actually in effect at the
243 time the invocation to the subroutine is compiled. In general,
244 this is probably not terribly useful.
245
246 =back
247
248 =head2 AUTHOR
249
250 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
251
252 =cut
253
254 my $default_root = 'Root000000000';
255
256 my $default_mask;
257
258 sub new {
259     my($class, $root, $mask) = @_;
260     my $obj = {};
261     bless $obj, $class;
262     $obj->root(defined($root) ? $root : ("Safe::".$default_root++));
263     $obj->mask(defined($mask) ? $mask : $default_mask);
264     # We must share $_ and @_ with the compartment or else ops such
265     # as split, length and so on won't default to $_ properly, nor
266     # will passing argument to subroutines work (via @_). In fact,
267     # for reasons I don't completely understand, we need to share
268     # the whole glob *_ rather than $_ and @_ separately, otherwise
269     # @_ in non default packages within the compartment don't work.
270     *{$obj->root . "::_"} = *_;
271     return $obj;
272 }
273
274 sub DESTROY {
275     my($obj) = @_;
276     my $root = $obj->root();
277     if ($root =~ /^Safe::(Root\d+)$/){
278         $root = $1;
279         delete $ {"Safe::"}{"$root\::"};
280     }
281 }
282
283 sub root {
284     my $obj = shift;
285     if (@_) {
286         $obj->{Root} = $_[0];
287     } else {
288         return $obj->{Root};
289     }
290 }
291
292 sub mask {
293     my $obj = shift;
294     if (@_) {
295         $obj->{Mask} = verify_mask($_[0]);
296     } else {
297         return $obj->{Mask};
298     }
299 }
300
301 sub verify_mask {
302     my($mask) = @_;
303     if (length($mask) != MAXO() || $mask !~ /^[\0\1]+$/) {
304         croak("argument is not a mask");
305     }
306     return $mask;
307 }
308
309 sub trap {
310     my $obj = shift;
311     $obj->setmaskel("\1", @_);
312 }
313
314 sub untrap {
315     my $obj = shift;
316     $obj->setmaskel("\0", @_);
317 }
318
319 sub emptymask { "\0" x MAXO() }
320 sub fullmask { "\1" x MAXO() }
321
322 sub setmaskel {
323     my $obj = shift;
324     my $val = shift;
325     croak("bad value for mask element") unless $val eq "\0" || $val eq "\1";
326     my $maskref = \$obj->{Mask};
327     my ($op, $opcode);
328     foreach $op (@_) {
329         $opcode = ($op =~ /^\d/) ? $op : opcode($op);
330         substr($$maskref, $opcode, 1) = $val;
331     }
332 }
333
334 sub share {
335     my $obj = shift;
336     my $root = $obj->root();
337     my ($arg);
338     foreach $arg (@_) {
339         my $var;
340         ($var = $arg) =~ s/^(.)//;
341         my $caller = caller;
342         *{$root."::$var"} = ($1 eq '$') ? \${$caller."::$var"}
343                           : ($1 eq '@') ? \@{$caller."::$var"}
344                           : ($1 eq '%') ? \%{$caller."::$var"}
345                           : ($1 eq '*') ? *{$caller."::$var"}
346                           : ($1 eq '&') ? \&{$caller."::$var"}
347                           : croak(qq(No such variable type for "$1$var"));
348     }
349 }
350
351 sub varglob {
352     my ($obj, $var) = @_;
353     return *{$obj->root()."::$var"};
354 }
355
356 sub reval {
357     my ($obj, $expr) = @_;
358     my $root = $obj->{Root};
359     my $mask = $obj->{Mask};
360     verify_mask($mask);
361
362     my $evalsub = eval sprintf(<<'EOT', $root);
363         package %s;
364         sub {
365             eval $expr;
366         }
367 EOT
368     return safe_call_sv($root, $mask, $evalsub);
369 }
370
371 sub rdo {
372     my ($obj, $file) = @_;
373     my $root = $obj->{Root};
374     my $mask = $obj->{Mask};
375     verify_mask($mask);
376
377     $file =~ s/"/\\"/g; # just in case the filename contains any double quotes
378     my $evalsub = eval sprintf(<<'EOT', $root, $file);
379         package %s;
380         sub {
381             do "%s";
382         }
383 EOT
384     return safe_call_sv($root, $mask, $evalsub);
385 }
386
387 bootstrap Safe;
388
389 $default_mask = fullmask;
390 my $name;
391 while (defined ($name = <DATA>)) {
392     chomp $name;
393     next if $name =~ /^#/;
394     my $code = opcode($name);
395     substr($default_mask, $code, 1) = "\0";
396 }
397
398 1;
399
400 __DATA__
401 null
402 stub
403 scalar
404 pushmark
405 wantarray
406 const
407 gvsv
408 gv
409 gelem
410 padsv
411 padav
412 padhv
413 padany
414 pushre
415 rv2gv
416 rv2sv
417 av2arylen
418 rv2cv
419 anoncode
420 prototype
421 refgen
422 srefgen
423 ref
424 bless
425 glob
426 readline
427 rcatline
428 regcmaybe
429 regcomp
430 match
431 subst
432 substcont
433 trans
434 sassign
435 aassign
436 chop
437 schop
438 chomp
439 schomp
440 defined
441 undef
442 study
443 pos
444 preinc
445 i_preinc
446 predec
447 i_predec
448 postinc
449 i_postinc
450 postdec
451 i_postdec
452 pow
453 multiply
454 i_multiply
455 divide
456 i_divide
457 modulo
458 i_modulo
459 repeat
460 add
461 i_add
462 subtract
463 i_subtract
464 concat
465 stringify
466 left_shift
467 right_shift
468 lt
469 i_lt
470 gt
471 i_gt
472 le
473 i_le
474 ge
475 i_ge
476 eq
477 i_eq
478 ne
479 i_ne
480 ncmp
481 i_ncmp
482 slt
483 sgt
484 sle
485 sge
486 seq
487 sne
488 scmp
489 bit_and
490 bit_xor
491 bit_or
492 negate
493 i_negate
494 not
495 complement
496 atan2
497 sin
498 cos
499 rand
500 srand
501 exp
502 log
503 sqrt
504 int
505 hex
506 oct
507 abs
508 length
509 substr
510 vec
511 index
512 rindex
513 sprintf
514 formline
515 ord
516 chr
517 crypt
518 ucfirst
519 lcfirst
520 uc
521 lc
522 quotemeta
523 rv2av
524 aelemfast
525 aelem
526 aslice
527 each
528 values
529 keys
530 delete
531 exists
532 rv2hv
533 helem
534 hslice
535 split
536 join
537 list
538 lslice
539 anonlist
540 anonhash
541 splice
542 push
543 pop
544 shift
545 unshift
546 reverse
547 grepstart
548 grepwhile
549 mapstart
550 mapwhile
551 range
552 flip
553 flop
554 and
555 or
556 xor
557 cond_expr
558 andassign
559 orassign
560 method
561 entersub
562 leavesub
563 caller
564 warn
565 die
566 reset
567 lineseq
568 nextstate
569 dbstate
570 unstack
571 enter
572 leave
573 scope
574 enteriter
575 iter
576 enterloop
577 leaveloop
578 return
579 last
580 next
581 redo
582 goto
583 close
584 fileno
585 tie
586 untie
587 dbmopen
588 dbmclose
589 sselect
590 select
591 getc
592 read
593 enterwrite
594 leavewrite
595 prtf
596 print
597 sysread
598 syswrite
599 send
600 recv
601 eof
602 tell
603 seek
604 truncate
605 fcntl
606 ioctl
607 sockpair
608 bind
609 connect
610 listen
611 accept
612 shutdown
613 gsockopt
614 ssockopt
615 getsockname
616 ftrwrite
617 ftsvtx
618 open_dir
619 readdir
620 telldir
621 seekdir
622 rewinddir
623 kill
624 getppid
625 getpgrp
626 setpgrp
627 getpriority
628 setpriority
629 time
630 tms
631 localtime
632 alarm
633 dofile
634 entereval
635 leaveeval
636 entertry
637 leavetry
638 ghbyname
639 ghbyaddr
640 ghostent
641 gnbyname
642 gnbyaddr
643 gnetent
644 gpbyname
645 gpbynumber
646 gprotoent
647 gsbyname
648 gsbyport
649 gservent
650 shostent
651 snetent
652 sprotoent
653 sservent
654 ehostent
655 enetent
656 eprotoent
657 eservent
658 gpwnam
659 gpwuid
660 gpwent
661 spwent
662 epwent
663 ggrnam
664 ggrgid
665 ggrent
666 sgrent
667 egrent