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.431 by elmex, Sun May 4 19:27: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 3.2; 31use EV;
31use Opcode; 32use Opcode;
32use Safe; 33use Safe;
33use Safe::Hole; 34use Safe::Hole;
34use Storable (); 35use Storable ();
35 36
36use Coro 4.50 (); 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;
45use Coro::AnyEvent;
43use Coro::AIO; 46use Coro::AIO;
44use Coro::BDB; 47use Coro::BDB 1.6;
45use Coro::Storable; 48use Coro::Storable;
46use Coro::Util (); 49use Coro::Util ();
47 50
48use JSON::XS 2.01 (); 51use JSON::XS 2.01 ();
49use BDB (); 52use BDB ();
50use Data::Dumper; 53use Data::Dumper;
51use Digest::MD5; 54use Digest::MD5;
52use Fcntl; 55use Fcntl;
53use YAML (); 56use YAML ();
54use IO::AIO 2.51 (); 57use IO::AIO ();
55use Time::HiRes; 58use Time::HiRes;
56use Compress::LZF; 59use Compress::LZF;
57use Digest::MD5 (); 60use Digest::MD5 ();
61
62AnyEvent::detect;
58 63
59# configure various modules to our taste 64# configure various modules to our taste
60# 65#
61$Storable::canonical = 1; # reduce rsync transfers 66$Storable::canonical = 1; # reduce rsync transfers
62Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
… …
90our $RANDOMDIR = "$LOCALDIR/random"; 95our $RANDOMDIR = "$LOCALDIR/random";
91our $BDBDIR = "$LOCALDIR/db"; 96our $BDBDIR = "$LOCALDIR/db";
92our %RESOURCE; 97our %RESOURCE;
93 98
94our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 99our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
95our $AIO_POLL_WATCHER;
96our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 100our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
97our $NEXT_TICK; 101our $NEXT_TICK;
98our $USE_FSYNC = 1; # use fsync to write maps - default off 102our $USE_FSYNC = 1; # use fsync to write maps - default off
99 103
100our $BDB_POLL_WATCHER;
101our $BDB_DEADLOCK_WATCHER; 104our $BDB_DEADLOCK_WATCHER;
102our $BDB_CHECKPOINT_WATCHER; 105our $BDB_CHECKPOINT_WATCHER;
103our $BDB_TRICKLE_WATCHER; 106our $BDB_TRICKLE_WATCHER;
104our $DB_ENV; 107our $DB_ENV;
105 108
… …
242for my $pkg (qw( 245for my $pkg (qw(
243 cf::global cf::attachable 246 cf::global cf::attachable
244 cf::object cf::object::player 247 cf::object cf::object::player
245 cf::client cf::player 248 cf::client cf::player
246 cf::arch cf::living 249 cf::arch cf::living
250 cf::map cf::mapspace
247 cf::map cf::party cf::region 251 cf::party cf::region
248)) { 252)) {
249 no strict 'refs';
250 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 253 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
251} 254}
252 255
253$EV::DIED = sub { 256$EV::DIED = sub {
254 warn "error in event callback: @_"; 257 warn "error in event callback: @_";
… …
1085 1088
1086sub reattach { 1089sub reattach {
1087 # basically do the same as instantiate, without calling instantiate 1090 # basically do the same as instantiate, without calling instantiate
1088 my ($obj) = @_; 1091 my ($obj) = @_;
1089 1092
1093 # no longer needed after getting rid of delete_package?
1090 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
1091 1095
1092 my $registry = $obj->registry; 1096 my $registry = $obj->registry;
1093 1097
1094 @$registry = (); 1098 @$registry = ();
1095 1099
… …
1331 1335
1332 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1336 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1333 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1337 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1334 1338
1335 $ext{source} = 1339 $ext{source} =
1336 "package $pkg; use strict; use utf8;\n" 1340 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1337 . "#line 1 \"$path\"\n{\n" 1341 . "#line 1 \"$path\"\n{\n"
1338 . $source 1342 . $source
1339 . "\n};\n1"; 1343 . "\n};\n1";
1340 1344
1341 $todo{$base} = \%ext; 1345 $todo{$base} = \%ext;
… …
1523 $pl->{deny_save} = 1; 1527 $pl->{deny_save} = 1;
1524 $pl->password ("*"); # this should lock out the player until we nuked the dir 1528 $pl->password ("*"); # this should lock out the player until we nuked the dir
1525 1529
1526 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1530 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1527 $pl->deactivate; 1531 $pl->deactivate;
1532 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1533 $pl->ob->check_score;
1528 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1534 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1529 $pl->ns->destroy if $pl->ns; 1535 $pl->ns->destroy if $pl->ns;
1530 1536
1531 my $path = playerdir $pl; 1537 my $path = playerdir $pl;
1532 my $temp = "$path~$cf::RUNTIME~deleting~"; 1538 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
2083 my $f = new_from_file cf::object::thawer $self->{load_path}; 2089 my $f = new_from_file cf::object::thawer $self->{load_path};
2084 $f->skip_block; 2090 $f->skip_block;
2085 $self->_load_objects ($f) 2091 $self->_load_objects ($f)
2086 or return; 2092 or return;
2087 2093
2088 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2094 $self->post_load_original
2089 if delete $self->{load_original}; 2095 if delete $self->{load_original};
2090 2096
2091 if (my $uniq = $self->uniq_path) { 2097 if (my $uniq = $self->uniq_path) {
2092 utf8::encode $uniq; 2098 utf8::encode $uniq;
2093 unless (aio_stat $uniq) { 2099 unless (aio_stat $uniq) {
… …
2610Moves 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
2611her, loading and preparing them map, calling the provided $check callback 2617her, loading and preparing them map, calling the provided $check callback
2612that 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
2613the 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
2614be 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 >>.
2615 2624
2616=cut 2625=cut
2617 2626
2618our $GOTOGEN; 2627our $GOTOGEN;
2619 2628
… …
3122=cut 3131=cut
3123 3132
3124for ( 3133for (
3125 ["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
3126 insert remove inv nrof name archname title slaying race 3135 insert remove inv nrof name archname title slaying race
3127 decrease split destroy)], 3136 decrease split destroy change_exp)],
3128 ["cf::object::player" => qw(player)], 3137 ["cf::object::player" => qw(player)],
3129 ["cf::player" => qw(peaceful)], 3138 ["cf::player" => qw(peaceful)],
3130 ["cf::map" => qw(trigger)], 3139 ["cf::map" => qw(trigger)],
3131) { 3140) {
3132 no strict 'refs'; 3141 no strict 'refs';
… …
3392 warn "finished reloading resource files\n"; 3401 warn "finished reloading resource files\n";
3393} 3402}
3394 3403
3395sub init { 3404sub init {
3396 my $guard = freeze_mainloop; 3405 my $guard = freeze_mainloop;
3406
3407 evthread_start IO::AIO::poll_fileno;
3397 3408
3398 reload_resources; 3409 reload_resources;
3399} 3410}
3400 3411
3401sub reload_config { 3412sub reload_config {
… …
3434 reload_config; 3445 reload_config;
3435 db_init; 3446 db_init;
3436 load_extensions; 3447 load_extensions;
3437 3448
3438 $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
3439 evthread_start IO::AIO::poll_fileno;
3440 } 3450 }
3441 3451
3442 EV::loop; 3452 EV::loop;
3443} 3453}
3444 3454
… …
3579 3589
3580 warn Carp::longmess "post_cleanup backtrace" 3590 warn Carp::longmess "post_cleanup backtrace"
3581 if $make_core; 3591 if $make_core;
3582} 3592}
3583 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
3584sub do_reload_perl() { 3622sub do_reload_perl() {
3585 # can/must only be called in main 3623 # can/must only be called in main
3586 if ($Coro::current != $Coro::main) { 3624 if ($Coro::current != $Coro::main) {
3587 warn "can only reload from main coroutine"; 3625 warn "can only reload from main coroutine";
3588 return; 3626 return;
3589 } 3627 }
3590 3628
3629 return if $RELOAD++;
3630
3631 while ($RELOAD) {
3591 warn "reloading..."; 3632 warn "reloading...";
3592 3633
3593 warn "entering sync_job"; 3634 warn "entering sync_job";
3594 3635
3595 cf::sync_job { 3636 cf::sync_job {
3596 cf::write_runtime_sync; # external watchdog should not bark 3637 cf::write_runtime_sync; # external watchdog should not bark
3597 cf::emergency_save; 3638 cf::emergency_save;
3598 cf::write_runtime_sync; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
3599 3640
3600 warn "syncing database to disk"; 3641 warn "syncing database to disk";
3601 BDB::db_env_txn_checkpoint $DB_ENV; 3642 BDB::db_env_txn_checkpoint $DB_ENV;
3602 3643
3603 # 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
3604 3645
3605 warn "flushing outstanding aio requests"; 3646 warn "flushing outstanding aio requests";
3606 for (;;) {
3607 BDB::flush;
3608 IO::AIO::flush;
3609 Coro::cede_notself;
3610 last unless IO::AIO::nreqs || BDB::nreqs; 3647 while (IO::AIO::nreqs || BDB::nreqs) {
3611 warn "iterate..."; 3648 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3612 }
3613
3614 ++$RELOAD;
3615
3616 warn "cancelling all extension coros";
3617 $_->cancel for values %EXT_CORO;
3618 %EXT_CORO = ();
3619
3620 warn "removing commands";
3621 %COMMAND = ();
3622
3623 warn "removing ext/exti commands";
3624 %EXTCMD = ();
3625 %EXTICMD = ();
3626
3627 warn "unloading/nuking all extensions";
3628 for my $pkg (@EXTS) {
3629 warn "... unloading $pkg";
3630
3631 if (my $cb = $pkg->can ("unload")) {
3632 eval {
3633 $cb->($pkg);
3634 1
3635 } or warn "$pkg unloaded, but with errors: $@";
3636 } 3649 }
3637 3650
3638 warn "... nuking $pkg"; 3651 warn "cancelling all extension coros";
3639 Symbol::delete_package $pkg; 3652 $_->cancel for values %EXT_CORO;
3640 } 3653 %EXT_CORO = ();
3641 3654
3642 warn "unloading all perl modules loaded from $LIBDIR"; 3655 warn "removing commands";
3643 while (my ($k, $v) = each %INC) { 3656 %COMMAND = ();
3644 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3645 3657
3658 warn "removing ext/exti commands";
3659 %EXTCMD = ();
3660 %EXTICMD = ();
3661
3662 warn "unloading/nuking all extensions";
3663 for my $pkg (@EXTS) {
3646 warn "... unloading $k"; 3664 warn "... unloading $pkg";
3647 delete $INC{$k};
3648 3665
3649 $k =~ s/\.pm$//;
3650 $k =~ s/\//::/g;
3651
3652 if (my $cb = $k->can ("unload_module")) { 3666 if (my $cb = $pkg->can ("unload")) {
3667 eval {
3653 $cb->(); 3668 $cb->($pkg);
3669 1
3670 } or warn "$pkg unloaded, but with errors: $@";
3671 }
3672
3673 warn "... clearing $pkg";
3674 clear_package $pkg;
3654 } 3675 }
3655 3676
3656 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;
3657 } 3692 }
3658 3693
3659 warn "getting rid of safe::, as good as possible"; 3694 warn "getting rid of safe::, as good as possible";
3660 Symbol::delete_package "safe::$_" 3695 clear_package "safe::$_"
3661 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);
3662 3697
3663 warn "unloading cf.pm \"a bit\""; 3698 warn "unloading cf.pm \"a bit\"";
3664 delete $INC{"cf.pm"}; 3699 delete $INC{"cf.pm"};
3665 delete $INC{"cf/pod.pm"}; 3700 delete $INC{"cf/pod.pm"};
3666 3701
3667 # don't, removes xs symbols, too, 3702 # don't, removes xs symbols, too,
3668 # and global variables created in xs 3703 # and global variables created in xs
3669 #Symbol::delete_package __PACKAGE__; 3704 #clear_package __PACKAGE__;
3670 3705
3671 warn "unload completed, starting to reload now"; 3706 warn "unload completed, starting to reload now";
3672 3707
3673 warn "reloading cf.pm"; 3708 warn "reloading cf.pm";
3674 require cf; 3709 require cf;
3675 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3710 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3676 3711
3677 warn "loading config and database again"; 3712 warn "loading config and database again";
3678 cf::reload_config; 3713 cf::reload_config;
3679 3714
3680 warn "loading extensions"; 3715 warn "loading extensions";
3681 cf::load_extensions; 3716 cf::load_extensions;
3682 3717
3683 warn "reattaching attachments to objects/players"; 3718 warn "reattaching attachments to objects/players";
3684 _global_reattach; # objects, sockets 3719 _global_reattach; # objects, sockets
3685 warn "reattaching attachments to maps"; 3720 warn "reattaching attachments to maps";
3686 reattach $_ for values %MAP; 3721 reattach $_ for values %MAP;
3687 warn "reattaching attachments to players"; 3722 warn "reattaching attachments to players";
3688 reattach $_ for values %PLAYER; 3723 reattach $_ for values %PLAYER;
3689 3724
3690 warn "leaving sync_job"; 3725 warn "leaving sync_job";
3691 3726
3692 1 3727 1
3693 } or do { 3728 } or do {
3694 warn $@; 3729 warn $@;
3695 cf::cleanup "error while reloading, exiting."; 3730 cf::cleanup "error while reloading, exiting.";
3696 }; 3731 };
3697 3732
3698 warn "reloaded"; 3733 warn "reloaded";
3734 --$RELOAD;
3735 }
3699}; 3736};
3700 3737
3701our $RELOAD_WATCHER; # used only during reload 3738our $RELOAD_WATCHER; # used only during reload
3702 3739
3703sub reload_perl() { 3740sub reload_perl() {
… …
3785{ 3822{
3786 # configure BDB 3823 # configure BDB
3787 3824
3788 BDB::min_parallel 8; 3825 BDB::min_parallel 8;
3789 BDB::max_poll_reqs $TICK * 0.1; 3826 BDB::max_poll_reqs $TICK * 0.1;
3790 $Coro::BDB::WATCHER->priority (1); 3827 $AnyEvent::BDB::WATCHER->priority (1);
3791 3828
3792 unless ($DB_ENV) { 3829 unless ($DB_ENV) {
3793 $DB_ENV = BDB::db_env_create; 3830 $DB_ENV = BDB::db_env_create;
3794 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3831 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3795 | 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;
3796 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3834 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3797 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3835 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3798 3836
3799 cf::sync_job { 3837 cf::sync_job {
3800 eval { 3838 eval {
… …
3826{ 3864{
3827 # configure IO::AIO 3865 # configure IO::AIO
3828 3866
3829 IO::AIO::min_parallel 8; 3867 IO::AIO::min_parallel 8;
3830 IO::AIO::max_poll_time $TICK * 0.1; 3868 IO::AIO::max_poll_time $TICK * 0.1;
3831 $Coro::AIO::WATCHER->priority (1); 3869 undef $AnyEvent::AIO::WATCHER;
3832} 3870}
3833 3871
3834my $_log_backtrace; 3872my $_log_backtrace;
3835 3873
3836sub _log_backtrace { 3874sub _log_backtrace {

Diff Legend

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