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.43 by root, Fri Aug 25 17:11:53 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: $!";
… …
352 # remove extcmds 352 # remove extcmds
353 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 353 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
354 delete $extcmd{$name}; 354 delete $extcmd{$name};
355 } 355 }
356 356
357 if (my $cb = $pkg->can ("on_unload")) { 357 if (my $cb = $pkg->can ("unload")) {
358 eval { 358 eval {
359 $cb->($pkg); 359 $cb->($pkg);
360 1 360 1
361 } or warn "$pkg unloaded, but with errors: $@"; 361 } or warn "$pkg unloaded, but with errors: $@";
362 } 362 }
… …
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;
… …
465 466
466############################################################################# 467#############################################################################
467# extcmd framework, basically convert ext <msg> 468# extcmd framework, basically convert ext <msg>
468# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 469# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
469 470
470sub on_extcmd { 471attach_global
472 on_extcmd => sub {
471 my ($pl, $buf) = @_; 473 my ($pl, $buf) = @_;
472 474
473 my $msg = eval { from_json $buf }; 475 my $msg = eval { from_json $buf };
474 476
475 if (ref $msg) { 477 if (ref $msg) {
476 if (my $cb = $extcmd{$msg->{msgtype}}) { 478 if (my $cb = $extcmd{$msg->{msgtype}}) {
477 if (my %reply = $cb->[0]->($pl, $msg)) { 479 if (my %reply = $cb->[0]->($pl, $msg)) {
478 $pl->ext_reply ($msg->{msgid}, %reply); 480 $pl->ext_reply ($msg->{msgid}, %reply);
481 }
479 } 482 }
483 } else {
484 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
480 } 485 }
481 } else { 486
482 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 487 cf::override;
483 } 488 },
484 489;
485 1
486}
487 490
488############################################################################# 491#############################################################################
489# load/save/clean perl data associated with a map 492# load/save/clean perl data associated with a map
490 493
491*cf::mapsupport::on_clean = sub { 494*cf::mapsupport::on_clean = sub {
… …
623} 626}
624 627
625############################################################################# 628#############################################################################
626# map scripting support 629# map scripting support
627 630
628our $safe = new Safe "ext"; 631our $safe = new Safe "safe";
629our $safe_hole = new Safe::Hole; 632our $safe_hole = new Safe::Hole;
630 633
631$SIG{FPE} = 'IGNORE'; 634$SIG{FPE} = 'IGNORE';
632 635
633$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 636$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
… …
639 ["cf::object::player" => qw(player)], 642 ["cf::object::player" => qw(player)],
640 ["cf::player" => qw(peaceful)], 643 ["cf::player" => qw(peaceful)],
641) { 644) {
642 no strict 'refs'; 645 no strict 'refs';
643 my ($pkg, @funs) = @$_; 646 my ($pkg, @funs) = @$_;
644 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 647 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
645 for @funs; 648 for @funs;
646} 649}
647 650
648sub safe_eval($;@) { 651sub safe_eval($;@) {
649 my ($code, %vars) = @_; 652 my ($code, %vars) = @_;
… …
651 my $qcode = $code; 654 my $qcode = $code;
652 $qcode =~ s/"/‟/g; # not allowed in #line filenames 655 $qcode =~ s/"/‟/g; # not allowed in #line filenames
653 $qcode =~ s/\n/\\n/g; 656 $qcode =~ s/\n/\\n/g;
654 657
655 local $_; 658 local $_;
656 local @ext::cf::_safe_eval_args = values %vars; 659 local @safe::cf::_safe_eval_args = values %vars;
657 660
658 $code = 661 my $eval =
659 "do {\n" 662 "do {\n"
660 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 663 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
661 . "#line 0 \"{$qcode}\"\n" 664 . "#line 0 \"{$qcode}\"\n"
662 . $code 665 . $code
663 . "\n}" 666 . "\n}"
664 ; 667 ;
665 668
666 sub_generation_inc; 669 sub_generation_inc;
667 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 670 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
668 sub_generation_inc; 671 sub_generation_inc;
672
673 if ($@) {
674 warn "$@";
675 warn "while executing safe code '$code'\n";
676 warn "with arguments " . (join " ", %vars) . "\n";
677 }
669 678
670 wantarray ? @res : $res[0] 679 wantarray ? @res : $res[0]
671} 680}
672 681
673sub register_script_function { 682sub register_script_function {
674 my ($fun, $cb) = @_; 683 my ($fun, $cb) = @_;
675 684
676 no strict 'refs'; 685 no strict 'refs';
677 *{"ext::$fun"} = $safe_hole->wrap ($cb); 686 *{"safe::$fun"} = $safe_hole->wrap ($cb);
678} 687}
679 688
680############################################################################# 689#############################################################################
681# the server's main() 690# the server's main()
682 691

Diff Legend

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