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.85 by root, Mon Dec 11 22:56:57 2006 UTC vs.
Revision 1.95 by root, Fri Dec 22 02:04:20 2006 UTC

… …
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1; 17$YAML::Syck::ImplicitUnicode = 1;
18 18
19use strict; 19use strict;
20 20
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
21our %COMMAND = (); 23our %COMMAND = ();
22our %COMMAND_TIME = (); 24our %COMMAND_TIME = ();
23our %EXTCMD = (); 25our %EXTCMD = ();
24 26
25_init_vars; 27_init_vars;
26 28
27our @EVENT; 29our @EVENT;
28our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
29 31
30our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
31our $TICK_WATCHER; 33our $TICK_WATCHER;
32our $NEXT_TICK; 34our $NEXT_TICK;
33 35
… …
72 print STDERR "cfperl: $msg"; 74 print STDERR "cfperl: $msg";
73 LOG llevError, "cfperl: $msg"; 75 LOG llevError, "cfperl: $msg";
74 }; 76 };
75} 77}
76 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';
77@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 84@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
78 85
79# 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
80# within the Safe compartment. 87# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 88for my $pkg (qw(
89 cf::global
90 cf::object cf::object::player
91 cf::client cf::player
92 cf::arch cf::living
93 cf::map cf::party cf::region
94)) {
82 no strict 'refs'; 95 no strict 'refs';
83 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 96 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 97}
85 98
86$Event::DIED = sub { 99$Event::DIED = sub {
… …
125 138
126=cut 139=cut
127 140
128############################################################################# 141#############################################################################
129 142
130=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+).
131 152
132=over 4 153=over 4
133 154
134=item $object->attach ($attachment, key => $value...)
135
136=item $object->detach ($attachment)
137
138Attach/detach a pre-registered attachment to an object.
139
140=item $player->attach ($attachment, key => $value...)
141
142=item $player->detach ($attachment)
143
144Attach/detach a pre-registered attachment to a player.
145
146=item $map->attach ($attachment, key => $value...) 155=item $attachable->attach ($attachment, key => $value...)
147 156
148=item $map->detach ($attachment) 157=item $attachable->detach ($attachment)
149 158
150Attach/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.
151 161
152=item $bool = $object->attached ($name) 162Example, attach a minesweeper attachment to the given object, making it a
16310x10 minesweeper game:
153 164
154=item $bool = $player->attached ($name) 165 $obj->attach (minesweeper => width => 10, height => 10);
155 166
156=item $bool = $map->attached ($name) 167=item $bool = $attachable->attached ($name)
157 168
158Checks wether the named attachment is currently attached to the object. 169Checks wether the named attachment is currently attached to the object.
159 170
160=item cf::attach_global ... 171=item cf::CLASS->attach ...
161 172
162Attach handlers for global events. 173=item cf::CLASS->detach ...
163 174
164This and all following C<attach_*>-functions expect any number of the 175Define an anonymous attachment and attach it to all objects of the given
165following 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:
166 209
167=over 4 210=over 4
168 211
169=item prio => $number 212=item prio => $number
170 213
… …
172by another C<prio> setting). Lower priority handlers get executed 215by another C<prio> setting). Lower priority handlers get executed
173earlier. 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
174registered at priority C<-1000>, so lower priorities should not be used 217registered at priority C<-1000>, so lower priorities should not be used
175unless you know what you are doing. 218unless you know what you are doing.
176 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
177=item on_I<event> => \&cb 226=item on_I<event> => \&cb
178 227
179Call the given code reference whenever the named event happens (event is 228Call the given code reference whenever the named event happens (event is
180something 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
181handlers are recognised generally depends on the type of object these 230handlers are recognised generally depends on the type of object these
… …
190package and register them. Only handlers for eevents supported by the 239package and register them. Only handlers for eevents supported by the
191object/class are recognised. 240object/class are recognised.
192 241
193=back 242=back
194 243
195=item cf::attach_to_type $object_type, $subtype, ... 244Example, define an attachment called "sockpuppet" that calls the given
245event handler when a monster attacks:
196 246
197Attach handlers for a specific object type (e.g. TRANSPORT) and 247 cf::object::attachment sockpuppet =>
198subtype. If C<$subtype> is zero or undef, matches all objects of the given 248 on_skill_attack => sub {
199type. 249 my ($self, $victim) = @_;
200 250 ...
201=item cf::attach_to_objects ... 251 }
202 252 }
203Attach handlers to all objects. Do not use this except for debugging or
204very rare events, as handlers are (obviously) called for I<all> objects in
205the game.
206
207=item cf::attach_to_players ...
208
209Attach handlers to all players.
210
211=item cf::attach_to_maps ...
212
213Attach handlers to all maps.
214
215=item cf:register_attachment $name, ...
216
217Register an attachment by name through which objects can refer to this
218attachment.
219
220=item cf:register_player_attachment $name, ...
221
222Register an attachment by name through which players can refer to this
223attachment.
224
225=item cf:register_map_attachment $name, ...
226
227Register an attachment by name through which maps can refer to this
228attachment.
229 253
230=cut 254=cut
231 255
232# 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
233our @CB_GLOBAL = (); # registry for all global events 257our @CB_GLOBAL = (); # registry for all global events
234our @CB_OBJECT = (); # all objects (should not be used except in emergency) 258our @CB_OBJECT = (); # all objects (should not be used except in emergency)
235our @CB_PLAYER = (); 259our @CB_PLAYER = ();
260our @CB_CLIENT = ();
236our @CB_TYPE = (); # registry for type (cf-object class) based events 261our @CB_TYPE = (); # registry for type (cf-object class) based events
237our @CB_MAP = (); 262our @CB_MAP = ();
238 263
239my %attachment; 264my %attachment;
240 265
241sub _attach_cb($\%$$$) { 266sub _attach_cb($$$$) {
242 my ($registry, $undo, $event, $prio, $cb) = @_; 267 my ($registry, $event, $prio, $cb) = @_;
243 268
244 use sort 'stable'; 269 use sort 'stable';
245 270
246 $cb = [$prio, $cb]; 271 $cb = [$prio, $cb];
247 272
248 @{$registry->[$event]} = sort 273 @{$registry->[$event]} = sort
249 { $a->[0] cmp $b->[0] } 274 { $a->[0] cmp $b->[0] }
250 @{$registry->[$event] || []}, $cb; 275 @{$registry->[$event] || []}, $cb;
251
252 push @{$undo->{cb}}, [$event, $cb];
253} 276}
254 277
255# attach handles attaching event callbacks 278# attach handles attaching event callbacks
256# 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
257# registry (== where the callback attaches to). 280# registry (== where the callback attaches to).
258sub _attach(\@$@) { 281sub _attach {
259 my ($registry, $klass, @arg) = @_; 282 my ($registry, $klass, @arg) = @_;
260 283
284 my $object_type;
261 my $prio = 0; 285 my $prio = 0;
262
263 my %undo = (
264 registry => $registry,
265 cb => [],
266 );
267
268 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;
269 287
270 while (@arg) { 288 while (@arg) {
271 my $type = shift @arg; 289 my $type = shift @arg;
272 290
273 if ($type eq "prio") { 291 if ($type eq "prio") {
274 $prio = shift @arg; 292 $prio = shift @arg;
275 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
276 } elsif ($type eq "package") { 303 } elsif ($type eq "package") {
277 my $pkg = shift @arg; 304 my $pkg = shift @arg;
278 305
279 while (my ($name, $id) = each %cb_id) { 306 while (my ($name, $id) = each %cb_id) {
280 if (my $cb = $pkg->can ($name)) { 307 if (my $cb = $pkg->can ($name)) {
281 _attach_cb $registry, %undo, $id, $prio, $cb; 308 _attach_cb $registry, $id, $prio, $cb;
282 } 309 }
283 } 310 }
284 311
285 } elsif (exists $cb_id{$type}) { 312 } elsif (exists $cb_id{$type}) {
286 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg; 313 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
287 314
288 } elsif (ref $type) { 315 } elsif (ref $type) {
289 warn "attaching objects not supported, ignoring.\n"; 316 warn "attaching objects not supported, ignoring.\n";
290 317
291 } else { 318 } else {
292 shift @arg; 319 shift @arg;
293 warn "attach argument '$type' not supported, ignoring.\n"; 320 warn "attach argument '$type' not supported, ignoring.\n";
294 } 321 }
295 } 322 }
296
297 \%undo
298} 323}
299 324
300sub _attach_attachment { 325sub _object_attach {
301 my ($obj, $name, %arg) = @_; 326 my ($obj, $name, %arg) = @_;
302 327
303 return if exists $obj->{_attachment}{$name}; 328 return if exists $obj->{_attachment}{$name};
304
305 my $res;
306 329
307 if (my $attach = $attachment{$name}) { 330 if (my $attach = $attachment{$name}) {
308 my $registry = $obj->registry; 331 my $registry = $obj->registry;
309 332
310 for (@$attach) { 333 for (@$attach) {
311 my ($klass, @attach) = @$_; 334 my ($klass, @attach) = @$_;
312 $res = _attach @$registry, $klass, @attach; 335 _attach $registry, $klass, @attach;
313 } 336 }
314 337
315 $obj->{$name} = \%arg; 338 $obj->{$name} = \%arg;
316 } else { 339 } else {
317 warn "object uses attachment '$name' that is not available, postponing.\n"; 340 warn "object uses attachment '$name' that is not available, postponing.\n";
318 } 341 }
319 342
320 $obj->{_attachment}{$name} = undef; 343 $obj->{_attachment}{$name} = undef;
321
322 $res->{attachment} = $name;
323 $res
324} 344}
325 345
326*cf::object::attach = 346sub cf::attachable::attach {
327*cf::player::attach = 347 if (ref $_[0]) {
328*cf::map::attach = sub { 348 _object_attach @_;
329 my ($obj, $name, %arg) = @_; 349 } else {
330 350 _attach shift->_attach_registry, @_;
331 _attach_attachment $obj, $name, %arg; 351 }
332}; 352};
333 353
334# all those should be optimised 354# all those should be optimised
335*cf::object::detach = 355sub cf::attachable::detach {
336*cf::player::detach =
337*cf::map::detach = sub {
338 my ($obj, $name) = @_; 356 my ($obj, $name) = @_;
339 357
358 if (ref $obj) {
340 delete $obj->{_attachment}{$name}; 359 delete $obj->{_attachment}{$name};
341 reattach ($obj); 360 reattach ($obj);
361 } else {
362 Carp::croak "cannot, currently, detach class attachments";
363 }
342}; 364};
343 365
344*cf::object::attached = 366sub cf::attachable::attached {
345*cf::player::attached =
346*cf::map::attached = sub {
347 my ($obj, $name) = @_; 367 my ($obj, $name) = @_;
348 368
349 exists $obj->{_attachment}{$name} 369 exists $obj->{_attachment}{$name}
350};
351
352sub attach_global {
353 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
354} 370}
355 371
356sub attach_to_type { 372for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {
357 my $type = shift; 373 eval "#line " . __LINE__ . " 'cf.pm'
358 my $subtype = shift; 374 sub cf::\L$klass\E::_attach_registry {
375 (\\\@CB_$klass, KLASS_$klass)
376 }
359 377
360 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_ 378 sub cf::\L$klass\E::attachment {
361}
362
363sub attach_to_objects {
364 _attach @CB_OBJECT, KLASS_OBJECT, @_
365}
366
367sub attach_to_players {
368 _attach @CB_PLAYER, KLASS_PLAYER, @_
369}
370
371sub attach_to_maps {
372 _attach @CB_MAP, KLASS_MAP, @_
373}
374
375sub register_attachment {
376 my $name = shift; 379 my \$name = shift;
377 380
378 $attachment{$name} = [[KLASS_OBJECT, @_]];
379}
380
381sub register_player_attachment {
382 my $name = shift;
383
384 $attachment{$name} = [[KLASS_PLAYER, @_]];
385}
386
387sub register_map_attachment {
388 my $name = shift;
389
390 $attachment{$name} = [[KLASS_MAP, @_]]; 381 \$attachment{\$name} = [[KLASS_$klass, \@_]];
382 }
383 ";
384 die if $@;
391} 385}
392 386
393our $override; 387our $override;
394our @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?
395 389
… …
425 419
426=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 420=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
427 421
428=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 422=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
429 423
424=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
425
430=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 426=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
431 427
432Generate a global/object/player/map-specific event with the given arguments. 428Generate a global/object/player/map-specific event with the given arguments.
433 429
434This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 430This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
… …
439 435
440=cut 436=cut
441 437
442############################################################################# 438#############################################################################
443 439
444=head2 METHODS VALID FOR ALL CORE OBJECTS 440=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
441
442Attachable objects includes objects, players, clients and maps.
445 443
446=over 4 444=over 4
447 445
448=item $object->valid, $player->valid, $map->valid 446=item $object->valid
449 447
450Just 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
451C-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
452valid C counterpart anymore you get an exception at runtime. This method 450valid C counterpart anymore you get an exception at runtime. This method
453can 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
… …
455 453
456=back 454=back
457 455
458=cut 456=cut
459 457
460*cf::object::valid =
461*cf::player::valid =
462*cf::map::valid = \&cf::_valid;
463
464############################################################################# 458#############################################################################
465# object support 459# object support
466 460
467sub instantiate { 461sub instantiate {
468 my ($obj, $data) = @_; 462 my ($obj, $data) = @_;
… …
487 481
488 for my $name (keys %{ $obj->{_attachment} || {} }) { 482 for my $name (keys %{ $obj->{_attachment} || {} }) {
489 if (my $attach = $attachment{$name}) { 483 if (my $attach = $attachment{$name}) {
490 for (@$attach) { 484 for (@$attach) {
491 my ($klass, @attach) = @$_; 485 my ($klass, @attach) = @$_;
492 _attach @$registry, $klass, @attach; 486 _attach $registry, $klass, @attach;
493 } 487 }
494 } else { 488 } else {
495 warn "object uses attachment '$name' that is not available, postponing.\n"; 489 warn "object uses attachment '$name' that is not available, postponing.\n";
496 } 490 }
497 } 491 }
… …
553 } 547 }
554 548
555 () 549 ()
556} 550}
557 551
558attach_to_objects 552cf::object->attach (
559 prio => -1000000, 553 prio => -1000000,
560 on_clone => sub { 554 on_clone => sub {
561 my ($src, $dst) = @_; 555 my ($src, $dst) = @_;
562 556
563 @{$dst->registry} = @{$src->registry}; 557 @{$dst->registry} = @{$src->registry};
… …
565 %$dst = %$src; 559 %$dst = %$src;
566 560
567 %{$dst->{_attachment}} = %{$src->{_attachment}} 561 %{$dst->{_attachment}} = %{$src->{_attachment}}
568 if exists $src->{_attachment}; 562 if exists $src->{_attachment};
569 }, 563 },
570; 564);
571 565
572############################################################################# 566#############################################################################
573# command handling &c 567# command handling &c
574 568
575=item cf::register_command $name => \&callback($ob,$args); 569=item cf::register_command $name => \&callback($ob,$args);
… …
604 #warn "registering extcmd '$name' to '$caller'"; 598 #warn "registering extcmd '$name' to '$caller'";
605 599
606 $EXTCMD{$name} = [$cb, $caller]; 600 $EXTCMD{$name} = [$cb, $caller];
607} 601}
608 602
609attach_to_players 603cf::player->attach (
610 on_command => sub { 604 on_command => sub {
611 my ($pl, $name, $params) = @_; 605 my ($pl, $name, $params) = @_;
612 606
613 my $cb = $COMMAND{$name} 607 my $cb = $COMMAND{$name}
614 or return; 608 or return;
… …
634 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 628 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
635 } 629 }
636 630
637 cf::override; 631 cf::override;
638 }, 632 },
639; 633);
640 634
641sub register { 635sub register {
642 my ($base, $pkg) = @_; 636 my ($base, $pkg) = @_;
643 637
644 #TODO 638 #TODO
… …
713 707
714 Symbol::delete_package $pkg; 708 Symbol::delete_package $pkg;
715} 709}
716 710
717sub load_extensions { 711sub load_extensions {
718 my $LIBDIR = maps_directory "perl";
719
720 for my $ext (<$LIBDIR/*.ext>) { 712 for my $ext (<$LIBDIR/*.ext>) {
721 next unless -r $ext; 713 next unless -r $ext;
722 eval { 714 eval {
723 load_extension $ext; 715 load_extension $ext;
724 1 716 1
… …
736 defined $path or return; 728 defined $path or return;
737 729
738 unlink "$path.pst"; 730 unlink "$path.pst";
739}; 731};
740 732
741attach_to_maps prio => -10000, package => cf::mapsupport::; 733cf::map->attach (prio => -10000, package => cf::mapsupport::);
742 734
743############################################################################# 735#############################################################################
744# load/save perl data associated with player->ob objects 736# load/save perl data associated with player->ob objects
745 737
746sub all_objects(@) { 738sub all_objects(@) {
747 @_, map all_objects ($_->inv), @_ 739 @_, map all_objects ($_->inv), @_
748} 740}
749 741
750# TODO: compatibility cruft, remove when no longer needed 742# TODO: compatibility cruft, remove when no longer needed
751attach_to_players 743cf::player->attach (
752 on_load => sub { 744 on_load => sub {
753 my ($pl, $path) = @_; 745 my ($pl, $path) = @_;
754 746
755 for my $o (all_objects $pl->ob) { 747 for my $o (all_objects $pl->ob) {
756 if (my $value = $o->get_ob_key_value ("_perl_data")) { 748 if (my $value = $o->get_ob_key_value ("_perl_data")) {
… …
758 750
759 %$o = %{ Storable::thaw pack "H*", $value }; 751 %$o = %{ Storable::thaw pack "H*", $value };
760 } 752 }
761 } 753 }
762 }, 754 },
763; 755);
764 756
765############################################################################# 757#############################################################################
766 758
767=head2 CORE EXTENSIONS 759=head2 CORE EXTENSIONS
768 760
769Functions and methods that extend core crossfire objects. 761Functions and methods that extend core crossfire objects.
762
763=head3 cf::player
770 764
771=over 4 765=over 4
772 766
773=item cf::player::exists $login 767=item cf::player::exists $login
774 768
… …
779sub cf::player::exists($) { 773sub cf::player::exists($) {
780 cf::player::find $_[0] 774 cf::player::find $_[0]
781 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 775 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
782} 776}
783 777
778=item $player->ext_reply ($msgid, $msgtype, %msg)
779
780Sends an ext reply to the player.
781
782=cut
783
784sub cf::player::ext_reply($$$%) {
785 my ($self, $id, %msg) = @_;
786
787 $msg{msgid} = $id;
788
789 $self->send ("ext " . to_json \%msg);
790}
791
792=back
793
794=head3 cf::object::player
795
796=over 4
797
784=item $player_object->reply ($npc, $msg[, $flags]) 798=item $player_object->reply ($npc, $msg[, $flags])
785 799
786Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 800Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
787can be C<undef>. Does the right thing when the player is currently in a 801can be C<undef>. Does the right thing when the player is currently in a
788dialogue with the given NPC character. 802dialogue with the given NPC character.
789 803
790=cut 804=cut
791 805
792# rough implementation of a future "reply" method that works 806# rough implementation of a future "reply" method that works
793# with dialog boxes. 807# with dialog boxes.
808#TODO: the first argument must go, split into a $npc->reply_to ( method
794sub cf::object::player::reply($$$;$) { 809sub cf::object::player::reply($$$;$) {
795 my ($self, $npc, $msg, $flags) = @_; 810 my ($self, $npc, $msg, $flags) = @_;
796 811
797 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 812 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
798 813
… …
802 $msg = $npc->name . " says: $msg" if $npc; 817 $msg = $npc->name . " says: $msg" if $npc;
803 $self->message ($msg, $flags); 818 $self->message ($msg, $flags);
804 } 819 }
805} 820}
806 821
807=item $player->ext_reply ($msgid, $msgtype, %msg)
808
809Sends an ext reply to the player.
810
811=cut
812
813sub cf::player::ext_reply($$$%) {
814 my ($self, $id, %msg) = @_;
815
816 $msg{msgid} = $id;
817
818 $self->send ("ext " . to_json \%msg);
819}
820
821=item $player_object->may ("access") 822=item $player_object->may ("access")
822 823
823Returns wether the given player is authorized to access resource "access" 824Returns wether the given player is authorized to access resource "access"
824(e.g. "command_wizcast"). 825(e.g. "command_wizcast").
825 826
… …
832 (ref $cf::CFG{"may_$access"} 833 (ref $cf::CFG{"may_$access"}
833 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 834 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
834 : $cf::CFG{"may_$access"}) 835 : $cf::CFG{"may_$access"})
835} 836}
836 837
837=cut 838=head3 cf::client
838 839
839############################################################################# 840=over 4
841
842=item $client->send_drawinfo ($text, $flags)
843
844Sends a drawinfo packet to the client. Circumvents output buffering so
845should not be used under normal circumstances.
846
847=cut
848
849sub cf::client::send_drawinfo {
850 my ($self, $text, $flags) = @_;
851
852 utf8::encode $text;
853 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
854}
855
856
857=item $success = $client->query ($flags, "text", \&cb)
858
859Queues a query to the client, calling the given callback with
860the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
861C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
862
863Queries can fail, so check the return code. Or don't, as queries will become
864reliable at some point in the future.
865
866=cut
867
868sub cf::client::query {
869 my ($self, $flags, $text, $cb) = @_;
870
871 return unless $self->state == ST_PLAYING
872 || $self->state == ST_SETUP
873 || $self->state == ST_CUSTOM;
874
875 $self->state (ST_CUSTOM);
876
877 utf8::encode $text;
878 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
879
880 $self->send_packet ($self->{query_queue}[0][0])
881 if @{ $self->{query_queue} } == 1;
882}
883
884cf::client->attach (
885 on_reply => sub {
886 my ($ns, $msg) = @_;
887
888 # this weird shuffling is so that direct followup queries
889 # get handled first
890 my $queue = delete $ns->{query_queue};
891
892 (shift @$queue)->[1]->($msg);
893
894 push @{ $ns->{query_queue} }, @$queue;
895
896 if (@{ $ns->{query_queue} } == @$queue) {
897 if (@$queue) {
898 $ns->send_packet ($ns->{query_queue}[0][0]);
899 } else {
900 $ns->state (ST_PLAYING);
901 }
902 }
903 },
904);
905
906=back
907
840 908
841=head2 SAFE SCRIPTING 909=head2 SAFE SCRIPTING
842 910
843Functions that provide a safe environment to compile and execute 911Functions that provide a safe environment to compile and execute
844snippets of perl code without them endangering the safety of the server 912snippets of perl code without them endangering the safety of the server
… …
859 927
860=pod 928=pod
861 929
862The following fucntions and emthods are available within a safe environment: 930The following fucntions and emthods are available within a safe environment:
863 931
864 cf::object contr pay_amount pay_player 932 cf::object contr pay_amount pay_player map
865 cf::object::player player 933 cf::object::player player
866 cf::player peaceful 934 cf::player peaceful
935 cf::map trigger
867 936
868=cut 937=cut
869 938
870for ( 939for (
871 ["cf::object" => qw(contr pay_amount pay_player)], 940 ["cf::object" => qw(contr pay_amount pay_player map)],
872 ["cf::object::player" => qw(player)], 941 ["cf::object::player" => qw(player)],
873 ["cf::player" => qw(peaceful)], 942 ["cf::player" => qw(peaceful)],
943 ["cf::map" => qw(trigger)],
874) { 944) {
875 no strict 'refs'; 945 no strict 'refs';
876 my ($pkg, @funs) = @$_; 946 my ($pkg, @funs) = @$_;
877 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 947 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
878 for @funs; 948 for @funs;
… …
1018 sub db_sync() { 1088 sub db_sync() {
1019 db_save if $dirty; 1089 db_save if $dirty;
1020 undef $dirty; 1090 undef $dirty;
1021 } 1091 }
1022 1092
1023 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1093 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1024 db_sync; 1094 db_sync;
1025 }); 1095 });
1026 1096
1027 sub db_dirty() { 1097 sub db_dirty() {
1028 $dirty = 1; 1098 $dirty = 1;
… …
1042 $DB->{$_[0]} = $_[1]; 1112 $DB->{$_[0]} = $_[1];
1043 } 1113 }
1044 db_dirty; 1114 db_dirty;
1045 } 1115 }
1046 1116
1047 attach_global 1117 cf::global->attach (
1048 prio => 10000, 1118 prio => 10000,
1049 on_cleanup => sub { 1119 on_cleanup => sub {
1050 db_sync; 1120 db_sync;
1051 }, 1121 },
1052 ; 1122 );
1053} 1123}
1054 1124
1055############################################################################# 1125#############################################################################
1056# the server's main() 1126# the server's main()
1057 1127
… …
1078 1148
1079 $msg->("reloading..."); 1149 $msg->("reloading...");
1080 1150
1081 eval { 1151 eval {
1082 # cancel all watchers 1152 # cancel all watchers
1083 $_->cancel for Event::all_watchers; 1153 for (Event::all_watchers) {
1154 $_->cancel if $_->data & WF_AUTOCANCEL;
1155 }
1084 1156
1085 # unload all extensions 1157 # unload all extensions
1086 for (@exts) { 1158 for (@exts) {
1087 $msg->("unloading <$_>"); 1159 $msg->("unloading <$_>");
1088 unload_extension $_; 1160 unload_extension $_;
… …
1164}; 1236};
1165 1237
1166unshift @INC, $LIBDIR; 1238unshift @INC, $LIBDIR;
1167 1239
1168$TICK_WATCHER = Event->timer ( 1240$TICK_WATCHER = Event->timer (
1169 prio => 1, 1241 prio => 0,
1170 async => 1,
1171 at => $NEXT_TICK || 1, 1242 at => $NEXT_TICK || 1,
1243 data => WF_AUTOCANCEL,
1172 cb => sub { 1244 cb => sub {
1173 cf::server_tick; # one server iteration 1245 cf::server_tick; # one server iteration
1174 1246
1175 my $NOW = Event::time; 1247 my $NOW = Event::time;
1176 $NEXT_TICK += $TICK; 1248 $NEXT_TICK += $TICK;
… …
1186IO::AIO::max_poll_time $TICK * 0.2; 1258IO::AIO::max_poll_time $TICK * 0.2;
1187 1259
1188Event->io (fd => IO::AIO::poll_fileno, 1260Event->io (fd => IO::AIO::poll_fileno,
1189 poll => 'r', 1261 poll => 'r',
1190 prio => 5, 1262 prio => 5,
1263 data => WF_AUTOCANCEL,
1191 cb => \&IO::AIO::poll_cb); 1264 cb => \&IO::AIO::poll_cb);
1192 1265
11931 12661
1194 1267

Diff Legend

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