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.592 by root, Fri Nov 9 00:11:49 2012 UTC vs.
Revision 1.622 by root, Wed Nov 23 06:05:33 2016 UTC

… …
57use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
58use BDB (); 58use BDB ();
59use Data::Dumper; 59use Data::Dumper;
60use Fcntl; 60use Fcntl;
61use YAML::XS (); 61use YAML::XS ();
62use CBOR::XS ();
62use IO::AIO (); 63use IO::AIO ();
63use Time::HiRes;
64use Compress::LZF; 64use Compress::LZF;
65use Digest::MD5 (); 65use Digest::MD5 ();
66 66
67AnyEvent::detect; 67AnyEvent::detect;
68 68
… …
87our %COMMAND = (); 87our %COMMAND = ();
88our %COMMAND_TIME = (); 88our %COMMAND_TIME = ();
89 89
90our @EXTS = (); # list of extension package names 90our @EXTS = (); # list of extension package names
91our %EXTCMD = (); 91our %EXTCMD = ();
92our %EXTACMD = ();
92our %EXTICMD = (); 93our %EXTICMD = ();
94our %EXTIACMD = ();
93our %EXT_CORO = (); # coroutines bound to extensions 95our %EXT_CORO = (); # coroutines bound to extensions
94our %EXT_MAP = (); # pluggable maps 96our %EXT_MAP = (); # pluggable maps
95 97
96our $RELOAD; # number of reloads so far, non-zero while in reload 98our $RELOAD; # number of reloads so far, non-zero while in reload
97our @EVENT; 99our @EVENT;
… …
224=item $cf::RUNTIME 226=item $cf::RUNTIME
225 227
226The time this server has run, starts at 0 and is increased by $cf::TICK on 228The time this server has run, starts at 0 and is increased by $cf::TICK on
227every server tick. 229every server tick.
228 230
229=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 231=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
230$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 232$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
231$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 233$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
232 234
233Various directories - "/etc", read-only install directory, perl-library 235Various directories - "/etc", read-only install directory, perl-library
234directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 236directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
… …
250Configuration for the server, loaded from C</etc/deliantra-server/config>, or 252Configuration for the server, loaded from C</etc/deliantra-server/config>, or
251from wherever your confdir points to. 253from wherever your confdir points to.
252 254
253=item cf::wait_for_tick, cf::wait_for_tick_begin 255=item cf::wait_for_tick, cf::wait_for_tick_begin
254 256
255These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 257These are functions that inhibit the current coroutine one tick.
256returns directly I<after> the tick processing (and consequently, can only wake one thread 258cf::wait_for_tick_begin only returns directly I<after> the tick
259processing (and consequently, can only wake one thread per tick), while
257per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 260cf::wait_for_tick wakes up all waiters after tick processing.
258 261
259Note that cf::Wait_for_tick will immediately return when the server is not 262Note that cf::wait_for_tick will immediately return when the server is not
260ticking, making it suitable for small pauses in threads that need to run 263ticking, making it suitable for small pauses in threads that need to run
261when the server is paused. If that is not applicable (i.e. you I<really> 264when the server is paused. If that is not applicable (i.e. you I<really>
262want to wait, use C<$cf::WAIT_FOR_TICK>). 265want to wait, use C<$cf::WAIT_FOR_TICK>).
263 266
264=item $cf::WAIT_FOR_TICK 267=item $cf::WAIT_FOR_TICK
… …
462 465
463sub decode_yaml($) { 466sub decode_yaml($) {
464 fork_call { YAML::XS::Load $_[0] } @_ 467 fork_call { YAML::XS::Load $_[0] } @_
465} 468}
466 469
470=item $scalar = cf::decode_cbor $scalar
471
472Same as CBOR::XS::decode_cbor, but takes server ticks into account, so
473blocks. For small amounts of data, C<CBOR::XS::decode_cbor> is the better
474alternative.
475
476=cut
477
478sub decode_cbor($) {
479 # we assume 10mb/s minimum decoding speed (on a ~2ghz machine)
480 cf::get_slot +(length $_[0]) / 10_000_000, 0, "decode_cbor";
481 CBOR::XS::decode_cbor $_[0]
482}
483
467=item $scalar = cf::unlzf $scalar 484=item $scalar = cf::unlzf $scalar
468 485
469Same as Compress::LZF::compress, but takes server ticks into account, so 486Same as Compress::LZF::compress, but takes server ticks into account, so
470blocks. 487blocks.
471 488
… …
508 } 525 }
509} 526}
510 527
511=item cf::lock_wait $string 528=item cf::lock_wait $string
512 529
513Wait until the given lock is available. See cf::lock_acquire. 530Wait until the given lock is available. See cf::lock_acquire.
514 531
515=item my $lock = cf::lock_acquire $string 532=item my $lock = cf::lock_acquire $string
516 533
517Wait until the given lock is available and then acquires it and returns 534Wait until the given lock is available and then acquires it and returns
518a L<Guard> object. If the guard object gets destroyed (goes out of scope, 535a L<Guard> object. If the guard object gets destroyed (goes out of scope,
… …
571Allocate $time seconds of blocking CPU time at priority C<$priority> 588Allocate $time seconds of blocking CPU time at priority C<$priority>
572(default: 0): This call blocks and returns only when you have at least 589(default: 0): This call blocks and returns only when you have at least
573C<$time> seconds of cpu time till the next tick. The slot is only valid 590C<$time> seconds of cpu time till the next tick. The slot is only valid
574till the next cede. 591till the next cede.
575 592
576Background jobs should use a priority les than zero, interactive jobs 593Background jobs should use a priority less than zero, interactive jobs
577should use 100 or more. 594should use 100 or more.
578 595
579The optional C<$name> can be used to identify the job to run. It might be 596The optional C<$name> can be used to identify the job to run. It might be
580used for statistical purposes and should identify the same time-class. 597used for statistical purposes and should identify the same time-class.
581 598
… …
594 my $signal = new Coro::Signal; 611 my $signal = new Coro::Signal;
595 my $busy; 612 my $busy;
596 613
597 while () { 614 while () {
598 next_job: 615 next_job:
616
617 Coro::cede;
599 618
600 my $avail = cf::till_tick; 619 my $avail = cf::till_tick;
601 620
602 for (0 .. $#SLOT_QUEUE) { 621 for (0 .. $#SLOT_QUEUE) {
603 if ($SLOT_QUEUE[$_][0] <= $avail) { 622 if ($SLOT_QUEUE[$_][0] <= $avail) {
604 $busy = 0; 623 $busy = 0;
605 my $job = splice @SLOT_QUEUE, $_, 1, (); 624 my $job = splice @SLOT_QUEUE, $_, 1, ();
606 $job->[2]->send; 625 $job->[2]->send;
607 Coro::cede;
608 goto next_job; 626 goto next_job;
609 } else { 627 } else {
610 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY; 628 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
611 } 629 }
612 } 630 }
613 631
614 if (@SLOT_QUEUE) { 632 if (@SLOT_QUEUE) {
615 # we do not use wait_for_tick() as it returns immediately when tick is inactive 633 wait_for_tick;
616 $WAIT_FOR_TICK->wait;
617 } else { 634 } else {
618 $busy = 0; 635 $busy = 0;
619 Coro::schedule; 636 Coro::schedule;
620 } 637 }
621 } 638 }
… …
647BEGIN { *async = \&Coro::async_pool } 664BEGIN { *async = \&Coro::async_pool }
648 665
649=item cf::sync_job { BLOCK } 666=item cf::sync_job { BLOCK }
650 667
651The design of Deliantra requires that the main coroutine ($Coro::main) 668The design of Deliantra requires that the main coroutine ($Coro::main)
652is always able to handle events or runnable, as Deliantra is only 669is always able to handle events or is runnable, as Deliantra is only
653partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 670partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
654acceptable. 671acceptable.
655 672
656If it must be done, put the blocking parts into C<sync_job>. This will run 673If it must be done, put the blocking parts into C<sync_job>. This will run
657the given BLOCK in another coroutine while waiting for the result. The 674the given BLOCK in another coroutine while waiting for the result. The
… …
685 702
686 while ($busy) { 703 while ($busy) {
687 if (Coro::nready) { 704 if (Coro::nready) {
688 Coro::cede_notself; 705 Coro::cede_notself;
689 } else { 706 } else {
690 EV::loop EV::LOOP_ONESHOT; 707 EV::run EV::RUN_ONCE;
691 } 708 }
692 } 709 }
693 710
694 my $time = AE::time - $time; 711 my $time = AE::time - $time;
695 712
… …
736 reset_signals; 753 reset_signals;
737} 754}
738 755
739sub fork_call(&@) { 756sub fork_call(&@) {
740 my ($cb, @args) = @_; 757 my ($cb, @args) = @_;
741
742 # we seemingly have to make a local copy of the whole thing,
743 # otherwise perl prematurely frees the stuff :/
744 # TODO: investigate and fix (likely this will be rather laborious)
745 758
746 my @res = Coro::Util::fork_eval { 759 my @res = Coro::Util::fork_eval {
747 cf::post_fork; 760 cf::post_fork;
748 &$cb 761 &$cb
749 } @args; 762 } @args;
… …
899 912
900 return db_get cache => "$id/data"; 913 return db_get cache => "$id/data";
901 } 914 }
902 } 915 }
903 916
904 my $t1 = Time::HiRes::time; 917 my $t1 = EV::time;
905 my $data = $process->(\@data); 918 my $data = $process->(\@data);
906 my $t2 = Time::HiRes::time; 919 my $t2 = EV::time;
907 920
908 info "cache: '$id' processed in ", $t2 - $t1, "s\n"; 921 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
909 922
910 db_put cache => "$id/data", $data; 923 db_put cache => "$id/data", $data;
911 db_put cache => "$id/md5" , $md5; 924 db_put cache => "$id/md5" , $md5;
… …
1431=cut 1444=cut
1432 1445
1433############################################################################# 1446#############################################################################
1434# command handling &c 1447# command handling &c
1435 1448
1436=item cf::register_command $name => \&callback($ob,$args); 1449=item cf::register_command $name => \&callback($ob,$args)
1437 1450
1438Register a callback for execution when the client sends the user command 1451Register a callback for execution when the client sends the user command
1439$name. 1452$name.
1440 1453
1441=cut 1454=cut
… …
1447 #warn "registering command '$name/$time' to '$caller'"; 1460 #warn "registering command '$name/$time' to '$caller'";
1448 1461
1449 push @{ $COMMAND{$name} }, [$caller, $cb]; 1462 push @{ $COMMAND{$name} }, [$caller, $cb];
1450} 1463}
1451 1464
1452=item cf::register_extcmd $name => \&callback($pl,$packet); 1465=item cf::register_extcmd $name => \&callback($pl,@args)
1453 1466
1454Register a callback for execution when the client sends an (synchronous) 1467Register a callback for execution when the client sends an (synchronous)
1455extcmd packet. Ext commands will be processed in the order they are 1468extcmd packet. Ext commands will be processed in the order they are
1456received by the server, like other user commands. The first argument is 1469received by the server, like other user commands. The first argument is
1457the logged-in player. Ext commands can only be processed after a player 1470the logged-in player. Ext commands can only be processed after a player
1458has logged in successfully. 1471has logged in successfully.
1459 1472
1460If the callback returns something, it is sent back as if reply was being 1473The values will be sent back to the client.
1461called.
1462 1474
1475=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
1476
1477Same as C<cf::register_extcmd>, but instead of returning values, the
1478callback needs to clal the C<$reply> function.
1479
1463=item cf::register_exticmd $name => \&callback($ns,$packet); 1480=item cf::register_exticmd $name => \&callback($ns,@args)
1464 1481
1465Register a callback for execution when the client sends an (asynchronous) 1482Register a callback for execution when the client sends an (asynchronous)
1466exticmd packet. Exti commands are processed by the server as soon as they 1483exticmd packet. Exti commands are processed by the server as soon as they
1467are received, i.e. out of order w.r.t. other commands. The first argument 1484are received, i.e. out of order w.r.t. other commands. The first argument
1468is a client socket. Exti commands can be received anytime, even before 1485is a client socket. Exti commands can be received anytime, even before
1469log-in. 1486log-in.
1470 1487
1471If the callback returns something, it is sent back as if reply was being 1488The values will be sent back to the client.
1472called.
1473 1489
1474=cut 1490=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1475 1491
1492Same as C<cf::register_extcmd>, but instead of returning values, the
1493callback needs to clal the C<$reply> function.
1494
1495=cut
1496
1476sub register_extcmd { 1497sub register_extcmd($$) {
1477 my ($name, $cb) = @_; 1498 my ($name, $cb) = @_;
1478 1499
1479 $EXTCMD{$name} = $cb; 1500 $EXTCMD{$name} = $cb;
1480} 1501}
1481 1502
1482sub register_exticmd { 1503sub register_async_extcmd($$) {
1483 my ($name, $cb) = @_; 1504 my ($name, $cb) = @_;
1484 1505
1506 $EXTACMD{$name} = $cb;
1507}
1508
1509sub register_exticmd($$) {
1510 my ($name, $cb) = @_;
1511
1485 $EXTICMD{$name} = $cb; 1512 $EXTICMD{$name} = $cb;
1513}
1514
1515sub register_async_exticmd($$) {
1516 my ($name, $cb) = @_;
1517
1518 $EXTIACMD{$name} = $cb;
1486} 1519}
1487 1520
1488use File::Glob (); 1521use File::Glob ();
1489 1522
1490cf::player->attach ( 1523cf::player->attach (
… …
1506 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1539 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1507 1540
1508 if (ref $msg) { 1541 if (ref $msg) {
1509 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash 1542 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1510 1543
1511 my @reply;
1512
1513 if (my $cb = $EXTCMD{$type}) { 1544 if (my $cb = $EXTACMD{$type}) {
1545 $cb->(
1546 $pl,
1547 sub {
1548 $pl->ext_msg ("reply-$reply", @_)
1549 if $reply;
1550 },
1551 @payload
1552 );
1553 } else {
1554 my @reply;
1555
1556 if (my $cb = $EXTCMD{$type}) {
1514 @reply = $cb->($pl, @payload); 1557 @reply = $cb->($pl, @payload);
1558 }
1559
1560 $pl->ext_msg ("reply-$reply", @reply)
1561 if $reply;
1515 } 1562 }
1516
1517 $pl->ext_reply ($reply, @reply)
1518 if $reply;
1519 1563
1520 } else { 1564 } else {
1521 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1565 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1522 } 1566 }
1523 1567
… …
1909} 1953}
1910 1954
1911=item $protocol_xml = $player->expand_cfpod ($cfpod) 1955=item $protocol_xml = $player->expand_cfpod ($cfpod)
1912 1956
1913Expand deliantra pod fragments into protocol xml. 1957Expand deliantra pod fragments into protocol xml.
1914
1915=item $player->ext_reply ($msgid, @msg)
1916
1917Sends an ext reply to the player.
1918
1919=cut
1920
1921sub ext_reply($$@) {
1922 my ($self, $id, @msg) = @_;
1923
1924 $self->ns->ext_reply ($id, @msg)
1925}
1926 1958
1927=item $player->ext_msg ($type, @msg) 1959=item $player->ext_msg ($type, @msg)
1928 1960
1929Sends an ext event to the client. 1961Sends an ext event to the client.
1930 1962
… …
2367 2399
2368 $MAP_PREFETCHER ||= cf::async { 2400 $MAP_PREFETCHER ||= cf::async {
2369 $Coro::current->{desc} = "map prefetcher"; 2401 $Coro::current->{desc} = "map prefetcher";
2370 2402
2371 while (%MAP_PREFETCH) { 2403 while (%MAP_PREFETCH) {
2372 while (my ($k, $v) = each %MAP_PREFETCH) { 2404 for my $k (keys %MAP_PREFETCH) {
2373 if (my $map = find $k) { 2405 if (my $map = find $k) {
2374 $map->load if $v; 2406 $map->load if $MAP_PREFETCH{$k};
2375 } 2407 }
2376 2408
2377 delete $MAP_PREFETCH{$k}; 2409 delete $MAP_PREFETCH{$k};
2378 } 2410 }
2379 } 2411 }
… …
2633 2665
2634Creates and returns a persistent reference to an object that can be stored as a string. 2666Creates and returns a persistent reference to an object that can be stored as a string.
2635 2667
2636=item $ob = cf::object::deref ($refstring) 2668=item $ob = cf::object::deref ($refstring)
2637 2669
2638returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2670returns the objetc referenced by refstring. may return undef when it cannot find the object,
2639even if the object actually exists. May block. 2671even if the object actually exists. May block.
2640 2672
2641=cut 2673=cut
2642 2674
2643sub deref { 2675sub deref {
… …
2725=item $player_object->may ("access") 2757=item $player_object->may ("access")
2726 2758
2727Returns wether the given player is authorized to access resource "access" 2759Returns wether the given player is authorized to access resource "access"
2728(e.g. "command_wizcast"). 2760(e.g. "command_wizcast").
2729 2761
2762This is implemented by checking a config setting of C<may_access> where
2763C<access> is replaced by the access string. The following alternatives are
2764possible (and are tested in order):
2765
2766=over 4
2767
2768=item * Player is DM
2769
2770The request will succeed.
2771
2772=item * may_access is an array reference
2773
2774If either the player nickname or UUID is in the array, the request will
2775succeed, otherwise it will fail.
2776
2777=item * may_access is a true value
2778
2779The request will succeed.
2780
2781=item * may_access is missing or false
2782
2783The request will fail.
2784
2785=back
2786
2730=cut 2787=cut
2731 2788
2732sub cf::object::player::may { 2789sub cf::object::player::may {
2733 my ($self, $access) = @_; 2790 my ($self, $access) = @_;
2734 2791
2735 $self->flag (cf::FLAG_WIZ) || 2792 $self->flag (cf::FLAG_WIZ) ||
2736 (ref $cf::CFG{"may_$access"} 2793 (ref $cf::CFG{"may_$access"}
2737 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 2794 ? scalar grep $self->name eq $_ || $self->uuid eq $_, @{$cf::CFG{"may_$access"}}
2738 : $cf::CFG{"may_$access"}) 2795 : $cf::CFG{"may_$access"})
2739} 2796}
2740 2797
2741=item $player_object->enter_link 2798=item $player_object->enter_link
2742 2799
… …
2745The player should be reasonably safe there for short amounts of time (e.g. 2802The player should be reasonably safe there for short amounts of time (e.g.
2746for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2803for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2747though, as the player cannot control the character while it is on the link 2804though, as the player cannot control the character while it is on the link
2748map. 2805map.
2749 2806
2750Will never block. 2807This method will never block, which is the whole reaosn for it's
2808existance: you can I<always> put a player onto the link map, which is the
2809only place to put objects that is guaranteed to exist.
2810
2811A typical usage pattern is to call C<enter_link> synchronously from the
2812server, then start a new thread, do your blocking stuff there and then
2813call C<leave_link> from that thread.
2751 2814
2752=item $player_object->leave_link ($map, $x, $y) 2815=item $player_object->leave_link ($map, $x, $y)
2753 2816
2754Moves the player out of the special C<{link}> map onto the specified 2817Moves the player out of the special C<{link}> map onto the specified
2755map. If the map is not valid (or omitted), the player will be moved back 2818map. If the map is not valid (or omitted), the player will be moved back
… …
3025 3088
3026=head3 cf::client 3089=head3 cf::client
3027 3090
3028=over 4 3091=over 4
3029 3092
3030=item $client->send_drawinfo ($text, $flags)
3031
3032Sends a drawinfo packet to the client. Circumvents output buffering so
3033should not be used under normal circumstances.
3034
3035=cut
3036
3037sub cf::client::send_drawinfo {
3038 my ($self, $text, $flags) = @_;
3039
3040 utf8::encode $text;
3041 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
3042}
3043
3044=item $client->send_big_packet ($pkt) 3093=item $client->send_big_packet ($pkt)
3045 3094
3046Like C<send_packet>, but tries to compress large packets, and fragments 3095Like C<send_packet>, but tries to compress large packets, and fragments
3047them as required. 3096them as required.
3048 3097
… …
3066 $self->send_packet ($pkt); 3115 $self->send_packet ($pkt);
3067} 3116}
3068 3117
3069=item $client->send_msg ($channel, $msg, $color, [extra...]) 3118=item $client->send_msg ($channel, $msg, $color, [extra...])
3070 3119
3071Send a drawinfo or msg packet to the client, formatting the msg for the 3120Send a msg packet to the client, formatting the msg for the client if
3072client if neccessary. C<$type> should be a string identifying the type of 3121necessary. C<$type> should be a string identifying the type of the
3073the message, with C<log> being the default. If C<$color> is negative, suppress 3122message, with C<log> being the default. If C<$color> is negative, suppress
3074the message unless the client supports the msg packet. 3123the message unless the client supports the msg packet.
3075 3124
3076=cut 3125=cut
3077 3126
3078# non-persistent channels (usually the info channel) 3127# non-persistent channels (usually the info channel)
… …
3183 id => "death", 3232 id => "death",
3184 title => "Death", 3233 title => "Death",
3185 reply => undef, 3234 reply => undef,
3186 tooltip => "Reason for and more info about your most recent death", 3235 tooltip => "Reason for and more info about your most recent death",
3187 }, 3236 },
3237 "c/fatal" => {
3238 id => "fatal",
3239 title => "Fatal Error",
3240 reply => undef,
3241 tooltip => "Reason for the server disconnect",
3242 },
3188 "c/say" => $SAY_CHANNEL, 3243 "c/say" => $SAY_CHANNEL,
3189 "c/chat" => $CHAT_CHANNEL, 3244 "c/chat" => $CHAT_CHANNEL,
3190); 3245);
3191 3246
3192sub cf::client::send_msg { 3247sub cf::client::send_msg {
… …
3238 my ($self, $type, @msg) = @_; 3293 my ($self, $type, @msg) = @_;
3239 3294
3240 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3295 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3241} 3296}
3242 3297
3243=item $client->ext_reply ($msgid, @msg)
3244
3245Sends an ext reply to the client.
3246
3247=cut
3248
3249sub cf::client::ext_reply($$@) {
3250 my ($self, $id, @msg) = @_;
3251
3252 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3253}
3254
3255=item $success = $client->query ($flags, "text", \&cb) 3298=item $success = $client->query ($flags, "text", \&cb)
3256 3299
3257Queues a query to the client, calling the given callback with 3300Queues a query to the client, calling the given callback with
3258the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 3301the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
3259C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 3302C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
… …
3277 3320
3278 $self->send_packet ($self->{query_queue}[0][0]) 3321 $self->send_packet ($self->{query_queue}[0][0])
3279 if @{ $self->{query_queue} } == 1; 3322 if @{ $self->{query_queue} } == 1;
3280 3323
3281 1 3324 1
3325}
3326
3327=item $client->update_command_faces
3328
3329=cut
3330
3331our %COMMAND_FACE;
3332
3333sub cf::client::update_command_faces {
3334 my ($self) = @_;
3335
3336 my @faces = grep $_,
3337 $COMMAND_FACE{preferred},
3338 $COMMAND_FACE{standard},
3339 $COMMAND_FACE{skill},
3340 $self->pl->ob->flag (cf::FLAG_WIZ) ? $COMMAND_FACE{dm} : (),
3341 $COMMAND_FACE{emote},
3342 ;
3343
3344 $self->send_face ($_)
3345 for @faces;
3346 $self->flush_fx;
3347
3348 $self->ext_msg (command_list => @faces);
3349}
3350
3351=item cf::client::set_command_face $type, $commands
3352
3353=cut
3354
3355sub cf::client::set_command_face {
3356 my ($type, $list) = @_;
3357
3358 my $idx = &cf::face::set ( #d# ugly forward reference
3359 "command_list/$type" => cf::FT_RSRC,
3360 JSON::XS->new->utf8->encode ([ sort @$list ])
3361 );
3362
3363 $COMMAND_FACE{$type} = $idx;
3282} 3364}
3283 3365
3284cf::client->attach ( 3366cf::client->attach (
3285 on_connect => sub { 3367 on_connect => sub {
3286 my ($ns) = @_; 3368 my ($ns) = @_;
… …
3314 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3396 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3315 3397
3316 if (ref $msg) { 3398 if (ref $msg) {
3317 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash 3399 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3318 3400
3319 my @reply;
3320
3321 if (my $cb = $EXTICMD{$type}) { 3401 if (my $cb = $EXTIACMD{$type}) {
3402 $cb->(
3403 $ns,
3404 sub {
3405 $ns->ext_msg ("reply-$reply", @_)
3406 if $reply;
3407 },
3408 @payload
3409 );
3410 } else {
3411 my @reply;
3412
3413 if (my $cb = $EXTICMD{$type}) {
3322 @reply = $cb->($ns, @payload); 3414 @reply = $cb->($ns, @payload);
3415 }
3416
3417 $ns->ext_msg ("reply-$reply", @reply)
3418 if $reply;
3323 } 3419 }
3324
3325 $ns->ext_reply ($reply, @reply)
3326 if $reply;
3327
3328 } else { 3420 } else {
3329 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3421 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3330 } 3422 }
3331 3423
3332 cf::override; 3424 cf::override;
… …
3500=cut 3592=cut
3501 3593
3502############################################################################# 3594#############################################################################
3503# the server's init and main functions 3595# the server's init and main functions
3504 3596
3505our %FACEHASH; # hash => idx, #d# HACK for http server 3597{
3598 package cf::face;
3506 3599
3600 our %HASH; # hash => idx
3601 our @DATA; # dynamically-created facedata, only faceste 0 used
3602 our @FOFS; # file offset, if > 0
3603 our @SIZE; # size of face, in octets
3604 our @META; # meta hash of face, if any
3605 our $DATAFH; # facedata filehandle
3606
3507# internal api, not fianlised 3607 # internal api, not finalised
3508sub add_face { 3608 sub set {
3509 my ($name, $type, $data) = @_; 3609 my ($name, $type, $data) = @_;
3510 3610
3511 my $idx = cf::face::find $name; 3611 my $idx = cf::face::find $name;
3512 3612
3513 if ($idx) { 3613 if ($idx) {
3514 delete $FACEHASH{cf::face::get_chksum $idx}; 3614 delete $HASH{cf::face::get_csum $idx};
3515 } else { 3615 } else {
3516 $idx = cf::face::alloc $name; 3616 $idx = cf::face::alloc $name;
3517 } 3617 }
3518 3618
3519 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data; 3619 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3520 3620
3521 cf::face::set_type $idx, $type; 3621 cf::face::set_type $idx, $type;
3522 cf::face::set_data $idx, 0, $data, $hash; 3622 cf::face::set_csum $idx, 0, $hash;
3523 cf::face::set_meta $idx, $type & 1 ? undef : undef; 3623
3624 # we need to destroy the SV itself, not just modify it, as a running ix
3625 # might hold a reference to it: "delete" achieves that.
3626 delete $FOFS[0][$idx];
3627 delete $DATA[0][$idx];
3628 $DATA[0][$idx] = $data;
3629 $SIZE[0][$idx] = length $data;
3630 delete $META[$idx];
3524 $FACEHASH{$hash} = $idx;#d# 3631 $HASH{$hash} = $idx;#d#
3525 3632
3526 $idx 3633 $idx
3634 }
3635
3636 sub _get_data($$$) {
3637 my ($idx, $set, $cb) = @_;
3638
3639 if (defined $DATA[$set][$idx]) {
3640 $cb->($DATA[$set][$idx]);
3641 } elsif (my $fofs = $FOFS[$set][$idx]) {
3642 my $size = $SIZE[$set][$idx];
3643 my $buf;
3644 IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
3645 if ($_[0] == $size) {
3646 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3647 $cb->($buf);
3648 } else {
3649 cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
3650 }
3651 };
3652 } else {
3653 cf::error "requested facedata for unknown face $idx#$set, ignoring.";
3654 }
3655 }
3656
3657 # rather ineffient
3658 sub cf::face::get_data($;$) {
3659 my ($idx, $set) = @_;
3660
3661 _get_data $idx, $set, Coro::rouse_cb;
3662 Coro::rouse_wait
3663 }
3664
3665 sub cf::face::ix {
3666 my ($ns, $set, $idx, $pri) = @_;
3667
3668 _get_data $idx, $set, sub {
3669 $ns->ix_send ($idx, $pri, $_[0]);
3670 };
3671 }
3527} 3672}
3528 3673
3529sub load_facedata($) { 3674sub load_facedata($) {
3530 my ($path) = @_; 3675 my ($path) = @_;
3531 3676
3532 # HACK to clear player env face cache, we need some signal framework
3533 # for this (global event?)
3534 %ext::player_env::MUSIC_FACE_CACHE = ();
3535
3536 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3677 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3537 3678
3538 trace "loading facedata from $path\n"; 3679 trace "loading facedata from $path\n";
3539 3680
3540 my $facedata = decode_storable load_file $path; 3681 my $facedata = decode_storable load_file "$path/faceinfo";
3541 3682
3542 $facedata->{version} == 2 3683 $facedata->{version} == 2
3543 or cf::cleanup "$path: version mismatch, cannot proceed."; 3684 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3544 3685
3545 cf::cede_to_tick; 3686 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3687 or cf::cleanup "$path/facedata: $!, cannot proceed.";
3688
3689 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3690
3691 # BEGIN ATOMIC
3692 # from here on, everything must be atomic - no thread switch allowed
3693 my $t1 = EV::time;
3546 3694
3547 { 3695 {
3548 my $faces = $facedata->{faceinfo}; 3696 my $faces = $facedata->{faceinfo};
3549 3697
3550 for my $face (sort keys %$faces) { 3698 for my $face (sort keys %$faces) {
3551 my $info = $faces->{$face}; 3699 my $info = $faces->{$face};
3552 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3700 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3553 3701
3554 cf::face::set_visibility $idx, $info->{visibility}; 3702 cf::face::set_visibility $idx, $info->{visibility};
3555 cf::face::set_magicmap $idx, $info->{magicmap}; 3703 cf::face::set_magicmap $idx, $info->{magicmap};
3556 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3704 cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
3557 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3705 cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
3558 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3706 cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3559 $FACEHASH{$info->{hash64}} = $idx;#d# 3707 $cf::face::HASH{$info->{hash64}} = $idx;
3560 3708 delete $cf::face::META[$idx];
3561 cf::cede_to_tick;
3562 } 3709 }
3563 3710
3564 while (my ($face, $info) = each %$faces) { 3711 while (my ($face, $info) = each %$faces) {
3565 next unless $info->{smooth}; 3712 next unless $info->{smooth};
3566 3713
… …
3571 cf::face::set_smooth $idx, $smooth; 3718 cf::face::set_smooth $idx, $smooth;
3572 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3719 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3573 } else { 3720 } else {
3574 error "smooth face '$info->{smooth}' not found for face '$face'"; 3721 error "smooth face '$info->{smooth}' not found for face '$face'";
3575 } 3722 }
3576
3577 cf::cede_to_tick;
3578 } 3723 }
3579 } 3724 }
3580 3725
3581 { 3726 {
3582 my $anims = $facedata->{animinfo}; 3727 my $anims = $facedata->{animinfo};
3583 3728
3584 while (my ($anim, $info) = each %$anims) { 3729 while (my ($anim, $info) = each %$anims) {
3585 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3730 cf::anim::set $anim, $info->{frames}, $info->{facings};
3586 cf::cede_to_tick;
3587 } 3731 }
3588 3732
3589 cf::anim::invalidate_all; # d'oh 3733 cf::anim::invalidate_all; # d'oh
3590 } 3734 }
3591 3735
… …
3596 if (defined (my $type = $info->{type})) { 3740 if (defined (my $type = $info->{type})) {
3597 # TODO: different hash - must free and use new index, or cache ixface data queue 3741 # TODO: different hash - must free and use new index, or cache ixface data queue
3598 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3742 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3599 3743
3600 cf::face::set_type $idx, $type; 3744 cf::face::set_type $idx, $type;
3601 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3745 cf::face::set_csum $idx, 0, $info->{hash};
3746 $cf::face::SIZE[0][$idx] = $info->{size};
3747 $cf::face::FOFS[0][$idx] = $info->{fofs};
3602 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already 3748 $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3603 $FACEHASH{$info->{hash}} = $idx;#d# 3749 $cf::face::HASH{$info->{hash}} = $idx;
3604 } else { 3750 } else {
3605# $RESOURCE{$name} = $info; # unused 3751# $RESOURCE{$name} = $info; # unused
3606 } 3752 }
3607
3608 cf::cede_to_tick;
3609 } 3753 }
3610 } 3754 }
3755
3756 ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
3757
3758 # HACK to clear player env face cache, we need some signal framework
3759 # for this (global event?)
3760 %ext::player_env::MUSIC_FACE_CACHE = ();
3761
3762 # END ATOMIC
3763
3764 cf::debug "facedata atomic update time ", EV::time - $t1;
3611 3765
3612 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3766 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3767
3768 aio_close $fh if $fh; # close old facedata
3613 3769
3614 1 3770 1
3615} 3771}
3616 3772
3617register_exticmd fx_want => sub { 3773register_exticmd fx_want => sub {
… …
3633} 3789}
3634 3790
3635sub reload_exp_table { 3791sub reload_exp_table {
3636 _reload_exp_table; 3792 _reload_exp_table;
3637 3793
3794 cf::face::set
3638 add_face "res/exp_table" => FT_RSRC, 3795 "res/exp_table" => FT_RSRC,
3639 JSON::XS->new->utf8->canonical->encode ( 3796 JSON::XS->new->utf8->canonical->encode (
3640 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level] 3797 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3641 ); 3798 );
3642} 3799}
3643 3800
3644sub reload_materials { 3801sub reload_materials {
3645 _reload_materials; 3802 _reload_materials;
3646} 3803}
… …
3658 if exists $_->{match}; 3815 if exists $_->{match};
3659 } 3816 }
3660} 3817}
3661 3818
3662sub reload_facedata { 3819sub reload_facedata {
3663 load_facedata "$DATADIR/facedata" 3820 load_facedata $DATADIR
3664 or die "unable to load facedata\n"; 3821 or die "unable to load facedata\n";
3665} 3822}
3666 3823
3667sub reload_archetypes { 3824sub reload_archetypes {
3668 load_resource_file "$DATADIR/archetypes" 3825 load_resource_file "$DATADIR/archetypes"
3669 or die "unable to load archetypes\n"; 3826 or die "unable to load archetypes\n";
3670 3827
3828 cf::face::set
3671 add_face "res/skill_info" => FT_RSRC, 3829 "res/skill_info" => FT_RSRC,
3672 JSON::XS->new->utf8->canonical->encode ( 3830 JSON::XS->new->utf8->canonical->encode (
3673 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1] 3831 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3674 ); 3832 );
3833
3834 cf::face::set
3675 add_face "res/spell_paths" => FT_RSRC, 3835 "res/spell_paths" => FT_RSRC,
3676 JSON::XS->new->utf8->canonical->encode ( 3836 JSON::XS->new->utf8->canonical->encode (
3677 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1] 3837 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3678 ); 3838 );
3839
3840 # command completion
3841 my @commands;
3842
3843 for (0..cf::arch::skillvec_size - 1) {
3844 my $skill = cf::arch::skillvec $_;
3845 my $name = $skill->name;
3846 my $flags = cf::skill_flags $skill->subtype;
3847
3848 push @commands, "ready_skill $name" if $flags & (SF_COMBAT | SF_RANGED | SF_GRACE);
3849 push @commands, "use_skill $name" if $flags & (SF_USE | SF_AUTARK | SF_GRACE);
3850 }
3851
3852 cf::client::set_command_face skill => \@commands;
3679} 3853}
3680 3854
3681sub reload_treasures { 3855sub reload_treasures {
3682 load_resource_file "$DATADIR/treasures" 3856 load_resource_file "$DATADIR/treasures"
3683 or die "unable to load treasurelists\n"; 3857 or die "unable to load treasurelists\n";
… …
3699 3873
3700 while (my ($k, $v) = each %{$soundconf->{event}}) { 3874 while (my ($k, $v) = each %{$soundconf->{event}}) {
3701 my $face = cf::face::find "sound/$v"; 3875 my $face = cf::face::find "sound/$v";
3702 cf::sound::set $k => $face; 3876 cf::sound::set $k => $face;
3703 } 3877 }
3704}
3705
3706#d# move docstuff to help or so
3707our %DOCSTRING;
3708
3709sub reload_pod {
3710 trace "loading pods $PODDIR\n";
3711
3712 %DOCSTRING = ();
3713 my @command_list;
3714
3715 for (
3716 [0, "command_help"],
3717 [1, "emote_help"],
3718 [2, "dmcommand_help"],
3719 ) {
3720 my ($type, $path) = @$_;
3721
3722 my $paragraphs = &cf::pod::load_pod ("$PODDIR/$path.pod")
3723 or die "unable to load $path";
3724
3725 my $level = 1e9;
3726 my $rpar;
3727
3728 for my $par (@$paragraphs) {
3729 if ($par->{type} eq "head2") {
3730 # this code taken almost verbatim from DC/Protocol.pm
3731
3732 if ($par->{markup} =~ /^(\S+) (?:\s+ \( ([^\)]*) \) )?/x) {
3733 my $cmd = $1;
3734 my @args = split /\|/, $2;
3735 @args = (".*") unless @args;
3736
3737 $_ = $_ eq ".*" ? "" : " $_"
3738 for @args;
3739
3740 my @variants = map "$cmd$_", sort { (length $a) <=> (length $b) } @args;
3741
3742 $rpar = \($DOCSTRING{"command/$cmd"} = &cf::pod::as_cfpod ([$par]));
3743
3744 push @command_list, [$type, \@variants];
3745 $level = $par->{level};
3746 } else {
3747 error "$par->{markup}: unparsable command heading";
3748 }
3749 } elsif ($par->{level} > $level) {
3750 $$rpar .= &cf::pod::as_cfpod ([$par]);
3751 }
3752
3753 cf::cede_to_tick;
3754 }
3755 }
3756
3757 @command_list = sort {
3758 $a->[0] <=> $b->[0]
3759 or $a->[1] cmp $b->[1]
3760 } @command_list;
3761
3762 cf::cede_to_tick;
3763
3764 add_face "res/command_list" => FT_RSRC,
3765 JSON::XS->new->utf8->encode (\@command_list);
3766} 3878}
3767 3879
3768sub reload_resources { 3880sub reload_resources {
3769 trace "reloading resource files...\n"; 3881 trace "reloading resource files...\n";
3770 3882
… …
3773 reload_exp_table; 3885 reload_exp_table;
3774 reload_sound; 3886 reload_sound;
3775 reload_archetypes; 3887 reload_archetypes;
3776 reload_regions; 3888 reload_regions;
3777 reload_treasures; 3889 reload_treasures;
3778 reload_pod;
3779 3890
3780 trace "finished reloading resource files\n"; 3891 trace "finished reloading resource files\n";
3781} 3892}
3782 3893
3783sub reload_config { 3894sub reload_config {
… …
3819 seek $fh, 0, 0; 3930 seek $fh, 0, 0;
3820 print $fh $$; 3931 print $fh $$;
3821} 3932}
3822 3933
3823sub main_loop { 3934sub main_loop {
3824 trace "EV::loop starting\n"; 3935 trace "EV::run starting\n";
3825 if (1) { 3936 if (1) {
3826 EV::loop; 3937 EV::run;
3827 } 3938 }
3828 trace "EV::loop returned\n"; 3939 trace "EV::run returned\n";
3829 goto &main_loop unless $REALLY_UNLOOP; 3940 goto &main_loop unless $REALLY_UNLOOP;
3830} 3941}
3831 3942
3832sub main { 3943sub main {
3833 cf::init_globals; # initialise logging 3944 cf::init_globals; # initialise logging
… …
3842 # we must not ever block the main coroutine 3953 # we must not ever block the main coroutine
3843 $Coro::idle = sub { 3954 $Coro::idle = sub {
3844 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3955 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3845 (async { 3956 (async {
3846 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3957 $Coro::current->{desc} = "IDLE BUG HANDLER";
3847 EV::loop EV::LOOP_ONESHOT; 3958 EV::run EV::RUN_ONCE;
3848 })->prio (Coro::PRIO_MAX); 3959 })->prio (Coro::PRIO_MAX);
3849 }; 3960 };
3850 3961
3851 evthread_start IO::AIO::poll_fileno; 3962 evthread_start IO::AIO::poll_fileno;
3852 3963

Diff Legend

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