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.384 by root, Fri Oct 12 18:17:16 2007 UTC vs.
Revision 1.392 by root, Fri Oct 26 04:44:54 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 4.1 (); 15use Coro 4.1 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
… …
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"
… …
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 = Coro::Storable::blocking_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 my $st = eval { Coro::Storable::thaw $av } 1127 my $st = eval { Coro::Storable::thaw $av };
1093 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1094 $av = $st->{objs}; 1128 $av = $st->{objs};
1095 } 1129 }
1096 1130
1097 utf8::decode (my $decname = $filename); 1131 utf8::decode (my $decname = $filename);
1098 warn sprintf "loading %s (%d,%d)\n", 1132 warn sprintf "loading %s (%d,%d)\n",
… …
1514 1548
1515Expand crossfire pod fragments into protocol xml. 1549Expand crossfire pod fragments into protocol xml.
1516 1550
1517=cut 1551=cut
1518 1552
1553 use re 'eval';
1554
1555my $group;
1556my $interior; $interior = qr{
1557 (?:
1558 \ (.*?)\ (?{ $group = $^N })
1559 | < (??{$interior}) >
1560 )
1561}x;
1562
1519sub expand_cfpod { 1563sub expand_cfpod {
1520 ((my $self), (local $_)) = @_; 1564 my ($self, $pod) = @_;
1521 1565
1522 # escape & and < 1566 my $xml;
1523 s/&/&amp;/g;
1524 s/(?<![BIUGHT])</&lt;/g;
1525 1567
1526 # this is buggy, it needs to properly take care of nested <'s 1568 while () {
1569 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1570 $group = $1;
1527 1571
1528 1 while 1572 $group =~ s/&/&amp;/g;
1529 # replace B<>, I<>, U<> etc. 1573 $group =~ s/</&lt;/g;
1530 s/B<([^\>]*)>/<b>$1<\/b>/ 1574
1531 || s/I<([^\>]*)>/<i>$1<\/i>/ 1575 $xml .= $group;
1532 || s/U<([^\>]*)>/<u>$1<\/u>/ 1576 } elsif ($pod =~ m%\G
1533 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1577 ([BCGHITU])
1534 # replace G<male|female> tags 1578 <
1535 || s{G<([^>|]*)\|([^>]*)>}{ 1579 (?:
1536 $self->gender ? $2 : $1 1580 ([^<>]*) (?{ $group = $^N })
1537 }ge 1581 | < $interior >
1538 # replace H<hint text> 1582 )
1539 || s{H<([^\>]*)>} 1583 >
1584 %gcsx
1540 { 1585 ) {
1586 my ($code, $data) = ($1, $group);
1587
1588 if ($code eq "B") {
1589 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1590 } elsif ($code eq "I") {
1591 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1592 } elsif ($code eq "U") {
1593 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1594 } elsif ($code eq "C") {
1595 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1596 } elsif ($code eq "T") {
1597 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1598 } elsif ($code eq "G") {
1599 my ($male, $female) = split /\|/, $data;
1600 $data = $self->gender ? $female : $male;
1601 $xml .= expand_cfpod ($self, $data);
1602 } elsif ($code eq "H") {
1541 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1603 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1542 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1604 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1543 "") 1605 "")
1544 [$self->{hintmode}] 1606 [$self->{hintmode}];
1607 } else {
1608 $xml .= "error processing '$code($data)' directive";
1545 }ge; 1609 }
1610 } else {
1611 if ($pod =~ /\G(.+)/) {
1612 warn "parse error while expanding $pod (at $1)";
1613 }
1614 last;
1615 }
1616 }
1546 1617
1618 for ($xml) {
1547 # create single paragraphs (very hackish) 1619 # create single paragraphs (very hackish)
1548 s/(?<=\S)\n(?=\w)/ /g; 1620 s/(?<=\S)\n(?=\w)/ /g;
1549 1621
1550 # compress some whitespace 1622 # compress some whitespace
1551 s/\s+\n/\n/g; # ws line-ends 1623 s/\s+\n/\n/g; # ws line-ends
1552 s/\n\n+/\n/g; # double lines 1624 s/\n\n+/\n/g; # double lines
1553 s/^\n+//; # beginning lines 1625 s/^\n+//; # beginning lines
1554 s/\n+$//; # ending lines 1626 s/\n+$//; # ending lines
1627 }
1555 1628
1556 $_ 1629 $xml
1557} 1630}
1558 1631
1559sub hintmode { 1632sub hintmode {
1560 $_[0]{hintmode} = $_[1] if @_ > 1; 1633 $_[0]{hintmode} = $_[1] if @_ > 1;
1561 $_[0]{hintmode} 1634 $_[0]{hintmode}
… …
2632the message, with C<log> being the default. If C<$color> is negative, suppress 2705the message, with C<log> being the default. If C<$color> is negative, suppress
2633the message unless the client supports the msg packet. 2706the message unless the client supports the msg packet.
2634 2707
2635=cut 2708=cut
2636 2709
2710# non-persistent channels (usually the info channel)
2637our %CHANNEL = ( 2711our %CHANNEL = (
2638 "c/identify" => { 2712 "c/identify" => {
2639 id => "infobox", 2713 id => "infobox",
2640 title => "Identify", 2714 title => "Identify",
2641 reply => undef, 2715 reply => undef,
… …
2645 id => "infobox", 2719 id => "infobox",
2646 title => "Examine", 2720 title => "Examine",
2647 reply => undef, 2721 reply => undef,
2648 tooltip => "Signs and other items you examined", 2722 tooltip => "Signs and other items you examined",
2649 }, 2723 },
2724 "c/book" => {
2725 id => "infobox",
2726 title => "Book",
2727 reply => undef,
2728 tooltip => "The contents of a note or book",
2729 },
2650 "c/lookat" => { 2730 "c/lookat" => {
2651 id => "infobox", 2731 id => "infobox",
2652 title => "Look", 2732 title => "Look",
2653 reply => undef, 2733 reply => undef,
2654 tooltip => "What you saw there", 2734 tooltip => "What you saw there",
2735 },
2736 "c/who" => {
2737 id => "infobox",
2738 title => "Players",
2739 reply => undef,
2740 tooltip => "Shows players who are currently online",
2741 },
2742 "c/body" => {
2743 id => "infobox",
2744 title => "Body Parts",
2745 reply => undef,
2746 tooltip => "Shows which body parts you posess and are available",
2747 },
2748 "c/uptime" => {
2749 id => "infobox",
2750 title => "Uptime",
2751 reply => undef,
2752 tooltip => "How long the server has been running since last restart",
2753 },
2754 "c/mapinfo" => {
2755 id => "infobox",
2756 title => "Map Info",
2757 reply => undef,
2758 tooltip => "Information related to the maps",
2655 }, 2759 },
2656); 2760);
2657 2761
2658sub cf::client::send_msg { 2762sub cf::client::send_msg {
2659 my ($self, $channel, $msg, $color, @extra) = @_; 2763 my ($self, $channel, $msg, $color, @extra) = @_;
… …
3338 3442
3339 warn "flushing outstanding aio requests"; 3443 warn "flushing outstanding aio requests";
3340 for (;;) { 3444 for (;;) {
3341 BDB::flush; 3445 BDB::flush;
3342 IO::AIO::flush; 3446 IO::AIO::flush;
3343 Coro::cede; 3447 Coro::cede_notself;
3344 last unless IO::AIO::nreqs || BDB::nreqs; 3448 last unless IO::AIO::nreqs || BDB::nreqs;
3345 warn "iterate..."; 3449 warn "iterate...";
3346 } 3450 }
3347 3451
3348 ++$RELOAD; 3452 ++$RELOAD;

Diff Legend

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