ext/Safe/Safe.pm

   1 package Safe;
   2 require Exporter;
   3 require DynaLoader;
   4 use Carp;
   5 @ISA = qw(Exporter DynaLoader);
   6 @EXPORT_OK = qw(op_mask ops_to_mask mask_to_ops opcode opname
   7                 MAXO emptymask fullmask);
   8
   9 =head1 NAME
  10
  11 Safe - Safe extension module for Perl
  12
  13 =head1 DESCRIPTION
  14
  15 The Safe extension module allows the creation of compartments
  16 in which perl code can be evaluated. Each compartment has
  17
  18 =over 8
  19
  20 =item a new namespace
  21
  22 The "root" of the namespace (i.e. "main::") is changed to a
  23 different package and code evaluated in the compartment cannot
  24 refer to variables outside this namespace, even with run-time
  25 glob lookups and other tricks. Code which is compiled outside
  26 the compartment can choose to place variables into (or share
  27 variables with) the compartment's namespace and only that
  28 data will be visible to code evaluated in the compartment.
  29
  30 By default, the only variables shared with compartments are the
  31 "underscore" variables $_ and @_ (and, technically, the much less
  32 frequently used %_, the _ filehandle and so on). This is because
  33 otherwise perl operators which default to $_ will not work and neither
  34 will the assignment of arguments to @_ on subroutine entry.
  35
  36 =item an operator mask
  37
  38 Each compartment has an associated "operator mask". Recall that
  39 perl code is compiled into an internal format before execution.
  40 Evaluating perl code (e.g. via "eval" or "do 'file'") causes
  41 the code to be compiled into an internal format and then,
  42 provided there was no error in the compilation, executed.
  43 Code evaulated in a compartment compiles subject to the
  44 compartment's operator mask. Attempting to evaulate code in a
  45 compartment which contains a masked operator will cause the
  46 compilation to fail with an error. The code will not be executed.
  47
  48 By default, the operator mask for a newly created compartment masks
  49 out all operations which give "access to the system" in some sense.
  50 This includes masking off operators such as I<system>, I<open>,
  51 I<chown>, and I<shmget> but does not mask off operators such as
  52 I<print>, I<sysread> and I<E<lt>HANDLE<gt>>. Those file operators
  53 are allowed since for the code in the compartment to have access
  54 to a filehandle, the code outside the compartment must have explicitly
  55 placed the filehandle variable inside the compartment.
  56
  57 Since it is only at the compilation stage that the operator mask
  58 applies, controlled access to potentially unsafe operations can
  59 be achieved by having a handle to a wrapper subroutine (written
  60 outside the compartment) placed into the compartment. For example,
  61
  62     $cpt = new Safe;
  63     sub wrapper {
  64         # vet arguments and perform potentially unsafe operations
  65     }
  66     $cpt->share('&wrapper');
  67
  68 =back
  69
  70 =head2 Operator masks
  71
  72 An operator mask exists at user-level as a string of bytes of length
  73 MAXO, each of which is either 0x00 or 0x01. Here, MAXO is the number
  74 of operators in the current version of perl. The subroutine MAXO()
  75 (available for export by package Safe) returns the number of operators
  76 in the current version of perl. Note that, unlike the beta versions of
  77 the Safe extension, this is a reliable count of the number of
  78 operators in the currently running perl executable. The presence of a
  79 0x01 byte at offset B<n> of the string indicates that operator number
  80 B<n> should be masked (i.e. disallowed).  The Safe extension makes
  81 available routines for converting from operator names to operator
  82 numbers (and I<vice versa>) and for converting from a list of operator
  83 names to the corresponding mask (and I<vice versa>).
  84
  85 =head2 Methods in class Safe
  86
  87 To create a new compartment, use
  88
  89     $cpt = new Safe;
  90
  91 Optional arguments are (NAMESPACE, MASK), where
  92
  93 =over 8
  94
  95 =item NAMESPACE
  96
  97 is the root namespace to use for the compartment (defaults to
  98 "Safe::Root000000000", auto-incremented for each new compartment); and
  99
 100 =item MASK
 101
 102 is the operator mask to use (defaults to a fairly restrictive set).
 103
 104 =back
 105
 106 The following methods can then be used on the compartment
 107 object returned by the above constructor. The object argument
 108 is implicit in each case.
 109
 110 =over 8
 111
 112 =item root (NAMESPACE)
 113
 114 This is a get-or-set method for the compartment's namespace. With the
 115 NAMESPACE argument present, it sets the root namespace for the
 116 compartment. With no NAMESPACE argument present, it returns the
 117 current root namespace of the compartment.
 118
 119 =item mask (MASK)
 120
 121 This is a get-or-set method for the compartment's operator mask.
 122 With the MASK argument present, it sets the operator mask for the
 123 compartment. With no MASK argument present, it returns the
 124 current operator mask of the compartment.
 125
 126 =item trap (OP, ...)
 127
 128 This sets bits in the compartment's operator mask corresponding
 129 to each operator named in the list of arguments. Each OP can be
 130 either the name of an operation or its number. See opcode.h or
 131 opcode.pl in the main perl distribution for a canonical list of
 132 operator names.
 133
 134 =item untrap (OP, ...)
 135
 136 This resets bits in the compartment's operator mask corresponding
 137 to each operator named in the list of arguments. Each OP can be
 138 either the name of an operation or its number. See opcode.h or
 139 opcode.pl in the main perl distribution for a canonical list of
 140 operator names.
 141
 142 =item share (VARNAME, ...)
 143
 144 This shares the variable(s) in the argument list with the compartment.
 145 Each VARNAME must be the B<name> of a variable with a leading type
 146 identifier included. Examples of legal variable names are '$foo' for
 147 a scalar, '@foo' for an array, '%foo' for a hash, '&foo' for a
 148 subroutine and '*foo' for a glob (i.e. all symbol table entries
 149 associated with "foo", including scalar, array, hash, sub and filehandle).
 150
 151 =item varglob (VARNAME)
 152
 153 This returns a glob for the symbol table entry of VARNAME in the package
 154 of the compartment. VARNAME must be the B<name> of a variable without
 155 any leading type marker. For example,
 156
 157     $cpt = new Safe 'Root';
 158     $Root::foo = "Hello world";
 159     # Equivalent version which doesn't need to know $cpt's package name:
 160     ${$cpt->varglob('foo')} = "Hello world";
 161
 162
 163 =item reval (STRING)
 164
 165 This evaluates STRING as perl code inside the compartment. The code
 166 can only see the compartment's namespace (as returned by the B<root>
 167 method). Any attempt by code in STRING to use an operator which is
 168 in the compartment's mask will cause an error (at run-time of the
 169 main program but at compile-time for the code in STRING). The error
 170 is of the form "%s trapped by operation mask operation...". If an
 171 operation is trapped in this way, then the code in STRING will not
 172 be executed. If such a trapped operation occurs or any other
 173 compile-time or return error, then $@ is set to the error message,
 174 just as with an eval(). If there is no error, then the method returns
 175 the value of the last expression evaluated, or a return statement may
 176 be used, just as with subroutines and B<eval()>. Note that this
 177 behaviour differs from the beta distribution of the Safe extension
 178 where earlier versions of perl made it hard to mimic the return
 179 behaviour of the eval() command.
 180
 181 =item rdo (FILENAME)
 182
 183 This evaluates the contents of file FILENAME inside the compartment.
 184 See above documentation on the B<reval> method for further details.
 185
 186 =back
 187
 188 =head2 Subroutines in package Safe
 189
 190 The Safe package contains subroutines for manipulating operator
 191 names and operator masks. All are available for export by the package.
 192 The canonical list of operator names is the contents of the array
 193 op_name defined and initialised in file F<opcode.h> of the Perl
 194 source distribution.
 195
 196 =over 8
 197
 198 =item ops_to_mask (OP, ...)
 199
 200 This takes a list of operator names and returns an operator mask
 201 with precisely those operators masked.
 202
 203 =item mask_to_ops (MASK)
 204
 205 This takes an operator mask and returns a list of operator names
 206 corresponding to those operators which are masked in MASK.
 207
 208 =item opcode (OP, ...)
 209
 210 This takes a list of operator names and returns the corresponding
 211 list of opcodes (which can then be used as byte offsets into a mask).
 212
 213 =item opname (OP, ...)
 214
 215 This takes a list of opcodes and returns the corresponding list of
 216 operator names.
 217
 218 =item fullmask
 219
 220 This just returns a mask which has all operators masked.
 221 It returns the string "\1" x MAXO().
 222
 223 =item emptymask
 224
 225 This just returns a mask which has all operators unmasked.
 226 It returns the string "\0" x MAXO(). This is useful if you
 227 want a compartment to make use of the namespace protection
 228 features but do not want the default restrictive mask.
 229
 230 =item MAXO
 231
 232 This returns the number of operators (and hence the length of an
 233 operator mask). Note that, unlike the beta distributions of the
 234 Safe extension, this is derived from a genuine integer variable
 235 in the perl executable and not from a preprocessor constant.
 236 This means that the Safe extension is more robust in the presence
 237 of mismatched versions of the perl executable and the Safe extension.
 238
 239 =item op_mask
 240
 241 This returns the operator mask which is actually in effect at the
 242 time the invocation to the subroutine is compiled. In general,
 243 this is probably not terribly useful.
 244
 245 =back
 246
 247 =head2 AUTHOR
 248
 249 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 250
 251 =cut
 252
 253 my $safes = "1111111111111111111111101111111111111111111111111111111111111111"
 254           . "1111111111111111111111111111111111111111111111111111111111111111"
 255           . "1111110011111111111011111111111111111111111111111111111101001010"
 256           . "0110111111111111111111110011111111100001000000000000000000000100"
 257           . "0000000000000111110000001111111110100000000000001111111111111111"
 258           . "11111111111111111110";
 259
 260 my $default_root = 'Safe::Root000000000';
 261
 262 sub new {
 263     my($class, $root, $mask) = @_;
 264     my $obj = {};
 265     bless $obj, $class;
 266     $obj->root(defined($root) ? $root : $default_root++);
 267     $obj->mask(defined($mask) ? $mask : $default_mask);
 268     # We must share $_ and @_ with the compartment or else ops such
 269     # as split, length and so on won't default to $_ properly, nor
 270     # will passing argument to subroutines work (via @_). In fact,
 271     # for reasons I don't completely understand, we need to share
 272     # the whole glob *_ rather than $_ and @_ separately, otherwise
 273     # @_ in non default packages within the compartment don't work.
 274     *{$obj->root . "::_"} = *_;
 275     return $obj;
 276 }
 277
 278 sub root {
 279     my $obj = shift;
 280     if (@_) {
 281         $obj->{Root} = $_[0];
 282     } else {
 283         return $obj->{Root};
 284     }
 285 }
 286
 287 sub mask {
 288     my $obj = shift;
 289     if (@_) {
 290         $obj->{Mask} = verify_mask($_[0]);
 291     } else {
 292         return $obj->{Mask};
 293     }
 294 }
 295
 296 sub verify_mask {
 297     my($mask) = @_;
 298     if (length($mask) != MAXO() || $mask !~ /^[\0\1]+$/) {
 299         croak("argument is not a mask");
 300     }
 301     return $mask;
 302 }
 303
 304 sub trap {
 305     my $obj = shift;
 306     $obj->setmaskel("\1", @_);
 307 }
 308
 309 sub untrap {
 310     my $obj = shift;
 311     $obj->setmaskel("\0", @_);
 312 }
 313
 314 sub emptymask { "\0" x MAXO() }
 315 sub fullmask { "\1" x MAXO() }
 316
 317 sub setmaskel {
 318     my $obj = shift;
 319     my $val = shift;
 320     croak("bad value for mask element") unless $val eq "\0" || $val eq "\1";
 321     my $maskref = \$obj->{Mask};
 322     my ($op, $opcode);
 323     foreach $op (@_) {
 324         $opcode = ($op =~ /^\d/) ? $op : opcode($op);
 325         substr($$maskref, $opcode, 1) = $val;
 326     }
 327 }
 328
 329 sub share {
 330     my $obj = shift;
 331     my $root = $obj->root();
 332     my ($arg);
 333     foreach $arg (@_) {
 334         my $var;
 335         ($var = $arg) =~ s/^(.)//;
 336         my $caller = caller;
 337         *{$root."::$var"} = ($1 eq '$') ? \${$caller."::$var"}
 338                           : ($1 eq '@') ? \@{$caller."::$var"}
 339                           : ($1 eq '%') ? \%{$caller."::$var"}
 340                           : ($1 eq '*') ? *{$caller."::$var"}
 341                           : ($1 eq '&') ? \&{$caller."::$var"}
 342                           : croak(qq(No such variable type for "$1$var"));
 343     }
 344 }
 345
 346 sub varglob {
 347     my ($obj, $var) = @_;
 348     return *{$obj->root()."::$var"};
 349 }
 350
 351 sub reval {
 352     my ($obj, $expr) = @_;
 353     my $root = $obj->{Root};
 354     my $mask = $obj->{Mask};
 355     verify_mask($mask);
 356
 357     my $evalsub = eval sprintf(<<'EOT', $root);
 358         package %s;
 359         sub {
 360             eval $expr;
 361         }
 362 EOT
 363     return safe_call_sv($root, $mask, $evalsub);
 364 }
 365
 366 sub rdo {
 367     my ($obj, $file) = @_;
 368     my $root = $obj->{Root};
 369     my $mask = $obj->{Mask};
 370     verify_mask($mask);
 371
 372     $file =~ s/"/\\"/g; # just in case the filename contains any double quotes
 373     my $evalsub = eval sprintf(<<'EOT', $root, $file);
 374         package %s;
 375         sub {
 376             do "%s";
 377         }
 378 EOT
 379     return safe_call_sv($root, $mask, $evalsub);
 380 }
 381
 382 bootstrap Safe;
 383
 384 $safes .= "0" x (MAXO() - length($safes));
 385 ($default_mask = $safes) =~ tr/01/\1\0/;        # invert for mask
 386
 387 1;