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.41 by root, Fri Aug 25 15:25:12 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: $!";
… …
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;
… …
648 ["cf::object::player" => qw(player)], 640 ["cf::object::player" => qw(player)],
649 ["cf::player" => qw(peaceful)], 641 ["cf::player" => qw(peaceful)],
650) { 642) {
651 no strict 'refs'; 643 no strict 'refs';
652 my ($pkg, @funs) = @$_; 644 my ($pkg, @funs) = @$_;
653 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 645 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
654 for @funs; 646 for @funs;
655} 647}
656 648
657sub safe_eval($;@) { 649sub safe_eval($;@) {
658 my ($code, %vars) = @_; 650 my ($code, %vars) = @_;
… …
660 my $qcode = $code; 652 my $qcode = $code;
661 $qcode =~ s/"/‟/g; # not allowed in #line filenames 653 $qcode =~ s/"/‟/g; # not allowed in #line filenames
662 $qcode =~ s/\n/\\n/g; 654 $qcode =~ s/\n/\\n/g;
663 655
664 local $_; 656 local $_;
665 local @ext::cf::_safe_eval_args = values %vars; 657 local @safe::cf::_safe_eval_args = values %vars;
666 658
667 $code = 659 $code =
668 "do {\n" 660 "do {\n"
669 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 661 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
670 . "#line 0 \"{$qcode}\"\n" 662 . "#line 0 \"{$qcode}\"\n"
… …
681 673
682sub register_script_function { 674sub register_script_function {
683 my ($fun, $cb) = @_; 675 my ($fun, $cb) = @_;
684 676
685 no strict 'refs'; 677 no strict 'refs';
686 *{"ext::$fun"} = $safe_hole->wrap ($cb); 678 *{"safe::$fun"} = $safe_hole->wrap ($cb);
687} 679}
688 680
689############################################################################# 681#############################################################################
690# the server's main() 682# the server's main()
691 683

Diff Legend

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