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.435 by root, Thu May 29 03:33:20 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;
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;
… …
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) {
… …
2613Moves the player to the given map-path and coordinates by first freezing 2616Moves the player to the given map-path and coordinates by first freezing
2614her, loading and preparing them map, calling the provided $check callback 2617her, loading and preparing them map, calling the provided $check callback
2615that has to return the map if sucecssful, and then unfreezes the player on 2618that has to return the map if sucecssful, and then unfreezes the player on
2616the new (success) or old (failed) map position. In either case, $done will 2619the new (success) or old (failed) map position. In either case, $done will
2617be called at the end of this process. 2620be called at the end of this process.
2621
2622Note that $check will be called with a potentially non-loaded map, so if
2623it needs a loaded map it has to call C<< ->load >>.
2618 2624
2619=cut 2625=cut
2620 2626
2621our $GOTOGEN; 2627our $GOTOGEN;
2622 2628
… …
3125=cut 3131=cut
3126 3132
3127for ( 3133for (
3128 ["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
3129 insert remove inv nrof name archname title slaying race 3135 insert remove inv nrof name archname title slaying race
3130 decrease split destroy)], 3136 decrease split destroy change_exp)],
3131 ["cf::object::player" => qw(player)], 3137 ["cf::object::player" => qw(player)],
3132 ["cf::player" => qw(peaceful)], 3138 ["cf::player" => qw(peaceful)],
3133 ["cf::map" => qw(trigger)], 3139 ["cf::map" => qw(trigger)],
3134) { 3140) {
3135 no strict 'refs'; 3141 no strict 'refs';
… …
3583 3589
3584 warn Carp::longmess "post_cleanup backtrace" 3590 warn Carp::longmess "post_cleanup backtrace"
3585 if $make_core; 3591 if $make_core;
3586} 3592}
3587 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
3588sub do_reload_perl() { 3622sub do_reload_perl() {
3589 # can/must only be called in main 3623 # can/must only be called in main
3590 if ($Coro::current != $Coro::main) { 3624 if ($Coro::current != $Coro::main) {
3591 warn "can only reload from main coroutine"; 3625 warn "can only reload from main coroutine";
3592 return; 3626 return;
3593 } 3627 }
3594 3628
3629 return if $RELOAD++;
3630
3631 while ($RELOAD) {
3595 warn "reloading..."; 3632 warn "reloading...";
3596 3633
3597 warn "entering sync_job"; 3634 warn "entering sync_job";
3598 3635
3599 cf::sync_job { 3636 cf::sync_job {
3600 cf::write_runtime_sync; # external watchdog should not bark 3637 cf::write_runtime_sync; # external watchdog should not bark
3601 cf::emergency_save; 3638 cf::emergency_save;
3602 cf::write_runtime_sync; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
3603 3640
3604 warn "syncing database to disk"; 3641 warn "syncing database to disk";
3605 BDB::db_env_txn_checkpoint $DB_ENV; 3642 BDB::db_env_txn_checkpoint $DB_ENV;
3606 3643
3607 # 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
3608 3645
3609 warn "flushing outstanding aio requests"; 3646 warn "flushing outstanding aio requests";
3610 for (;;) {
3611 BDB::flush;
3612 IO::AIO::flush;
3613 Coro::cede_notself;
3614 last unless IO::AIO::nreqs || BDB::nreqs; 3647 while (IO::AIO::nreqs || BDB::nreqs) {
3615 warn "iterate..."; 3648 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3616 }
3617
3618 ++$RELOAD;
3619
3620 warn "cancelling all extension coros";
3621 $_->cancel for values %EXT_CORO;
3622 %EXT_CORO = ();
3623
3624 warn "removing commands";
3625 %COMMAND = ();
3626
3627 warn "removing ext/exti commands";
3628 %EXTCMD = ();
3629 %EXTICMD = ();
3630
3631 warn "unloading/nuking all extensions";
3632 for my $pkg (@EXTS) {
3633 warn "... unloading $pkg";
3634
3635 if (my $cb = $pkg->can ("unload")) {
3636 eval {
3637 $cb->($pkg);
3638 1
3639 } or warn "$pkg unloaded, but with errors: $@";
3640 } 3649 }
3641 3650
3642 warn "... nuking $pkg"; 3651 warn "cancelling all extension coros";
3643 Symbol::delete_package $pkg; 3652 $_->cancel for values %EXT_CORO;
3644 } 3653 %EXT_CORO = ();
3645 3654
3646 warn "unloading all perl modules loaded from $LIBDIR"; 3655 warn "removing commands";
3647 while (my ($k, $v) = each %INC) { 3656 %COMMAND = ();
3648 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3649 3657
3658 warn "removing ext/exti commands";
3659 %EXTCMD = ();
3660 %EXTICMD = ();
3661
3662 warn "unloading/nuking all extensions";
3663 for my $pkg (@EXTS) {
3650 warn "... unloading $k"; 3664 warn "... unloading $pkg";
3651 delete $INC{$k};
3652 3665
3653 $k =~ s/\.pm$//;
3654 $k =~ s/\//::/g;
3655
3656 if (my $cb = $k->can ("unload_module")) { 3666 if (my $cb = $pkg->can ("unload")) {
3667 eval {
3657 $cb->(); 3668 $cb->($pkg);
3669 1
3670 } or warn "$pkg unloaded, but with errors: $@";
3671 }
3672
3673 warn "... clearing $pkg";
3674 clear_package $pkg;
3658 } 3675 }
3659 3676
3660 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;
3661 } 3692 }
3662 3693
3663 warn "getting rid of safe::, as good as possible"; 3694 warn "getting rid of safe::, as good as possible";
3664 Symbol::delete_package "safe::$_" 3695 clear_package "safe::$_"
3665 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);
3666 3697
3667 warn "unloading cf.pm \"a bit\""; 3698 warn "unloading cf.pm \"a bit\"";
3668 delete $INC{"cf.pm"}; 3699 delete $INC{"cf.pm"};
3669 delete $INC{"cf/pod.pm"}; 3700 delete $INC{"cf/pod.pm"};
3670 3701
3671 # don't, removes xs symbols, too, 3702 # don't, removes xs symbols, too,
3672 # and global variables created in xs 3703 # and global variables created in xs
3673 #Symbol::delete_package __PACKAGE__; 3704 #clear_package __PACKAGE__;
3674 3705
3675 warn "unload completed, starting to reload now"; 3706 warn "unload completed, starting to reload now";
3676 3707
3677 warn "reloading cf.pm"; 3708 warn "reloading cf.pm";
3678 require cf; 3709 require cf;
3679 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3710 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3680 3711
3681 warn "loading config and database again"; 3712 warn "loading config and database again";
3682 cf::reload_config; 3713 cf::reload_config;
3683 3714
3684 warn "loading extensions"; 3715 warn "loading extensions";
3685 cf::load_extensions; 3716 cf::load_extensions;
3686 3717
3687 warn "reattaching attachments to objects/players"; 3718 warn "reattaching attachments to objects/players";
3688 _global_reattach; # objects, sockets 3719 _global_reattach; # objects, sockets
3689 warn "reattaching attachments to maps"; 3720 warn "reattaching attachments to maps";
3690 reattach $_ for values %MAP; 3721 reattach $_ for values %MAP;
3691 warn "reattaching attachments to players"; 3722 warn "reattaching attachments to players";
3692 reattach $_ for values %PLAYER; 3723 reattach $_ for values %PLAYER;
3693 3724
3694 warn "leaving sync_job"; 3725 warn "leaving sync_job";
3695 3726
3696 1 3727 1
3697 } or do { 3728 } or do {
3698 warn $@; 3729 warn $@;
3699 cf::cleanup "error while reloading, exiting."; 3730 cf::cleanup "error while reloading, exiting.";
3700 }; 3731 };
3701 3732
3702 warn "reloaded"; 3733 warn "reloaded";
3734 --$RELOAD;
3735 }
3703}; 3736};
3704 3737
3705our $RELOAD_WATCHER; # used only during reload 3738our $RELOAD_WATCHER; # used only during reload
3706 3739
3707sub reload_perl() { 3740sub reload_perl() {
… …
3793 BDB::max_poll_reqs $TICK * 0.1; 3826 BDB::max_poll_reqs $TICK * 0.1;
3794 $AnyEvent::BDB::WATCHER->priority (1); 3827 $AnyEvent::BDB::WATCHER->priority (1);
3795 3828
3796 unless ($DB_ENV) { 3829 unless ($DB_ENV) {
3797 $DB_ENV = BDB::db_env_create; 3830 $DB_ENV = BDB::db_env_create;
3798 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3831 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3799 | BDB::LOG_AUTOREMOVE, 1); 3832 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3833 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3800 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3834 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3801 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3835 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3802 3836
3803 cf::sync_job { 3837 cf::sync_job {
3804 eval { 3838 eval {

Diff Legend

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