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