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.94 by root, Thu Dec 21 23:02:54 2006 UTC vs.
Revision 1.102 by root, Wed Dec 27 15:20:54 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 = ();
25our %EXTCMD = (); 34our %EXTCMD = ();
26
27_init_vars;
28 35
29our @EVENT; 36our @EVENT;
30our $LIBDIR = datadir . "/ext"; 37our $LIBDIR = datadir . "/ext";
31 38
32our $TICK = MAX_TIME * 1e-6; 39our $TICK = MAX_TIME * 1e-6;
… …
84@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 91@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
85 92
86# we bless all objects into (empty) derived classes to force a method lookup 93# we bless all objects into (empty) derived classes to force a method lookup
87# within the Safe compartment. 94# within the Safe compartment.
88for my $pkg (qw( 95for my $pkg (qw(
89 cf::global 96 cf::global cf::attachable
90 cf::object cf::object::player 97 cf::object cf::object::player
91 cf::client cf::player 98 cf::client cf::player
92 cf::arch cf::living 99 cf::arch cf::living
93 cf::map cf::party cf::region 100 cf::map cf::party cf::region
94)) { 101)) {
… …
249 my ($self, $victim) = @_; 256 my ($self, $victim) = @_;
250 ... 257 ...
251 } 258 }
252 } 259 }
253 260
261=item $attachable->valid
262
263Just because you have a perl object does not mean that the corresponding
264C-level object still exists. If you try to access an object that has no
265valid C counterpart anymore you get an exception at runtime. This method
266can be used to test for existence of the C object part without causing an
267exception.
268
254=cut 269=cut
255 270
256# the following variables are defined in .xs and must not be re-created 271# the following variables are defined in .xs and must not be re-created
257our @CB_GLOBAL = (); # registry for all global events 272our @CB_GLOBAL = (); # registry for all global events
273our @CB_ATTACHABLE = (); # registry for all attachables
258our @CB_OBJECT = (); # all objects (should not be used except in emergency) 274our @CB_OBJECT = (); # all objects (should not be used except in emergency)
259our @CB_PLAYER = (); 275our @CB_PLAYER = ();
260our @CB_CLIENT = (); 276our @CB_CLIENT = ();
261our @CB_TYPE = (); # registry for type (cf-object class) based events 277our @CB_TYPE = (); # registry for type (cf-object class) based events
262our @CB_MAP = (); 278our @CB_MAP = ();
263 279
264my %attachment; 280my %attachment;
265 281
266sub _attach_cb($$$$) { 282sub _attach_cb($$$$) {
267 my ($registry, $event, $prio, $cb) = @_; 283 my ($registry, $event, $prio, $cb) = @_;
… …
272 288
273 @{$registry->[$event]} = sort 289 @{$registry->[$event]} = sort
274 { $a->[0] cmp $b->[0] } 290 { $a->[0] cmp $b->[0] }
275 @{$registry->[$event] || []}, $cb; 291 @{$registry->[$event] || []}, $cb;
276} 292}
293
294# hack
295my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
277 296
278# attach handles attaching event callbacks 297# attach handles attaching event callbacks
279# the only thing the caller has to do is pass the correct 298# the only thing the caller has to do is pass the correct
280# registry (== where the callback attaches to). 299# registry (== where the callback attaches to).
281sub _attach { 300sub _attach {
… …
283 302
284 my $object_type; 303 my $object_type;
285 my $prio = 0; 304 my $prio = 0;
286 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 305 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
287 306
307 #TODO: get rid of this hack
308 if ($attachable_klass{$klass}) {
309 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
310 }
311
288 while (@arg) { 312 while (@arg) {
289 my $type = shift @arg; 313 my $type = shift @arg;
290 314
291 if ($type eq "prio") { 315 if ($type eq "prio") {
292 $prio = shift @arg; 316 $prio = shift @arg;
… …
367 my ($obj, $name) = @_; 391 my ($obj, $name) = @_;
368 392
369 exists $obj->{_attachment}{$name} 393 exists $obj->{_attachment}{$name}
370} 394}
371 395
372for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { 396for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
373 eval "#line " . __LINE__ . " 'cf.pm' 397 eval "#line " . __LINE__ . " 'cf.pm'
374 sub cf::\L$klass\E::_attach_registry { 398 sub cf::\L$klass\E::_attach_registry {
375 (\\\@CB_$klass, KLASS_$klass) 399 (\\\@CB_$klass, KLASS_$klass)
376 } 400 }
377 401
… …
413 } 437 }
414 438
415 0 439 0
416} 440}
417 441
418=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... 442=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
419 443
420=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
421
422=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
423
424=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...) 444=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
425 445
426=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
427
428Generate a global/object/player/map-specific event with the given arguments. 446Generate an object-specific event with the given arguments.
429 447
430This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 448This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
431removed in future versions), and there is no public API to access override 449removed in future versions), and there is no public API to access override
432results (if you must, access C<@cf::invoke_results> directly). 450results (if you must, access C<@cf::invoke_results> directly).
433 451
434=back 452=back
435 453
436=cut 454=cut
437 455
438############################################################################# 456#############################################################################
439
440=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
441
442Attachable objects includes objects, players, clients and maps.
443
444=over 4
445
446=item $object->valid
447
448Just because you have a perl object does not mean that the corresponding
449C-level object still exists. If you try to access an object that has no
450valid C counterpart anymore you get an exception at runtime. This method
451can be used to test for existence of the C object part without causing an
452exception.
453
454=back
455
456=cut
457
458#############################################################################
459# object support 457# object support
460 458
461sub instantiate {
462 my ($obj, $data) = @_;
463
464 $data = from_json $data;
465
466 for (@$data) {
467 my ($name, $args) = @$_;
468
469 $obj->attach ($name, %{$args || {} });
470 }
471}
472
473# basically do the same as instantiate, without calling instantiate
474sub reattach { 459sub reattach {
460 # basically do the same as instantiate, without calling instantiate
475 my ($obj) = @_; 461 my ($obj) = @_;
462
476 my $registry = $obj->registry; 463 my $registry = $obj->registry;
477 464
478 @$registry = (); 465 @$registry = ();
479 466
480 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 467 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
… …
489 warn "object uses attachment '$name' that is not available, postponing.\n"; 476 warn "object uses attachment '$name' that is not available, postponing.\n";
490 } 477 }
491 } 478 }
492} 479}
493 480
481cf::attachable->attach (
482 prio => -1000000,
483 on_instantiate => sub {
484 my ($obj, $data) = @_;
485
486 $data = from_json $data;
487
488 for (@$data) {
489 my ($name, $args) = @$_;
490
491 $obj->attach ($name, %{$args || {} });
492 }
493 },
494 on_reattach => \&reattach,
495 on_clone => sub {
496 my ($src, $dst) = @_;
497
498 @{$dst->registry} = @{$src->registry};
499
500 %$dst = %$src;
501
502 %{$dst->{_attachment}} = %{$src->{_attachment}}
503 if exists $src->{_attachment};
504 },
505);
506
494sub object_freezer_save { 507sub object_freezer_save {
495 my ($filename, $rdata, $objs) = @_; 508 my ($filename, $rdata, $objs) = @_;
496 509
497 if (length $$rdata) { 510 if (length $$rdata) {
498 warn sprintf "saving %s (%d,%d)\n", 511 warn sprintf "saving %s (%d,%d)\n",
… …
547 } 560 }
548 561
549 () 562 ()
550} 563}
551 564
552cf::object->attach (
553 prio => -1000000,
554 on_clone => sub {
555 my ($src, $dst) = @_;
556
557 @{$dst->registry} = @{$src->registry};
558
559 %$dst = %$src;
560
561 %{$dst->{_attachment}} = %{$src->{_attachment}}
562 if exists $src->{_attachment};
563 },
564);
565
566############################################################################# 565#############################################################################
567# command handling &c 566# command handling &c
568 567
569=item cf::register_command $name => \&callback($ob,$args); 568=item cf::register_command $name => \&callback($ob,$args);
570 569
… …
758 757
759=head2 CORE EXTENSIONS 758=head2 CORE EXTENSIONS
760 759
761Functions and methods that extend core crossfire objects. 760Functions and methods that extend core crossfire objects.
762 761
762=head3 cf::player
763
763=over 4 764=over 4
764 765
765=item cf::player::exists $login 766=item cf::player::exists $login
766 767
767Returns true when the given account exists. 768Returns true when the given account exists.
… …
771sub cf::player::exists($) { 772sub cf::player::exists($) {
772 cf::player::find $_[0] 773 cf::player::find $_[0]
773 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 774 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
774} 775}
775 776
777=item $player->ext_reply ($msgid, $msgtype, %msg)
778
779Sends an ext reply to the player.
780
781=cut
782
783sub cf::player::ext_reply($$$%) {
784 my ($self, $id, %msg) = @_;
785
786 $msg{msgid} = $id;
787
788 $self->send ("ext " . to_json \%msg);
789}
790
791=back
792
793=head3 cf::object::player
794
795=over 4
796
776=item $player_object->reply ($npc, $msg[, $flags]) 797=item $player_object->reply ($npc, $msg[, $flags])
777 798
778Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 799Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
779can be C<undef>. Does the right thing when the player is currently in a 800can be C<undef>. Does the right thing when the player is currently in a
780dialogue with the given NPC character. 801dialogue with the given NPC character.
781 802
782=cut 803=cut
783 804
784# rough implementation of a future "reply" method that works 805# rough implementation of a future "reply" method that works
785# with dialog boxes. 806# with dialog boxes.
807#TODO: the first argument must go, split into a $npc->reply_to ( method
786sub cf::object::player::reply($$$;$) { 808sub cf::object::player::reply($$$;$) {
787 my ($self, $npc, $msg, $flags) = @_; 809 my ($self, $npc, $msg, $flags) = @_;
788 810
789 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 811 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
790 812
… …
794 $msg = $npc->name . " says: $msg" if $npc; 816 $msg = $npc->name . " says: $msg" if $npc;
795 $self->message ($msg, $flags); 817 $self->message ($msg, $flags);
796 } 818 }
797} 819}
798 820
799=item $player->ext_reply ($msgid, $msgtype, %msg)
800
801Sends an ext reply to the player.
802
803=cut
804
805sub cf::player::ext_reply($$$%) {
806 my ($self, $id, %msg) = @_;
807
808 $msg{msgid} = $id;
809
810 $self->send ("ext " . to_json \%msg);
811}
812
813=item $player_object->may ("access") 821=item $player_object->may ("access")
814 822
815Returns wether the given player is authorized to access resource "access" 823Returns wether the given player is authorized to access resource "access"
816(e.g. "command_wizcast"). 824(e.g. "command_wizcast").
817 825
… …
824 (ref $cf::CFG{"may_$access"} 832 (ref $cf::CFG{"may_$access"}
825 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 833 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
826 : $cf::CFG{"may_$access"}) 834 : $cf::CFG{"may_$access"})
827} 835}
828 836
829=cut 837=head3 cf::client
830 838
831############################################################################# 839=over 4
840
841=item $client->send_drawinfo ($text, $flags)
842
843Sends a drawinfo packet to the client. Circumvents output buffering so
844should not be used under normal circumstances.
845
846=cut
847
848sub cf::client::send_drawinfo {
849 my ($self, $text, $flags) = @_;
850
851 utf8::encode $text;
852 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
853}
854
855
856=item $success = $client->query ($flags, "text", \&cb)
857
858Queues a query to the client, calling the given callback with
859the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
860C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
861
862Queries can fail, so check the return code. Or don't, as queries will become
863reliable at some point in the future.
864
865=cut
866
867sub cf::client::query {
868 my ($self, $flags, $text, $cb) = @_;
869
870 return unless $self->state == ST_PLAYING
871 || $self->state == ST_SETUP
872 || $self->state == ST_CUSTOM;
873
874 $self->state (ST_CUSTOM);
875
876 utf8::encode $text;
877 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
878
879 $self->send_packet ($self->{query_queue}[0][0])
880 if @{ $self->{query_queue} } == 1;
881}
882
883cf::client->attach (
884 on_reply => sub {
885 my ($ns, $msg) = @_;
886
887 # this weird shuffling is so that direct followup queries
888 # get handled first
889 my $queue = delete $ns->{query_queue};
890
891 (shift @$queue)->[1]->($msg);
892
893 push @{ $ns->{query_queue} }, @$queue;
894
895 if (@{ $ns->{query_queue} } == @$queue) {
896 if (@$queue) {
897 $ns->send_packet ($ns->{query_queue}[0][0]);
898 } else {
899 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
900 }
901 }
902 },
903);
904
905=item $client->coro (\&cb)
906
907Create a new coroutine, running the specified callback. The coroutine will
908be automatically cancelled when the client gets destroyed (e.g. on logout,
909or loss of connection).
910
911=cut
912
913sub cf::client::coro {
914 my ($self, $cb) = @_;
915
916 my $coro; $coro = async {
917 eval {
918 $cb->();
919 };
920 warn $@ if $@;
921 delete $self->{_coro}{$coro+0};
922 };
923
924 $self->{_coro}{$coro+0} = $coro;
925}
926
927cf::client->attach (
928 on_destroy => sub {
929 my ($ns) = @_;
930
931 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
932 },
933);
934
935=back
936
832 937
833=head2 SAFE SCRIPTING 938=head2 SAFE SCRIPTING
834 939
835Functions that provide a safe environment to compile and execute 940Functions that provide a safe environment to compile and execute
836snippets of perl code without them endangering the safety of the server 941snippets of perl code without them endangering the safety of the server
… …
1119 #Symbol::delete_package __PACKAGE__; 1224 #Symbol::delete_package __PACKAGE__;
1120 1225
1121 # reload cf.pm 1226 # reload cf.pm
1122 $msg->("reloading cf.pm"); 1227 $msg->("reloading cf.pm");
1123 require cf; 1228 require cf;
1229 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1124 1230
1125 # load config and database again 1231 # load config and database again
1126 cf::cfg_load; 1232 cf::cfg_load;
1127 cf::db_load; 1233 cf::db_load;
1128 1234

Diff Legend

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