| Commit | Line | Data |
|---|
| cb1a09d0 |
1 | package Safe; |
| 73c78b0a |
2 | |
| 3 | use vars qw($VERSION @ISA @EXPORT_OK); |
| 4 | |
| cb1a09d0 |
5 | require Exporter; |
| 6 | require DynaLoader; |
| 7 | use Carp; |
| 73c78b0a |
8 | $VERSION = "1.00"; |
| cb1a09d0 |
9 | @ISA = qw(Exporter DynaLoader); |
| c07a80fd |
10 | @EXPORT_OK = qw(op_mask ops_to_mask mask_to_ops opcode opname opdesc |
| cb1a09d0 |
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 | |
| 8bb1f2cf |
257 | my $default_root = 'Root000000000'; |
| 258 | |
| 259 | my $default_mask; |
| cb1a09d0 |
260 | |
| 261 | sub new { |
| 262 | my($class, $root, $mask) = @_; |
| 263 | my $obj = {}; |
| 264 | bless $obj, $class; |
| 8bb1f2cf |
265 | $obj->root(defined($root) ? $root : ("Safe::".$default_root++)); |
| cb1a09d0 |
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 | |
| 8bb1f2cf |
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 | |
| cb1a09d0 |
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 | |
| 73c78b0a |
390 | bootstrap Safe $VERSION; |
| cb1a09d0 |
391 | |
| c07a80fd |
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 | } |
| cb1a09d0 |
400 | |
| 401 | 1; |
| c07a80fd |
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 |
projects / p5sagit/p5-mst-13.2.git / blame