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.439 by root, Mon Jul 14 16:42:49 2008 UTC vs.
Revision 1.444 by root, Mon Sep 8 11:27:25 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;
… …
243for my $pkg (qw( 245for my $pkg (qw(
244 cf::global cf::attachable 246 cf::global cf::attachable
245 cf::object cf::object::player 247 cf::object cf::object::player
246 cf::client cf::player 248 cf::client cf::player
247 cf::arch cf::living 249 cf::arch cf::living
250 cf::map cf::mapspace
248 cf::map cf::party cf::region 251 cf::party cf::region
249)) { 252)) {
250 no strict 'refs';
251 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 253 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
252} 254}
253 255
254$EV::DIED = sub { 256$EV::DIED = sub {
255 warn "error in event callback: @_"; 257 warn "error in event callback: @_";
… …
1086 1088
1087sub reattach { 1089sub reattach {
1088 # basically do the same as instantiate, without calling instantiate 1090 # basically do the same as instantiate, without calling instantiate
1089 my ($obj) = @_; 1091 my ($obj) = @_;
1090 1092
1093 # no longer needed after getting rid of delete_package?
1091 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
1092 1095
1093 my $registry = $obj->registry; 1096 my $registry = $obj->registry;
1094 1097
1095 @$registry = (); 1098 @$registry = ();
1096 1099
… …
1332 1335
1333 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1336 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1334 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1337 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1335 1338
1336 $ext{source} = 1339 $ext{source} =
1337 "package $pkg; use strict; use utf8;\n" 1340 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1338 . "#line 1 \"$path\"\n{\n" 1341 . "#line 1 \"$path\"\n{\n"
1339 . $source 1342 . $source
1340 . "\n};\n1"; 1343 . "\n};\n1";
1341 1344
1342 $todo{$base} = \%ext; 1345 $todo{$base} = \%ext;
… …
1520 my ($pl) = @_; 1523 my ($pl) = @_;
1521 1524
1522 my $name = $pl->ob->name; 1525 my $name = $pl->ob->name;
1523 1526
1524 $pl->{deny_save} = 1; 1527 $pl->{deny_save} = 1;
1525 $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
1526 1529
1527 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1530 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1528 $pl->deactivate; 1531 $pl->deactivate;
1529 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;
1530 $pl->ob->check_score; 1533 $pl->ob->check_score;
… …
1619} 1622}
1620 1623
1621=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1624=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1622 1625
1623Expand crossfire pod fragments into protocol xml. 1626Expand crossfire pod fragments into protocol xml.
1624
1625=cut
1626
1627use re 'eval';
1628
1629my $group;
1630my $interior; $interior = qr{
1631 # match a pod interior sequence sans C<< >>
1632 (?:
1633 \ (.*?)\ (?{ $group = $^N })
1634 | < (??{$interior}) >
1635 )
1636}x;
1637
1638sub expand_cfpod {
1639 my ($self, $pod) = @_;
1640
1641 my $xml;
1642
1643 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1645 $group = $1;
1646
1647 $group =~ s/&/&amp;/g;
1648 $group =~ s/</&lt;/g;
1649
1650 $xml .= $group;
1651 } elsif ($pod =~ m%\G
1652 ([BCGHITU])
1653 <
1654 (?:
1655 ([^<>]*) (?{ $group = $^N })
1656 | < $interior >
1657 )
1658 >
1659 %gcsx
1660 ) {
1661 my ($code, $data) = ($1, $group);
1662
1663 if ($code eq "B") {
1664 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1665 } elsif ($code eq "I") {
1666 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1667 } elsif ($code eq "U") {
1668 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1669 } elsif ($code eq "C") {
1670 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1671 } elsif ($code eq "T") {
1672 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1673 } elsif ($code eq "G") {
1674 my ($male, $female) = split /\|/, $data;
1675 $data = $self->gender ? $female : $male;
1676 $xml .= expand_cfpod ($self, $data);
1677 } elsif ($code eq "H") {
1678 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1680 "")
1681 [$self->{hintmode}];
1682 } else {
1683 $xml .= "error processing '$code($data)' directive";
1684 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 }
1689 last;
1690 }
1691 }
1692
1693 for ($xml) {
1694 # create single paragraphs (very hackish)
1695 s/(?<=\S)\n(?=\w)/ /g;
1696
1697 # compress some whitespace
1698 s/\s+\n/\n/g; # ws line-ends
1699 s/\n\n+/\n/g; # double lines
1700 s/^\n+//; # beginning lines
1701 s/\n+$//; # ending lines
1702 }
1703
1704 $xml
1705}
1706
1707no re 'eval';
1708
1709sub hintmode {
1710 $_[0]{hintmode} = $_[1] if @_ > 1;
1711 $_[0]{hintmode}
1712}
1713 1627
1714=item $player->ext_reply ($msgid, @msg) 1628=item $player->ext_reply ($msgid, @msg)
1715 1629
1716Sends an ext reply to the player. 1630Sends an ext reply to the player.
1717 1631
… …
2902 if ($self->can_msg) { 2816 if ($self->can_msg) {
2903 # default colour, mask it out 2817 # default colour, mask it out
2904 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2818 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2905 if $color & cf::NDI_DEF; 2819 if $color & cf::NDI_DEF;
2906 2820
2907 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2821 my $pkt = "msg "
2822 . $self->{json_coder}->encode (
2908 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2823 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2824 );
2825
2826 # try lzf for large packets
2827 $pkt = "lzf " . Compress::LZF::compress $pkt
2828 if 1024 <= length $pkt and $self->{can_lzf};
2829
2830 # split very large packets
2831 if (8192 < length $pkt and $self->{can_lzf}) {
2832 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2833 $pkt = "frag";
2834 }
2835
2836 $self->send_packet ($pkt);
2909 } else { 2837 } else {
2910 if ($color >= 0) { 2838 if ($color >= 0) {
2911 # replace some tags by gcfclient-compatible ones 2839 # replace some tags by gcfclient-compatible ones
2912 for ($msg) { 2840 for ($msg) {
2913 1 while 2841 1 while
… …
3586 3514
3587 warn Carp::longmess "post_cleanup backtrace" 3515 warn Carp::longmess "post_cleanup backtrace"
3588 if $make_core; 3516 if $make_core;
3589} 3517}
3590 3518
3519# a safer delete_package, copied from Symbol
3520sub clear_package($) {
3521 my $pkg = shift;
3522
3523 # expand to full symbol table name if needed
3524 unless ($pkg =~ /^main::.*::$/) {
3525 $pkg = "main$pkg" if $pkg =~ /^::/;
3526 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3527 $pkg .= '::' unless $pkg =~ /::$/;
3528 }
3529
3530 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3531 my $stem_symtab = *{$stem}{HASH};
3532
3533 defined $stem_symtab and exists $stem_symtab->{$leaf}
3534 or return;
3535
3536 # clear all symbols
3537 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3538 for my $name (keys %$leaf_symtab) {
3539 _gv_clear *{"$pkg$name"};
3540# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3541 }
3542 warn "cleared package #$pkg\n";#d#
3543}
3544
3545our $RELOAD; # how many times to reload
3546
3591sub do_reload_perl() { 3547sub do_reload_perl() {
3592 # can/must only be called in main 3548 # can/must only be called in main
3593 if ($Coro::current != $Coro::main) { 3549 if ($Coro::current != $Coro::main) {
3594 warn "can only reload from main coroutine"; 3550 warn "can only reload from main coroutine";
3595 return; 3551 return;
3596 } 3552 }
3597 3553
3554 return if $RELOAD++;
3555
3556 while ($RELOAD) {
3598 warn "reloading..."; 3557 warn "reloading...";
3599 3558
3600 warn "entering sync_job"; 3559 warn "entering sync_job";
3601 3560
3602 cf::sync_job { 3561 cf::sync_job {
3603 cf::write_runtime_sync; # external watchdog should not bark 3562 cf::write_runtime_sync; # external watchdog should not bark
3604 cf::emergency_save; 3563 cf::emergency_save;
3605 cf::write_runtime_sync; # external watchdog should not bark 3564 cf::write_runtime_sync; # external watchdog should not bark
3606 3565
3607 warn "syncing database to disk"; 3566 warn "syncing database to disk";
3608 BDB::db_env_txn_checkpoint $DB_ENV; 3567 BDB::db_env_txn_checkpoint $DB_ENV;
3609 3568
3610 # if anything goes wrong in here, we should simply crash as we already saved 3569 # if anything goes wrong in here, we should simply crash as we already saved
3611 3570
3612 warn "flushing outstanding aio requests"; 3571 warn "flushing outstanding aio requests";
3613 for (;;) {
3614 BDB::flush;
3615 IO::AIO::flush;
3616 Coro::cede_notself;
3617 last unless IO::AIO::nreqs || BDB::nreqs; 3572 while (IO::AIO::nreqs || BDB::nreqs) {
3618 warn "iterate..."; 3573 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3619 }
3620
3621 ++$RELOAD;
3622
3623 warn "cancelling all extension coros";
3624 $_->cancel for values %EXT_CORO;
3625 %EXT_CORO = ();
3626
3627 warn "removing commands";
3628 %COMMAND = ();
3629
3630 warn "removing ext/exti commands";
3631 %EXTCMD = ();
3632 %EXTICMD = ();
3633
3634 warn "unloading/nuking all extensions";
3635 for my $pkg (@EXTS) {
3636 warn "... unloading $pkg";
3637
3638 if (my $cb = $pkg->can ("unload")) {
3639 eval {
3640 $cb->($pkg);
3641 1
3642 } or warn "$pkg unloaded, but with errors: $@";
3643 } 3574 }
3644 3575
3645 warn "... nuking $pkg"; 3576 warn "cancelling all extension coros";
3646 Symbol::delete_package $pkg; 3577 $_->cancel for values %EXT_CORO;
3647 } 3578 %EXT_CORO = ();
3648 3579
3649 warn "unloading all perl modules loaded from $LIBDIR"; 3580 warn "removing commands";
3650 while (my ($k, $v) = each %INC) { 3581 %COMMAND = ();
3651 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3652 3582
3583 warn "removing ext/exti commands";
3584 %EXTCMD = ();
3585 %EXTICMD = ();
3586
3587 warn "unloading/nuking all extensions";
3588 for my $pkg (@EXTS) {
3653 warn "... unloading $k"; 3589 warn "... unloading $pkg";
3654 delete $INC{$k};
3655 3590
3656 $k =~ s/\.pm$//;
3657 $k =~ s/\//::/g;
3658
3659 if (my $cb = $k->can ("unload_module")) { 3591 if (my $cb = $pkg->can ("unload")) {
3592 eval {
3660 $cb->(); 3593 $cb->($pkg);
3594 1
3595 } or warn "$pkg unloaded, but with errors: $@";
3596 }
3597
3598 warn "... clearing $pkg";
3599 clear_package $pkg;
3661 } 3600 }
3662 3601
3663 Symbol::delete_package $k; 3602 warn "unloading all perl modules loaded from $LIBDIR";
3603 while (my ($k, $v) = each %INC) {
3604 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3605
3606 warn "... unloading $k";
3607 delete $INC{$k};
3608
3609 $k =~ s/\.pm$//;
3610 $k =~ s/\//::/g;
3611
3612 if (my $cb = $k->can ("unload_module")) {
3613 $cb->();
3614 }
3615
3616 clear_package $k;
3664 } 3617 }
3665 3618
3666 warn "getting rid of safe::, as good as possible"; 3619 warn "getting rid of safe::, as good as possible";
3667 Symbol::delete_package "safe::$_" 3620 clear_package "safe::$_"
3668 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3621 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3669 3622
3670 warn "unloading cf.pm \"a bit\""; 3623 warn "unloading cf.pm \"a bit\"";
3671 delete $INC{"cf.pm"}; 3624 delete $INC{"cf.pm"};
3672 delete $INC{"cf/pod.pm"}; 3625 delete $INC{"cf/pod.pm"};
3673 3626
3674 # don't, removes xs symbols, too, 3627 # don't, removes xs symbols, too,
3675 # and global variables created in xs 3628 # and global variables created in xs
3676 #Symbol::delete_package __PACKAGE__; 3629 #clear_package __PACKAGE__;
3677 3630
3678 warn "unload completed, starting to reload now"; 3631 warn "unload completed, starting to reload now";
3679 3632
3680 warn "reloading cf.pm"; 3633 warn "reloading cf.pm";
3681 require cf; 3634 require cf;
3682 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3635 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3683 3636
3684 warn "loading config and database again"; 3637 warn "loading config and database again";
3685 cf::reload_config; 3638 cf::reload_config;
3686 3639
3687 warn "loading extensions"; 3640 warn "loading extensions";
3688 cf::load_extensions; 3641 cf::load_extensions;
3689 3642
3690 warn "reattaching attachments to objects/players"; 3643 warn "reattaching attachments to objects/players";
3691 _global_reattach; # objects, sockets 3644 _global_reattach; # objects, sockets
3692 warn "reattaching attachments to maps"; 3645 warn "reattaching attachments to maps";
3693 reattach $_ for values %MAP; 3646 reattach $_ for values %MAP;
3694 warn "reattaching attachments to players"; 3647 warn "reattaching attachments to players";
3695 reattach $_ for values %PLAYER; 3648 reattach $_ for values %PLAYER;
3696 3649
3697 warn "leaving sync_job"; 3650 warn "leaving sync_job";
3698 3651
3699 1 3652 1
3700 } or do { 3653 } or do {
3701 warn $@; 3654 warn $@;
3702 cf::cleanup "error while reloading, exiting."; 3655 cf::cleanup "error while reloading, exiting.";
3703 }; 3656 };
3704 3657
3705 warn "reloaded"; 3658 warn "reloaded";
3659 --$RELOAD;
3660 }
3706}; 3661};
3707 3662
3708our $RELOAD_WATCHER; # used only during reload 3663our $RELOAD_WATCHER; # used only during reload
3709 3664
3710sub reload_perl() { 3665sub reload_perl() {

Diff Legend

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