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.378 by root, Thu Oct 4 11:36:54 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, Carp::longmess "sync job";#d#
433
432 # TODO: use suspend/resume instead 434 # TODO: use suspend/resume instead
433 # (but this is cancel-safe) 435 # (but this is cancel-safe)
434 my $freeze_guard = freeze_mainloop; 436 my $freeze_guard = freeze_mainloop;
435 437
436 my $busy = 1; 438 my $busy = 1;
442 warn $@ if $@; 444 warn $@ if $@;
443 undef $busy; 445 undef $busy;
444 })->prio (Coro::PRIO_MAX); 446 })->prio (Coro::PRIO_MAX);
445 447
446 while ($busy) { 448 while ($busy) {
449 if (Coro::nready) {
450 Coro::cede_notself;
451 } else {
447 Coro::cede or Event::one_event; 452 Event::one_event;
453 }
448 } 454 }
449 455
450 $time = Event::time - $time; 456 $time = Event::time - $time;
451 457
452 LOG llevError | logBacktrace, Carp::longmess "long sync job" 458 LOG llevError | logBacktrace, Carp::longmess "long sync job"
656attach callbacks/event handlers (a collection of which is called an "attachment") 662attach callbacks/event handlers (a collection of which is called an "attachment")
657to it. All such attachable objects support the following methods. 663to it. All such attachable objects support the following methods.
658 664
659In 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>
660C<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
661Crossfire TRT). 667Deliantra).
662 668
663=over 4 669=over 4
664 670
665=item $attachable->attach ($attachment, key => $value...) 671=item $attachable->attach ($attachment, key => $value...)
666 672
964 970
965=cut 971=cut
966 972
967############################################################################# 973#############################################################################
968# object support 974# object support
969#
970 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#
971sub _can_merge { 1009sub _can_merge {
972 my ($ob1, $ob2) = @_; 1010 my ($ob1, $ob2) = @_;
973 1011
974 local $Storable::canonical = 1; 1012 ++$SLOW_MERGES;#d#
975 my $fob1 = Storable::freeze $ob1;
976 my $fob2 = Storable::freeze $ob2;
977 1013
978 $fob1 eq $fob2 1014 # we do the slow way here
1015 return _object_equal $ob1, $ob2
979} 1016}
980 1017
981sub reattach { 1018sub reattach {
982 # basically do the same as instantiate, without calling instantiate 1019 # basically do the same as instantiate, without calling instantiate
983 my ($obj) = @_; 1020 my ($obj) = @_;
1044 close $fh; 1081 close $fh;
1045 1082
1046 if (@$objs) { 1083 if (@$objs) {
1047 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) {
1048 chmod SAVE_MODE, $fh; 1085 chmod SAVE_MODE, $fh;
1049 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1086 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1050 aio_write $fh, 0, (length $data), $data, 0; 1087 aio_write $fh, 0, (length $data), $data, 0;
1051 aio_fsync $fh if $cf::USE_FSYNC; 1088 aio_fsync $fh if $cf::USE_FSYNC;
1052 close $fh; 1089 close $fh;
1053 aio_rename "$filename.pst~", "$filename.pst"; 1090 aio_rename "$filename.pst~", "$filename.pst";
1054 } 1091 }
1085 1122
1086 unless (aio_stat "$filename.pst") { 1123 unless (aio_stat "$filename.pst") {
1087 (aio_load "$filename.pst", $av) >= 0 1124 (aio_load "$filename.pst", $av) >= 0
1088 or return; 1125 or return;
1089 1126
1090 $av = eval { (Storable::thaw $av)->{objs} }; 1127 my $st = eval { Coro::Storable::thaw $av };
1128 $av = $st->{objs};
1091 } 1129 }
1092 1130
1093 utf8::decode (my $decname = $filename); 1131 utf8::decode (my $decname = $filename);
1094 warn sprintf "loading %s (%d,%d)\n", 1132 warn sprintf "loading %s (%d,%d)\n",
1095 $decname, length $data, scalar @{$av || []}; 1133 $decname, length $data, scalar @{$av || []};
1510 1548
1511Expand crossfire pod fragments into protocol xml. 1549Expand crossfire pod fragments into protocol xml.
1512 1550
1513=cut 1551=cut
1514 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
1515sub expand_cfpod { 1564sub expand_cfpod {
1516 ((my $self), (local $_)) = @_; 1565 my ($self, $pod) = @_;
1517 1566
1518 # escape & and < 1567 my $xml;
1519 s/&/&amp;/g;
1520 s/(?<![BIUGHT])</&lt;/g;
1521 1568
1522 # this is buggy, it needs to properly take care of nested <'s 1569 while () {
1570 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1571 $group = $1;
1523 1572
1524 1 while 1573 $group =~ s/&/&amp;/g;
1525 # replace B<>, I<>, U<> etc. 1574 $group =~ s/</&lt;/g;
1526 s/B<([^\>]*)>/<b>$1<\/b>/ 1575
1527 || s/I<([^\>]*)>/<i>$1<\/i>/ 1576 $xml .= $group;
1528 || s/U<([^\>]*)>/<u>$1<\/u>/ 1577 } elsif ($pod =~ m%\G
1529 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1578 ([BCGHITU])
1530 # replace G<male|female> tags 1579 <
1531 || s{G<([^>|]*)\|([^>]*)>}{ 1580 (?:
1532 $self->gender ? $2 : $1 1581 ([^<>]*) (?{ $group = $^N })
1533 }ge 1582 | < $interior >
1534 # replace H<hint text> 1583 )
1535 || s{H<([^\>]*)>} 1584 >
1585 %gcsx
1536 { 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") {
1537 ("<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>",
1538 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1605 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1539 "") 1606 "")
1540 [$self->{hintmode}] 1607 [$self->{hintmode}];
1608 } else {
1609 $xml .= "error processing '$code($data)' directive";
1541 }ge; 1610 }
1611 } else {
1612 if ($pod =~ /\G(.+)/) {
1613 warn "parse error while expanding $pod (at $1)";
1614 }
1615 last;
1616 }
1617 }
1542 1618
1619 for ($xml) {
1543 # create single paragraphs (very hackish) 1620 # create single paragraphs (very hackish)
1544 s/(?<=\S)\n(?=\w)/ /g; 1621 s/(?<=\S)\n(?=\w)/ /g;
1545 1622
1546 # compress some whitespace 1623 # compress some whitespace
1547 s/\s+\n/\n/g; # ws line-ends 1624 s/\s+\n/\n/g; # ws line-ends
1548 s/\n\n+/\n/g; # double lines 1625 s/\n\n+/\n/g; # double lines
1549 s/^\n+//; # beginning lines 1626 s/^\n+//; # beginning lines
1550 s/\n+$//; # ending lines 1627 s/\n+$//; # ending lines
1628 }
1551 1629
1552 $_ 1630 $xml
1553} 1631}
1632
1633no re 'eval';
1554 1634
1555sub hintmode { 1635sub hintmode {
1556 $_[0]{hintmode} = $_[1] if @_ > 1; 1636 $_[0]{hintmode} = $_[1] if @_ > 1;
1557 $_[0]{hintmode} 1637 $_[0]{hintmode}
1558} 1638}
2628the 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
2629the message unless the client supports the msg packet. 2709the message unless the client supports the msg packet.
2630 2710
2631=cut 2711=cut
2632 2712
2713# non-persistent channels (usually the info channel)
2633our %CHANNEL = ( 2714our %CHANNEL = (
2634 "c/identify" => { 2715 "c/identify" => {
2635 id => "infobox", 2716 id => "infobox",
2636 title => "Identify", 2717 title => "Identify",
2637 reply => undef, 2718 reply => undef,
2641 id => "infobox", 2722 id => "infobox",
2642 title => "Examine", 2723 title => "Examine",
2643 reply => undef, 2724 reply => undef,
2644 tooltip => "Signs and other items you examined", 2725 tooltip => "Signs and other items you examined",
2645 }, 2726 },
2727 "c/book" => {
2728 id => "infobox",
2729 title => "Book",
2730 reply => undef,
2731 tooltip => "The contents of a note or book",
2732 },
2646 "c/lookat" => { 2733 "c/lookat" => {
2647 id => "infobox", 2734 id => "infobox",
2648 title => "Look", 2735 title => "Look",
2649 reply => undef, 2736 reply => undef,
2650 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",
2651 }, 2762 },
2652); 2763);
2653 2764
2654sub cf::client::send_msg { 2765sub cf::client::send_msg {
2655 my ($self, $channel, $msg, $color, @extra) = @_; 2766 my ($self, $channel, $msg, $color, @extra) = @_;
2892=pod 3003=pod
2893 3004
2894The following functions and methods are available within a safe environment: 3005The following functions and methods are available within a safe environment:
2895 3006
2896 cf::object 3007 cf::object
2897 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
2898 insert remove name archname title slaying race decrease_ob_nr 3009 insert remove name archname title slaying race decrease_ob_nr
2899 3010
2900 cf::object::player 3011 cf::object::player
2901 player 3012 player
2902 3013
2909=cut 3020=cut
2910 3021
2911for ( 3022for (
2912 ["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
2913 insert remove inv name archname title slaying race 3024 insert remove inv name archname title slaying race
2914 decrease_ob_nr)], 3025 decrease_ob_nr destroy)],
2915 ["cf::object::player" => qw(player)], 3026 ["cf::object::player" => qw(player)],
2916 ["cf::player" => qw(peaceful)], 3027 ["cf::player" => qw(peaceful)],
2917 ["cf::map" => qw(trigger)], 3028 ["cf::map" => qw(trigger)],
2918) { 3029) {
2919 no strict 'refs'; 3030 no strict 'refs';
3276 # and maps saved/destroyed asynchronously. 3387 # and maps saved/destroyed asynchronously.
3277 warn "begin emergency player save\n"; 3388 warn "begin emergency player save\n";
3278 for my $login (keys %cf::PLAYER) { 3389 for my $login (keys %cf::PLAYER) {
3279 my $pl = $cf::PLAYER{$login} or next; 3390 my $pl = $cf::PLAYER{$login} or next;
3280 $pl->valid or next; 3391 $pl->valid or next;
3392 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3281 $pl->save; 3393 $pl->save;
3282 } 3394 }
3283 warn "end emergency player save\n"; 3395 warn "end emergency player save\n";
3284 3396
3285 warn "begin emergency map save\n"; 3397 warn "begin emergency map save\n";
3333 3445
3334 warn "flushing outstanding aio requests"; 3446 warn "flushing outstanding aio requests";
3335 for (;;) { 3447 for (;;) {
3336 BDB::flush; 3448 BDB::flush;
3337 IO::AIO::flush; 3449 IO::AIO::flush;
3338 Coro::cede; 3450 Coro::cede_notself;
3339 last unless IO::AIO::nreqs || BDB::nreqs; 3451 last unless IO::AIO::nreqs || BDB::nreqs;
3340 warn "iterate..."; 3452 warn "iterate...";
3341 } 3453 }
3342 3454
3343 ++$RELOAD; 3455 ++$RELOAD;

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines