Parent Directory
| 
Revision Log
change calls to use Safe.pm to use WWSafe.pm closed security hole in ProblemSetDetail.pm other small improvements brought in from gage_dev
1 package WWSafe; 2 3 use 5.003_11; 4 use strict; 5 6 $Safe::VERSION = "2.16"; 7 8 # *** Don't declare any lexicals above this point *** 9 # 10 # This function should return a closure which contains an eval that can't 11 # see any lexicals in scope (apart from __ExPr__ which is unavoidable) 12 13 sub lexless_anon_sub { 14 # $_[0] is package; 15 # $_[1] is strict flag; 16 my $__ExPr__ = $_[2]; # must be a lexical to create the closure that 17 # can be used to pass the value into the safe 18 # world 19 20 # Create anon sub ref in root of compartment. 21 # Uses a closure (on $__ExPr__) to pass in the code to be executed. 22 # (eval on one line to keep line numbers as expected by caller) 23 eval sprintf 24 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }', 25 $_[0], $_[1] ? 'use' : 'no'; 26 } 27 28 use Carp; 29 BEGIN { eval q{ 30 use Carp::Heavy; 31 } } 32 33 use Opcode 1.01, qw( 34 opset opset_to_ops opmask_add 35 empty_opset full_opset invert_opset verify_opset 36 opdesc opcodes opmask define_optag opset_to_hex 37 ); 38 39 *ops_to_opset = \&opset; # Temporary alias for old Penguins 40 41 42 my $default_root = 0; 43 # share *_ and functions defined in universal.c 44 # Don't share stuff like *UNIVERSAL:: otherwise code from the 45 # compartment can 0wn functions in UNIVERSAL 46 my $default_share = [qw[ 47 *_ 48 &PerlIO::get_layers 49 &UNIVERSAL::isa 50 &UNIVERSAL::can 51 &UNIVERSAL::VERSION 52 &utf8::is_utf8 53 &utf8::valid 54 &utf8::encode 55 &utf8::decode 56 &utf8::upgrade 57 &utf8::downgrade 58 &utf8::native_to_unicode 59 &utf8::unicode_to_native 60 ], ($] >= 5.008001 && qw[ 61 &Regexp::DESTROY 62 ]), ($] >= 5.010 && qw[ 63 &re::is_regexp 64 &re::regname 65 &re::regnames 66 &re::regnames_count 67 &Tie::Hash::NamedCapture::FETCH 68 &Tie::Hash::NamedCapture::STORE 69 &Tie::Hash::NamedCapture::DELETE 70 &Tie::Hash::NamedCapture::CLEAR 71 &Tie::Hash::NamedCapture::EXISTS 72 &Tie::Hash::NamedCapture::FIRSTKEY 73 &Tie::Hash::NamedCapture::NEXTKEY 74 &Tie::Hash::NamedCapture::SCALAR 75 &Tie::Hash::NamedCapture::flags 76 &UNIVERSAL::DOES 77 &version::() 78 &version::new 79 &version::("" 80 &version::stringify 81 &version::(0+ 82 &version::numify 83 &version::normal 84 &version::(cmp 85 &version::(<=> 86 &version::vcmp 87 &version::(bool 88 &version::boolean 89 &version::(nomethod 90 &version::noop 91 &version::is_alpha 92 &version::qv 93 ]), ($] >= 5.011 && qw[ 94 &re::regexp_pattern 95 ])]; 96 97 sub new { 98 my($class, $root, $mask) = @_; 99 my $obj = {}; 100 bless $obj, $class; 101 102 if (defined($root)) { 103 croak "Can't use \"$root\" as root name" 104 if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/; 105 $obj->{Root} = $root; 106 $obj->{Erase} = 0; 107 } 108 else { 109 $obj->{Root} = "Safe::Root".$default_root++; 110 $obj->{Erase} = 1; 111 } 112 113 # use permit/deny methods instead till interface issues resolved 114 # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...; 115 croak "Mask parameter to new no longer supported" if defined $mask; 116 $obj->permit_only(':default'); 117 118 # We must share $_ and @_ with the compartment or else ops such 119 # as split, length and so on won't default to $_ properly, nor 120 # will passing argument to subroutines work (via @_). In fact, 121 # for reasons I don't completely understand, we need to share 122 # the whole glob *_ rather than $_ and @_ separately, otherwise 123 # @_ in non default packages within the compartment don't work. 124 $obj->share_from('main', $default_share); 125 Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); 126 return $obj; 127 } 128 129 sub DESTROY { 130 my $obj = shift; 131 $obj->erase('DESTROY') if $obj->{Erase}; 132 } 133 134 sub erase { 135 my ($obj, $action) = @_; 136 my $pkg = $obj->root(); 137 my ($stem, $leaf); 138 139 no strict 'refs'; 140 $pkg = "main::$pkg\::"; # expand to full symbol table name 141 ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; 142 143 # The 'my $foo' is needed! Without it you get an 144 # 'Attempt to free unreferenced scalar' warning! 145 my $stem_symtab = *{$stem}{HASH}; 146 147 #warn "erase($pkg) stem=$stem, leaf=$leaf"; 148 #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n"; 149 # ", join(', ', %$stem_symtab),"\n"; 150 151 # delete $stem_symtab->{$leaf}; 152 153 my $leaf_glob = $stem_symtab->{$leaf}; 154 my $leaf_symtab = *{$leaf_glob}{HASH}; 155 # warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; 156 %$leaf_symtab = (); 157 #delete $leaf_symtab->{'__ANON__'}; 158 #delete $leaf_symtab->{'foo'}; 159 #delete $leaf_symtab->{'main::'}; 160 # my $foo = undef ${"$stem\::"}{"$leaf\::"}; 161 162 if ($action and $action eq 'DESTROY') { 163 delete $stem_symtab->{$leaf}; 164 } else { 165 $obj->share_from('main', $default_share); 166 } 167 1; 168 } 169 170 171 sub reinit { 172 my $obj= shift; 173 $obj->erase; 174 $obj->share_redo; 175 } 176 177 sub root { 178 my $obj = shift; 179 croak("Safe root method now read-only") if @_; 180 return $obj->{Root}; 181 } 182 183 184 sub mask { 185 my $obj = shift; 186 return $obj->{Mask} unless @_; 187 $obj->deny_only(@_); 188 } 189 190 # v1 compatibility methods 191 sub trap { shift->deny(@_) } 192 sub untrap { shift->permit(@_) } 193 194 sub deny { 195 my $obj = shift; 196 $obj->{Mask} |= opset(@_); 197 } 198 sub deny_only { 199 my $obj = shift; 200 $obj->{Mask} = opset(@_); 201 } 202 203 sub permit { 204 my $obj = shift; 205 # XXX needs testing 206 $obj->{Mask} &= invert_opset opset(@_); 207 } 208 sub permit_only { 209 my $obj = shift; 210 $obj->{Mask} = invert_opset opset(@_); 211 } 212 213 214 sub dump_mask { 215 my $obj = shift; 216 print opset_to_hex($obj->{Mask}),"\n"; 217 } 218 219 220 221 sub share { 222 my($obj, @vars) = @_; 223 $obj->share_from(scalar(caller), \@vars); 224 } 225 226 sub share_from { 227 my $obj = shift; 228 my $pkg = shift; 229 my $vars = shift; 230 my $no_record = shift || 0; 231 my $root = $obj->root(); 232 croak("vars not an array ref") unless ref $vars eq 'ARRAY'; 233 no strict 'refs'; 234 # Check that 'from' package actually exists 235 croak("Package \"$pkg\" does not exist") 236 unless keys %{"$pkg\::"}; 237 my $arg; 238 foreach $arg (@$vars) { 239 # catch some $safe->share($var) errors: 240 my ($var, $type); 241 $type = $1 if ($var = $arg) =~ s/^(\W)//; 242 # warn "share_from $pkg $type $var"; 243 *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"} 244 : ($type eq '&') ? \&{$pkg."::$var"} 245 : ($type eq '$') ? \${$pkg."::$var"} 246 : ($type eq '@') ? \@{$pkg."::$var"} 247 : ($type eq '%') ? \%{$pkg."::$var"} 248 : ($type eq '*') ? *{$pkg."::$var"} 249 : croak(qq(Can't share "$type$var" of unknown type)); 250 } 251 $obj->share_record($pkg, $vars) unless $no_record or !$vars; 252 } 253 254 sub share_record { 255 my $obj = shift; 256 my $pkg = shift; 257 my $vars = shift; 258 my $shares = \%{$obj->{Shares} ||= {}}; 259 # Record shares using keys of $obj->{Shares}. See reinit. 260 @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; 261 } 262 sub share_redo { 263 my $obj = shift; 264 my $shares = \%{$obj->{Shares} ||= {}}; 265 my($var, $pkg); 266 while(($var, $pkg) = each %$shares) { 267 # warn "share_redo $pkg\:: $var"; 268 $obj->share_from($pkg, [ $var ], 1); 269 } 270 } 271 sub share_forget { 272 delete shift->{Shares}; 273 } 274 275 sub varglob { 276 my ($obj, $var) = @_; 277 no strict 'refs'; 278 return *{$obj->root()."::$var"}; 279 } 280 281 282 sub reval { 283 my ($obj, $expr, $strict) = @_; 284 my $root = $obj->{Root}; 285 286 my $evalsub = lexless_anon_sub($root,$strict, $expr); 287 return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); 288 } 289 290 sub rdo { 291 my ($obj, $file) = @_; 292 my $root = $obj->{Root}; 293 294 my $evalsub = eval 295 sprintf('package %s; sub { @_ = (); do $file }', $root); 296 return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); 297 } 298 299 300 1; 301 302 __END__ 303 304 =head1 NAME 305 306 Safe - Compile and execute code in restricted compartments 307 308 =head1 SYNOPSIS 309 310 use WWSafe; 311 312 $compartment = new Safe; 313 314 $compartment->permit(qw(time sort :browse)); 315 316 $result = $compartment->reval($unsafe_code); 317 318 =head1 DESCRIPTION 319 320 The Safe extension module allows the creation of compartments 321 in which perl code can be evaluated. Each compartment has 322 323 =over 8 324 325 =item a new namespace 326 327 The "root" of the namespace (i.e. "main::") is changed to a 328 different package and code evaluated in the compartment cannot 329 refer to variables outside this namespace, even with run-time 330 glob lookups and other tricks. 331 332 Code which is compiled outside the compartment can choose to place 333 variables into (or I<share> variables with) the compartment's namespace 334 and only that data will be visible to code evaluated in the 335 compartment. 336 337 By default, the only variables shared with compartments are the 338 "underscore" variables $_ and @_ (and, technically, the less frequently 339 used %_, the _ filehandle and so on). This is because otherwise perl 340 operators which default to $_ will not work and neither will the 341 assignment of arguments to @_ on subroutine entry. 342 343 =item an operator mask 344 345 Each compartment has an associated "operator mask". Recall that 346 perl code is compiled into an internal format before execution. 347 Evaluating perl code (e.g. via "eval" or "do 'file'") causes 348 the code to be compiled into an internal format and then, 349 provided there was no error in the compilation, executed. 350 Code evaluated in a compartment compiles subject to the 351 compartment's operator mask. Attempting to evaluate code in a 352 compartment which contains a masked operator will cause the 353 compilation to fail with an error. The code will not be executed. 354 355 The default operator mask for a newly created compartment is 356 the ':default' optag. 357 358 It is important that you read the L<Opcode> module documentation 359 for more information, especially for detailed definitions of opnames, 360 optags and opsets. 361 362 Since it is only at the compilation stage that the operator mask 363 applies, controlled access to potentially unsafe operations can 364 be achieved by having a handle to a wrapper subroutine (written 365 outside the compartment) placed into the compartment. For example, 366 367 $cpt = new Safe; 368 sub wrapper { 369 # vet arguments and perform potentially unsafe operations 370 } 371 $cpt->share('&wrapper'); 372 373 =back 374 375 376 =head1 WARNING 377 378 The authors make B<no warranty>, implied or otherwise, about the 379 suitability of this software for safety or security purposes. 380 381 The authors shall not in any case be liable for special, incidental, 382 consequential, indirect or other similar damages arising from the use 383 of this software. 384 385 Your mileage will vary. If in any doubt B<do not use it>. 386 387 388 =head2 RECENT CHANGES 389 390 The interface to the Safe module has changed quite dramatically since 391 version 1 (as supplied with Perl5.002). Study these pages carefully if 392 you have code written to use Safe version 1 because you will need to 393 makes changes. 394 395 396 =head2 Methods in class Safe 397 398 To create a new compartment, use 399 400 $cpt = new Safe; 401 402 Optional argument is (NAMESPACE), where NAMESPACE is the root namespace 403 to use for the compartment (defaults to "Safe::Root0", incremented for 404 each new compartment). 405 406 Note that version 1.00 of the Safe module supported a second optional 407 parameter, MASK. That functionality has been withdrawn pending deeper 408 consideration. Use the permit and deny methods described below. 409 410 The following methods can then be used on the compartment 411 object returned by the above constructor. The object argument 412 is implicit in each case. 413 414 415 =over 8 416 417 =item permit (OP, ...) 418 419 Permit the listed operators to be used when compiling code in the 420 compartment (in I<addition> to any operators already permitted). 421 422 You can list opcodes by names, or use a tag name; see 423 L<Opcode/"Predefined Opcode Tags">. 424 425 =item permit_only (OP, ...) 426 427 Permit I<only> the listed operators to be used when compiling code in 428 the compartment (I<no> other operators are permitted). 429 430 =item deny (OP, ...) 431 432 Deny the listed operators from being used when compiling code in the 433 compartment (other operators may still be permitted). 434 435 =item deny_only (OP, ...) 436 437 Deny I<only> the listed operators from being used when compiling code 438 in the compartment (I<all> other operators will be permitted). 439 440 =item trap (OP, ...) 441 442 =item untrap (OP, ...) 443 444 The trap and untrap methods are synonyms for deny and permit 445 respectfully. 446 447 =item share (NAME, ...) 448 449 This shares the variable(s) in the argument list with the compartment. 450 This is almost identical to exporting variables using the L<Exporter> 451 module. 452 453 Each NAME must be the B<name> of a non-lexical variable, typically 454 with the leading type identifier included. A bareword is treated as a 455 function name. 456 457 Examples of legal names are '$foo' for a scalar, '@foo' for an 458 array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo' 459 for a glob (i.e. all symbol table entries associated with "foo", 460 including scalar, array, hash, sub and filehandle). 461 462 Each NAME is assumed to be in the calling package. See share_from 463 for an alternative method (which share uses). 464 465 =item share_from (PACKAGE, ARRAYREF) 466 467 This method is similar to share() but allows you to explicitly name the 468 package that symbols should be shared from. The symbol names (including 469 type characters) are supplied as an array reference. 470 471 $safe->share_from('main', [ '$foo', '%bar', 'func' ]); 472 473 474 =item varglob (VARNAME) 475 476 This returns a glob reference for the symbol table entry of VARNAME in 477 the package of the compartment. VARNAME must be the B<name> of a 478 variable without any leading type marker. For example, 479 480 $cpt = new Safe 'Root'; 481 $Root::foo = "Hello world"; 482 # Equivalent version which doesn't need to know $cpt's package name: 483 ${$cpt->varglob('foo')} = "Hello world"; 484 485 486 =item reval (STRING) 487 488 This evaluates STRING as perl code inside the compartment. 489 490 The code can only see the compartment's namespace (as returned by the 491 B<root> method). The compartment's root package appears to be the 492 C<main::> package to the code inside the compartment. 493 494 Any attempt by the code in STRING to use an operator which is not permitted 495 by the compartment will cause an error (at run-time of the main program 496 but at compile-time for the code in STRING). The error is of the form 497 "'%s' trapped by operation mask...". 498 499 If an operation is trapped in this way, then the code in STRING will 500 not be executed. If such a trapped operation occurs or any other 501 compile-time or return error, then $@ is set to the error message, just 502 as with an eval(). 503 504 If there is no error, then the method returns the value of the last 505 expression evaluated, or a return statement may be used, just as with 506 subroutines and B<eval()>. The context (list or scalar) is determined 507 by the caller as usual. 508 509 This behaviour differs from the beta distribution of the Safe extension 510 where earlier versions of perl made it hard to mimic the return 511 behaviour of the eval() command and the context was always scalar. 512 513 Some points to note: 514 515 If the entereval op is permitted then the code can use eval "..." to 516 'hide' code which might use denied ops. This is not a major problem 517 since when the code tries to execute the eval it will fail because the 518 opmask is still in effect. However this technique would allow clever, 519 and possibly harmful, code to 'probe' the boundaries of what is 520 possible. 521 522 Any string eval which is executed by code executing in a compartment, 523 or by code called from code executing in a compartment, will be eval'd 524 in the namespace of the compartment. This is potentially a serious 525 problem. 526 527 Consider a function foo() in package pkg compiled outside a compartment 528 but shared with it. Assume the compartment has a root package called 529 'Root'. If foo() contains an eval statement like eval '$foo = 1' then, 530 normally, $pkg::foo will be set to 1. If foo() is called from the 531 compartment (by whatever means) then instead of setting $pkg::foo, the 532 eval will actually set $Root::pkg::foo. 533 534 This can easily be demonstrated by using a module, such as the Socket 535 module, which uses eval "..." as part of an AUTOLOAD function. You can 536 'use' the module outside the compartment and share an (autoloaded) 537 function with the compartment. If an autoload is triggered by code in 538 the compartment, or by any code anywhere that is called by any means 539 from the compartment, then the eval in the Socket module's AUTOLOAD 540 function happens in the namespace of the compartment. Any variables 541 created or used by the eval'd code are now under the control of 542 the code in the compartment. 543 544 A similar effect applies to I<all> runtime symbol lookups in code 545 called from a compartment but not compiled within it. 546 547 548 549 =item rdo (FILENAME) 550 551 This evaluates the contents of file FILENAME inside the compartment. 552 See above documentation on the B<reval> method for further details. 553 554 =item root (NAMESPACE) 555 556 This method returns the name of the package that is the root of the 557 compartment's namespace. 558 559 Note that this behaviour differs from version 1.00 of the Safe module 560 where the root module could be used to change the namespace. That 561 functionality has been withdrawn pending deeper consideration. 562 563 =item mask (MASK) 564 565 This is a get-or-set method for the compartment's operator mask. 566 567 With no MASK argument present, it returns the current operator mask of 568 the compartment. 569 570 With the MASK argument present, it sets the operator mask for the 571 compartment (equivalent to calling the deny_only method). 572 573 =back 574 575 576 =head2 Some Safety Issues 577 578 This section is currently just an outline of some of the things code in 579 a compartment might do (intentionally or unintentionally) which can 580 have an effect outside the compartment. 581 582 =over 8 583 584 =item Memory 585 586 Consuming all (or nearly all) available memory. 587 588 =item CPU 589 590 Causing infinite loops etc. 591 592 =item Snooping 593 594 Copying private information out of your system. Even something as 595 simple as your user name is of value to others. Much useful information 596 could be gleaned from your environment variables for example. 597 598 =item Signals 599 600 Causing signals (especially SIGFPE and SIGALARM) to affect your process. 601 602 Setting up a signal handler will need to be carefully considered 603 and controlled. What mask is in effect when a signal handler 604 gets called? If a user can get an imported function to get an 605 exception and call the user's signal handler, does that user's 606 restricted mask get re-instated before the handler is called? 607 Does an imported handler get called with its original mask or 608 the user's one? 609 610 =item State Changes 611 612 Ops such as chdir obviously effect the process as a whole and not just 613 the code in the compartment. Ops such as rand and srand have a similar 614 but more subtle effect. 615 616 =back 617 618 =head2 AUTHOR 619 620 Originally designed and implemented by Malcolm Beattie. 621 622 Reworked to use the Opcode module and other changes added by Tim Bunce. 623 624 Currently maintained by the Perl 5 Porters, <perl5-porters@perl.org>. 625 626 =cut 627
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |