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.39 by root, Fri Aug 25 13:24:50 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};
… …
96############################################################################# 96#############################################################################
97# "new" plug-in system 97# "new" plug-in system
98 98
99=item cf::object::attach ... # NYI 99=item cf::object::attach ... # NYI
100 100
101=item cf::attach_global ... # NYI 101=item cf::attach_global ...
102 102
103=item cf::attach_to_type ... # NYI 103=item cf::attach_to_type ...
104 104
105=item cf::attach_to_objects ... # NYI 105=item cf::attach_to_objects ...
106 106
107=item cf::attach_to_players ... # NYI 107=item cf::attach_to_players ...
108 108
109=item cf::attach_to_maps ... # NYI 109=item cf::attach_to_maps ...
110 110
111 prio => $number, # higehr is earlier 111 prio => $number, # lower is earlier
112 on_xxx => \&cb, 112 on_xxx => \&cb,
113 package => package::, 113 package => package::,
114 114
115=cut 115=cut
116 116
117our %CB_CLASS = (); # registry for class-based events 117# the following variables are defined in .xs and must not be re-created
118our @CB_GLOBAL = (); # registry for all global events 118our @CB_GLOBAL = (); # registry for all global events
119our @CB_OBJECT = ();
120our @CB_PLAYER = ();
119our @CB_TYPE = (); # registry for type (cf-object class) based events 121our @CB_TYPE = (); # registry for type (cf-object class) based events
122our @CB_MAP = ();
120 123
121sub _attach_cb($\%$$$) { 124sub _attach_cb($\%$$$) {
122 my ($registry, $undo, $event, $prio, $cb) = @_; 125 my ($registry, $undo, $event, $prio, $cb) = @_;
123 126
124 use sort 'stable'; 127 use sort 'stable';
… …
183 186
184sub attach_global { 187sub attach_global {
185 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 188 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
186} 189}
187 190
188sub attach_type { 191sub attach_to_type {
189 my $type = shift; 192 my $type = shift;
190 _attach @{$CB_TYPE[$type]}, KLASS_MAP, @_ 193 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_
191} 194}
192 195
193sub attach_to_objects { 196sub attach_to_objects {
194 _attach @{$CB_CLASS{cf::object::wrap::}}, KLASS_OBJECT, @_ 197 _attach @CB_OBJECT, KLASS_OBJECT, @_
195} 198}
196 199
197sub attach_to_players { 200sub attach_to_players {
198 _attach @{$CB_CLASS{cf::player::wrap::}}, KLASS_PLAYER, @_ 201 _attach @CB_PLAYER, KLASS_PLAYER, @_
199} 202}
200 203
201sub attach_to_maps { 204sub attach_to_maps {
202 _attach @{$CB_CLASS{cf::map::wrap::}}, KLASS_MAP, @_ 205 _attach @CB_MAP, KLASS_MAP, @_
203} 206}
204 207
205our $override; 208our $override;
206 209
207sub override() { 210sub override() {
208 $override = 1 211 $override = 1
209} 212}
210 213
211sub invoke { 214sub invoke {
212 my $event = shift; 215 my $event = shift;
213 216 my $callbacks = shift;
214 my @cb;
215
216 if (my $ref = ref $_[0]) {
217 # 1. object-specific (NYI)
218 # 2. class-specific
219 push @cb, @{$CB_CLASS{$ref}[$event] || []};
220 }
221
222 # global
223 push @cb, @{$CB_GLOBAL[$event] || []};
224
225# warn "invoke id $EVENT[$event][0], args <@_> <=> @cb\n";#d#
226 217
227 local $override; 218 local $override;
228 219
229 for (@cb) { 220 for (@$callbacks) {
230 eval { &{$_->[1]} }; 221 eval { &{$_->[1]} };
231 222
232 if ($@) { 223 if ($@) {
233 warn "$@"; 224 warn "$@";
234 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 225 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";
… …
308 299
309 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 300 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
310 my $base = $1; 301 my $base = $1;
311 my $pkg = $1; 302 my $pkg = $1;
312 $pkg =~ s/[^[:word:]]/_/g; 303 $pkg =~ s/[^[:word:]]/_/g;
313 $pkg = "cf::ext::$pkg"; 304 $pkg = "ext::$pkg";
314 305
315 warn "loading '$path' into '$pkg'\n"; 306 warn "loading '$path' into '$pkg'\n";
316 307
317 open my $fh, "<:utf8", $path 308 open my $fh, "<:utf8", $path
318 or die "$path: $!"; 309 or die "$path: $!";
… …
361 # remove extcmds 352 # remove extcmds
362 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 353 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
363 delete $extcmd{$name}; 354 delete $extcmd{$name};
364 } 355 }
365 356
366 if (my $cb = $pkg->can ("on_unload")) { 357 if (my $cb = $pkg->can ("unload")) {
367 eval { 358 eval {
368 $cb->($pkg); 359 $cb->($pkg);
369 1 360 1
370 } or warn "$pkg unloaded, but with errors: $@"; 361 } or warn "$pkg unloaded, but with errors: $@";
371 } 362 }
… …
415 } 406 }
416 407
417 Symbol::delete_package $k; 408 Symbol::delete_package $k;
418 } 409 }
419 410
420 # 4. get rid of ext::, as good as possible 411 # 4. get rid of safe::, as good as possible
421 Symbol::delete_package "ext::$_" 412 Symbol::delete_package "safe::$_"
422 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);
423 414
424 # 5. remove register_script_function callbacks 415 # 5. remove register_script_function callbacks
425 # TODO 416 # TODO
426 417
427 # 6. unload cf.pm "a bit" 418 # 6. unload cf.pm "a bit"
428 delete $INC{"cf.pm"}; 419 delete $INC{"cf.pm"};
429 420
430 # don't, removes xs symbols, too 421 # don't, removes xs symbols, too,
422 # and global variables created in xs
431 #Symbol::delete_package __PACKAGE__; 423 #Symbol::delete_package __PACKAGE__;
432 424
433 # 7. reload cf.pm 425 # 7. reload cf.pm
434 $msg->("reloading cf.pm"); 426 $msg->("reloading cf.pm");
435 require cf; 427 require cf;
… …
474 466
475############################################################################# 467#############################################################################
476# extcmd framework, basically convert ext <msg> 468# extcmd framework, basically convert ext <msg>
477# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 469# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
478 470
479sub on_extcmd { 471attach_global
472 on_extcmd => sub {
480 my ($pl, $buf) = @_; 473 my ($pl, $buf) = @_;
481 474
482 my $msg = eval { from_json $buf }; 475 my $msg = eval { from_json $buf };
483 476
484 if (ref $msg) { 477 if (ref $msg) {
485 if (my $cb = $extcmd{$msg->{msgtype}}) { 478 if (my $cb = $extcmd{$msg->{msgtype}}) {
486 if (my %reply = $cb->[0]->($pl, $msg)) { 479 if (my %reply = $cb->[0]->($pl, $msg)) {
487 $pl->ext_reply ($msg->{msgid}, %reply); 480 $pl->ext_reply ($msg->{msgid}, %reply);
481 }
488 } 482 }
483 } else {
484 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
489 } 485 }
490 } else { 486
491 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 487 cf::override;
492 } 488 },
493 489;
494 1
495}
496 490
497############################################################################# 491#############################################################################
498# load/save/clean perl data associated with a map 492# load/save/clean perl data associated with a map
499 493
500*cf::mapsupport::on_clean = sub { 494*cf::mapsupport::on_clean = sub {
… …
632} 626}
633 627
634############################################################################# 628#############################################################################
635# map scripting support 629# map scripting support
636 630
637our $safe = new Safe "ext"; 631our $safe = new Safe "safe";
638our $safe_hole = new Safe::Hole; 632our $safe_hole = new Safe::Hole;
639 633
640$SIG{FPE} = 'IGNORE'; 634$SIG{FPE} = 'IGNORE';
641 635
642$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));
… …
648 ["cf::object::player" => qw(player)], 642 ["cf::object::player" => qw(player)],
649 ["cf::player" => qw(peaceful)], 643 ["cf::player" => qw(peaceful)],
650) { 644) {
651 no strict 'refs'; 645 no strict 'refs';
652 my ($pkg, @funs) = @$_; 646 my ($pkg, @funs) = @$_;
653 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 647 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
654 for @funs; 648 for @funs;
655} 649}
656 650
657sub safe_eval($;@) { 651sub safe_eval($;@) {
658 my ($code, %vars) = @_; 652 my ($code, %vars) = @_;
… …
660 my $qcode = $code; 654 my $qcode = $code;
661 $qcode =~ s/"/‟/g; # not allowed in #line filenames 655 $qcode =~ s/"/‟/g; # not allowed in #line filenames
662 $qcode =~ s/\n/\\n/g; 656 $qcode =~ s/\n/\\n/g;
663 657
664 local $_; 658 local $_;
665 local @ext::cf::_safe_eval_args = values %vars; 659 local @safe::cf::_safe_eval_args = values %vars;
666 660
667 $code = 661 my $eval =
668 "do {\n" 662 "do {\n"
669 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 663 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
670 . "#line 0 \"{$qcode}\"\n" 664 . "#line 0 \"{$qcode}\"\n"
671 . $code 665 . $code
672 . "\n}" 666 . "\n}"
673 ; 667 ;
674 668
675 sub_generation_inc; 669 sub_generation_inc;
676 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 670 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
677 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 }
678 678
679 wantarray ? @res : $res[0] 679 wantarray ? @res : $res[0]
680} 680}
681 681
682sub register_script_function { 682sub register_script_function {
683 my ($fun, $cb) = @_; 683 my ($fun, $cb) = @_;
684 684
685 no strict 'refs'; 685 no strict 'refs';
686 *{"ext::$fun"} = $safe_hole->wrap ($cb); 686 *{"safe::$fun"} = $safe_hole->wrap ($cb);
687} 687}
688 688
689############################################################################# 689#############################################################################
690# the server's main() 690# the server's main()
691 691

Diff Legend

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