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.437 by root, Tue Jul 8 08:33:27 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;
… …
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;
… …
2086 my $f = new_from_file cf::object::thawer $self->{load_path}; 2089 my $f = new_from_file cf::object::thawer $self->{load_path};
2087 $f->skip_block; 2090 $f->skip_block;
2088 $self->_load_objects ($f) 2091 $self->_load_objects ($f)
2089 or return; 2092 or return;
2090 2093
2091 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2094 $self->post_load_original
2092 if delete $self->{load_original}; 2095 if delete $self->{load_original};
2093 2096
2094 if (my $uniq = $self->uniq_path) { 2097 if (my $uniq = $self->uniq_path) {
2095 utf8::encode $uniq; 2098 utf8::encode $uniq;
2096 unless (aio_stat $uniq) { 2099 unless (aio_stat $uniq) {
… …
3128=cut 3131=cut
3129 3132
3130for ( 3133for (
3131 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3134 ["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 3135 insert remove inv nrof name archname title slaying race
3133 decrease split destroy)], 3136 decrease split destroy change_exp)],
3134 ["cf::object::player" => qw(player)], 3137 ["cf::object::player" => qw(player)],
3135 ["cf::player" => qw(peaceful)], 3138 ["cf::player" => qw(peaceful)],
3136 ["cf::map" => qw(trigger)], 3139 ["cf::map" => qw(trigger)],
3137) { 3140) {
3138 no strict 'refs'; 3141 no strict 'refs';
… …
3586 3589
3587 warn Carp::longmess "post_cleanup backtrace" 3590 warn Carp::longmess "post_cleanup backtrace"
3588 if $make_core; 3591 if $make_core;
3589} 3592}
3590 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
3591sub do_reload_perl() { 3622sub do_reload_perl() {
3592 # can/must only be called in main 3623 # can/must only be called in main
3593 if ($Coro::current != $Coro::main) { 3624 if ($Coro::current != $Coro::main) {
3594 warn "can only reload from main coroutine"; 3625 warn "can only reload from main coroutine";
3595 return; 3626 return;
3596 } 3627 }
3597 3628
3629 return if $RELOAD++;
3630
3631 while ($RELOAD) {
3598 warn "reloading..."; 3632 warn "reloading...";
3599 3633
3600 warn "entering sync_job"; 3634 warn "entering sync_job";
3601 3635
3602 cf::sync_job { 3636 cf::sync_job {
3603 cf::write_runtime_sync; # external watchdog should not bark 3637 cf::write_runtime_sync; # external watchdog should not bark
3604 cf::emergency_save; 3638 cf::emergency_save;
3605 cf::write_runtime_sync; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
3606 3640
3607 warn "syncing database to disk"; 3641 warn "syncing database to disk";
3608 BDB::db_env_txn_checkpoint $DB_ENV; 3642 BDB::db_env_txn_checkpoint $DB_ENV;
3609 3643
3610 # 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
3611 3645
3612 warn "flushing outstanding aio requests"; 3646 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; 3647 while (IO::AIO::nreqs || BDB::nreqs) {
3618 warn "iterate..."; 3648 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 } 3649 }
3644 3650
3645 warn "... nuking $pkg"; 3651 warn "cancelling all extension coros";
3646 Symbol::delete_package $pkg; 3652 $_->cancel for values %EXT_CORO;
3647 } 3653 %EXT_CORO = ();
3648 3654
3649 warn "unloading all perl modules loaded from $LIBDIR"; 3655 warn "removing commands";
3650 while (my ($k, $v) = each %INC) { 3656 %COMMAND = ();
3651 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3652 3657
3658 warn "removing ext/exti commands";
3659 %EXTCMD = ();
3660 %EXTICMD = ();
3661
3662 warn "unloading/nuking all extensions";
3663 for my $pkg (@EXTS) {
3653 warn "... unloading $k"; 3664 warn "... unloading $pkg";
3654 delete $INC{$k};
3655 3665
3656 $k =~ s/\.pm$//;
3657 $k =~ s/\//::/g;
3658
3659 if (my $cb = $k->can ("unload_module")) { 3666 if (my $cb = $pkg->can ("unload")) {
3667 eval {
3660 $cb->(); 3668 $cb->($pkg);
3669 1
3670 } or warn "$pkg unloaded, but with errors: $@";
3671 }
3672
3673 warn "... clearing $pkg";
3674 clear_package $pkg;
3661 } 3675 }
3662 3676
3663 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;
3664 } 3692 }
3665 3693
3666 warn "getting rid of safe::, as good as possible"; 3694 warn "getting rid of safe::, as good as possible";
3667 Symbol::delete_package "safe::$_" 3695 clear_package "safe::$_"
3668 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);
3669 3697
3670 warn "unloading cf.pm \"a bit\""; 3698 warn "unloading cf.pm \"a bit\"";
3671 delete $INC{"cf.pm"}; 3699 delete $INC{"cf.pm"};
3672 delete $INC{"cf/pod.pm"}; 3700 delete $INC{"cf/pod.pm"};
3673 3701
3674 # don't, removes xs symbols, too, 3702 # don't, removes xs symbols, too,
3675 # and global variables created in xs 3703 # and global variables created in xs
3676 #Symbol::delete_package __PACKAGE__; 3704 #clear_package __PACKAGE__;
3677 3705
3678 warn "unload completed, starting to reload now"; 3706 warn "unload completed, starting to reload now";
3679 3707
3680 warn "reloading cf.pm"; 3708 warn "reloading cf.pm";
3681 require cf; 3709 require cf;
3682 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3710 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3683 3711
3684 warn "loading config and database again"; 3712 warn "loading config and database again";
3685 cf::reload_config; 3713 cf::reload_config;
3686 3714
3687 warn "loading extensions"; 3715 warn "loading extensions";
3688 cf::load_extensions; 3716 cf::load_extensions;
3689 3717
3690 warn "reattaching attachments to objects/players"; 3718 warn "reattaching attachments to objects/players";
3691 _global_reattach; # objects, sockets 3719 _global_reattach; # objects, sockets
3692 warn "reattaching attachments to maps"; 3720 warn "reattaching attachments to maps";
3693 reattach $_ for values %MAP; 3721 reattach $_ for values %MAP;
3694 warn "reattaching attachments to players"; 3722 warn "reattaching attachments to players";
3695 reattach $_ for values %PLAYER; 3723 reattach $_ for values %PLAYER;
3696 3724
3697 warn "leaving sync_job"; 3725 warn "leaving sync_job";
3698 3726
3699 1 3727 1
3700 } or do { 3728 } or do {
3701 warn $@; 3729 warn $@;
3702 cf::cleanup "error while reloading, exiting."; 3730 cf::cleanup "error while reloading, exiting.";
3703 }; 3731 };
3704 3732
3705 warn "reloaded"; 3733 warn "reloaded";
3734 --$RELOAD;
3735 }
3706}; 3736};
3707 3737
3708our $RELOAD_WATCHER; # used only during reload 3738our $RELOAD_WATCHER; # used only during reload
3709 3739
3710sub reload_perl() { 3740sub reload_perl() {

Diff Legend

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