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.440 by root, Mon Aug 11 23:23:41 2008 UTC vs.
Revision 1.443 by root, Sun Aug 31 10:05:26 2008 UTC

… …
19# The authors can be reached via e-mail to <support@deliantra.net> 19# The authors can be reached via e-mail to <support@deliantra.net>
20# 20#
21 21
22package cf; 22package cf;
23 23
24use 5.10.0;
24use utf8; 25use utf8;
25use strict; 26use strict "vars", "subs";
26 27
27use Symbol; 28use Symbol;
28use List::Util; 29use List::Util;
29use Socket; 30use Socket;
30use EV; 31use EV;
… …
34use Storable (); 35use Storable ();
35 36
36use Coro (); 37use Coro ();
37use Coro::State; 38use Coro::State;
38use Coro::Handle; 39use Coro::Handle;
40use Coro::EV;
39use Coro::AnyEvent; 41use Coro::AnyEvent;
40use Coro::Timer; 42use Coro::Timer;
41use Coro::Signal; 43use Coro::Signal;
42use Coro::Semaphore; 44use Coro::Semaphore;
43use Coro::AnyEvent; 45use Coro::AnyEvent;
… …
246 cf::client cf::player 248 cf::client cf::player
247 cf::arch cf::living 249 cf::arch cf::living
248 cf::map cf::mapspace 250 cf::map cf::mapspace
249 cf::party cf::region 251 cf::party cf::region
250)) { 252)) {
251 no strict 'refs';
252 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 253 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
253} 254}
254 255
255$EV::DIED = sub { 256$EV::DIED = sub {
256 warn "error in event callback: @_"; 257 warn "error in event callback: @_";
… …
1087 1088
1088sub reattach { 1089sub reattach {
1089 # basically do the same as instantiate, without calling instantiate 1090 # basically do the same as instantiate, without calling instantiate
1090 my ($obj) = @_; 1091 my ($obj) = @_;
1091 1092
1093 # no longer needed after getting rid of delete_package?
1092 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1094 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1093 1095
1094 my $registry = $obj->registry; 1096 my $registry = $obj->registry;
1095 1097
1096 @$registry = (); 1098 @$registry = ();
1097 1099
… …
1333 1335
1334 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1336 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1335 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1337 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1336 1338
1337 $ext{source} = 1339 $ext{source} =
1338 "package $pkg; use strict; use utf8;\n" 1340 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1339 . "#line 1 \"$path\"\n{\n" 1341 . "#line 1 \"$path\"\n{\n"
1340 . $source 1342 . $source
1341 . "\n};\n1"; 1343 . "\n};\n1";
1342 1344
1343 $todo{$base} = \%ext; 1345 $todo{$base} = \%ext;
… …
1521 my ($pl) = @_; 1523 my ($pl) = @_;
1522 1524
1523 my $name = $pl->ob->name; 1525 my $name = $pl->ob->name;
1524 1526
1525 $pl->{deny_save} = 1; 1527 $pl->{deny_save} = 1;
1526 $pl->password ("*"); # this should lock out the player until we nuked the dir 1528 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1527 1529
1528 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1530 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1529 $pl->deactivate; 1531 $pl->deactivate;
1530 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1532 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1531 $pl->ob->check_score; 1533 $pl->ob->check_score;
… …
1623 1625
1624Expand crossfire pod fragments into protocol xml. 1626Expand crossfire pod fragments into protocol xml.
1625 1627
1626=cut 1628=cut
1627 1629
1628use re 'eval';
1629
1630my $group;
1631my $interior; $interior = qr{
1632 # match a pod interior sequence sans C<< >>
1633 (?:
1634 \ (.*?)\ (?{ $group = $^N })
1635 | < (??{$interior}) >
1636 )
1637}x;
1638
1639sub expand_cfpod { 1630sub expand_cfpod {
1640 my ($self, $pod) = @_; 1631 my ($self, $pod) = @_;
1641 1632
1633 my @nest = [qr<\G$>, undef, ""];
1642 my $xml; 1634 my $xml;
1643 1635
1636 for ($pod) {
1644 while () { 1637 while () {
1645 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) { 1638 if (/\G( (?: [^BCEGHITUZ&>\n\ ]+ | [BCEGHITUZ](?!<) | \ (?!>) )+ )/xgcs) {
1646 $group = $1;
1647
1648 $group =~ s/&/&amp;/g;
1649 $group =~ s/</&lt;/g;
1650
1651 $xml .= $group; 1639 $xml .= $1;
1652 } elsif ($pod =~ m%\G 1640 } elsif (/\G\n(?=\S)/xgcs) {
1653 ([BCGHITU]) 1641 $xml .= " ";
1654 < 1642 } elsif (/\G\n/xgcs) {
1655 (?: 1643 $xml .= "\n";
1656 ([^<>]*) (?{ $group = $^N }) 1644 } elsif (/\G ([BCEGHITUZ]) (< (?: <+\ | (?!<) ) )/xgcs) {
1657 | < $interior > 1645 my ($code, $delim) = ($1, scalar reverse $2);
1658 ) 1646 $delim =~ y/</>/; # delim now contains the stop sequence
1659 > 1647 $delim = qr{\G\Q$delim};
1660 %gcsx
1661 ) {
1662 my ($code, $data) = ($1, $group);
1663 1648
1649 my $cb;
1650
1664 if ($code eq "B") { 1651 if ($code eq "B") {
1665 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>"; 1652 $cb = sub { "<b>$_[0]</b>" };
1666 } elsif ($code eq "I") {
1667 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1668 } elsif ($code eq "U") {
1669 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1670 } elsif ($code eq "C") { 1653 } elsif ($code eq "C") {
1671 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>"; 1654 $cb = sub { "<tt>$_[0]</tt>" };
1672 } elsif ($code eq "T") { 1655 } elsif ($code eq "E") {
1673 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>"; 1656 $cb = sub { warn "E<$_[0]>\n";"&$_[0];" };
1674 } elsif ($code eq "G") { 1657 } elsif ($code eq "G") {
1658 $cb = sub {
1675 my ($male, $female) = split /\|/, $data; 1659 my ($male, $female) = split /\|/, $_[0];
1676 $data = $self->gender ? $female : $male; 1660 $self->gender ? $female : $male
1677 $xml .= expand_cfpod ($self, $data); 1661 };
1678 } elsif ($code eq "H") { 1662 } elsif ($code eq "H") {
1679 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>", 1663 $cb = sub {
1664 (
1665 "<fg name=\"lightblue\">[$_[0] (Use hintmode to suppress hints)]</fg>",
1680 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1666 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1681 "") 1667 "",
1682 [$self->{hintmode}]; 1668 )[$self->{hintmode}];
1669 };
1670 } elsif ($code eq "I") {
1671 $cb = sub { "<i>$_[0]</i>" };
1672 } elsif ($code eq "T") {
1673 $cb = sub { "<big><b>$_[0]</b></big>" };
1674 } elsif ($code eq "U") {
1675 $cb = sub { "<u>$_[0]</u>" };
1676 } elsif ($code eq "Z") {
1677 $cb = sub { };
1678 } else {
1679 die "FATAL error in expand_cfpod";
1680 }
1681
1682 push @nest, [$delim, $cb, $xml];
1683 undef $xml;
1684
1685 } elsif ($_ =~ /$nest[-1][0]/gcs) {
1686 my $nest = pop @nest;
1687
1688 if ($nest->[1]) {
1689 $xml = $nest->[2] . $nest->[1]->($xml);
1690 } else {
1691 last;
1692 }
1693 } elsif (/\G</xgcs) {
1694 $xml .= "&lt;";
1695 } elsif (/\G&/xgcs) {
1696 $xml .= "&amp;";
1697 } elsif (/\G>/xgcs) {
1698 $xml .= ">";
1683 } else { 1699 } else {
1684 $xml .= "error processing '$code($data)' directive"; 1700 if ($pod =~ /\G(.+)/xgcs) {
1701 warn "parse error (at $1)($nest[-1][0]) while expanding cfpod:\n$pod";
1702 last;
1703 } else {
1704 warn "parse error (unclosed interior sequence at end of cfpod) while expanding cfpod:\n$pod";
1705 return "<b>Sorry, the server encountered an internal error when formatting this message, please report this.</b>";
1706 }
1685 } 1707 }
1686 } else {
1687 if ($pod =~ /\G(.+)/) {
1688 warn "parse error while expanding $pod (at $1)";
1689 } 1708 }
1690 last;
1691 }
1692 }
1693
1694 for ($xml) {
1695 # create single paragraphs (very hackish)
1696 s/(?<=\S)\n(?=\w)/ /g;
1697
1698 # compress some whitespace
1699 s/\s+\n/\n/g; # ws line-ends
1700 s/\n\n+/\n/g; # double lines
1701 s/^\n+//; # beginning lines
1702 s/\n+$//; # ending lines
1703 } 1709 }
1704 1710
1705 $xml 1711 $xml
1706} 1712}
1707
1708no re 'eval';
1709 1713
1710sub hintmode { 1714sub hintmode {
1711 $_[0]{hintmode} = $_[1] if @_ > 1; 1715 $_[0]{hintmode} = $_[1] if @_ > 1;
1712 $_[0]{hintmode} 1716 $_[0]{hintmode}
1713} 1717}
… …
2903 if ($self->can_msg) { 2907 if ($self->can_msg) {
2904 # default colour, mask it out 2908 # default colour, mask it out
2905 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2909 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2906 if $color & cf::NDI_DEF; 2910 if $color & cf::NDI_DEF;
2907 2911
2908 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2912 my $pkt = "msg "
2913 . $self->{json_coder}->encode (
2909 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2914 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2915 );
2916
2917 # try lzf for large packets
2918 $pkt = "lzf " . Compress::LZF::compress $pkt
2919 if 1024 <= length $pkt and $self->{can_lzf};
2920
2921 # split very large packets
2922 if (8192 < length $pkt and $self->{can_lzf}) {
2923 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2924 $pkt = "frag";
2925 }
2926
2927 $self->send_packet ($pkt);
2910 } else { 2928 } else {
2911 if ($color >= 0) { 2929 if ($color >= 0) {
2912 # replace some tags by gcfclient-compatible ones 2930 # replace some tags by gcfclient-compatible ones
2913 for ($msg) { 2931 for ($msg) {
2914 1 while 2932 1 while
… …
3587 3605
3588 warn Carp::longmess "post_cleanup backtrace" 3606 warn Carp::longmess "post_cleanup backtrace"
3589 if $make_core; 3607 if $make_core;
3590} 3608}
3591 3609
3610# a safer delete_package, copied from Symbol
3611sub clear_package($) {
3612 my $pkg = shift;
3613
3614 # expand to full symbol table name if needed
3615 unless ($pkg =~ /^main::.*::$/) {
3616 $pkg = "main$pkg" if $pkg =~ /^::/;
3617 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3618 $pkg .= '::' unless $pkg =~ /::$/;
3619 }
3620
3621 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3622 my $stem_symtab = *{$stem}{HASH};
3623
3624 defined $stem_symtab and exists $stem_symtab->{$leaf}
3625 or return;
3626
3627 # clear all symbols
3628 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3629 for my $name (keys %$leaf_symtab) {
3630 _gv_clear *{"$pkg$name"};
3631# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3632 }
3633 warn "cleared package #$pkg\n";#d#
3634}
3635
3636our $RELOAD; # how many times to reload
3637
3592sub do_reload_perl() { 3638sub do_reload_perl() {
3593 # can/must only be called in main 3639 # can/must only be called in main
3594 if ($Coro::current != $Coro::main) { 3640 if ($Coro::current != $Coro::main) {
3595 warn "can only reload from main coroutine"; 3641 warn "can only reload from main coroutine";
3596 return; 3642 return;
3597 } 3643 }
3598 3644
3645 return if $RELOAD++;
3646
3647 while ($RELOAD) {
3599 warn "reloading..."; 3648 warn "reloading...";
3600 3649
3601 warn "entering sync_job"; 3650 warn "entering sync_job";
3602 3651
3603 cf::sync_job { 3652 cf::sync_job {
3604 cf::write_runtime_sync; # external watchdog should not bark 3653 cf::write_runtime_sync; # external watchdog should not bark
3605 cf::emergency_save; 3654 cf::emergency_save;
3606 cf::write_runtime_sync; # external watchdog should not bark 3655 cf::write_runtime_sync; # external watchdog should not bark
3607 3656
3608 warn "syncing database to disk"; 3657 warn "syncing database to disk";
3609 BDB::db_env_txn_checkpoint $DB_ENV; 3658 BDB::db_env_txn_checkpoint $DB_ENV;
3610 3659
3611 # if anything goes wrong in here, we should simply crash as we already saved 3660 # if anything goes wrong in here, we should simply crash as we already saved
3612 3661
3613 warn "flushing outstanding aio requests"; 3662 warn "flushing outstanding aio requests";
3614 for (;;) {
3615 BDB::flush;
3616 IO::AIO::flush;
3617 Coro::cede_notself;
3618 last unless IO::AIO::nreqs || BDB::nreqs; 3663 while (IO::AIO::nreqs || BDB::nreqs) {
3619 warn "iterate..."; 3664 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3620 }
3621
3622 ++$RELOAD;
3623
3624 warn "cancelling all extension coros";
3625 $_->cancel for values %EXT_CORO;
3626 %EXT_CORO = ();
3627
3628 warn "removing commands";
3629 %COMMAND = ();
3630
3631 warn "removing ext/exti commands";
3632 %EXTCMD = ();
3633 %EXTICMD = ();
3634
3635 warn "unloading/nuking all extensions";
3636 for my $pkg (@EXTS) {
3637 warn "... unloading $pkg";
3638
3639 if (my $cb = $pkg->can ("unload")) {
3640 eval {
3641 $cb->($pkg);
3642 1
3643 } or warn "$pkg unloaded, but with errors: $@";
3644 } 3665 }
3645 3666
3646 warn "... nuking $pkg"; 3667 warn "cancelling all extension coros";
3647 Symbol::delete_package $pkg; 3668 $_->cancel for values %EXT_CORO;
3648 } 3669 %EXT_CORO = ();
3649 3670
3650 warn "unloading all perl modules loaded from $LIBDIR"; 3671 warn "removing commands";
3651 while (my ($k, $v) = each %INC) { 3672 %COMMAND = ();
3652 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3653 3673
3674 warn "removing ext/exti commands";
3675 %EXTCMD = ();
3676 %EXTICMD = ();
3677
3678 warn "unloading/nuking all extensions";
3679 for my $pkg (@EXTS) {
3654 warn "... unloading $k"; 3680 warn "... unloading $pkg";
3655 delete $INC{$k};
3656 3681
3657 $k =~ s/\.pm$//;
3658 $k =~ s/\//::/g;
3659
3660 if (my $cb = $k->can ("unload_module")) { 3682 if (my $cb = $pkg->can ("unload")) {
3683 eval {
3661 $cb->(); 3684 $cb->($pkg);
3685 1
3686 } or warn "$pkg unloaded, but with errors: $@";
3687 }
3688
3689 warn "... clearing $pkg";
3690 clear_package $pkg;
3662 } 3691 }
3663 3692
3664 Symbol::delete_package $k; 3693 warn "unloading all perl modules loaded from $LIBDIR";
3694 while (my ($k, $v) = each %INC) {
3695 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3696
3697 warn "... unloading $k";
3698 delete $INC{$k};
3699
3700 $k =~ s/\.pm$//;
3701 $k =~ s/\//::/g;
3702
3703 if (my $cb = $k->can ("unload_module")) {
3704 $cb->();
3705 }
3706
3707 clear_package $k;
3665 } 3708 }
3666 3709
3667 warn "getting rid of safe::, as good as possible"; 3710 warn "getting rid of safe::, as good as possible";
3668 Symbol::delete_package "safe::$_" 3711 clear_package "safe::$_"
3669 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3712 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3670 3713
3671 warn "unloading cf.pm \"a bit\""; 3714 warn "unloading cf.pm \"a bit\"";
3672 delete $INC{"cf.pm"}; 3715 delete $INC{"cf.pm"};
3673 delete $INC{"cf/pod.pm"}; 3716 delete $INC{"cf/pod.pm"};
3674 3717
3675 # don't, removes xs symbols, too, 3718 # don't, removes xs symbols, too,
3676 # and global variables created in xs 3719 # and global variables created in xs
3677 #Symbol::delete_package __PACKAGE__; 3720 #clear_package __PACKAGE__;
3678 3721
3679 warn "unload completed, starting to reload now"; 3722 warn "unload completed, starting to reload now";
3680 3723
3681 warn "reloading cf.pm"; 3724 warn "reloading cf.pm";
3682 require cf; 3725 require cf;
3683 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3726 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3684 3727
3685 warn "loading config and database again"; 3728 warn "loading config and database again";
3686 cf::reload_config; 3729 cf::reload_config;
3687 3730
3688 warn "loading extensions"; 3731 warn "loading extensions";
3689 cf::load_extensions; 3732 cf::load_extensions;
3690 3733
3691 warn "reattaching attachments to objects/players"; 3734 warn "reattaching attachments to objects/players";
3692 _global_reattach; # objects, sockets 3735 _global_reattach; # objects, sockets
3693 warn "reattaching attachments to maps"; 3736 warn "reattaching attachments to maps";
3694 reattach $_ for values %MAP; 3737 reattach $_ for values %MAP;
3695 warn "reattaching attachments to players"; 3738 warn "reattaching attachments to players";
3696 reattach $_ for values %PLAYER; 3739 reattach $_ for values %PLAYER;
3697 3740
3698 warn "leaving sync_job"; 3741 warn "leaving sync_job";
3699 3742
3700 1 3743 1
3701 } or do { 3744 } or do {
3702 warn $@; 3745 warn $@;
3703 cf::cleanup "error while reloading, exiting."; 3746 cf::cleanup "error while reloading, exiting.";
3704 }; 3747 };
3705 3748
3706 warn "reloaded"; 3749 warn "reloaded";
3750 --$RELOAD;
3751 }
3707}; 3752};
3708 3753
3709our $RELOAD_WATCHER; # used only during reload 3754our $RELOAD_WATCHER; # used only during reload
3710 3755
3711sub reload_perl() { 3756sub reload_perl() {

Diff Legend

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