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.433 by root, Sat May 10 22:38:52 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;
… …
35 36
36use Coro (); 37use Coro ();
37use Coro::State; 38use Coro::State;
38use Coro::Handle; 39use Coro::Handle;
39use Coro::EV; 40use Coro::EV;
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';
… …
3395 warn "finished reloading resource files\n"; 3401 warn "finished reloading resource files\n";
3396} 3402}
3397 3403
3398sub init { 3404sub init {
3399 my $guard = freeze_mainloop; 3405 my $guard = freeze_mainloop;
3406
3407 evthread_start IO::AIO::poll_fileno;
3400 3408
3401 reload_resources; 3409 reload_resources;
3402} 3410}
3403 3411
3404sub reload_config { 3412sub reload_config {
… …
3437 reload_config; 3445 reload_config;
3438 db_init; 3446 db_init;
3439 load_extensions; 3447 load_extensions;
3440 3448
3441 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3449 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3442 evthread_start IO::AIO::poll_fileno;
3443 } 3450 }
3444 3451
3445 EV::loop; 3452 EV::loop;
3446} 3453}
3447 3454
… …
3582 3589
3583 warn Carp::longmess "post_cleanup backtrace" 3590 warn Carp::longmess "post_cleanup backtrace"
3584 if $make_core; 3591 if $make_core;
3585} 3592}
3586 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
3587sub do_reload_perl() { 3622sub do_reload_perl() {
3588 # can/must only be called in main 3623 # can/must only be called in main
3589 if ($Coro::current != $Coro::main) { 3624 if ($Coro::current != $Coro::main) {
3590 warn "can only reload from main coroutine"; 3625 warn "can only reload from main coroutine";
3591 return; 3626 return;
3592 } 3627 }
3593 3628
3629 return if $RELOAD++;
3630
3631 while ($RELOAD) {
3594 warn "reloading..."; 3632 warn "reloading...";
3595 3633
3596 warn "entering sync_job"; 3634 warn "entering sync_job";
3597 3635
3598 cf::sync_job { 3636 cf::sync_job {
3599 cf::write_runtime_sync; # external watchdog should not bark 3637 cf::write_runtime_sync; # external watchdog should not bark
3600 cf::emergency_save; 3638 cf::emergency_save;
3601 cf::write_runtime_sync; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
3602 3640
3603 warn "syncing database to disk"; 3641 warn "syncing database to disk";
3604 BDB::db_env_txn_checkpoint $DB_ENV; 3642 BDB::db_env_txn_checkpoint $DB_ENV;
3605 3643
3606 # 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
3607 3645
3608 warn "flushing outstanding aio requests"; 3646 warn "flushing outstanding aio requests";
3609 for (;;) {
3610 BDB::flush;
3611 IO::AIO::flush;
3612 Coro::cede_notself;
3613 last unless IO::AIO::nreqs || BDB::nreqs; 3647 while (IO::AIO::nreqs || BDB::nreqs) {
3614 warn "iterate..."; 3648 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3615 }
3616
3617 ++$RELOAD;
3618
3619 warn "cancelling all extension coros";
3620 $_->cancel for values %EXT_CORO;
3621 %EXT_CORO = ();
3622
3623 warn "removing commands";
3624 %COMMAND = ();
3625
3626 warn "removing ext/exti commands";
3627 %EXTCMD = ();
3628 %EXTICMD = ();
3629
3630 warn "unloading/nuking all extensions";
3631 for my $pkg (@EXTS) {
3632 warn "... unloading $pkg";
3633
3634 if (my $cb = $pkg->can ("unload")) {
3635 eval {
3636 $cb->($pkg);
3637 1
3638 } or warn "$pkg unloaded, but with errors: $@";
3639 } 3649 }
3640 3650
3641 warn "... nuking $pkg"; 3651 warn "cancelling all extension coros";
3642 Symbol::delete_package $pkg; 3652 $_->cancel for values %EXT_CORO;
3643 } 3653 %EXT_CORO = ();
3644 3654
3645 warn "unloading all perl modules loaded from $LIBDIR"; 3655 warn "removing commands";
3646 while (my ($k, $v) = each %INC) { 3656 %COMMAND = ();
3647 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3648 3657
3658 warn "removing ext/exti commands";
3659 %EXTCMD = ();
3660 %EXTICMD = ();
3661
3662 warn "unloading/nuking all extensions";
3663 for my $pkg (@EXTS) {
3649 warn "... unloading $k"; 3664 warn "... unloading $pkg";
3650 delete $INC{$k};
3651 3665
3652 $k =~ s/\.pm$//;
3653 $k =~ s/\//::/g;
3654
3655 if (my $cb = $k->can ("unload_module")) { 3666 if (my $cb = $pkg->can ("unload")) {
3667 eval {
3656 $cb->(); 3668 $cb->($pkg);
3669 1
3670 } or warn "$pkg unloaded, but with errors: $@";
3671 }
3672
3673 warn "... clearing $pkg";
3674 clear_package $pkg;
3657 } 3675 }
3658 3676
3659 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;
3660 } 3692 }
3661 3693
3662 warn "getting rid of safe::, as good as possible"; 3694 warn "getting rid of safe::, as good as possible";
3663 Symbol::delete_package "safe::$_" 3695 clear_package "safe::$_"
3664 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);
3665 3697
3666 warn "unloading cf.pm \"a bit\""; 3698 warn "unloading cf.pm \"a bit\"";
3667 delete $INC{"cf.pm"}; 3699 delete $INC{"cf.pm"};
3668 delete $INC{"cf/pod.pm"}; 3700 delete $INC{"cf/pod.pm"};
3669 3701
3670 # don't, removes xs symbols, too, 3702 # don't, removes xs symbols, too,
3671 # and global variables created in xs 3703 # and global variables created in xs
3672 #Symbol::delete_package __PACKAGE__; 3704 #clear_package __PACKAGE__;
3673 3705
3674 warn "unload completed, starting to reload now"; 3706 warn "unload completed, starting to reload now";
3675 3707
3676 warn "reloading cf.pm"; 3708 warn "reloading cf.pm";
3677 require cf; 3709 require cf;
3678 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3710 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3679 3711
3680 warn "loading config and database again"; 3712 warn "loading config and database again";
3681 cf::reload_config; 3713 cf::reload_config;
3682 3714
3683 warn "loading extensions"; 3715 warn "loading extensions";
3684 cf::load_extensions; 3716 cf::load_extensions;
3685 3717
3686 warn "reattaching attachments to objects/players"; 3718 warn "reattaching attachments to objects/players";
3687 _global_reattach; # objects, sockets 3719 _global_reattach; # objects, sockets
3688 warn "reattaching attachments to maps"; 3720 warn "reattaching attachments to maps";
3689 reattach $_ for values %MAP; 3721 reattach $_ for values %MAP;
3690 warn "reattaching attachments to players"; 3722 warn "reattaching attachments to players";
3691 reattach $_ for values %PLAYER; 3723 reattach $_ for values %PLAYER;
3692 3724
3693 warn "leaving sync_job"; 3725 warn "leaving sync_job";
3694 3726
3695 1 3727 1
3696 } or do { 3728 } or do {
3697 warn $@; 3729 warn $@;
3698 cf::cleanup "error while reloading, exiting."; 3730 cf::cleanup "error while reloading, exiting.";
3699 }; 3731 };
3700 3732
3701 warn "reloaded"; 3733 warn "reloaded";
3734 --$RELOAD;
3735 }
3702}; 3736};
3703 3737
3704our $RELOAD_WATCHER; # used only during reload 3738our $RELOAD_WATCHER; # used only during reload
3705 3739
3706sub reload_perl() { 3740sub reload_perl() {
… …
3792 BDB::max_poll_reqs $TICK * 0.1; 3826 BDB::max_poll_reqs $TICK * 0.1;
3793 $AnyEvent::BDB::WATCHER->priority (1); 3827 $AnyEvent::BDB::WATCHER->priority (1);
3794 3828
3795 unless ($DB_ENV) { 3829 unless ($DB_ENV) {
3796 $DB_ENV = BDB::db_env_create; 3830 $DB_ENV = BDB::db_env_create;
3797 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3831 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3798 | 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;
3799 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3834 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3800 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3835 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3801 3836
3802 cf::sync_job { 3837 cf::sync_job {
3803 eval { 3838 eval {
… …
3829{ 3864{
3830 # configure IO::AIO 3865 # configure IO::AIO
3831 3866
3832 IO::AIO::min_parallel 8; 3867 IO::AIO::min_parallel 8;
3833 IO::AIO::max_poll_time $TICK * 0.1; 3868 IO::AIO::max_poll_time $TICK * 0.1;
3834 $AnyEvent::AIO::WATCHER->priority (1); 3869 undef $AnyEvent::AIO::WATCHER;
3835} 3870}
3836 3871
3837my $_log_backtrace; 3872my $_log_backtrace;
3838 3873
3839sub _log_backtrace { 3874sub _log_backtrace {

Diff Legend

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