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.436 by root, Sun Jun 15 20:32:51 2008 UTC vs.
Revision 1.442 by root, Sun Aug 31 09:03:31 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;
44use Coro::AIO; 46use Coro::AIO;
45use Coro::BDB; 47use Coro::BDB 1.6;
46use Coro::Storable; 48use Coro::Storable;
47use Coro::Util (); 49use Coro::Util ();
48 50
49use JSON::XS 2.01 (); 51use JSON::XS 2.01 ();
50use BDB (); 52use BDB ();
… …
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;
… …
1622 1625
1623Expand crossfire pod fragments into protocol xml. 1626Expand crossfire pod fragments into protocol xml.
1624 1627
1625=cut 1628=cut
1626 1629
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 { 1630sub expand_cfpod {
1639 my ($self, $pod) = @_; 1631 my ($self, $pod) = @_;
1640 1632
1633 my @nest = [qr<\G$>, undef, ""];
1641 my $xml; 1634 my $xml;
1642 1635
1636 for ($pod) {
1643 while () { 1637 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) { 1638 if (/\G( (?: [^BCEGHITUZ&>\n\ ]+ | [BCEGHITUZ](?!<) | \ (?!>) )+ )/xgcs) {
1645 $group = $1;
1646
1647 $group =~ s/&/&amp;/g;
1648 $group =~ s/</&lt;/g;
1649
1650 $xml .= $group; 1639 $xml .= $1;
1651 } elsif ($pod =~ m%\G 1640 } elsif (/\G\n(?=\S)/xgcs) {
1652 ([BCGHITU]) 1641 $xml .= " ";
1653 < 1642 } elsif (/\G\n/xgcs) {
1654 (?: 1643 $xml .= "\n";
1655 ([^<>]*) (?{ $group = $^N }) 1644 } elsif (/\G ([BCEGHITUZ]) (< (?: <+\ | (?!<) ) )/xgcs) {
1656 | < $interior > 1645 my ($code, $delim) = ($1, scalar reverse $2);
1657 ) 1646 $delim =~ y/</>/; # delim now contains the stop sequence
1658 > 1647 $delim = qr{\G\Q$delim};
1659 %gcsx
1660 ) {
1661 my ($code, $data) = ($1, $group);
1662 1648
1649 my $cb;
1650
1663 if ($code eq "B") { 1651 if ($code eq "B") {
1664 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>"; 1652 $cb = sub { "<b>$_[0]</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") { 1653 } elsif ($code eq "C") {
1670 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>"; 1654 $cb = sub { "<tt>$_[0]</tt>" };
1671 } elsif ($code eq "T") { 1655 } elsif ($code eq "E") {
1672 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>"; 1656 $cb = sub { warn "E<$_[0]>\n";"&$_[0];" };
1673 } elsif ($code eq "G") { 1657 } elsif ($code eq "G") {
1658 $cb = sub {
1674 my ($male, $female) = split /\|/, $data; 1659 my ($male, $female) = split /\|/, $_[0];
1675 $data = $self->gender ? $female : $male; 1660 $self->gender ? $female : $male
1676 $xml .= expand_cfpod ($self, $data); 1661 };
1677 } elsif ($code eq "H") { 1662 } elsif ($code eq "H") {
1678 $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>",
1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1666 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1680 "") 1667 "",
1681 [$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 .= ">";
1682 } else { 1699 } else {
1683 $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 }
1684 } 1707 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 } 1708 }
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 } 1709 }
1703 1710
1704 $xml 1711 $xml
1705} 1712}
1706
1707no re 'eval';
1708 1713
1709sub hintmode { 1714sub hintmode {
1710 $_[0]{hintmode} = $_[1] if @_ > 1; 1715 $_[0]{hintmode} = $_[1] if @_ > 1;
1711 $_[0]{hintmode} 1716 $_[0]{hintmode}
1712} 1717}
… …
2086 my $f = new_from_file cf::object::thawer $self->{load_path}; 2091 my $f = new_from_file cf::object::thawer $self->{load_path};
2087 $f->skip_block; 2092 $f->skip_block;
2088 $self->_load_objects ($f) 2093 $self->_load_objects ($f)
2089 or return; 2094 or return;
2090 2095
2091 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2096 $self->post_load_original
2092 if delete $self->{load_original}; 2097 if delete $self->{load_original};
2093 2098
2094 if (my $uniq = $self->uniq_path) { 2099 if (my $uniq = $self->uniq_path) {
2095 utf8::encode $uniq; 2100 utf8::encode $uniq;
2096 unless (aio_stat $uniq) { 2101 unless (aio_stat $uniq) {
… …
3128=cut 3133=cut
3129 3134
3130for ( 3135for (
3131 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3136 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3132 insert remove inv nrof name archname title slaying race 3137 insert remove inv nrof name archname title slaying race
3133 decrease split destroy)], 3138 decrease split destroy change_exp)],
3134 ["cf::object::player" => qw(player)], 3139 ["cf::object::player" => qw(player)],
3135 ["cf::player" => qw(peaceful)], 3140 ["cf::player" => qw(peaceful)],
3136 ["cf::map" => qw(trigger)], 3141 ["cf::map" => qw(trigger)],
3137) { 3142) {
3138 no strict 'refs'; 3143 no strict 'refs';
… …
3586 3591
3587 warn Carp::longmess "post_cleanup backtrace" 3592 warn Carp::longmess "post_cleanup backtrace"
3588 if $make_core; 3593 if $make_core;
3589} 3594}
3590 3595
3596# a safer delete_package, copied from Symbol
3597sub clear_package($) {
3598 my $pkg = shift;
3599
3600 # expand to full symbol table name if needed
3601 unless ($pkg =~ /^main::.*::$/) {
3602 $pkg = "main$pkg" if $pkg =~ /^::/;
3603 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3604 $pkg .= '::' unless $pkg =~ /::$/;
3605 }
3606
3607 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3608 my $stem_symtab = *{$stem}{HASH};
3609
3610 defined $stem_symtab and exists $stem_symtab->{$leaf}
3611 or return;
3612
3613 # clear all symbols
3614 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3615 for my $name (keys %$leaf_symtab) {
3616 _gv_clear *{"$pkg$name"};
3617# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3618 }
3619 warn "cleared package #$pkg\n";#d#
3620}
3621
3622our $RELOAD; # how many times to reload
3623
3591sub do_reload_perl() { 3624sub do_reload_perl() {
3592 # can/must only be called in main 3625 # can/must only be called in main
3593 if ($Coro::current != $Coro::main) { 3626 if ($Coro::current != $Coro::main) {
3594 warn "can only reload from main coroutine"; 3627 warn "can only reload from main coroutine";
3595 return; 3628 return;
3596 } 3629 }
3597 3630
3631 return if $RELOAD++;
3632
3633 while ($RELOAD) {
3598 warn "reloading..."; 3634 warn "reloading...";
3599 3635
3600 warn "entering sync_job"; 3636 warn "entering sync_job";
3601 3637
3602 cf::sync_job { 3638 cf::sync_job {
3603 cf::write_runtime_sync; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
3604 cf::emergency_save; 3640 cf::emergency_save;
3605 cf::write_runtime_sync; # external watchdog should not bark 3641 cf::write_runtime_sync; # external watchdog should not bark
3606 3642
3607 warn "syncing database to disk"; 3643 warn "syncing database to disk";
3608 BDB::db_env_txn_checkpoint $DB_ENV; 3644 BDB::db_env_txn_checkpoint $DB_ENV;
3609 3645
3610 # if anything goes wrong in here, we should simply crash as we already saved 3646 # if anything goes wrong in here, we should simply crash as we already saved
3611 3647
3612 warn "flushing outstanding aio requests"; 3648 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; 3649 while (IO::AIO::nreqs || BDB::nreqs) {
3618 warn "iterate..."; 3650 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 } 3651 }
3644 3652
3645 warn "... nuking $pkg"; 3653 warn "cancelling all extension coros";
3646 Symbol::delete_package $pkg; 3654 $_->cancel for values %EXT_CORO;
3647 } 3655 %EXT_CORO = ();
3648 3656
3649 warn "unloading all perl modules loaded from $LIBDIR"; 3657 warn "removing commands";
3650 while (my ($k, $v) = each %INC) { 3658 %COMMAND = ();
3651 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3652 3659
3660 warn "removing ext/exti commands";
3661 %EXTCMD = ();
3662 %EXTICMD = ();
3663
3664 warn "unloading/nuking all extensions";
3665 for my $pkg (@EXTS) {
3653 warn "... unloading $k"; 3666 warn "... unloading $pkg";
3654 delete $INC{$k};
3655 3667
3656 $k =~ s/\.pm$//;
3657 $k =~ s/\//::/g;
3658
3659 if (my $cb = $k->can ("unload_module")) { 3668 if (my $cb = $pkg->can ("unload")) {
3669 eval {
3660 $cb->(); 3670 $cb->($pkg);
3671 1
3672 } or warn "$pkg unloaded, but with errors: $@";
3673 }
3674
3675 warn "... clearing $pkg";
3676 clear_package $pkg;
3661 } 3677 }
3662 3678
3663 Symbol::delete_package $k; 3679 warn "unloading all perl modules loaded from $LIBDIR";
3680 while (my ($k, $v) = each %INC) {
3681 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3682
3683 warn "... unloading $k";
3684 delete $INC{$k};
3685
3686 $k =~ s/\.pm$//;
3687 $k =~ s/\//::/g;
3688
3689 if (my $cb = $k->can ("unload_module")) {
3690 $cb->();
3691 }
3692
3693 clear_package $k;
3664 } 3694 }
3665 3695
3666 warn "getting rid of safe::, as good as possible"; 3696 warn "getting rid of safe::, as good as possible";
3667 Symbol::delete_package "safe::$_" 3697 clear_package "safe::$_"
3668 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3698 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3669 3699
3670 warn "unloading cf.pm \"a bit\""; 3700 warn "unloading cf.pm \"a bit\"";
3671 delete $INC{"cf.pm"}; 3701 delete $INC{"cf.pm"};
3672 delete $INC{"cf/pod.pm"}; 3702 delete $INC{"cf/pod.pm"};
3673 3703
3674 # don't, removes xs symbols, too, 3704 # don't, removes xs symbols, too,
3675 # and global variables created in xs 3705 # and global variables created in xs
3676 #Symbol::delete_package __PACKAGE__; 3706 #clear_package __PACKAGE__;
3677 3707
3678 warn "unload completed, starting to reload now"; 3708 warn "unload completed, starting to reload now";
3679 3709
3680 warn "reloading cf.pm"; 3710 warn "reloading cf.pm";
3681 require cf; 3711 require cf;
3682 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3712 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3683 3713
3684 warn "loading config and database again"; 3714 warn "loading config and database again";
3685 cf::reload_config; 3715 cf::reload_config;
3686 3716
3687 warn "loading extensions"; 3717 warn "loading extensions";
3688 cf::load_extensions; 3718 cf::load_extensions;
3689 3719
3690 warn "reattaching attachments to objects/players"; 3720 warn "reattaching attachments to objects/players";
3691 _global_reattach; # objects, sockets 3721 _global_reattach; # objects, sockets
3692 warn "reattaching attachments to maps"; 3722 warn "reattaching attachments to maps";
3693 reattach $_ for values %MAP; 3723 reattach $_ for values %MAP;
3694 warn "reattaching attachments to players"; 3724 warn "reattaching attachments to players";
3695 reattach $_ for values %PLAYER; 3725 reattach $_ for values %PLAYER;
3696 3726
3697 warn "leaving sync_job"; 3727 warn "leaving sync_job";
3698 3728
3699 1 3729 1
3700 } or do { 3730 } or do {
3701 warn $@; 3731 warn $@;
3702 cf::cleanup "error while reloading, exiting."; 3732 cf::cleanup "error while reloading, exiting.";
3703 }; 3733 };
3704 3734
3705 warn "reloaded"; 3735 warn "reloaded";
3736 --$RELOAD;
3737 }
3706}; 3738};
3707 3739
3708our $RELOAD_WATCHER; # used only during reload 3740our $RELOAD_WATCHER; # used only during reload
3709 3741
3710sub reload_perl() { 3742sub reload_perl() {
… …
3796 BDB::max_poll_reqs $TICK * 0.1; 3828 BDB::max_poll_reqs $TICK * 0.1;
3797 $AnyEvent::BDB::WATCHER->priority (1); 3829 $AnyEvent::BDB::WATCHER->priority (1);
3798 3830
3799 unless ($DB_ENV) { 3831 unless ($DB_ENV) {
3800 $DB_ENV = BDB::db_env_create; 3832 $DB_ENV = BDB::db_env_create;
3801 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3833 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3802 | BDB::LOG_AUTOREMOVE, 1); 3834 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3835 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3803 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3836 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3804 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3837 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3805 3838
3806 cf::sync_job { 3839 cf::sync_job {
3807 eval { 3840 eval {

Diff Legend

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