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.584 by root, Tue Oct 30 17:07:50 2012 UTC vs.
Revision 1.622 by root, Wed Nov 23 06:05:33 2016 UTC

32use Safe; 32use Safe;
33use Safe::Hole; 33use Safe::Hole;
34use Storable (); 34use Storable ();
35use Carp (); 35use Carp ();
36 36
37use Guard (); 37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
40
38use Coro (); 41use Coro ();
39use Coro::State; 42use Coro::State;
40use Coro::Handle; 43use Coro::Handle;
41use Coro::EV; 44use Coro::EV;
42use Coro::AnyEvent; 45use Coro::AnyEvent;
48use Coro::AIO; 51use Coro::AIO;
49use Coro::BDB 1.6; 52use Coro::BDB 1.6;
50use Coro::Storable; 53use Coro::Storable;
51use Coro::Util (); 54use Coro::Util ();
52 55
56use Guard ();
53use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
54use BDB (); 58use BDB ();
55use Data::Dumper; 59use Data::Dumper;
56use Fcntl; 60use Fcntl;
57use YAML::XS (); 61use YAML::XS ();
62use CBOR::XS ();
58use IO::AIO (); 63use IO::AIO ();
59use Time::HiRes;
60use Compress::LZF; 64use Compress::LZF;
61use Digest::MD5 (); 65use Digest::MD5 ();
62 66
63AnyEvent::detect; 67AnyEvent::detect;
64 68
83our %COMMAND = (); 87our %COMMAND = ();
84our %COMMAND_TIME = (); 88our %COMMAND_TIME = ();
85 89
86our @EXTS = (); # list of extension package names 90our @EXTS = (); # list of extension package names
87our %EXTCMD = (); 91our %EXTCMD = ();
92our %EXTACMD = ();
88our %EXTICMD = (); 93our %EXTICMD = ();
94our %EXTIACMD = ();
89our %EXT_CORO = (); # coroutines bound to extensions 95our %EXT_CORO = (); # coroutines bound to extensions
90our %EXT_MAP = (); # pluggable maps 96our %EXT_MAP = (); # pluggable maps
91 97
92our $RELOAD; # number of reloads so far, non-zero while in reload 98our $RELOAD; # number of reloads so far, non-zero while in reload
93our @EVENT; 99our @EVENT;
220=item $cf::RUNTIME 226=item $cf::RUNTIME
221 227
222The 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
223every server tick. 229every server tick.
224 230
225=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 231=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
226$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 232$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
227$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 233$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
228 234
229Various directories - "/etc", read-only install directory, perl-library 235Various directories - "/etc", read-only install directory, perl-library
230directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 236directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
231unique-items directory, player file directory, random maps directory and 237unique-items directory, player file directory, random maps directory and
232database environment. 238database environment.
246Configuration for the server, loaded from C</etc/deliantra-server/config>, or 252Configuration for the server, loaded from C</etc/deliantra-server/config>, or
247from wherever your confdir points to. 253from wherever your confdir points to.
248 254
249=item cf::wait_for_tick, cf::wait_for_tick_begin 255=item cf::wait_for_tick, cf::wait_for_tick_begin
250 256
251These 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.
252returns 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
253per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 260cf::wait_for_tick wakes up all waiters after tick processing.
254 261
255Note 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
256ticking, 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
257when 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>
258want to wait, use C<$cf::WAIT_FOR_TICK>). 265want to wait, use C<$cf::WAIT_FOR_TICK>).
259 266
260=item $cf::WAIT_FOR_TICK 267=item $cf::WAIT_FOR_TICK
336)) { 343)) {
337 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 344 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
338} 345}
339 346
340$EV::DIED = sub { 347$EV::DIED = sub {
341 Carp::cluck "error in event callback: @_"; 348 warn "error in event callback: $@";
342}; 349};
343 350
344############################################################################# 351#############################################################################
345 352
346sub fork_call(&@); 353sub fork_call(&@);
458 465
459sub decode_yaml($) { 466sub decode_yaml($) {
460 fork_call { YAML::XS::Load $_[0] } @_ 467 fork_call { YAML::XS::Load $_[0] } @_
461} 468}
462 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
463=item $scalar = cf::unlzf $scalar 484=item $scalar = cf::unlzf $scalar
464 485
465Same as Compress::LZF::compress, but takes server ticks into account, so 486Same as Compress::LZF::compress, but takes server ticks into account, so
466blocks. 487blocks.
467 488
504 } 525 }
505} 526}
506 527
507=item cf::lock_wait $string 528=item cf::lock_wait $string
508 529
509Wait until the given lock is available. See cf::lock_acquire. 530Wait until the given lock is available. See cf::lock_acquire.
510 531
511=item my $lock = cf::lock_acquire $string 532=item my $lock = cf::lock_acquire $string
512 533
513Wait 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
514a 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,
567Allocate $time seconds of blocking CPU time at priority C<$priority> 588Allocate $time seconds of blocking CPU time at priority C<$priority>
568(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
569C<$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
570till the next cede. 591till the next cede.
571 592
572Background jobs should use a priority les than zero, interactive jobs 593Background jobs should use a priority less than zero, interactive jobs
573should use 100 or more. 594should use 100 or more.
574 595
575The 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
576used for statistical purposes and should identify the same time-class. 597used for statistical purposes and should identify the same time-class.
577 598
590 my $signal = new Coro::Signal; 611 my $signal = new Coro::Signal;
591 my $busy; 612 my $busy;
592 613
593 while () { 614 while () {
594 next_job: 615 next_job:
616
617 Coro::cede;
595 618
596 my $avail = cf::till_tick; 619 my $avail = cf::till_tick;
597 620
598 for (0 .. $#SLOT_QUEUE) { 621 for (0 .. $#SLOT_QUEUE) {
599 if ($SLOT_QUEUE[$_][0] <= $avail) { 622 if ($SLOT_QUEUE[$_][0] <= $avail) {
600 $busy = 0; 623 $busy = 0;
601 my $job = splice @SLOT_QUEUE, $_, 1, (); 624 my $job = splice @SLOT_QUEUE, $_, 1, ();
602 $job->[2]->send; 625 $job->[2]->send;
603 Coro::cede;
604 goto next_job; 626 goto next_job;
605 } else { 627 } else {
606 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY; 628 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
607 } 629 }
608 } 630 }
609 631
610 if (@SLOT_QUEUE) { 632 if (@SLOT_QUEUE) {
611 # we do not use wait_for_tick() as it returns immediately when tick is inactive 633 wait_for_tick;
612 $WAIT_FOR_TICK->wait;
613 } else { 634 } else {
614 $busy = 0; 635 $busy = 0;
615 Coro::schedule; 636 Coro::schedule;
616 } 637 }
617 } 638 }
643BEGIN { *async = \&Coro::async_pool } 664BEGIN { *async = \&Coro::async_pool }
644 665
645=item cf::sync_job { BLOCK } 666=item cf::sync_job { BLOCK }
646 667
647The design of Deliantra requires that the main coroutine ($Coro::main) 668The design of Deliantra requires that the main coroutine ($Coro::main)
648is always able to handle events or runnable, as Deliantra is only 669is always able to handle events or is runnable, as Deliantra is only
649partly 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
650acceptable. 671acceptable.
651 672
652If 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
653the given BLOCK in another coroutine while waiting for the result. The 674the given BLOCK in another coroutine while waiting for the result. The
681 702
682 while ($busy) { 703 while ($busy) {
683 if (Coro::nready) { 704 if (Coro::nready) {
684 Coro::cede_notself; 705 Coro::cede_notself;
685 } else { 706 } else {
686 EV::loop EV::LOOP_ONESHOT; 707 EV::run EV::RUN_ONCE;
687 } 708 }
688 } 709 }
689 710
690 my $time = AE::time - $time; 711 my $time = AE::time - $time;
691 712
732 reset_signals; 753 reset_signals;
733} 754}
734 755
735sub fork_call(&@) { 756sub fork_call(&@) {
736 my ($cb, @args) = @_; 757 my ($cb, @args) = @_;
737
738 # we seemingly have to make a local copy of the whole thing,
739 # otherwise perl prematurely frees the stuff :/
740 # TODO: investigate and fix (likely this will be rather laborious)
741 758
742 my @res = Coro::Util::fork_eval { 759 my @res = Coro::Util::fork_eval {
743 cf::post_fork; 760 cf::post_fork;
744 &$cb 761 &$cb
745 } @args; 762 } @args;
895 912
896 return db_get cache => "$id/data"; 913 return db_get cache => "$id/data";
897 } 914 }
898 } 915 }
899 916
900 my $t1 = Time::HiRes::time; 917 my $t1 = EV::time;
901 my $data = $process->(\@data); 918 my $data = $process->(\@data);
902 my $t2 = Time::HiRes::time; 919 my $t2 = EV::time;
903 920
904 info "cache: '$id' processed in ", $t2 - $t1, "s\n"; 921 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
905 922
906 db_put cache => "$id/data", $data; 923 db_put cache => "$id/data", $data;
907 db_put cache => "$id/md5" , $md5; 924 db_put cache => "$id/md5" , $md5;
1427=cut 1444=cut
1428 1445
1429############################################################################# 1446#############################################################################
1430# command handling &c 1447# command handling &c
1431 1448
1432=item cf::register_command $name => \&callback($ob,$args); 1449=item cf::register_command $name => \&callback($ob,$args)
1433 1450
1434Register a callback for execution when the client sends the user command 1451Register a callback for execution when the client sends the user command
1435$name. 1452$name.
1436 1453
1437=cut 1454=cut
1443 #warn "registering command '$name/$time' to '$caller'"; 1460 #warn "registering command '$name/$time' to '$caller'";
1444 1461
1445 push @{ $COMMAND{$name} }, [$caller, $cb]; 1462 push @{ $COMMAND{$name} }, [$caller, $cb];
1446} 1463}
1447 1464
1448=item cf::register_extcmd $name => \&callback($pl,$packet); 1465=item cf::register_extcmd $name => \&callback($pl,@args)
1449 1466
1450Register a callback for execution when the client sends an (synchronous) 1467Register a callback for execution when the client sends an (synchronous)
1451extcmd packet. Ext commands will be processed in the order they are 1468extcmd packet. Ext commands will be processed in the order they are
1452received by the server, like other user commands. The first argument is 1469received by the server, like other user commands. The first argument is
1453the 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
1454has logged in successfully. 1471has logged in successfully.
1455 1472
1456If the callback returns something, it is sent back as if reply was being 1473The values will be sent back to the client.
1457called.
1458 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
1459=item cf::register_exticmd $name => \&callback($ns,$packet); 1480=item cf::register_exticmd $name => \&callback($ns,@args)
1460 1481
1461Register a callback for execution when the client sends an (asynchronous) 1482Register a callback for execution when the client sends an (asynchronous)
1462exticmd 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
1463are 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
1464is a client socket. Exti commands can be received anytime, even before 1485is a client socket. Exti commands can be received anytime, even before
1465log-in. 1486log-in.
1466 1487
1467If the callback returns something, it is sent back as if reply was being 1488The values will be sent back to the client.
1468called.
1469 1489
1470=cut 1490=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1471 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
1472sub register_extcmd { 1497sub register_extcmd($$) {
1473 my ($name, $cb) = @_; 1498 my ($name, $cb) = @_;
1474 1499
1475 $EXTCMD{$name} = $cb; 1500 $EXTCMD{$name} = $cb;
1476} 1501}
1477 1502
1478sub register_exticmd { 1503sub register_async_extcmd($$) {
1479 my ($name, $cb) = @_; 1504 my ($name, $cb) = @_;
1480 1505
1506 $EXTACMD{$name} = $cb;
1507}
1508
1509sub register_exticmd($$) {
1510 my ($name, $cb) = @_;
1511
1481 $EXTICMD{$name} = $cb; 1512 $EXTICMD{$name} = $cb;
1513}
1514
1515sub register_async_exticmd($$) {
1516 my ($name, $cb) = @_;
1517
1518 $EXTIACMD{$name} = $cb;
1482} 1519}
1483 1520
1484use File::Glob (); 1521use File::Glob ();
1485 1522
1486cf::player->attach ( 1523cf::player->attach (
1502 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1539 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1503 1540
1504 if (ref $msg) { 1541 if (ref $msg) {
1505 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash 1542 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1506 1543
1507 my @reply;
1508
1509 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}) {
1510 @reply = $cb->($pl, @payload); 1557 @reply = $cb->($pl, @payload);
1558 }
1559
1560 $pl->ext_msg ("reply-$reply", @reply)
1561 if $reply;
1511 } 1562 }
1512
1513 $pl->ext_reply ($reply, @reply)
1514 if $reply;
1515 1563
1516 } else { 1564 } else {
1517 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1565 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1518 } 1566 }
1519 1567
1905} 1953}
1906 1954
1907=item $protocol_xml = $player->expand_cfpod ($cfpod) 1955=item $protocol_xml = $player->expand_cfpod ($cfpod)
1908 1956
1909Expand deliantra pod fragments into protocol xml. 1957Expand deliantra pod fragments into protocol xml.
1910
1911=item $player->ext_reply ($msgid, @msg)
1912
1913Sends an ext reply to the player.
1914
1915=cut
1916
1917sub ext_reply($$@) {
1918 my ($self, $id, @msg) = @_;
1919
1920 $self->ns->ext_reply ($id, @msg)
1921}
1922 1958
1923=item $player->ext_msg ($type, @msg) 1959=item $player->ext_msg ($type, @msg)
1924 1960
1925Sends an ext event to the client. 1961Sends an ext event to the client.
1926 1962
2363 2399
2364 $MAP_PREFETCHER ||= cf::async { 2400 $MAP_PREFETCHER ||= cf::async {
2365 $Coro::current->{desc} = "map prefetcher"; 2401 $Coro::current->{desc} = "map prefetcher";
2366 2402
2367 while (%MAP_PREFETCH) { 2403 while (%MAP_PREFETCH) {
2368 while (my ($k, $v) = each %MAP_PREFETCH) { 2404 for my $k (keys %MAP_PREFETCH) {
2369 if (my $map = find $k) { 2405 if (my $map = find $k) {
2370 $map->load if $v; 2406 $map->load if $MAP_PREFETCH{$k};
2371 } 2407 }
2372 2408
2373 delete $MAP_PREFETCH{$k}; 2409 delete $MAP_PREFETCH{$k};
2374 } 2410 }
2375 } 2411 }
2629 2665
2630Creates 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.
2631 2667
2632=item $ob = cf::object::deref ($refstring) 2668=item $ob = cf::object::deref ($refstring)
2633 2669
2634returns 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,
2635even if the object actually exists. May block. 2671even if the object actually exists. May block.
2636 2672
2637=cut 2673=cut
2638 2674
2639sub deref { 2675sub deref {
2721=item $player_object->may ("access") 2757=item $player_object->may ("access")
2722 2758
2723Returns wether the given player is authorized to access resource "access" 2759Returns wether the given player is authorized to access resource "access"
2724(e.g. "command_wizcast"). 2760(e.g. "command_wizcast").
2725 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
2726=cut 2787=cut
2727 2788
2728sub cf::object::player::may { 2789sub cf::object::player::may {
2729 my ($self, $access) = @_; 2790 my ($self, $access) = @_;
2730 2791
2731 $self->flag (cf::FLAG_WIZ) || 2792 $self->flag (cf::FLAG_WIZ) ||
2732 (ref $cf::CFG{"may_$access"} 2793 (ref $cf::CFG{"may_$access"}
2733 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 2794 ? scalar grep $self->name eq $_ || $self->uuid eq $_, @{$cf::CFG{"may_$access"}}
2734 : $cf::CFG{"may_$access"}) 2795 : $cf::CFG{"may_$access"})
2735} 2796}
2736 2797
2737=item $player_object->enter_link 2798=item $player_object->enter_link
2738 2799
2741The 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.
2742for 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,
2743though, 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
2744map. 2805map.
2745 2806
2746Will 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.
2747 2814
2748=item $player_object->leave_link ($map, $x, $y) 2815=item $player_object->leave_link ($map, $x, $y)
2749 2816
2750Moves 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
2751map. 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
3021 3088
3022=head3 cf::client 3089=head3 cf::client
3023 3090
3024=over 4 3091=over 4
3025 3092
3026=item $client->send_drawinfo ($text, $flags)
3027
3028Sends a drawinfo packet to the client. Circumvents output buffering so
3029should not be used under normal circumstances.
3030
3031=cut
3032
3033sub cf::client::send_drawinfo {
3034 my ($self, $text, $flags) = @_;
3035
3036 utf8::encode $text;
3037 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
3038}
3039
3040=item $client->send_big_packet ($pkt) 3093=item $client->send_big_packet ($pkt)
3041 3094
3042Like C<send_packet>, but tries to compress large packets, and fragments 3095Like C<send_packet>, but tries to compress large packets, and fragments
3043them as required. 3096them as required.
3044 3097
3062 $self->send_packet ($pkt); 3115 $self->send_packet ($pkt);
3063} 3116}
3064 3117
3065=item $client->send_msg ($channel, $msg, $color, [extra...]) 3118=item $client->send_msg ($channel, $msg, $color, [extra...])
3066 3119
3067Send 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
3068client if neccessary. C<$type> should be a string identifying the type of 3121necessary. C<$type> should be a string identifying the type of the
3069the 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
3070the message unless the client supports the msg packet. 3123the message unless the client supports the msg packet.
3071 3124
3072=cut 3125=cut
3073 3126
3074# non-persistent channels (usually the info channel) 3127# non-persistent channels (usually the info channel)
3179 id => "death", 3232 id => "death",
3180 title => "Death", 3233 title => "Death",
3181 reply => undef, 3234 reply => undef,
3182 tooltip => "Reason for and more info about your most recent death", 3235 tooltip => "Reason for and more info about your most recent death",
3183 }, 3236 },
3237 "c/fatal" => {
3238 id => "fatal",
3239 title => "Fatal Error",
3240 reply => undef,
3241 tooltip => "Reason for the server disconnect",
3242 },
3184 "c/say" => $SAY_CHANNEL, 3243 "c/say" => $SAY_CHANNEL,
3185 "c/chat" => $CHAT_CHANNEL, 3244 "c/chat" => $CHAT_CHANNEL,
3186); 3245);
3187 3246
3188sub cf::client::send_msg { 3247sub cf::client::send_msg {
3231=cut 3290=cut
3232 3291
3233sub cf::client::ext_msg($$@) { 3292sub cf::client::ext_msg($$@) {
3234 my ($self, $type, @msg) = @_; 3293 my ($self, $type, @msg) = @_;
3235 3294
3236 if ($self->extcmd == 2) {
3237 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3295 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3238 } elsif ($self->extcmd == 1) { # TODO: remove
3239 push @msg, msgtype => "event_$type";
3240 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3241 }
3242}
3243
3244=item $client->ext_reply ($msgid, @msg)
3245
3246Sends an ext reply to the client.
3247
3248=cut
3249
3250sub cf::client::ext_reply($$@) {
3251 my ($self, $id, @msg) = @_;
3252
3253 return unless $self->extcmd == 2;
3254
3255 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3256} 3296}
3257 3297
3258=item $success = $client->query ($flags, "text", \&cb) 3298=item $success = $client->query ($flags, "text", \&cb)
3259 3299
3260Queues a query to the client, calling the given callback with 3300Queues a query to the client, calling the given callback with
3280 3320
3281 $self->send_packet ($self->{query_queue}[0][0]) 3321 $self->send_packet ($self->{query_queue}[0][0])
3282 if @{ $self->{query_queue} } == 1; 3322 if @{ $self->{query_queue} } == 1;
3283 3323
3284 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;
3285} 3364}
3286 3365
3287cf::client->attach ( 3366cf::client->attach (
3288 on_connect => sub { 3367 on_connect => sub {
3289 my ($ns) = @_; 3368 my ($ns) = @_;
3317 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3396 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3318 3397
3319 if (ref $msg) { 3398 if (ref $msg) {
3320 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash 3399 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3321 3400
3322 my @reply;
3323
3324 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}) {
3325 @reply = $cb->($ns, @payload); 3414 @reply = $cb->($ns, @payload);
3415 }
3416
3417 $ns->ext_msg ("reply-$reply", @reply)
3418 if $reply;
3326 } 3419 }
3327
3328 $ns->ext_reply ($reply, @reply)
3329 if $reply;
3330
3331 } else { 3420 } else {
3332 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";
3333 } 3422 }
3334 3423
3335 cf::override; 3424 cf::override;
3503=cut 3592=cut
3504 3593
3505############################################################################# 3594#############################################################################
3506# the server's init and main functions 3595# the server's init and main functions
3507 3596
3508our %FACEHASH; # hash => idx, #d# HACK for http server 3597{
3598 package cf::face;
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
3607 # internal api, not finalised
3608 sub set {
3609 my ($name, $type, $data) = @_;
3610
3611 my $idx = cf::face::find $name;
3612
3613 if ($idx) {
3614 delete $HASH{cf::face::get_csum $idx};
3615 } else {
3616 $idx = cf::face::alloc $name;
3617 }
3618
3619 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3620
3621 cf::face::set_type $idx, $type;
3622 cf::face::set_csum $idx, 0, $hash;
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];
3631 $HASH{$hash} = $idx;#d#
3632
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 }
3672}
3509 3673
3510sub load_facedata($) { 3674sub load_facedata($) {
3511 my ($path) = @_; 3675 my ($path) = @_;
3512 3676
3513 # HACK to clear player env face cache, we need some signal framework
3514 # for this (global event?)
3515 %ext::player_env::MUSIC_FACE_CACHE = ();
3516
3517 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3677 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3518 3678
3519 trace "loading facedata from $path\n"; 3679 trace "loading facedata from $path\n";
3520 3680
3521 my $facedata = decode_storable load_file $path; 3681 my $facedata = decode_storable load_file "$path/faceinfo";
3522 3682
3523 $facedata->{version} == 2 3683 $facedata->{version} == 2
3524 or cf::cleanup "$path: version mismatch, cannot proceed."; 3684 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3525 3685
3526 # patch in the exptable 3686 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3527 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]); 3687 or cf::cleanup "$path/facedata: $!, cannot proceed.";
3528 $facedata->{resource}{"res/exp_table"} = { 3688
3529 type => FT_RSRC, 3689 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3530 data => $exp_table, 3690
3531 hash => (Digest::MD5::md5 $exp_table), 3691 # BEGIN ATOMIC
3532 }; 3692 # from here on, everything must be atomic - no thread switch allowed
3533 cf::cede_to_tick; 3693 my $t1 = EV::time;
3534 3694
3535 { 3695 {
3536 my $faces = $facedata->{faceinfo}; 3696 my $faces = $facedata->{faceinfo};
3537 3697
3538 while (my ($face, $info) = each %$faces) { 3698 for my $face (sort keys %$faces) {
3699 my $info = $faces->{$face};
3539 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3700 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3540 3701
3541 cf::face::set_visibility $idx, $info->{visibility}; 3702 cf::face::set_visibility $idx, $info->{visibility};
3542 cf::face::set_magicmap $idx, $info->{magicmap}; 3703 cf::face::set_magicmap $idx, $info->{magicmap};
3543 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};
3544 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};
3545 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};
3546 $FACEHASH{$info->{hash64}} = $idx;#d# 3707 $cf::face::HASH{$info->{hash64}} = $idx;
3547 3708 delete $cf::face::META[$idx];
3548 cf::cede_to_tick;
3549 } 3709 }
3550 3710
3551 while (my ($face, $info) = each %$faces) { 3711 while (my ($face, $info) = each %$faces) {
3552 next unless $info->{smooth}; 3712 next unless $info->{smooth};
3553 3713
3558 cf::face::set_smooth $idx, $smooth; 3718 cf::face::set_smooth $idx, $smooth;
3559 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3719 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3560 } else { 3720 } else {
3561 error "smooth face '$info->{smooth}' not found for face '$face'"; 3721 error "smooth face '$info->{smooth}' not found for face '$face'";
3562 } 3722 }
3563
3564 cf::cede_to_tick;
3565 } 3723 }
3566 } 3724 }
3567 3725
3568 { 3726 {
3569 my $anims = $facedata->{animinfo}; 3727 my $anims = $facedata->{animinfo};
3570 3728
3571 while (my ($anim, $info) = each %$anims) { 3729 while (my ($anim, $info) = each %$anims) {
3572 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3730 cf::anim::set $anim, $info->{frames}, $info->{facings};
3573 cf::cede_to_tick;
3574 } 3731 }
3575 3732
3576 cf::anim::invalidate_all; # d'oh 3733 cf::anim::invalidate_all; # d'oh
3577 } 3734 }
3578 3735
3582 while (my ($name, $info) = each %$res) { 3739 while (my ($name, $info) = each %$res) {
3583 if (defined (my $type = $info->{type})) { 3740 if (defined (my $type = $info->{type})) {
3584 # 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
3585 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3742 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3586 3743
3587 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3588 cf::face::set_type $idx, $type; 3744 cf::face::set_type $idx, $type;
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};
3589 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
3590 $FACEHASH{$info->{hash}} = $idx;#d# 3749 $cf::face::HASH{$info->{hash}} = $idx;
3591 } else { 3750 } else {
3592# $RESOURCE{$name} = $info; # unused 3751# $RESOURCE{$name} = $info; # unused
3593 } 3752 }
3594
3595 cf::cede_to_tick;
3596 } 3753 }
3597 } 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;
3598 3765
3599 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
3600 3769
3601 1 3770 1
3602} 3771}
3603 3772
3604register_exticmd fx_want => sub { 3773register_exticmd fx_want => sub {
3615 my $status = load_resource_file_ $_[0]; 3784 my $status = load_resource_file_ $_[0];
3616 get_slot 0.1, 100; 3785 get_slot 0.1, 100;
3617 cf::arch::commit_load; 3786 cf::arch::commit_load;
3618 3787
3619 $status 3788 $status
3789}
3790
3791sub reload_exp_table {
3792 _reload_exp_table;
3793
3794 cf::face::set
3795 "res/exp_table" => FT_RSRC,
3796 JSON::XS->new->utf8->canonical->encode (
3797 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3798 );
3799}
3800
3801sub reload_materials {
3802 _reload_materials;
3620} 3803}
3621 3804
3622sub reload_regions { 3805sub reload_regions {
3623 # HACK to clear player env face cache, we need some signal framework 3806 # HACK to clear player env face cache, we need some signal framework
3624 # for this (global event?) 3807 # for this (global event?)
3632 if exists $_->{match}; 3815 if exists $_->{match};
3633 } 3816 }
3634} 3817}
3635 3818
3636sub reload_facedata { 3819sub reload_facedata {
3637 load_facedata "$DATADIR/facedata" 3820 load_facedata $DATADIR
3638 or die "unable to load facedata\n"; 3821 or die "unable to load facedata\n";
3639} 3822}
3640 3823
3641sub reload_archetypes { 3824sub reload_archetypes {
3642 load_resource_file "$DATADIR/archetypes" 3825 load_resource_file "$DATADIR/archetypes"
3643 or die "unable to load archetypes\n"; 3826 or die "unable to load archetypes\n";
3827
3828 cf::face::set
3829 "res/skill_info" => FT_RSRC,
3830 JSON::XS->new->utf8->canonical->encode (
3831 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3832 );
3833
3834 cf::face::set
3835 "res/spell_paths" => FT_RSRC,
3836 JSON::XS->new->utf8->canonical->encode (
3837 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
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;
3644} 3853}
3645 3854
3646sub reload_treasures { 3855sub reload_treasures {
3647 load_resource_file "$DATADIR/treasures" 3856 load_resource_file "$DATADIR/treasures"
3648 or die "unable to load treasurelists\n"; 3857 or die "unable to load treasurelists\n";
3669} 3878}
3670 3879
3671sub reload_resources { 3880sub reload_resources {
3672 trace "reloading resource files...\n"; 3881 trace "reloading resource files...\n";
3673 3882
3674 reload_exp_table;
3675 reload_materials; 3883 reload_materials;
3676 reload_facedata; 3884 reload_facedata;
3885 reload_exp_table;
3677 reload_sound; 3886 reload_sound;
3678 reload_archetypes; 3887 reload_archetypes;
3679 reload_regions; 3888 reload_regions;
3680 reload_treasures; 3889 reload_treasures;
3681 3890
3721 seek $fh, 0, 0; 3930 seek $fh, 0, 0;
3722 print $fh $$; 3931 print $fh $$;
3723} 3932}
3724 3933
3725sub main_loop { 3934sub main_loop {
3726 trace "EV::loop starting\n"; 3935 trace "EV::run starting\n";
3727 if (1) { 3936 if (1) {
3728 EV::loop; 3937 EV::run;
3729 } 3938 }
3730 trace "EV::loop returned\n"; 3939 trace "EV::run returned\n";
3731 goto &main_loop unless $REALLY_UNLOOP; 3940 goto &main_loop unless $REALLY_UNLOOP;
3732} 3941}
3733 3942
3734sub main { 3943sub main {
3735 cf::init_globals; # initialise logging 3944 cf::init_globals; # initialise logging
3740 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3949 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3741 3950
3742 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3951 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3743 3952
3744 # we must not ever block the main coroutine 3953 # we must not ever block the main coroutine
3745 local $Coro::idle = sub { 3954 $Coro::idle = sub {
3746 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#
3747 (async { 3956 (async {
3748 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3957 $Coro::current->{desc} = "IDLE BUG HANDLER";
3749 EV::loop EV::LOOP_ONESHOT; 3958 EV::run EV::RUN_ONCE;
3750 })->prio (Coro::PRIO_MAX); 3959 })->prio (Coro::PRIO_MAX);
3751 }; 3960 };
3752 3961
3753 evthread_start IO::AIO::poll_fileno; 3962 evthread_start IO::AIO::poll_fileno;
3754 3963
3755 cf::sync_job { 3964 cf::sync_job {
3756 cf::incloader::init (); 3965 cf::incloader::init ();
3966
3967 db_init;
3757 3968
3758 cf::init_anim; 3969 cf::init_anim;
3759 cf::init_attackmess; 3970 cf::init_attackmess;
3760 cf::init_dynamic; 3971 cf::init_dynamic;
3761 3972
3762 cf::load_settings; 3973 cf::load_settings;
3763 3974
3764 reload_resources; 3975 reload_resources;
3765 reload_config; 3976 reload_config;
3766 db_init;
3767 3977
3768 cf::init_uuid; 3978 cf::init_uuid;
3769 cf::init_signals; 3979 cf::init_signals;
3770 cf::init_skills; 3980 cf::init_skills;
3771 3981
4196 } 4406 }
4197} 4407}
4198 4408
4199{ 4409{
4200 # configure BDB 4410 # configure BDB
4411 info "initialising database";
4201 4412
4202 BDB::min_parallel 16; 4413 BDB::min_parallel 16;
4203 BDB::max_poll_reqs $TICK * 0.1; 4414 BDB::max_poll_reqs $TICK * 0.1;
4204 #$AnyEvent::BDB::WATCHER->priority (1); 4415 #$AnyEvent::BDB::WATCHER->priority (1);
4205 4416
4234 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4445 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4235 }; 4446 };
4236 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4447 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4237 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4448 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4238 }; 4449 };
4450
4451 info "database initialised";
4239} 4452}
4240 4453
4241{ 4454{
4242 # configure IO::AIO 4455 # configure IO::AIO
4243 4456
4457 info "initialising aio";
4244 IO::AIO::min_parallel 8; 4458 IO::AIO::min_parallel 8;
4245 IO::AIO::max_poll_time $TICK * 0.1; 4459 IO::AIO::max_poll_time $TICK * 0.1;
4246 undef $AnyEvent::AIO::WATCHER; 4460 undef $AnyEvent::AIO::WATCHER;
4461 info "aio initialised";
4247} 4462}
4248 4463
4249our $_log_backtrace; 4464our $_log_backtrace;
4250our $_log_backtrace_last; 4465our $_log_backtrace_last;
4251 4466

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines