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