ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.40 by root, Fri Aug 25 15:21:57 2006 UTC vs.
Revision 1.42 by root, Fri Aug 25 15:31:44 2006 UTC

… …
71prop_gen MAP_PROP => "cf::map"; 71prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch"; 72prop_gen ARCH_PROP => "cf::arch";
73 73
74# guessed hierarchies 74# guessed hierarchies
75 75
76@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 76@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object'; 77@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 78
79# we bless all objects into derived classes to force a method lookup 79# we bless all objects into (empty) derived classes to force a method lookup
80# within the Safe compartment. 80# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { 81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs'; 82 no strict 'refs';
83 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 83 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 84}
85 85
86$Event::DIED = sub { 86$Event::DIED = sub {
87 warn "error in event callback: @_"; 87 warn "error in event callback: @_";
88}; 88};
… …
299 299
300 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 300 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
301 my $base = $1; 301 my $base = $1;
302 my $pkg = $1; 302 my $pkg = $1;
303 $pkg =~ s/[^[:word:]]/_/g; 303 $pkg =~ s/[^[:word:]]/_/g;
304 $pkg = "cf::ext::$pkg"; 304 $pkg = "ext::$pkg";
305 305
306 warn "loading '$path' into '$pkg'\n"; 306 warn "loading '$path' into '$pkg'\n";
307 307
308 open my $fh, "<:utf8", $path 308 open my $fh, "<:utf8", $path
309 or die "$path: $!"; 309 or die "$path: $!";
… …
406 } 406 }
407 407
408 Symbol::delete_package $k; 408 Symbol::delete_package $k;
409 } 409 }
410 410
411 # 4. get rid of ext::, as good as possible 411 # 4. get rid of safe::, as good as possible
412 Symbol::delete_package "ext::$_" 412 Symbol::delete_package "safe::$_"
413 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 413 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
414 414
415 # 5. remove register_script_function callbacks 415 # 5. remove register_script_function callbacks
416 # TODO 416 # TODO
417 417
418 # 6. unload cf.pm "a bit" 418 # 6. unload cf.pm "a bit"
419 delete $INC{"cf.pm"}; 419 delete $INC{"cf.pm"};
420 420
421 # don't, removes xs symbols, too 421 # don't, removes xs symbols, too,
422 # and global variables created in xs
422 #Symbol::delete_package __PACKAGE__; 423 #Symbol::delete_package __PACKAGE__;
423 424
424 # 7. reload cf.pm 425 # 7. reload cf.pm
425 $msg->("reloading cf.pm"); 426 $msg->("reloading cf.pm");
426 require cf; 427 require cf;
… …
623} 624}
624 625
625############################################################################# 626#############################################################################
626# map scripting support 627# map scripting support
627 628
628our $safe = new Safe "ext"; 629our $safe = new Safe "safe";
629our $safe_hole = new Safe::Hole; 630our $safe_hole = new Safe::Hole;
630 631
631$SIG{FPE} = 'IGNORE'; 632$SIG{FPE} = 'IGNORE';
632 633
633$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 634$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
… …
639 ["cf::object::player" => qw(player)], 640 ["cf::object::player" => qw(player)],
640 ["cf::player" => qw(peaceful)], 641 ["cf::player" => qw(peaceful)],
641) { 642) {
642 no strict 'refs'; 643 no strict 'refs';
643 my ($pkg, @funs) = @$_; 644 my ($pkg, @funs) = @$_;
644 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 645 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
645 for @funs; 646 for @funs;
646} 647}
647 648
648sub safe_eval($;@) { 649sub safe_eval($;@) {
649 my ($code, %vars) = @_; 650 my ($code, %vars) = @_;
… …
651 my $qcode = $code; 652 my $qcode = $code;
652 $qcode =~ s/"/‟/g; # not allowed in #line filenames 653 $qcode =~ s/"/‟/g; # not allowed in #line filenames
653 $qcode =~ s/\n/\\n/g; 654 $qcode =~ s/\n/\\n/g;
654 655
655 local $_; 656 local $_;
656 local @ext::cf::_safe_eval_args = values %vars; 657 local @safe::cf::_safe_eval_args = values %vars;
657 658
658 $code = 659 my $eval =
659 "do {\n" 660 "do {\n"
660 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 661 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
661 . "#line 0 \"{$qcode}\"\n" 662 . "#line 0 \"{$qcode}\"\n"
662 . $code 663 . $code
663 . "\n}" 664 . "\n}"
664 ; 665 ;
665 666
666 sub_generation_inc; 667 sub_generation_inc;
667 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 668 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
668 sub_generation_inc; 669 sub_generation_inc;
670
671 if ($@) {
672 warn "$@";
673 warn "while executing safe code '$code'\n";
674 warn "with arguments " . (join " ", %vars) . "\n";
675 }
669 676
670 wantarray ? @res : $res[0] 677 wantarray ? @res : $res[0]
671} 678}
672 679
673sub register_script_function { 680sub register_script_function {
674 my ($fun, $cb) = @_; 681 my ($fun, $cb) = @_;
675 682
676 no strict 'refs'; 683 no strict 'refs';
677 *{"ext::$fun"} = $safe_hole->wrap ($cb); 684 *{"safe::$fun"} = $safe_hole->wrap ($cb);
678} 685}
679 686
680############################################################################# 687#############################################################################
681# the server's main() 688# the server's main()
682 689

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines