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.44 by root, Sat Aug 26 08:44:06 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};
… …
90my %ext_pkg; 90my %ext_pkg;
91my @exts; 91my @exts;
92my @hook; 92my @hook;
93my %command; 93my %command;
94my %extcmd; 94my %extcmd;
95
96#############################################################################
97# object support
98
99sub reattach {
100 warn "reattach<@_>\n";
101}
102
103sub instantiate {
104 warn "instantiate<@_>\n";
105}
106
107sub clone {
108 warn "clone<@_>\n";
109}
95 110
96############################################################################# 111#############################################################################
97# "new" plug-in system 112# "new" plug-in system
98 113
99=item cf::object::attach ... # NYI 114=item cf::object::attach ... # NYI
… …
299 314
300 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 315 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
301 my $base = $1; 316 my $base = $1;
302 my $pkg = $1; 317 my $pkg = $1;
303 $pkg =~ s/[^[:word:]]/_/g; 318 $pkg =~ s/[^[:word:]]/_/g;
304 $pkg = "cf::ext::$pkg"; 319 $pkg = "ext::$pkg";
305 320
306 warn "loading '$path' into '$pkg'\n"; 321 warn "loading '$path' into '$pkg'\n";
307 322
308 open my $fh, "<:utf8", $path 323 open my $fh, "<:utf8", $path
309 or die "$path: $!"; 324 or die "$path: $!";
… …
352 # remove extcmds 367 # remove extcmds
353 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 368 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
354 delete $extcmd{$name}; 369 delete $extcmd{$name};
355 } 370 }
356 371
357 if (my $cb = $pkg->can ("on_unload")) { 372 if (my $cb = $pkg->can ("unload")) {
358 eval { 373 eval {
359 $cb->($pkg); 374 $cb->($pkg);
360 1 375 1
361 } or warn "$pkg unloaded, but with errors: $@"; 376 } or warn "$pkg unloaded, but with errors: $@";
362 } 377 }
… …
406 } 421 }
407 422
408 Symbol::delete_package $k; 423 Symbol::delete_package $k;
409 } 424 }
410 425
411 # 4. get rid of ext::, as good as possible 426 # 4. get rid of safe::, as good as possible
412 Symbol::delete_package "ext::$_" 427 Symbol::delete_package "safe::$_"
413 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); 428 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
414 429
415 # 5. remove register_script_function callbacks 430 # 5. remove register_script_function callbacks
416 # TODO 431 # TODO
417 432
418 # 6. unload cf.pm "a bit" 433 # 6. unload cf.pm "a bit"
419 delete $INC{"cf.pm"}; 434 delete $INC{"cf.pm"};
420 435
421 # don't, removes xs symbols, too 436 # don't, removes xs symbols, too,
437 # and global variables created in xs
422 #Symbol::delete_package __PACKAGE__; 438 #Symbol::delete_package __PACKAGE__;
423 439
424 # 7. reload cf.pm 440 # 7. reload cf.pm
425 $msg->("reloading cf.pm"); 441 $msg->("reloading cf.pm");
426 require cf; 442 require cf;
… …
465 481
466############################################################################# 482#############################################################################
467# extcmd framework, basically convert ext <msg> 483# extcmd framework, basically convert ext <msg>
468# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 484# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
469 485
470sub on_extcmd { 486attach_to_players
487 on_extcmd => sub {
471 my ($pl, $buf) = @_; 488 my ($pl, $buf) = @_;
472 489
473 my $msg = eval { from_json $buf }; 490 my $msg = eval { from_json $buf };
474 491
475 if (ref $msg) { 492 if (ref $msg) {
476 if (my $cb = $extcmd{$msg->{msgtype}}) { 493 if (my $cb = $extcmd{$msg->{msgtype}}) {
477 if (my %reply = $cb->[0]->($pl, $msg)) { 494 if (my %reply = $cb->[0]->($pl, $msg)) {
478 $pl->ext_reply ($msg->{msgid}, %reply); 495 $pl->ext_reply ($msg->{msgid}, %reply);
496 }
479 } 497 }
498 } else {
499 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
480 } 500 }
481 } else { 501
482 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 502 cf::override;
483 } 503 },
484 504;
485 1
486}
487 505
488############################################################################# 506#############################################################################
489# load/save/clean perl data associated with a map 507# load/save/clean perl data associated with a map
490 508
491*cf::mapsupport::on_clean = sub { 509*cf::mapsupport::on_clean = sub {
… …
623} 641}
624 642
625############################################################################# 643#############################################################################
626# map scripting support 644# map scripting support
627 645
628our $safe = new Safe "ext"; 646our $safe = new Safe "safe";
629our $safe_hole = new Safe::Hole; 647our $safe_hole = new Safe::Hole;
630 648
631$SIG{FPE} = 'IGNORE'; 649$SIG{FPE} = 'IGNORE';
632 650
633$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 651$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
… …
639 ["cf::object::player" => qw(player)], 657 ["cf::object::player" => qw(player)],
640 ["cf::player" => qw(peaceful)], 658 ["cf::player" => qw(peaceful)],
641) { 659) {
642 no strict 'refs'; 660 no strict 'refs';
643 my ($pkg, @funs) = @$_; 661 my ($pkg, @funs) = @$_;
644 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 662 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
645 for @funs; 663 for @funs;
646} 664}
647 665
648sub safe_eval($;@) { 666sub safe_eval($;@) {
649 my ($code, %vars) = @_; 667 my ($code, %vars) = @_;
… …
651 my $qcode = $code; 669 my $qcode = $code;
652 $qcode =~ s/"/‟/g; # not allowed in #line filenames 670 $qcode =~ s/"/‟/g; # not allowed in #line filenames
653 $qcode =~ s/\n/\\n/g; 671 $qcode =~ s/\n/\\n/g;
654 672
655 local $_; 673 local $_;
656 local @ext::cf::_safe_eval_args = values %vars; 674 local @safe::cf::_safe_eval_args = values %vars;
657 675
658 $code = 676 my $eval =
659 "do {\n" 677 "do {\n"
660 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 678 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
661 . "#line 0 \"{$qcode}\"\n" 679 . "#line 0 \"{$qcode}\"\n"
662 . $code 680 . $code
663 . "\n}" 681 . "\n}"
664 ; 682 ;
665 683
666 sub_generation_inc; 684 sub_generation_inc;
667 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 685 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
668 sub_generation_inc; 686 sub_generation_inc;
687
688 if ($@) {
689 warn "$@";
690 warn "while executing safe code '$code'\n";
691 warn "with arguments " . (join " ", %vars) . "\n";
692 }
669 693
670 wantarray ? @res : $res[0] 694 wantarray ? @res : $res[0]
671} 695}
672 696
673sub register_script_function { 697sub register_script_function {
674 my ($fun, $cb) = @_; 698 my ($fun, $cb) = @_;
675 699
676 no strict 'refs'; 700 no strict 'refs';
677 *{"ext::$fun"} = $safe_hole->wrap ($cb); 701 *{"safe::$fun"} = $safe_hole->wrap ($cb);
678} 702}
679 703
680############################################################################# 704#############################################################################
681# the server's main() 705# the server's main()
682 706

Diff Legend

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