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.376 by root, Mon Oct 1 00:44:44 2007 UTC vs.
Revision 1.394 by root, Thu Nov 8 19:43:25 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
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}
2273=cut 2353=cut
2274 2354
2275sub deref { 2355sub deref {
2276 my ($ref) = @_; 2356 my ($ref) = @_;
2277 2357
2278 # temporary compatibility#TODO#remove
2279 $ref =~ s{^<}{player/<};
2280
2281 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2358 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2282 my ($uuid, $name) = ($1, $2); 2359 my ($uuid, $name) = ($1, $2);
2283 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2360 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2284 or return; 2361 or return;
2285 $pl->ob->uuid eq $uuid 2362 $pl->ob->uuid eq $uuid
2286 or return; 2363 or return;
2631the 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
2632the message unless the client supports the msg packet. 2709the message unless the client supports the msg packet.
2633 2710
2634=cut 2711=cut
2635 2712
2713# non-persistent channels (usually the info channel)
2636our %CHANNEL = ( 2714our %CHANNEL = (
2637 "c/identify" => { 2715 "c/identify" => {
2638 id => "infobox", 2716 id => "infobox",
2639 title => "Identify", 2717 title => "Identify",
2640 reply => undef, 2718 reply => undef,
2644 id => "infobox", 2722 id => "infobox",
2645 title => "Examine", 2723 title => "Examine",
2646 reply => undef, 2724 reply => undef,
2647 tooltip => "Signs and other items you examined", 2725 tooltip => "Signs and other items you examined",
2648 }, 2726 },
2727 "c/book" => {
2728 id => "infobox",
2729 title => "Book",
2730 reply => undef,
2731 tooltip => "The contents of a note or book",
2732 },
2649 "c/lookat" => { 2733 "c/lookat" => {
2650 id => "infobox", 2734 id => "infobox",
2651 title => "Look", 2735 title => "Look",
2652 reply => undef, 2736 reply => undef,
2653 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",
2654 }, 2762 },
2655); 2763);
2656 2764
2657sub cf::client::send_msg { 2765sub cf::client::send_msg {
2658 my ($self, $channel, $msg, $color, @extra) = @_; 2766 my ($self, $channel, $msg, $color, @extra) = @_;
2895=pod 3003=pod
2896 3004
2897The following functions and methods are available within a safe environment: 3005The following functions and methods are available within a safe environment:
2898 3006
2899 cf::object 3007 cf::object
2900 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
2901 insert remove name archname title slaying race decrease_ob_nr 3009 insert remove name archname title slaying race decrease_ob_nr
2902 3010
2903 cf::object::player 3011 cf::object::player
2904 player 3012 player
2905 3013
2912=cut 3020=cut
2913 3021
2914for ( 3022for (
2915 ["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
2916 insert remove inv name archname title slaying race 3024 insert remove inv name archname title slaying race
2917 decrease_ob_nr)], 3025 decrease_ob_nr destroy)],
2918 ["cf::object::player" => qw(player)], 3026 ["cf::object::player" => qw(player)],
2919 ["cf::player" => qw(peaceful)], 3027 ["cf::player" => qw(peaceful)],
2920 ["cf::map" => qw(trigger)], 3028 ["cf::map" => qw(trigger)],
2921) { 3029) {
2922 no strict 'refs'; 3030 no strict 'refs';
3279 # and maps saved/destroyed asynchronously. 3387 # and maps saved/destroyed asynchronously.
3280 warn "begin emergency player save\n"; 3388 warn "begin emergency player save\n";
3281 for my $login (keys %cf::PLAYER) { 3389 for my $login (keys %cf::PLAYER) {
3282 my $pl = $cf::PLAYER{$login} or next; 3390 my $pl = $cf::PLAYER{$login} or next;
3283 $pl->valid or next; 3391 $pl->valid or next;
3392 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3284 $pl->save; 3393 $pl->save;
3285 } 3394 }
3286 warn "end emergency player save\n"; 3395 warn "end emergency player save\n";
3287 3396
3288 warn "begin emergency map save\n"; 3397 warn "begin emergency map save\n";
3336 3445
3337 warn "flushing outstanding aio requests"; 3446 warn "flushing outstanding aio requests";
3338 for (;;) { 3447 for (;;) {
3339 BDB::flush; 3448 BDB::flush;
3340 IO::AIO::flush; 3449 IO::AIO::flush;
3341 Coro::cede; 3450 Coro::cede_notself;
3342 last unless IO::AIO::nreqs || BDB::nreqs; 3451 last unless IO::AIO::nreqs || BDB::nreqs;
3343 warn "iterate..."; 3452 warn "iterate...";
3344 } 3453 }
3345 3454
3346 ++$RELOAD; 3455 ++$RELOAD;

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines