… | |
… | |
71 | prop_gen MAP_PROP => "cf::map"; |
71 | prop_gen MAP_PROP => "cf::map"; |
72 | prop_gen ARCH_PROP => "cf::arch"; |
72 | prop_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. |
81 | for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { |
81 | for 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; |
… | |
… | |
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 | |
648 | sub safe_eval($;@) { |
649 | sub 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 | $code = |
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" |
… | |
… | |
672 | |
673 | |
673 | sub register_script_function { |
674 | sub register_script_function { |
674 | my ($fun, $cb) = @_; |
675 | my ($fun, $cb) = @_; |
675 | |
676 | |
676 | no strict 'refs'; |
677 | no strict 'refs'; |
677 | *{"ext::$fun"} = $safe_hole->wrap ($cb); |
678 | *{"safe::$fun"} = $safe_hole->wrap ($cb); |
678 | } |
679 | } |
679 | |
680 | |
680 | ############################################################################# |
681 | ############################################################################# |
681 | # the server's main() |
682 | # the server's main() |
682 | |
683 | |