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.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};
… …
92my @hook; 92my @hook;
93my %command; 93my %command;
94my %extcmd; 94my %extcmd;
95 95
96############################################################################# 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}
110
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
100 115
101=item cf::attach_global ... # NYI 116=item cf::attach_global ...
102 117
103=item cf::attach_to_type ... # NYI 118=item cf::attach_to_type ...
104 119
105=item cf::attach_to_objects ... # NYI 120=item cf::attach_to_objects ...
106 121
107=item cf::attach_to_players ... # NYI 122=item cf::attach_to_players ...
108 123
109=item cf::attach_to_maps ... # NYI 124=item cf::attach_to_maps ...
110 125
111 prio => $number, # higehr is earlier 126 prio => $number, # lower is earlier
112 on_xxx => \&cb, 127 on_xxx => \&cb,
113 package => package::, 128 package => package::,
114 129
115=cut 130=cut
116 131
117our %CB_CLASS = (); # registry for class-based events 132# the following variables are defined in .xs and must not be re-created
118our @CB_GLOBAL = (); # registry for all global events 133our @CB_GLOBAL = (); # registry for all global events
134our @CB_OBJECT = ();
135our @CB_PLAYER = ();
119our @CB_TYPE = (); # registry for type (cf-object class) based events 136our @CB_TYPE = (); # registry for type (cf-object class) based events
137our @CB_MAP = ();
120 138
121sub _attach_cb($\%$$$) { 139sub _attach_cb($\%$$$) {
122 my ($registry, $undo, $event, $prio, $cb) = @_; 140 my ($registry, $undo, $event, $prio, $cb) = @_;
123 141
124 use sort 'stable'; 142 use sort 'stable';
… …
183 201
184sub attach_global { 202sub attach_global {
185 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 203 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
186} 204}
187 205
188sub attach_type { 206sub attach_to_type {
189 my $type = shift; 207 my $type = shift;
190 _attach @{$CB_TYPE[$type]}, KLASS_MAP, @_ 208 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_
191} 209}
192 210
193sub attach_to_objects { 211sub attach_to_objects {
194 _attach @{$CB_CLASS{cf::object::wrap::}}, KLASS_OBJECT, @_ 212 _attach @CB_OBJECT, KLASS_OBJECT, @_
195} 213}
196 214
197sub attach_to_players { 215sub attach_to_players {
198 _attach @{$CB_CLASS{cf::player::wrap::}}, KLASS_PLAYER, @_ 216 _attach @CB_PLAYER, KLASS_PLAYER, @_
199} 217}
200 218
201sub attach_to_maps { 219sub attach_to_maps {
202 _attach @{$CB_CLASS{cf::map::wrap::}}, KLASS_MAP, @_ 220 _attach @CB_MAP, KLASS_MAP, @_
203} 221}
204 222
205our $override; 223our $override;
206 224
207sub override() { 225sub override() {
208 $override = 1 226 $override = 1
209} 227}
210 228
211sub invoke { 229sub invoke {
212 my $event = shift; 230 my $event = shift;
213 231 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 232
227 local $override; 233 local $override;
228 234
229 for (@cb) { 235 for (@$callbacks) {
230 eval { &{$_->[1]} }; 236 eval { &{$_->[1]} };
231 237
232 if ($@) { 238 if ($@) {
233 warn "$@"; 239 warn "$@";
234 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 240 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";
… …
308 314
309 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 315 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
310 my $base = $1; 316 my $base = $1;
311 my $pkg = $1; 317 my $pkg = $1;
312 $pkg =~ s/[^[:word:]]/_/g; 318 $pkg =~ s/[^[:word:]]/_/g;
313 $pkg = "cf::ext::$pkg"; 319 $pkg = "ext::$pkg";
314 320
315 warn "loading '$path' into '$pkg'\n"; 321 warn "loading '$path' into '$pkg'\n";
316 322
317 open my $fh, "<:utf8", $path 323 open my $fh, "<:utf8", $path
318 or die "$path: $!"; 324 or die "$path: $!";
… …
361 # remove extcmds 367 # remove extcmds
362 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 368 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
363 delete $extcmd{$name}; 369 delete $extcmd{$name};
364 } 370 }
365 371
366 if (my $cb = $pkg->can ("on_unload")) { 372 if (my $cb = $pkg->can ("unload")) {
367 eval { 373 eval {
368 $cb->($pkg); 374 $cb->($pkg);
369 1 375 1
370 } or warn "$pkg unloaded, but with errors: $@"; 376 } or warn "$pkg unloaded, but with errors: $@";
371 } 377 }
… …
415 } 421 }
416 422
417 Symbol::delete_package $k; 423 Symbol::delete_package $k;
418 } 424 }
419 425
420 # 4. get rid of ext::, as good as possible 426 # 4. get rid of safe::, as good as possible
421 Symbol::delete_package "ext::$_" 427 Symbol::delete_package "safe::$_"
422 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);
423 429
424 # 5. remove register_script_function callbacks 430 # 5. remove register_script_function callbacks
425 # TODO 431 # TODO
426 432
427 # 6. unload cf.pm "a bit" 433 # 6. unload cf.pm "a bit"
428 delete $INC{"cf.pm"}; 434 delete $INC{"cf.pm"};
429 435
430 # don't, removes xs symbols, too 436 # don't, removes xs symbols, too,
437 # and global variables created in xs
431 #Symbol::delete_package __PACKAGE__; 438 #Symbol::delete_package __PACKAGE__;
432 439
433 # 7. reload cf.pm 440 # 7. reload cf.pm
434 $msg->("reloading cf.pm"); 441 $msg->("reloading cf.pm");
435 require cf; 442 require cf;
… …
474 481
475############################################################################# 482#############################################################################
476# extcmd framework, basically convert ext <msg> 483# extcmd framework, basically convert ext <msg>
477# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 484# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
478 485
479sub on_extcmd { 486attach_to_players
487 on_extcmd => sub {
480 my ($pl, $buf) = @_; 488 my ($pl, $buf) = @_;
481 489
482 my $msg = eval { from_json $buf }; 490 my $msg = eval { from_json $buf };
483 491
484 if (ref $msg) { 492 if (ref $msg) {
485 if (my $cb = $extcmd{$msg->{msgtype}}) { 493 if (my $cb = $extcmd{$msg->{msgtype}}) {
486 if (my %reply = $cb->[0]->($pl, $msg)) { 494 if (my %reply = $cb->[0]->($pl, $msg)) {
487 $pl->ext_reply ($msg->{msgid}, %reply); 495 $pl->ext_reply ($msg->{msgid}, %reply);
496 }
488 } 497 }
498 } else {
499 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
489 } 500 }
490 } else { 501
491 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 502 cf::override;
492 } 503 },
493 504;
494 1
495}
496 505
497############################################################################# 506#############################################################################
498# load/save/clean perl data associated with a map 507# load/save/clean perl data associated with a map
499 508
500*cf::mapsupport::on_clean = sub { 509*cf::mapsupport::on_clean = sub {
… …
632} 641}
633 642
634############################################################################# 643#############################################################################
635# map scripting support 644# map scripting support
636 645
637our $safe = new Safe "ext"; 646our $safe = new Safe "safe";
638our $safe_hole = new Safe::Hole; 647our $safe_hole = new Safe::Hole;
639 648
640$SIG{FPE} = 'IGNORE'; 649$SIG{FPE} = 'IGNORE';
641 650
642$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));
… …
648 ["cf::object::player" => qw(player)], 657 ["cf::object::player" => qw(player)],
649 ["cf::player" => qw(peaceful)], 658 ["cf::player" => qw(peaceful)],
650) { 659) {
651 no strict 'refs'; 660 no strict 'refs';
652 my ($pkg, @funs) = @$_; 661 my ($pkg, @funs) = @$_;
653 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 662 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
654 for @funs; 663 for @funs;
655} 664}
656 665
657sub safe_eval($;@) { 666sub safe_eval($;@) {
658 my ($code, %vars) = @_; 667 my ($code, %vars) = @_;
… …
660 my $qcode = $code; 669 my $qcode = $code;
661 $qcode =~ s/"/‟/g; # not allowed in #line filenames 670 $qcode =~ s/"/‟/g; # not allowed in #line filenames
662 $qcode =~ s/\n/\\n/g; 671 $qcode =~ s/\n/\\n/g;
663 672
664 local $_; 673 local $_;
665 local @ext::cf::_safe_eval_args = values %vars; 674 local @safe::cf::_safe_eval_args = values %vars;
666 675
667 $code = 676 my $eval =
668 "do {\n" 677 "do {\n"
669 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 678 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
670 . "#line 0 \"{$qcode}\"\n" 679 . "#line 0 \"{$qcode}\"\n"
671 . $code 680 . $code
672 . "\n}" 681 . "\n}"
673 ; 682 ;
674 683
675 sub_generation_inc; 684 sub_generation_inc;
676 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 685 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
677 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 }
678 693
679 wantarray ? @res : $res[0] 694 wantarray ? @res : $res[0]
680} 695}
681 696
682sub register_script_function { 697sub register_script_function {
683 my ($fun, $cb) = @_; 698 my ($fun, $cb) = @_;
684 699
685 no strict 'refs'; 700 no strict 'refs';
686 *{"ext::$fun"} = $safe_hole->wrap ($cb); 701 *{"safe::$fun"} = $safe_hole->wrap ($cb);
687} 702}
688 703
689############################################################################# 704#############################################################################
690# the server's main() 705# the server's main()
691 706

Diff Legend

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