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.99 by root, Sat Dec 23 05:25:35 2006 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
5use Storable; 8use Storable;
6use Opcode; 9use Opcode;
7use Safe; 10use Safe;
8use Safe::Hole; 11use Safe::Hole;
9 12
13use Coro;
14use Coro::Event;
15use Coro::Timer;
16use Coro::Signal;
17use Coro::Semaphore;
18
10use IO::AIO (); 19use IO::AIO 2.3;
11use YAML::Syck (); 20use YAML::Syck ();
12use Time::HiRes; 21use Time::HiRes;
13use Event; 22
14$Event::Eval = 1; # no idea why this is required, but it is 23use Event; $Event::Eval = 1; # no idea why this is required, but it is
15 24
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1; 26$YAML::Syck::ImplicitUnicode = 1;
18 27
19use strict; 28$Coro::main->prio (Coro::PRIO_MIN);
20 29
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22 31
23our %COMMAND = (); 32our %COMMAND = ();
24our %COMMAND_TIME = (); 33our %COMMAND_TIME = ();
… …
74 print STDERR "cfperl: $msg"; 83 print STDERR "cfperl: $msg";
75 LOG llevError, "cfperl: $msg"; 84 LOG llevError, "cfperl: $msg";
76 }; 85 };
77} 86}
78 87
88@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
89@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
90@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
91@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
92@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 93@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
80 94
81# we bless all objects into (empty) derived classes to force a method lookup 95# we bless all objects into (empty) derived classes to force a method lookup
82# within the Safe compartment. 96# within the Safe compartment.
83for my $pkg (qw( 97for my $pkg (qw(
98 cf::global
84 cf::object cf::object::player 99 cf::object cf::object::player
85 cf::client cf::player 100 cf::client cf::player
86 cf::arch cf::living 101 cf::arch cf::living
87 cf::map cf::party cf::region 102 cf::map cf::party cf::region
88)) { 103)) {
… …
132 147
133=cut 148=cut
134 149
135############################################################################# 150#############################################################################
136 151
137=head2 EVENTS AND OBJECT ATTACHMENTS 152=head2 ATTACHABLE OBJECTS
153
154Many objects in crossfire are so-called attachable objects. That means you can
155attach callbacks/event handlers (a collection of which is called an "attachment")
156to it. All such attachable objects support the following methods.
157
158In the following description, CLASS can be any of C<global>, C<object>
159C<player>, C<client> or C<map> (i.e. the attachable objects in
160crossfire+).
138 161
139=over 4 162=over 4
140 163
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...) 164=item $attachable->attach ($attachment, key => $value...)
160 165
161=item $client->detach ($attachment) 166=item $attachable->detach ($attachment)
162 167
163Attach/detach a pre-registered attachment to a map. 168Attach/detach a pre-registered attachment to a specific object and give it
169the specified key/value pairs as arguments.
164 170
165=item $bool = $object->attached ($name) 171Example, attach a minesweeper attachment to the given object, making it a
17210x10 minesweeper game:
166 173
167=item $bool = $player->attached ($name) 174 $obj->attach (minesweeper => width => 10, height => 10);
168 175
169=item $bool = $client->attached ($name) 176=item $bool = $attachable->attached ($name)
170
171=item $bool = $map->attached ($name)
172 177
173Checks wether the named attachment is currently attached to the object. 178Checks wether the named attachment is currently attached to the object.
174 179
175=item cf::attach_global ... 180=item cf::CLASS->attach ...
176 181
177Attach handlers for global events. 182=item cf::CLASS->detach ...
178 183
179This and all following C<attach_*>-functions expect any number of the 184Define an anonymous attachment and attach it to all objects of the given
180following handler/hook descriptions: 185CLASS. See the next function for an explanation of its arguments.
186
187You can attach to global events by using the C<cf::global> class.
188
189Example, log all player logins:
190
191 cf::player->attach (
192 on_login => sub {
193 my ($pl) = @_;
194 ...
195 },
196 );
197
198Example, attach to the jeweler skill:
199
200 cf::object->attach (
201 type => cf::SKILL,
202 subtype => cf::SK_JEWELER,
203 on_use_skill => sub {
204 my ($sk, $ob, $part, $dir, $msg) = @_;
205 ...
206 },
207 );
208
209=item cf::CLASS::attachment $name, ...
210
211Register an attachment by C<$name> through which attachable objects of the
212given CLASS can refer to this attachment.
213
214Some classes such as crossfire maps and objects can specify attachments
215that are attached at load/instantiate time, thus the need for a name.
216
217These calls expect any number of the following handler/hook descriptions:
181 218
182=over 4 219=over 4
183 220
184=item prio => $number 221=item prio => $number
185 222
… …
187by another C<prio> setting). Lower priority handlers get executed 224by another C<prio> setting). Lower priority handlers get executed
188earlier. The default priority is C<0>, and many built-in handlers are 225earlier. The default priority is C<0>, and many built-in handlers are
189registered at priority C<-1000>, so lower priorities should not be used 226registered at priority C<-1000>, so lower priorities should not be used
190unless you know what you are doing. 227unless you know what you are doing.
191 228
229=item type => $type
230
231(Only for C<< cf::object->attach >> calls), limits the attachment to the
232given type of objects only (the additional parameter C<subtype> can be
233used to further limit to the given subtype).
234
192=item on_I<event> => \&cb 235=item on_I<event> => \&cb
193 236
194Call the given code reference whenever the named event happens (event is 237Call 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 238something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
196handlers are recognised generally depends on the type of object these 239handlers are recognised generally depends on the type of object these
… …
205package and register them. Only handlers for eevents supported by the 248package and register them. Only handlers for eevents supported by the
206object/class are recognised. 249object/class are recognised.
207 250
208=back 251=back
209 252
210=item cf::attach_to_type $object_type, $subtype, ... 253Example, define an attachment called "sockpuppet" that calls the given
254event handler when a monster attacks:
211 255
212Attach handlers for a specific object type (e.g. TRANSPORT) and 256 cf::object::attachment sockpuppet =>
213subtype. If C<$subtype> is zero or undef, matches all objects of the given 257 on_skill_attack => sub {
214type. 258 my ($self, $victim) = @_;
259 ...
260 }
261 }
215 262
216=item cf::attach_to_objects ... 263=item $attachable->valid
217 264
218Attach handlers to all objects. Do not use this except for debugging or 265Just because you have a perl object does not mean that the corresponding
219very rare events, as handlers are (obviously) called for I<all> objects in 266C-level object still exists. If you try to access an object that has no
220the game. 267valid C counterpart anymore you get an exception at runtime. This method
221 268can be used to test for existence of the C object part without causing an
222=item cf::attach_to_players ... 269exception.
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 270
249=cut 271=cut
250 272
251# the following variables are defined in .xs and must not be re-created 273# the following variables are defined in .xs and must not be re-created
252our @CB_GLOBAL = (); # registry for all global events 274our @CB_GLOBAL = (); # registry for all global events
… …
256our @CB_TYPE = (); # registry for type (cf-object class) based events 278our @CB_TYPE = (); # registry for type (cf-object class) based events
257our @CB_MAP = (); 279our @CB_MAP = ();
258 280
259my %attachment; 281my %attachment;
260 282
261sub _attach_cb($\%$$$) { 283sub _attach_cb($$$$) {
262 my ($registry, $undo, $event, $prio, $cb) = @_; 284 my ($registry, $event, $prio, $cb) = @_;
263 285
264 use sort 'stable'; 286 use sort 'stable';
265 287
266 $cb = [$prio, $cb]; 288 $cb = [$prio, $cb];
267 289
268 @{$registry->[$event]} = sort 290 @{$registry->[$event]} = sort
269 { $a->[0] cmp $b->[0] } 291 { $a->[0] cmp $b->[0] }
270 @{$registry->[$event] || []}, $cb; 292 @{$registry->[$event] || []}, $cb;
271
272 push @{$undo->{cb}}, [$event, $cb];
273} 293}
274 294
275# attach handles attaching event callbacks 295# attach handles attaching event callbacks
276# the only thing the caller has to do is pass the correct 296# the only thing the caller has to do is pass the correct
277# registry (== where the callback attaches to). 297# registry (== where the callback attaches to).
278sub _attach(\@$@) { 298sub _attach {
279 my ($registry, $klass, @arg) = @_; 299 my ($registry, $klass, @arg) = @_;
280 300
301 my $object_type;
281 my $prio = 0; 302 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; 303 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
289 304
290 while (@arg) { 305 while (@arg) {
291 my $type = shift @arg; 306 my $type = shift @arg;
292 307
293 if ($type eq "prio") { 308 if ($type eq "prio") {
294 $prio = shift @arg; 309 $prio = shift @arg;
295 310
311 } elsif ($type eq "type") {
312 $object_type = shift @arg;
313 $registry = $CB_TYPE[$object_type] ||= [];
314
315 } elsif ($type eq "subtype") {
316 defined $object_type or Carp::croak "subtype specified without type";
317 my $object_subtype = shift @arg;
318 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
319
296 } elsif ($type eq "package") { 320 } elsif ($type eq "package") {
297 my $pkg = shift @arg; 321 my $pkg = shift @arg;
298 322
299 while (my ($name, $id) = each %cb_id) { 323 while (my ($name, $id) = each %cb_id) {
300 if (my $cb = $pkg->can ($name)) { 324 if (my $cb = $pkg->can ($name)) {
301 _attach_cb $registry, %undo, $id, $prio, $cb; 325 _attach_cb $registry, $id, $prio, $cb;
302 } 326 }
303 } 327 }
304 328
305 } elsif (exists $cb_id{$type}) { 329 } elsif (exists $cb_id{$type}) {
306 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg; 330 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
307 331
308 } elsif (ref $type) { 332 } elsif (ref $type) {
309 warn "attaching objects not supported, ignoring.\n"; 333 warn "attaching objects not supported, ignoring.\n";
310 334
311 } else { 335 } else {
312 shift @arg; 336 shift @arg;
313 warn "attach argument '$type' not supported, ignoring.\n"; 337 warn "attach argument '$type' not supported, ignoring.\n";
314 } 338 }
315 } 339 }
316
317 \%undo
318} 340}
319 341
320sub _attach_attachment { 342sub _object_attach {
321 my ($obj, $name, %arg) = @_; 343 my ($obj, $name, %arg) = @_;
322 344
323 return if exists $obj->{_attachment}{$name}; 345 return if exists $obj->{_attachment}{$name};
324
325 my $res;
326 346
327 if (my $attach = $attachment{$name}) { 347 if (my $attach = $attachment{$name}) {
328 my $registry = $obj->registry; 348 my $registry = $obj->registry;
329 349
330 for (@$attach) { 350 for (@$attach) {
331 my ($klass, @attach) = @$_; 351 my ($klass, @attach) = @$_;
332 $res = _attach @$registry, $klass, @attach; 352 _attach $registry, $klass, @attach;
333 } 353 }
334 354
335 $obj->{$name} = \%arg; 355 $obj->{$name} = \%arg;
336 } else { 356 } else {
337 warn "object uses attachment '$name' that is not available, postponing.\n"; 357 warn "object uses attachment '$name' that is not available, postponing.\n";
338 } 358 }
339 359
340 $obj->{_attachment}{$name} = undef; 360 $obj->{_attachment}{$name} = undef;
341
342 $res->{attachment} = $name;
343 $res
344} 361}
345 362
346*cf::object::attach = 363sub cf::attachable::attach {
347*cf::player::attach = 364 if (ref $_[0]) {
348*cf::client::attach = 365 _object_attach @_;
349*cf::map::attach = sub { 366 } else {
350 my ($obj, $name, %arg) = @_; 367 _attach shift->_attach_registry, @_;
351 368 }
352 _attach_attachment $obj, $name, %arg;
353}; 369};
354 370
355# all those should be optimised 371# all those should be optimised
356*cf::object::detach = 372sub cf::attachable::detach {
357*cf::player::detach =
358*cf::client::detach =
359*cf::map::detach = sub {
360 my ($obj, $name) = @_; 373 my ($obj, $name) = @_;
361 374
375 if (ref $obj) {
362 delete $obj->{_attachment}{$name}; 376 delete $obj->{_attachment}{$name};
363 reattach ($obj); 377 reattach ($obj);
378 } else {
379 Carp::croak "cannot, currently, detach class attachments";
380 }
364}; 381};
365 382
366*cf::object::attached = 383sub cf::attachable::attached {
367*cf::player::attached =
368*cf::client::attached =
369*cf::map::attached = sub {
370 my ($obj, $name) = @_; 384 my ($obj, $name) = @_;
371 385
372 exists $obj->{_attachment}{$name} 386 exists $obj->{_attachment}{$name}
373};
374
375sub attach_global {
376 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
377} 387}
378 388
379sub attach_to_type { 389for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {
380 my $type = shift; 390 eval "#line " . __LINE__ . " 'cf.pm'
381 my $subtype = shift; 391 sub cf::\L$klass\E::_attach_registry {
392 (\\\@CB_$klass, KLASS_$klass)
393 }
382 394
383 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_ 395 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; 396 my \$name = shift;
404 397
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, @_]]; 398 \$attachment{\$name} = [[KLASS_$klass, \@_]];
399 }
400 ";
401 die if $@;
424} 402}
425 403
426our $override; 404our $override;
427our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 405our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
428 406
… …
452 } 430 }
453 431
454 0 432 0
455} 433}
456 434
457=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... 435=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
458 436
459=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
460
461=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
462
463=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...) 437=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
464 438
465=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
466
467Generate a global/object/player/map-specific event with the given arguments. 439Generate an object-specific event with the given arguments.
468 440
469This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 441This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
470removed in future versions), and there is no public API to access override 442removed in future versions), and there is no public API to access override
471results (if you must, access C<@cf::invoke_results> directly). 443results (if you must, access C<@cf::invoke_results> directly).
472 444
473=back 445=back
474 446
475=cut 447=cut
476
477#############################################################################
478
479=head2 METHODS VALID FOR ALL CORE OBJECTS
480
481=over 4
482
483=item $object->valid, $player->valid, $client->valid, $map->valid
484
485Just 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
487valid 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
489exception.
490
491=back
492
493=cut
494
495*cf::object::valid =
496*cf::player::valid =
497*cf::client::valid =
498*cf::map::valid = \&cf::_valid;
499 448
500############################################################################# 449#############################################################################
501# object support 450# object support
502 451
503sub instantiate { 452sub instantiate {
… …
523 472
524 for my $name (keys %{ $obj->{_attachment} || {} }) { 473 for my $name (keys %{ $obj->{_attachment} || {} }) {
525 if (my $attach = $attachment{$name}) { 474 if (my $attach = $attachment{$name}) {
526 for (@$attach) { 475 for (@$attach) {
527 my ($klass, @attach) = @$_; 476 my ($klass, @attach) = @$_;
528 _attach @$registry, $klass, @attach; 477 _attach $registry, $klass, @attach;
529 } 478 }
530 } else { 479 } else {
531 warn "object uses attachment '$name' that is not available, postponing.\n"; 480 warn "object uses attachment '$name' that is not available, postponing.\n";
532 } 481 }
533 } 482 }
… …
589 } 538 }
590 539
591 () 540 ()
592} 541}
593 542
594attach_to_objects 543cf::object->attach (
595 prio => -1000000, 544 prio => -1000000,
596 on_clone => sub { 545 on_clone => sub {
597 my ($src, $dst) = @_; 546 my ($src, $dst) = @_;
598 547
599 @{$dst->registry} = @{$src->registry}; 548 @{$dst->registry} = @{$src->registry};
… …
601 %$dst = %$src; 550 %$dst = %$src;
602 551
603 %{$dst->{_attachment}} = %{$src->{_attachment}} 552 %{$dst->{_attachment}} = %{$src->{_attachment}}
604 if exists $src->{_attachment}; 553 if exists $src->{_attachment};
605 }, 554 },
606; 555);
607 556
608############################################################################# 557#############################################################################
609# command handling &c 558# command handling &c
610 559
611=item cf::register_command $name => \&callback($ob,$args); 560=item cf::register_command $name => \&callback($ob,$args);
… …
640 #warn "registering extcmd '$name' to '$caller'"; 589 #warn "registering extcmd '$name' to '$caller'";
641 590
642 $EXTCMD{$name} = [$cb, $caller]; 591 $EXTCMD{$name} = [$cb, $caller];
643} 592}
644 593
645attach_to_players 594cf::player->attach (
646 on_command => sub { 595 on_command => sub {
647 my ($pl, $name, $params) = @_; 596 my ($pl, $name, $params) = @_;
648 597
649 my $cb = $COMMAND{$name} 598 my $cb = $COMMAND{$name}
650 or return; 599 or return;
… …
670 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 619 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
671 } 620 }
672 621
673 cf::override; 622 cf::override;
674 }, 623 },
675; 624);
676 625
677sub register { 626sub register {
678 my ($base, $pkg) = @_; 627 my ($base, $pkg) = @_;
679 628
680 #TODO 629 #TODO
… …
770 defined $path or return; 719 defined $path or return;
771 720
772 unlink "$path.pst"; 721 unlink "$path.pst";
773}; 722};
774 723
775attach_to_maps prio => -10000, package => cf::mapsupport::; 724cf::map->attach (prio => -10000, package => cf::mapsupport::);
776 725
777############################################################################# 726#############################################################################
778# load/save perl data associated with player->ob objects 727# load/save perl data associated with player->ob objects
779 728
780sub all_objects(@) { 729sub all_objects(@) {
781 @_, map all_objects ($_->inv), @_ 730 @_, map all_objects ($_->inv), @_
782} 731}
783 732
784# TODO: compatibility cruft, remove when no longer needed 733# TODO: compatibility cruft, remove when no longer needed
785attach_to_players 734cf::player->attach (
786 on_load => sub { 735 on_load => sub {
787 my ($pl, $path) = @_; 736 my ($pl, $path) = @_;
788 737
789 for my $o (all_objects $pl->ob) { 738 for my $o (all_objects $pl->ob) {
790 if (my $value = $o->get_ob_key_value ("_perl_data")) { 739 if (my $value = $o->get_ob_key_value ("_perl_data")) {
… …
792 741
793 %$o = %{ Storable::thaw pack "H*", $value }; 742 %$o = %{ Storable::thaw pack "H*", $value };
794 } 743 }
795 } 744 }
796 }, 745 },
797; 746);
798 747
799############################################################################# 748#############################################################################
800 749
801=head2 CORE EXTENSIONS 750=head2 CORE EXTENSIONS
802 751
803Functions and methods that extend core crossfire objects. 752Functions and methods that extend core crossfire objects.
753
754=head3 cf::player
804 755
805=over 4 756=over 4
806 757
807=item cf::player::exists $login 758=item cf::player::exists $login
808 759
… …
813sub cf::player::exists($) { 764sub cf::player::exists($) {
814 cf::player::find $_[0] 765 cf::player::find $_[0]
815 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 766 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
816} 767}
817 768
769=item $player->ext_reply ($msgid, $msgtype, %msg)
770
771Sends an ext reply to the player.
772
773=cut
774
775sub cf::player::ext_reply($$$%) {
776 my ($self, $id, %msg) = @_;
777
778 $msg{msgid} = $id;
779
780 $self->send ("ext " . to_json \%msg);
781}
782
783=back
784
785=head3 cf::object::player
786
787=over 4
788
818=item $player_object->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
819 790
820Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 791Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
821can be C<undef>. Does the right thing when the player is currently in a 792can be C<undef>. Does the right thing when the player is currently in a
822dialogue with the given NPC character. 793dialogue with the given NPC character.
823 794
824=cut 795=cut
825 796
826# rough implementation of a future "reply" method that works 797# rough implementation of a future "reply" method that works
827# with dialog boxes. 798# with dialog boxes.
799#TODO: the first argument must go, split into a $npc->reply_to ( method
828sub cf::object::player::reply($$$;$) { 800sub cf::object::player::reply($$$;$) {
829 my ($self, $npc, $msg, $flags) = @_; 801 my ($self, $npc, $msg, $flags) = @_;
830 802
831 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 803 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
832 804
… …
836 $msg = $npc->name . " says: $msg" if $npc; 808 $msg = $npc->name . " says: $msg" if $npc;
837 $self->message ($msg, $flags); 809 $self->message ($msg, $flags);
838 } 810 }
839} 811}
840 812
841=item $player->ext_reply ($msgid, $msgtype, %msg)
842
843Sends an ext reply to the player.
844
845=cut
846
847sub cf::player::ext_reply($$$%) {
848 my ($self, $id, %msg) = @_;
849
850 $msg{msgid} = $id;
851
852 $self->send ("ext " . to_json \%msg);
853}
854
855=item $player_object->may ("access") 813=item $player_object->may ("access")
856 814
857Returns wether the given player is authorized to access resource "access" 815Returns wether the given player is authorized to access resource "access"
858(e.g. "command_wizcast"). 816(e.g. "command_wizcast").
859 817
… …
866 (ref $cf::CFG{"may_$access"} 824 (ref $cf::CFG{"may_$access"}
867 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 825 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
868 : $cf::CFG{"may_$access"}) 826 : $cf::CFG{"may_$access"})
869} 827}
870 828
871=cut 829=head3 cf::client
872 830
873############################################################################# 831=over 4
832
833=item $client->send_drawinfo ($text, $flags)
834
835Sends a drawinfo packet to the client. Circumvents output buffering so
836should not be used under normal circumstances.
837
838=cut
839
840sub cf::client::send_drawinfo {
841 my ($self, $text, $flags) = @_;
842
843 utf8::encode $text;
844 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
845}
846
847
848=item $success = $client->query ($flags, "text", \&cb)
849
850Queues a query to the client, calling the given callback with
851the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
852C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
853
854Queries can fail, so check the return code. Or don't, as queries will become
855reliable at some point in the future.
856
857=cut
858
859sub cf::client::query {
860 my ($self, $flags, $text, $cb) = @_;
861
862 return unless $self->state == ST_PLAYING
863 || $self->state == ST_SETUP
864 || $self->state == ST_CUSTOM;
865
866 $self->state (ST_CUSTOM);
867
868 utf8::encode $text;
869 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
870
871 $self->send_packet ($self->{query_queue}[0][0])
872 if @{ $self->{query_queue} } == 1;
873}
874
875cf::client->attach (
876 on_reply => sub {
877 my ($ns, $msg) = @_;
878
879 # this weird shuffling is so that direct followup queries
880 # get handled first
881 my $queue = delete $ns->{query_queue};
882
883 (shift @$queue)->[1]->($msg);
884
885 push @{ $ns->{query_queue} }, @$queue;
886
887 if (@{ $ns->{query_queue} } == @$queue) {
888 if (@$queue) {
889 $ns->send_packet ($ns->{query_queue}[0][0]);
890 } else {
891 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892 }
893 }
894 },
895);
896
897=item $client->coro (\&cb)
898
899Create a new coroutine, running the specified callback. The coroutine will
900be automatically cancelled when the client gets destroyed (e.g. on logout,
901or loss of connection).
902
903=cut
904
905sub cf::client::coro {
906 my ($self, $cb) = @_;
907
908 my $coro; $coro = async {
909 eval {
910 $cb->();
911 };
912 warn $@ if $@;
913 delete $self->{_coro}{$coro+0};
914 };
915
916 $self->{_coro}{$coro+0} = $coro;
917}
918
919cf::client->attach (
920 on_destroy => sub {
921 my ($ns) = @_;
922
923 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
924 },
925);
926
927=back
928
874 929
875=head2 SAFE SCRIPTING 930=head2 SAFE SCRIPTING
876 931
877Functions that provide a safe environment to compile and execute 932Functions that provide a safe environment to compile and execute
878snippets of perl code without them endangering the safety of the server 933snippets of perl code without them endangering the safety of the server
… …
1078 $DB->{$_[0]} = $_[1]; 1133 $DB->{$_[0]} = $_[1];
1079 } 1134 }
1080 db_dirty; 1135 db_dirty;
1081 } 1136 }
1082 1137
1083 attach_global 1138 cf::global->attach (
1084 prio => 10000, 1139 prio => 10000,
1085 on_cleanup => sub { 1140 on_cleanup => sub {
1086 db_sync; 1141 db_sync;
1087 }, 1142 },
1088 ; 1143 );
1089} 1144}
1090 1145
1091############################################################################# 1146#############################################################################
1092# the server's main() 1147# the server's main()
1093 1148

Diff Legend

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