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.441 by root, Sat Aug 30 05:19:03 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;
… …
3587 3589
3588 warn Carp::longmess "post_cleanup backtrace" 3590 warn Carp::longmess "post_cleanup backtrace"
3589 if $make_core; 3591 if $make_core;
3590} 3592}
3591 3593
3594# a safer delete_package, copied from Symbol
3595sub clear_package($) {
3596 my $pkg = shift;
3597
3598 # expand to full symbol table name if needed
3599 unless ($pkg =~ /^main::.*::$/) {
3600 $pkg = "main$pkg" if $pkg =~ /^::/;
3601 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3602 $pkg .= '::' unless $pkg =~ /::$/;
3603 }
3604
3605 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3606 my $stem_symtab = *{$stem}{HASH};
3607
3608 defined $stem_symtab and exists $stem_symtab->{$leaf}
3609 or return;
3610
3611 # clear all symbols
3612 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3613 for my $name (keys %$leaf_symtab) {
3614 _gv_clear *{"$pkg$name"};
3615# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3616 }
3617 warn "cleared package #$pkg\n";#d#
3618}
3619
3620our $RELOAD; # how many times to reload
3621
3592sub do_reload_perl() { 3622sub do_reload_perl() {
3593 # can/must only be called in main 3623 # can/must only be called in main
3594 if ($Coro::current != $Coro::main) { 3624 if ($Coro::current != $Coro::main) {
3595 warn "can only reload from main coroutine"; 3625 warn "can only reload from main coroutine";
3596 return; 3626 return;
3597 } 3627 }
3598 3628
3629 return if $RELOAD++;
3630
3631 while ($RELOAD) {
3599 warn "reloading..."; 3632 warn "reloading...";
3600 3633
3601 warn "entering sync_job"; 3634 warn "entering sync_job";
3602 3635
3603 cf::sync_job { 3636 cf::sync_job {
3604 cf::write_runtime_sync; # external watchdog should not bark 3637 cf::write_runtime_sync; # external watchdog should not bark
3605 cf::emergency_save; 3638 cf::emergency_save;
3606 cf::write_runtime_sync; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
3607 3640
3608 warn "syncing database to disk"; 3641 warn "syncing database to disk";
3609 BDB::db_env_txn_checkpoint $DB_ENV; 3642 BDB::db_env_txn_checkpoint $DB_ENV;
3610 3643
3611 # if anything goes wrong in here, we should simply crash as we already saved 3644 # if anything goes wrong in here, we should simply crash as we already saved
3612 3645
3613 warn "flushing outstanding aio requests"; 3646 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; 3647 while (IO::AIO::nreqs || BDB::nreqs) {
3619 warn "iterate..."; 3648 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 } 3649 }
3645 3650
3646 warn "... nuking $pkg"; 3651 warn "cancelling all extension coros";
3647 Symbol::delete_package $pkg; 3652 $_->cancel for values %EXT_CORO;
3648 } 3653 %EXT_CORO = ();
3649 3654
3650 warn "unloading all perl modules loaded from $LIBDIR"; 3655 warn "removing commands";
3651 while (my ($k, $v) = each %INC) { 3656 %COMMAND = ();
3652 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3653 3657
3658 warn "removing ext/exti commands";
3659 %EXTCMD = ();
3660 %EXTICMD = ();
3661
3662 warn "unloading/nuking all extensions";
3663 for my $pkg (@EXTS) {
3654 warn "... unloading $k"; 3664 warn "... unloading $pkg";
3655 delete $INC{$k};
3656 3665
3657 $k =~ s/\.pm$//;
3658 $k =~ s/\//::/g;
3659
3660 if (my $cb = $k->can ("unload_module")) { 3666 if (my $cb = $pkg->can ("unload")) {
3667 eval {
3661 $cb->(); 3668 $cb->($pkg);
3669 1
3670 } or warn "$pkg unloaded, but with errors: $@";
3671 }
3672
3673 warn "... clearing $pkg";
3674 clear_package $pkg;
3662 } 3675 }
3663 3676
3664 Symbol::delete_package $k; 3677 warn "unloading all perl modules loaded from $LIBDIR";
3678 while (my ($k, $v) = each %INC) {
3679 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3680
3681 warn "... unloading $k";
3682 delete $INC{$k};
3683
3684 $k =~ s/\.pm$//;
3685 $k =~ s/\//::/g;
3686
3687 if (my $cb = $k->can ("unload_module")) {
3688 $cb->();
3689 }
3690
3691 clear_package $k;
3665 } 3692 }
3666 3693
3667 warn "getting rid of safe::, as good as possible"; 3694 warn "getting rid of safe::, as good as possible";
3668 Symbol::delete_package "safe::$_" 3695 clear_package "safe::$_"
3669 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3696 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3670 3697
3671 warn "unloading cf.pm \"a bit\""; 3698 warn "unloading cf.pm \"a bit\"";
3672 delete $INC{"cf.pm"}; 3699 delete $INC{"cf.pm"};
3673 delete $INC{"cf/pod.pm"}; 3700 delete $INC{"cf/pod.pm"};
3674 3701
3675 # don't, removes xs symbols, too, 3702 # don't, removes xs symbols, too,
3676 # and global variables created in xs 3703 # and global variables created in xs
3677 #Symbol::delete_package __PACKAGE__; 3704 #clear_package __PACKAGE__;
3678 3705
3679 warn "unload completed, starting to reload now"; 3706 warn "unload completed, starting to reload now";
3680 3707
3681 warn "reloading cf.pm"; 3708 warn "reloading cf.pm";
3682 require cf; 3709 require cf;
3683 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3710 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3684 3711
3685 warn "loading config and database again"; 3712 warn "loading config and database again";
3686 cf::reload_config; 3713 cf::reload_config;
3687 3714
3688 warn "loading extensions"; 3715 warn "loading extensions";
3689 cf::load_extensions; 3716 cf::load_extensions;
3690 3717
3691 warn "reattaching attachments to objects/players"; 3718 warn "reattaching attachments to objects/players";
3692 _global_reattach; # objects, sockets 3719 _global_reattach; # objects, sockets
3693 warn "reattaching attachments to maps"; 3720 warn "reattaching attachments to maps";
3694 reattach $_ for values %MAP; 3721 reattach $_ for values %MAP;
3695 warn "reattaching attachments to players"; 3722 warn "reattaching attachments to players";
3696 reattach $_ for values %PLAYER; 3723 reattach $_ for values %PLAYER;
3697 3724
3698 warn "leaving sync_job"; 3725 warn "leaving sync_job";
3699 3726
3700 1 3727 1
3701 } or do { 3728 } or do {
3702 warn $@; 3729 warn $@;
3703 cf::cleanup "error while reloading, exiting."; 3730 cf::cleanup "error while reloading, exiting.";
3704 }; 3731 };
3705 3732
3706 warn "reloaded"; 3733 warn "reloaded";
3734 --$RELOAD;
3735 }
3707}; 3736};
3708 3737
3709our $RELOAD_WATCHER; # used only during reload 3738our $RELOAD_WATCHER; # used only during reload
3710 3739
3711sub reload_perl() { 3740sub reload_perl() {

Diff Legend

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