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.92 by root, Thu Dec 21 06:42:28 2006 UTC vs.
Revision 1.94 by root, Thu Dec 21 23:02:54 2006 UTC

… …
74 print STDERR "cfperl: $msg"; 74 print STDERR "cfperl: $msg";
75 LOG llevError, "cfperl: $msg"; 75 LOG llevError, "cfperl: $msg";
76 }; 76 };
77} 77}
78 78
79@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
80@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
81@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
82@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
83@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 84@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
80 85
81# we bless all objects into (empty) derived classes to force a method lookup 86# we bless all objects into (empty) derived classes to force a method lookup
82# within the Safe compartment. 87# within the Safe compartment.
83for my $pkg (qw( 88for my $pkg (qw(
89 cf::global
84 cf::object cf::object::player 90 cf::object cf::object::player
85 cf::client cf::player 91 cf::client cf::player
86 cf::arch cf::living 92 cf::arch cf::living
87 cf::map cf::party cf::region 93 cf::map cf::party cf::region
88)) { 94)) {
… …
132 138
133=cut 139=cut
134 140
135############################################################################# 141#############################################################################
136 142
137=head2 EVENTS AND OBJECT ATTACHMENTS 143=head2 ATTACHABLE OBJECTS
144
145Many objects in crossfire are so-called attachable objects. That means you can
146attach callbacks/event handlers (a collection of which is called an "attachment")
147to it. All such attachable objects support the following methods.
148
149In the following description, CLASS can be any of C<global>, C<object>
150C<player>, C<client> or C<map> (i.e. the attachable objects in
151crossfire+).
138 152
139=over 4 153=over 4
140 154
141=item $object->attach ($attachment, key => $value...)
142
143=item $object->detach ($attachment)
144
145Attach/detach a pre-registered attachment to an object.
146
147=item $player->attach ($attachment, key => $value...)
148
149=item $player->detach ($attachment)
150
151Attach/detach a pre-registered attachment to a player.
152
153=item $map->attach ($attachment, key => $value...)
154
155=item $map->detach ($attachment)
156
157Attach/detach a pre-registered attachment to a client.
158
159=item $client->attach ($attachment, key => $value...) 155=item $attachable->attach ($attachment, key => $value...)
160 156
161=item $client->detach ($attachment) 157=item $attachable->detach ($attachment)
162 158
163Attach/detach a pre-registered attachment to a map. 159Attach/detach a pre-registered attachment to a specific object and give it
160the specified key/value pairs as arguments.
164 161
165=item $bool = $object->attached ($name) 162Example, attach a minesweeper attachment to the given object, making it a
16310x10 minesweeper game:
166 164
167=item $bool = $player->attached ($name) 165 $obj->attach (minesweeper => width => 10, height => 10);
168 166
169=item $bool = $client->attached ($name) 167=item $bool = $attachable->attached ($name)
170
171=item $bool = $map->attached ($name)
172 168
173Checks wether the named attachment is currently attached to the object. 169Checks wether the named attachment is currently attached to the object.
174 170
175=item cf::attach_global ... 171=item cf::CLASS->attach ...
176 172
177Attach handlers for global events. 173=item cf::CLASS->detach ...
178 174
179This and all following C<attach_*>-functions expect any number of the 175Define an anonymous attachment and attach it to all objects of the given
180following handler/hook descriptions: 176CLASS. See the next function for an explanation of its arguments.
177
178You can attach to global events by using the C<cf::global> class.
179
180Example, log all player logins:
181
182 cf::player->attach (
183 on_login => sub {
184 my ($pl) = @_;
185 ...
186 },
187 );
188
189Example, attach to the jeweler skill:
190
191 cf::object->attach (
192 type => cf::SKILL,
193 subtype => cf::SK_JEWELER,
194 on_use_skill => sub {
195 my ($sk, $ob, $part, $dir, $msg) = @_;
196 ...
197 },
198 );
199
200=item cf::CLASS::attachment $name, ...
201
202Register an attachment by C<$name> through which attachable objects of the
203given CLASS can refer to this attachment.
204
205Some classes such as crossfire maps and objects can specify attachments
206that are attached at load/instantiate time, thus the need for a name.
207
208These calls expect any number of the following handler/hook descriptions:
181 209
182=over 4 210=over 4
183 211
184=item prio => $number 212=item prio => $number
185 213
… …
187by another C<prio> setting). Lower priority handlers get executed 215by another C<prio> setting). Lower priority handlers get executed
188earlier. The default priority is C<0>, and many built-in handlers are 216earlier. The default priority is C<0>, and many built-in handlers are
189registered at priority C<-1000>, so lower priorities should not be used 217registered at priority C<-1000>, so lower priorities should not be used
190unless you know what you are doing. 218unless you know what you are doing.
191 219
220=item type => $type
221
222(Only for C<< cf::object->attach >> calls), limits the attachment to the
223given type of objects only (the additional parameter C<subtype> can be
224used to further limit to the given subtype).
225
192=item on_I<event> => \&cb 226=item on_I<event> => \&cb
193 227
194Call the given code reference whenever the named event happens (event is 228Call the given code reference whenever the named event happens (event is
195something like C<instantiate>, C<apply>, C<use_skill> and so on, and which 229something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
196handlers are recognised generally depends on the type of object these 230handlers are recognised generally depends on the type of object these
… …
205package and register them. Only handlers for eevents supported by the 239package and register them. Only handlers for eevents supported by the
206object/class are recognised. 240object/class are recognised.
207 241
208=back 242=back
209 243
210=item cf::attach_to_type $object_type, $subtype, ... 244Example, define an attachment called "sockpuppet" that calls the given
245event handler when a monster attacks:
211 246
212Attach handlers for a specific object type (e.g. TRANSPORT) and 247 cf::object::attachment sockpuppet =>
213subtype. If C<$subtype> is zero or undef, matches all objects of the given 248 on_skill_attack => sub {
214type. 249 my ($self, $victim) = @_;
215 250 ...
216=item cf::attach_to_objects ... 251 }
217 252 }
218Attach handlers to all objects. Do not use this except for debugging or
219very rare events, as handlers are (obviously) called for I<all> objects in
220the game.
221
222=item cf::attach_to_players ...
223
224Attach handlers to all players.
225
226=item cf::attach_to_clients ...
227
228Attach handlers to all players.
229
230=item cf::attach_to_maps ...
231
232Attach handlers to all maps.
233
234=item cf:register_attachment $name, ...
235
236Register an attachment by name through which objects can refer to this
237attachment.
238
239=item cf:register_player_attachment $name, ...
240
241Register an attachment by name through which players can refer to this
242attachment.
243
244=item cf:register_map_attachment $name, ...
245
246Register an attachment by name through which maps can refer to this
247attachment.
248 253
249=cut 254=cut
250 255
251# the following variables are defined in .xs and must not be re-created 256# the following variables are defined in .xs and must not be re-created
252our @CB_GLOBAL = (); # registry for all global events 257our @CB_GLOBAL = (); # registry for all global events
… …
256our @CB_TYPE = (); # registry for type (cf-object class) based events 261our @CB_TYPE = (); # registry for type (cf-object class) based events
257our @CB_MAP = (); 262our @CB_MAP = ();
258 263
259my %attachment; 264my %attachment;
260 265
261sub _attach_cb($\%$$$) { 266sub _attach_cb($$$$) {
262 my ($registry, $undo, $event, $prio, $cb) = @_; 267 my ($registry, $event, $prio, $cb) = @_;
263 268
264 use sort 'stable'; 269 use sort 'stable';
265 270
266 $cb = [$prio, $cb]; 271 $cb = [$prio, $cb];
267 272
268 @{$registry->[$event]} = sort 273 @{$registry->[$event]} = sort
269 { $a->[0] cmp $b->[0] } 274 { $a->[0] cmp $b->[0] }
270 @{$registry->[$event] || []}, $cb; 275 @{$registry->[$event] || []}, $cb;
271
272 push @{$undo->{cb}}, [$event, $cb];
273} 276}
274 277
275# attach handles attaching event callbacks 278# attach handles attaching event callbacks
276# the only thing the caller has to do is pass the correct 279# the only thing the caller has to do is pass the correct
277# registry (== where the callback attaches to). 280# registry (== where the callback attaches to).
278sub _attach(\@$@) { 281sub _attach {
279 my ($registry, $klass, @arg) = @_; 282 my ($registry, $klass, @arg) = @_;
280 283
284 my $object_type;
281 my $prio = 0; 285 my $prio = 0;
282
283 my %undo = (
284 registry => $registry,
285 cb => [],
286 );
287
288 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 286 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
289 287
290 while (@arg) { 288 while (@arg) {
291 my $type = shift @arg; 289 my $type = shift @arg;
292 290
293 if ($type eq "prio") { 291 if ($type eq "prio") {
294 $prio = shift @arg; 292 $prio = shift @arg;
295 293
294 } elsif ($type eq "type") {
295 $object_type = shift @arg;
296 $registry = $CB_TYPE[$object_type] ||= [];
297
298 } elsif ($type eq "subtype") {
299 defined $object_type or Carp::croak "subtype specified without type";
300 my $object_subtype = shift @arg;
301 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
302
296 } elsif ($type eq "package") { 303 } elsif ($type eq "package") {
297 my $pkg = shift @arg; 304 my $pkg = shift @arg;
298 305
299 while (my ($name, $id) = each %cb_id) { 306 while (my ($name, $id) = each %cb_id) {
300 if (my $cb = $pkg->can ($name)) { 307 if (my $cb = $pkg->can ($name)) {
301 _attach_cb $registry, %undo, $id, $prio, $cb; 308 _attach_cb $registry, $id, $prio, $cb;
302 } 309 }
303 } 310 }
304 311
305 } elsif (exists $cb_id{$type}) { 312 } elsif (exists $cb_id{$type}) {
306 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg; 313 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
307 314
308 } elsif (ref $type) { 315 } elsif (ref $type) {
309 warn "attaching objects not supported, ignoring.\n"; 316 warn "attaching objects not supported, ignoring.\n";
310 317
311 } else { 318 } else {
312 shift @arg; 319 shift @arg;
313 warn "attach argument '$type' not supported, ignoring.\n"; 320 warn "attach argument '$type' not supported, ignoring.\n";
314 } 321 }
315 } 322 }
316
317 \%undo
318} 323}
319 324
320sub _attach_attachment { 325sub _object_attach {
321 my ($obj, $name, %arg) = @_; 326 my ($obj, $name, %arg) = @_;
322 327
323 return if exists $obj->{_attachment}{$name}; 328 return if exists $obj->{_attachment}{$name};
324
325 my $res;
326 329
327 if (my $attach = $attachment{$name}) { 330 if (my $attach = $attachment{$name}) {
328 my $registry = $obj->registry; 331 my $registry = $obj->registry;
329 332
330 for (@$attach) { 333 for (@$attach) {
331 my ($klass, @attach) = @$_; 334 my ($klass, @attach) = @$_;
332 $res = _attach @$registry, $klass, @attach; 335 _attach $registry, $klass, @attach;
333 } 336 }
334 337
335 $obj->{$name} = \%arg; 338 $obj->{$name} = \%arg;
336 } else { 339 } else {
337 warn "object uses attachment '$name' that is not available, postponing.\n"; 340 warn "object uses attachment '$name' that is not available, postponing.\n";
338 } 341 }
339 342
340 $obj->{_attachment}{$name} = undef; 343 $obj->{_attachment}{$name} = undef;
341
342 $res->{attachment} = $name;
343 $res
344} 344}
345 345
346*cf::object::attach = 346sub cf::attachable::attach {
347*cf::player::attach = 347 if (ref $_[0]) {
348*cf::client::attach = 348 _object_attach @_;
349*cf::map::attach = sub { 349 } else {
350 my ($obj, $name, %arg) = @_; 350 _attach shift->_attach_registry, @_;
351 351 }
352 _attach_attachment $obj, $name, %arg;
353}; 352};
354 353
355# all those should be optimised 354# all those should be optimised
356*cf::object::detach = 355sub cf::attachable::detach {
357*cf::player::detach =
358*cf::client::detach =
359*cf::map::detach = sub {
360 my ($obj, $name) = @_; 356 my ($obj, $name) = @_;
361 357
358 if (ref $obj) {
362 delete $obj->{_attachment}{$name}; 359 delete $obj->{_attachment}{$name};
363 reattach ($obj); 360 reattach ($obj);
361 } else {
362 Carp::croak "cannot, currently, detach class attachments";
363 }
364}; 364};
365 365
366*cf::object::attached = 366sub cf::attachable::attached {
367*cf::player::attached =
368*cf::client::attached =
369*cf::map::attached = sub {
370 my ($obj, $name) = @_; 367 my ($obj, $name) = @_;
371 368
372 exists $obj->{_attachment}{$name} 369 exists $obj->{_attachment}{$name}
373};
374
375sub attach_global {
376 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
377} 370}
378 371
379sub attach_to_type { 372for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {
380 my $type = shift; 373 eval "#line " . __LINE__ . " 'cf.pm'
381 my $subtype = shift; 374 sub cf::\L$klass\E::_attach_registry {
375 (\\\@CB_$klass, KLASS_$klass)
376 }
382 377
383 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_ 378 sub cf::\L$klass\E::attachment {
384}
385
386sub attach_to_objects {
387 _attach @CB_OBJECT, KLASS_OBJECT, @_
388}
389
390sub attach_to_players {
391 _attach @CB_PLAYER, KLASS_PLAYER, @_
392}
393
394sub attach_to_clients {
395 _attach @CB_CLIENT, KLASS_CLIENT, @_
396}
397
398sub attach_to_maps {
399 _attach @CB_MAP, KLASS_MAP, @_
400}
401
402sub register_attachment {
403 my $name = shift; 379 my \$name = shift;
404 380
405 $attachment{$name} = [[KLASS_OBJECT, @_]];
406}
407
408sub register_player_attachment {
409 my $name = shift;
410
411 $attachment{$name} = [[KLASS_PLAYER, @_]];
412}
413
414sub register_client_attachment {
415 my $name = shift;
416
417 $attachment{$name} = [[KLASS_CLIENT, @_]];
418}
419
420sub register_map_attachment {
421 my $name = shift;
422
423 $attachment{$name} = [[KLASS_MAP, @_]]; 381 \$attachment{\$name} = [[KLASS_$klass, \@_]];
382 }
383 ";
384 die if $@;
424} 385}
425 386
426our $override; 387our $override;
427our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 388our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
428 389
… …
474 435
475=cut 436=cut
476 437
477############################################################################# 438#############################################################################
478 439
479=head2 METHODS VALID FOR ALL CORE OBJECTS 440=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
441
442Attachable objects includes objects, players, clients and maps.
480 443
481=over 4 444=over 4
482 445
483=item $object->valid, $player->valid, $client->valid, $map->valid 446=item $object->valid
484 447
485Just because you have a perl object does not mean that the corresponding 448Just because you have a perl object does not mean that the corresponding
486C-level object still exists. If you try to access an object that has no 449C-level object still exists. If you try to access an object that has no
487valid C counterpart anymore you get an exception at runtime. This method 450valid C counterpart anymore you get an exception at runtime. This method
488can be used to test for existence of the C object part without causing an 451can be used to test for existence of the C object part without causing an
… …
490 453
491=back 454=back
492 455
493=cut 456=cut
494 457
495*cf::object::valid =
496*cf::player::valid =
497*cf::client::valid =
498*cf::map::valid = \&cf::_valid;
499
500############################################################################# 458#############################################################################
501# object support 459# object support
502 460
503sub instantiate { 461sub instantiate {
504 my ($obj, $data) = @_; 462 my ($obj, $data) = @_;
… …
523 481
524 for my $name (keys %{ $obj->{_attachment} || {} }) { 482 for my $name (keys %{ $obj->{_attachment} || {} }) {
525 if (my $attach = $attachment{$name}) { 483 if (my $attach = $attachment{$name}) {
526 for (@$attach) { 484 for (@$attach) {
527 my ($klass, @attach) = @$_; 485 my ($klass, @attach) = @$_;
528 _attach @$registry, $klass, @attach; 486 _attach $registry, $klass, @attach;
529 } 487 }
530 } else { 488 } else {
531 warn "object uses attachment '$name' that is not available, postponing.\n"; 489 warn "object uses attachment '$name' that is not available, postponing.\n";
532 } 490 }
533 } 491 }
… …
589 } 547 }
590 548
591 () 549 ()
592} 550}
593 551
594attach_to_objects 552cf::object->attach (
595 prio => -1000000, 553 prio => -1000000,
596 on_clone => sub { 554 on_clone => sub {
597 my ($src, $dst) = @_; 555 my ($src, $dst) = @_;
598 556
599 @{$dst->registry} = @{$src->registry}; 557 @{$dst->registry} = @{$src->registry};
… …
601 %$dst = %$src; 559 %$dst = %$src;
602 560
603 %{$dst->{_attachment}} = %{$src->{_attachment}} 561 %{$dst->{_attachment}} = %{$src->{_attachment}}
604 if exists $src->{_attachment}; 562 if exists $src->{_attachment};
605 }, 563 },
606; 564);
607 565
608############################################################################# 566#############################################################################
609# command handling &c 567# command handling &c
610 568
611=item cf::register_command $name => \&callback($ob,$args); 569=item cf::register_command $name => \&callback($ob,$args);
… …
640 #warn "registering extcmd '$name' to '$caller'"; 598 #warn "registering extcmd '$name' to '$caller'";
641 599
642 $EXTCMD{$name} = [$cb, $caller]; 600 $EXTCMD{$name} = [$cb, $caller];
643} 601}
644 602
645attach_to_players 603cf::player->attach (
646 on_command => sub { 604 on_command => sub {
647 my ($pl, $name, $params) = @_; 605 my ($pl, $name, $params) = @_;
648 606
649 my $cb = $COMMAND{$name} 607 my $cb = $COMMAND{$name}
650 or return; 608 or return;
… …
670 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 628 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
671 } 629 }
672 630
673 cf::override; 631 cf::override;
674 }, 632 },
675; 633);
676 634
677sub register { 635sub register {
678 my ($base, $pkg) = @_; 636 my ($base, $pkg) = @_;
679 637
680 #TODO 638 #TODO
… …
770 defined $path or return; 728 defined $path or return;
771 729
772 unlink "$path.pst"; 730 unlink "$path.pst";
773}; 731};
774 732
775attach_to_maps prio => -10000, package => cf::mapsupport::; 733cf::map->attach (prio => -10000, package => cf::mapsupport::);
776 734
777############################################################################# 735#############################################################################
778# load/save perl data associated with player->ob objects 736# load/save perl data associated with player->ob objects
779 737
780sub all_objects(@) { 738sub all_objects(@) {
781 @_, map all_objects ($_->inv), @_ 739 @_, map all_objects ($_->inv), @_
782} 740}
783 741
784# TODO: compatibility cruft, remove when no longer needed 742# TODO: compatibility cruft, remove when no longer needed
785attach_to_players 743cf::player->attach (
786 on_load => sub { 744 on_load => sub {
787 my ($pl, $path) = @_; 745 my ($pl, $path) = @_;
788 746
789 for my $o (all_objects $pl->ob) { 747 for my $o (all_objects $pl->ob) {
790 if (my $value = $o->get_ob_key_value ("_perl_data")) { 748 if (my $value = $o->get_ob_key_value ("_perl_data")) {
… …
792 750
793 %$o = %{ Storable::thaw pack "H*", $value }; 751 %$o = %{ Storable::thaw pack "H*", $value };
794 } 752 }
795 } 753 }
796 }, 754 },
797; 755);
798 756
799############################################################################# 757#############################################################################
800 758
801=head2 CORE EXTENSIONS 759=head2 CORE EXTENSIONS
802 760
… …
1078 $DB->{$_[0]} = $_[1]; 1036 $DB->{$_[0]} = $_[1];
1079 } 1037 }
1080 db_dirty; 1038 db_dirty;
1081 } 1039 }
1082 1040
1083 attach_global 1041 cf::global->attach (
1084 prio => 10000, 1042 prio => 10000,
1085 on_cleanup => sub { 1043 on_cleanup => sub {
1086 db_sync; 1044 db_sync;
1087 }, 1045 },
1088 ; 1046 );
1089} 1047}
1090 1048
1091############################################################################# 1049#############################################################################
1092# the server's main() 1050# the server's main()
1093 1051

Diff Legend

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