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.379 by root, Thu Oct 4 23:59:07 2007 UTC vs.
Revision 1.395 by root, Sat Nov 10 22:41:59 2007 UTC

4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable;
10use Event; 9use Event;
11use Opcode; 10use Opcode;
12use Safe; 11use Safe;
13use Safe::Hole; 12use Safe::Hole;
13use Storable ();
14 14
15use Coro 3.64 (); 15use Coro 4.1 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
27use BDB (); 27use BDB ();
28use Data::Dumper; 28use Data::Dumper;
29use Digest::MD5; 29use Digest::MD5;
30use Fcntl; 30use Fcntl;
31use YAML::Syck (); 31use YAML::Syck ();
32use IO::AIO 2.32 (); 32use IO::AIO 2.51 ();
33use Time::HiRes; 33use Time::HiRes;
34use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 (); 35use Digest::MD5 ();
36 36
37# configure various modules to our taste 37# configure various modules to our taste
162 162
163The raw value load value from the last tick. 163The raw value load value from the last tick.
164 164
165=item %cf::CFG 165=item %cf::CFG
166 166
167Configuration for the server, loaded from C</etc/crossfire/config>, or 167Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 168from wherever your confdir points to.
169 169
170=item cf::wait_for_tick, cf::wait_for_tick_begin 170=item cf::wait_for_tick, cf::wait_for_tick_begin
171 171
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
373 } 373 }
374 } 374 }
375 } 375 }
376 376
377 if (@SLOT_QUEUE) { 377 if (@SLOT_QUEUE) {
378 # we do not use wait_For_tick() as it returns immediately when tick is inactive 378 # we do not use wait_for_tick() as it returns immediately when tick is inactive
379 push @cf::WAIT_FOR_TICK, $signal; 379 push @cf::WAIT_FOR_TICK, $signal;
380 $signal->wait; 380 $signal->wait;
381 } else { 381 } else {
382 Coro::schedule; 382 Coro::schedule;
383 } 383 }
406 406
407BEGIN { *async = \&Coro::async_pool } 407BEGIN { *async = \&Coro::async_pool }
408 408
409=item cf::sync_job { BLOCK } 409=item cf::sync_job { BLOCK }
410 410
411The design of Crossfire TRT requires that the main coroutine ($Coro::main) 411The design of Deliantra requires that the main coroutine ($Coro::main)
412is always able to handle events or runnable, as Crossfire TRT is only 412is always able to handle events or runnable, as Deliantra is only
413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable. 414acceptable.
415 415
416If it must be done, put the blocking parts into C<sync_job>. This will run 416If it must be done, put the blocking parts into C<sync_job>. This will run
417the given BLOCK in another coroutine while waiting for the result. The 417the given BLOCK in another coroutine while waiting for the result. The
427 my $time = Event::time; 427 my $time = Event::time;
428 428
429 # this is the main coro, too bad, we have to block 429 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 430 # till the operation succeeds, freezing the server :/
431 431
432 LOG llevError | logBacktrace, Carp::longmess "sync job";#d# 432 LOG llevError, Carp::longmess "sync job";#d#
433 433
434 # TODO: use suspend/resume instead 434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe) 435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 436 my $freeze_guard = freeze_mainloop;
437 437
444 warn $@ if $@; 444 warn $@ if $@;
445 undef $busy; 445 undef $busy;
446 })->prio (Coro::PRIO_MAX); 446 })->prio (Coro::PRIO_MAX);
447 447
448 while ($busy) { 448 while ($busy) {
449 if (Coro::nready) {
450 Coro::cede_notself;
451 } else {
449 Coro::cede or Event::one_event; 452 Event::one_event;
453 }
450 } 454 }
451 455
452 $time = Event::time - $time; 456 $time = Event::time - $time;
453 457
454 LOG llevError | logBacktrace, Carp::longmess "long sync job" 458 LOG llevError | logBacktrace, Carp::longmess "long sync job"
658attach callbacks/event handlers (a collection of which is called an "attachment") 662attach callbacks/event handlers (a collection of which is called an "attachment")
659to it. All such attachable objects support the following methods. 663to it. All such attachable objects support the following methods.
660 664
661In the following description, CLASS can be any of C<global>, C<object> 665In the following description, CLASS can be any of C<global>, C<object>
662C<player>, C<client> or C<map> (i.e. the attachable objects in 666C<player>, C<client> or C<map> (i.e. the attachable objects in
663Crossfire TRT). 667Deliantra).
664 668
665=over 4 669=over 4
666 670
667=item $attachable->attach ($attachment, key => $value...) 671=item $attachable->attach ($attachment, key => $value...)
668 672
966 970
967=cut 971=cut
968 972
969############################################################################# 973#############################################################################
970# object support 974# object support
971#
972 975
976sub _object_equal($$);
977sub _object_equal($$) {
978 my ($a, $b) = @_;
979
980 return 0 unless (ref $a) eq (ref $b);
981
982 if ("HASH" eq ref $a) {
983 my @ka = keys %$a;
984 my @kb = keys %$b;
985
986 return 0 if @ka != @kb;
987
988 for (0 .. $#ka) {
989 return 0 unless $ka[$_] eq $kb[$_];
990 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
991 }
992
993 } elsif ("ARRAY" eq ref $a) {
994
995 return 0 if @$a != @$b;
996
997 for (0 .. $#$a) {
998 return 0 unless _object_equal $a->[$_], $b->[$_];
999 }
1000
1001 } elsif ($a ne $b) {
1002 return 0;
1003 }
1004
1005 1
1006}
1007
1008our $SLOW_MERGES;#d#
973sub _can_merge { 1009sub _can_merge {
974 my ($ob1, $ob2) = @_; 1010 my ($ob1, $ob2) = @_;
975 1011
976 local $Storable::canonical = 1; 1012 ++$SLOW_MERGES;#d#
977 my $fob1 = Storable::freeze $ob1;
978 my $fob2 = Storable::freeze $ob2;
979 1013
980 $fob1 eq $fob2 1014 # we do the slow way here
1015 return _object_equal $ob1, $ob2
981} 1016}
982 1017
983sub reattach { 1018sub reattach {
984 # basically do the same as instantiate, without calling instantiate 1019 # basically do the same as instantiate, without calling instantiate
985 my ($obj) = @_; 1020 my ($obj) = @_;
1046 close $fh; 1081 close $fh;
1047 1082
1048 if (@$objs) { 1083 if (@$objs) {
1049 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1084 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1050 chmod SAVE_MODE, $fh; 1085 chmod SAVE_MODE, $fh;
1051 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1086 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1052 aio_write $fh, 0, (length $data), $data, 0; 1087 aio_write $fh, 0, (length $data), $data, 0;
1053 aio_fsync $fh if $cf::USE_FSYNC; 1088 aio_fsync $fh if $cf::USE_FSYNC;
1054 close $fh; 1089 close $fh;
1055 aio_rename "$filename.pst~", "$filename.pst"; 1090 aio_rename "$filename.pst~", "$filename.pst";
1056 } 1091 }
1087 1122
1088 unless (aio_stat "$filename.pst") { 1123 unless (aio_stat "$filename.pst") {
1089 (aio_load "$filename.pst", $av) >= 0 1124 (aio_load "$filename.pst", $av) >= 0
1090 or return; 1125 or return;
1091 1126
1092 $av = eval { (Storable::thaw $av)->{objs} }; 1127 my $st = eval { Coro::Storable::thaw $av };
1128 $av = $st->{objs};
1093 } 1129 }
1094 1130
1095 utf8::decode (my $decname = $filename); 1131 utf8::decode (my $decname = $filename);
1096 warn sprintf "loading %s (%d,%d)\n", 1132 warn sprintf "loading %s (%d,%d)\n",
1097 $decname, length $data, scalar @{$av || []}; 1133 $decname, length $data, scalar @{$av || []};
1512 1548
1513Expand crossfire pod fragments into protocol xml. 1549Expand crossfire pod fragments into protocol xml.
1514 1550
1515=cut 1551=cut
1516 1552
1553use re 'eval';
1554
1555my $group;
1556my $interior; $interior = qr{
1557 # match a pod interior sequence sans C<< >>
1558 (?:
1559 \ (.*?)\ (?{ $group = $^N })
1560 | < (??{$interior}) >
1561 )
1562}x;
1563
1517sub expand_cfpod { 1564sub expand_cfpod {
1518 ((my $self), (local $_)) = @_; 1565 my ($self, $pod) = @_;
1519 1566
1520 # escape & and < 1567 my $xml;
1521 s/&/&amp;/g;
1522 s/(?<![BIUGHT])</&lt;/g;
1523 1568
1524 # this is buggy, it needs to properly take care of nested <'s 1569 while () {
1570 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1571 $group = $1;
1525 1572
1526 1 while 1573 $group =~ s/&/&amp;/g;
1527 # replace B<>, I<>, U<> etc. 1574 $group =~ s/</&lt;/g;
1528 s/B<([^\>]*)>/<b>$1<\/b>/ 1575
1529 || s/I<([^\>]*)>/<i>$1<\/i>/ 1576 $xml .= $group;
1530 || s/U<([^\>]*)>/<u>$1<\/u>/ 1577 } elsif ($pod =~ m%\G
1531 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1578 ([BCGHITU])
1532 # replace G<male|female> tags 1579 <
1533 || s{G<([^>|]*)\|([^>]*)>}{ 1580 (?:
1534 $self->gender ? $2 : $1 1581 ([^<>]*) (?{ $group = $^N })
1535 }ge 1582 | < $interior >
1536 # replace H<hint text> 1583 )
1537 || s{H<([^\>]*)>} 1584 >
1585 %gcsx
1538 { 1586 ) {
1587 my ($code, $data) = ($1, $group);
1588
1589 if ($code eq "B") {
1590 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1591 } elsif ($code eq "I") {
1592 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1593 } elsif ($code eq "U") {
1594 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1595 } elsif ($code eq "C") {
1596 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1597 } elsif ($code eq "T") {
1598 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1599 } elsif ($code eq "G") {
1600 my ($male, $female) = split /\|/, $data;
1601 $data = $self->gender ? $female : $male;
1602 $xml .= expand_cfpod ($self, $data);
1603 } elsif ($code eq "H") {
1539 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1604 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1540 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1605 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1541 "") 1606 "")
1542 [$self->{hintmode}] 1607 [$self->{hintmode}];
1608 } else {
1609 $xml .= "error processing '$code($data)' directive";
1543 }ge; 1610 }
1611 } else {
1612 if ($pod =~ /\G(.+)/) {
1613 warn "parse error while expanding $pod (at $1)";
1614 }
1615 last;
1616 }
1617 }
1544 1618
1619 for ($xml) {
1545 # create single paragraphs (very hackish) 1620 # create single paragraphs (very hackish)
1546 s/(?<=\S)\n(?=\w)/ /g; 1621 s/(?<=\S)\n(?=\w)/ /g;
1547 1622
1548 # compress some whitespace 1623 # compress some whitespace
1549 s/\s+\n/\n/g; # ws line-ends 1624 s/\s+\n/\n/g; # ws line-ends
1550 s/\n\n+/\n/g; # double lines 1625 s/\n\n+/\n/g; # double lines
1551 s/^\n+//; # beginning lines 1626 s/^\n+//; # beginning lines
1552 s/\n+$//; # ending lines 1627 s/\n+$//; # ending lines
1628 }
1553 1629
1554 $_ 1630 $xml
1555} 1631}
1632
1633no re 'eval';
1556 1634
1557sub hintmode { 1635sub hintmode {
1558 $_[0]{hintmode} = $_[1] if @_ > 1; 1636 $_[0]{hintmode} = $_[1] if @_ > 1;
1559 $_[0]{hintmode} 1637 $_[0]{hintmode}
1560} 1638}
2630the message, with C<log> being the default. If C<$color> is negative, suppress 2708the message, with C<log> being the default. If C<$color> is negative, suppress
2631the message unless the client supports the msg packet. 2709the message unless the client supports the msg packet.
2632 2710
2633=cut 2711=cut
2634 2712
2713# non-persistent channels (usually the info channel)
2635our %CHANNEL = ( 2714our %CHANNEL = (
2636 "c/identify" => { 2715 "c/identify" => {
2637 id => "infobox", 2716 id => "infobox",
2638 title => "Identify", 2717 title => "Identify",
2639 reply => undef, 2718 reply => undef,
2643 id => "infobox", 2722 id => "infobox",
2644 title => "Examine", 2723 title => "Examine",
2645 reply => undef, 2724 reply => undef,
2646 tooltip => "Signs and other items you examined", 2725 tooltip => "Signs and other items you examined",
2647 }, 2726 },
2727 "c/book" => {
2728 id => "infobox",
2729 title => "Book",
2730 reply => undef,
2731 tooltip => "The contents of a note or book",
2732 },
2648 "c/lookat" => { 2733 "c/lookat" => {
2649 id => "infobox", 2734 id => "infobox",
2650 title => "Look", 2735 title => "Look",
2651 reply => undef, 2736 reply => undef,
2652 tooltip => "What you saw there", 2737 tooltip => "What you saw there",
2738 },
2739 "c/who" => {
2740 id => "infobox",
2741 title => "Players",
2742 reply => undef,
2743 tooltip => "Shows players who are currently online",
2744 },
2745 "c/body" => {
2746 id => "infobox",
2747 title => "Body Parts",
2748 reply => undef,
2749 tooltip => "Shows which body parts you posess and are available",
2750 },
2751 "c/uptime" => {
2752 id => "infobox",
2753 title => "Uptime",
2754 reply => undef,
2755 tooltip => "How long the server has been running since last restart",
2756 },
2757 "c/mapinfo" => {
2758 id => "infobox",
2759 title => "Map Info",
2760 reply => undef,
2761 tooltip => "Information related to the maps",
2653 }, 2762 },
2654); 2763);
2655 2764
2656sub cf::client::send_msg { 2765sub cf::client::send_msg {
2657 my ($self, $channel, $msg, $color, @extra) = @_; 2766 my ($self, $channel, $msg, $color, @extra) = @_;
2894=pod 3003=pod
2895 3004
2896The following functions and methods are available within a safe environment: 3005The following functions and methods are available within a safe environment:
2897 3006
2898 cf::object 3007 cf::object
2899 contr pay_amount pay_player map x y force_find force_add 3008 contr pay_amount pay_player map x y force_find force_add destroy
2900 insert remove name archname title slaying race decrease_ob_nr 3009 insert remove name archname title slaying race decrease_ob_nr
2901 3010
2902 cf::object::player 3011 cf::object::player
2903 player 3012 player
2904 3013
2911=cut 3020=cut
2912 3021
2913for ( 3022for (
2914 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3023 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2915 insert remove inv name archname title slaying race 3024 insert remove inv name archname title slaying race
2916 decrease_ob_nr)], 3025 decrease_ob_nr destroy)],
2917 ["cf::object::player" => qw(player)], 3026 ["cf::object::player" => qw(player)],
2918 ["cf::player" => qw(peaceful)], 3027 ["cf::player" => qw(peaceful)],
2919 ["cf::map" => qw(trigger)], 3028 ["cf::map" => qw(trigger)],
2920) { 3029) {
2921 no strict 'refs'; 3030 no strict 'refs';
3278 # and maps saved/destroyed asynchronously. 3387 # and maps saved/destroyed asynchronously.
3279 warn "begin emergency player save\n"; 3388 warn "begin emergency player save\n";
3280 for my $login (keys %cf::PLAYER) { 3389 for my $login (keys %cf::PLAYER) {
3281 my $pl = $cf::PLAYER{$login} or next; 3390 my $pl = $cf::PLAYER{$login} or next;
3282 $pl->valid or next; 3391 $pl->valid or next;
3392 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3283 $pl->save; 3393 $pl->save;
3284 } 3394 }
3285 warn "end emergency player save\n"; 3395 warn "end emergency player save\n";
3286 3396
3287 warn "begin emergency map save\n"; 3397 warn "begin emergency map save\n";
3335 3445
3336 warn "flushing outstanding aio requests"; 3446 warn "flushing outstanding aio requests";
3337 for (;;) { 3447 for (;;) {
3338 BDB::flush; 3448 BDB::flush;
3339 IO::AIO::flush; 3449 IO::AIO::flush;
3340 Coro::cede; 3450 Coro::cede_notself;
3341 last unless IO::AIO::nreqs || BDB::nreqs; 3451 last unless IO::AIO::nreqs || BDB::nreqs;
3342 warn "iterate..."; 3452 warn "iterate...";
3343 } 3453 }
3344 3454
3345 ++$RELOAD; 3455 ++$RELOAD;

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines