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.432 by root, Mon May 5 22:38:47 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;
… …
2085 my $f = new_from_file cf::object::thawer $self->{load_path}; 2089 my $f = new_from_file cf::object::thawer $self->{load_path};
2086 $f->skip_block; 2090 $f->skip_block;
2087 $self->_load_objects ($f) 2091 $self->_load_objects ($f)
2088 or return; 2092 or return;
2089 2093
2090 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2094 $self->post_load_original
2091 if delete $self->{load_original}; 2095 if delete $self->{load_original};
2092 2096
2093 if (my $uniq = $self->uniq_path) { 2097 if (my $uniq = $self->uniq_path) {
2094 utf8::encode $uniq; 2098 utf8::encode $uniq;
2095 unless (aio_stat $uniq) { 2099 unless (aio_stat $uniq) {
… …
2612Moves 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
2613her, loading and preparing them map, calling the provided $check callback 2617her, loading and preparing them map, calling the provided $check callback
2614that 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
2615the 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
2616be 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 >>.
2617 2624
2618=cut 2625=cut
2619 2626
2620our $GOTOGEN; 2627our $GOTOGEN;
2621 2628
… …
3124=cut 3131=cut
3125 3132
3126for ( 3133for (
3127 ["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
3128 insert remove inv nrof name archname title slaying race 3135 insert remove inv nrof name archname title slaying race
3129 decrease split destroy)], 3136 decrease split destroy change_exp)],
3130 ["cf::object::player" => qw(player)], 3137 ["cf::object::player" => qw(player)],
3131 ["cf::player" => qw(peaceful)], 3138 ["cf::player" => qw(peaceful)],
3132 ["cf::map" => qw(trigger)], 3139 ["cf::map" => qw(trigger)],
3133) { 3140) {
3134 no strict 'refs'; 3141 no strict 'refs';
… …
3394 warn "finished reloading resource files\n"; 3401 warn "finished reloading resource files\n";
3395} 3402}
3396 3403
3397sub init { 3404sub init {
3398 my $guard = freeze_mainloop; 3405 my $guard = freeze_mainloop;
3406
3407 evthread_start IO::AIO::poll_fileno;
3399 3408
3400 reload_resources; 3409 reload_resources;
3401} 3410}
3402 3411
3403sub reload_config { 3412sub reload_config {
… …
3436 reload_config; 3445 reload_config;
3437 db_init; 3446 db_init;
3438 load_extensions; 3447 load_extensions;
3439 3448
3440 $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
3441 evthread_start IO::AIO::poll_fileno;
3442 } 3450 }
3443 3451
3444 EV::loop; 3452 EV::loop;
3445} 3453}
3446 3454
… …
3581 3589
3582 warn Carp::longmess "post_cleanup backtrace" 3590 warn Carp::longmess "post_cleanup backtrace"
3583 if $make_core; 3591 if $make_core;
3584} 3592}
3585 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
3586sub do_reload_perl() { 3622sub do_reload_perl() {
3587 # can/must only be called in main 3623 # can/must only be called in main
3588 if ($Coro::current != $Coro::main) { 3624 if ($Coro::current != $Coro::main) {
3589 warn "can only reload from main coroutine"; 3625 warn "can only reload from main coroutine";
3590 return; 3626 return;
3591 } 3627 }
3592 3628
3629 return if $RELOAD++;
3630
3631 while ($RELOAD) {
3593 warn "reloading..."; 3632 warn "reloading...";
3594 3633
3595 warn "entering sync_job"; 3634 warn "entering sync_job";
3596 3635
3597 cf::sync_job { 3636 cf::sync_job {
3598 cf::write_runtime_sync; # external watchdog should not bark 3637 cf::write_runtime_sync; # external watchdog should not bark
3599 cf::emergency_save; 3638 cf::emergency_save;
3600 cf::write_runtime_sync; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
3601 3640
3602 warn "syncing database to disk"; 3641 warn "syncing database to disk";
3603 BDB::db_env_txn_checkpoint $DB_ENV; 3642 BDB::db_env_txn_checkpoint $DB_ENV;
3604 3643
3605 # 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
3606 3645
3607 warn "flushing outstanding aio requests"; 3646 warn "flushing outstanding aio requests";
3608 for (;;) {
3609 BDB::flush;
3610 IO::AIO::flush;
3611 Coro::cede_notself;
3612 last unless IO::AIO::nreqs || BDB::nreqs; 3647 while (IO::AIO::nreqs || BDB::nreqs) {
3613 warn "iterate..."; 3648 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3614 }
3615
3616 ++$RELOAD;
3617
3618 warn "cancelling all extension coros";
3619 $_->cancel for values %EXT_CORO;
3620 %EXT_CORO = ();
3621
3622 warn "removing commands";
3623 %COMMAND = ();
3624
3625 warn "removing ext/exti commands";
3626 %EXTCMD = ();
3627 %EXTICMD = ();
3628
3629 warn "unloading/nuking all extensions";
3630 for my $pkg (@EXTS) {
3631 warn "... unloading $pkg";
3632
3633 if (my $cb = $pkg->can ("unload")) {
3634 eval {
3635 $cb->($pkg);
3636 1
3637 } or warn "$pkg unloaded, but with errors: $@";
3638 } 3649 }
3639 3650
3640 warn "... nuking $pkg"; 3651 warn "cancelling all extension coros";
3641 Symbol::delete_package $pkg; 3652 $_->cancel for values %EXT_CORO;
3642 } 3653 %EXT_CORO = ();
3643 3654
3644 warn "unloading all perl modules loaded from $LIBDIR"; 3655 warn "removing commands";
3645 while (my ($k, $v) = each %INC) { 3656 %COMMAND = ();
3646 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3647 3657
3658 warn "removing ext/exti commands";
3659 %EXTCMD = ();
3660 %EXTICMD = ();
3661
3662 warn "unloading/nuking all extensions";
3663 for my $pkg (@EXTS) {
3648 warn "... unloading $k"; 3664 warn "... unloading $pkg";
3649 delete $INC{$k};
3650 3665
3651 $k =~ s/\.pm$//;
3652 $k =~ s/\//::/g;
3653
3654 if (my $cb = $k->can ("unload_module")) { 3666 if (my $cb = $pkg->can ("unload")) {
3667 eval {
3655 $cb->(); 3668 $cb->($pkg);
3669 1
3670 } or warn "$pkg unloaded, but with errors: $@";
3671 }
3672
3673 warn "... clearing $pkg";
3674 clear_package $pkg;
3656 } 3675 }
3657 3676
3658 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;
3659 } 3692 }
3660 3693
3661 warn "getting rid of safe::, as good as possible"; 3694 warn "getting rid of safe::, as good as possible";
3662 Symbol::delete_package "safe::$_" 3695 clear_package "safe::$_"
3663 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);
3664 3697
3665 warn "unloading cf.pm \"a bit\""; 3698 warn "unloading cf.pm \"a bit\"";
3666 delete $INC{"cf.pm"}; 3699 delete $INC{"cf.pm"};
3667 delete $INC{"cf/pod.pm"}; 3700 delete $INC{"cf/pod.pm"};
3668 3701
3669 # don't, removes xs symbols, too, 3702 # don't, removes xs symbols, too,
3670 # and global variables created in xs 3703 # and global variables created in xs
3671 #Symbol::delete_package __PACKAGE__; 3704 #clear_package __PACKAGE__;
3672 3705
3673 warn "unload completed, starting to reload now"; 3706 warn "unload completed, starting to reload now";
3674 3707
3675 warn "reloading cf.pm"; 3708 warn "reloading cf.pm";
3676 require cf; 3709 require cf;
3677 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3710 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3678 3711
3679 warn "loading config and database again"; 3712 warn "loading config and database again";
3680 cf::reload_config; 3713 cf::reload_config;
3681 3714
3682 warn "loading extensions"; 3715 warn "loading extensions";
3683 cf::load_extensions; 3716 cf::load_extensions;
3684 3717
3685 warn "reattaching attachments to objects/players"; 3718 warn "reattaching attachments to objects/players";
3686 _global_reattach; # objects, sockets 3719 _global_reattach; # objects, sockets
3687 warn "reattaching attachments to maps"; 3720 warn "reattaching attachments to maps";
3688 reattach $_ for values %MAP; 3721 reattach $_ for values %MAP;
3689 warn "reattaching attachments to players"; 3722 warn "reattaching attachments to players";
3690 reattach $_ for values %PLAYER; 3723 reattach $_ for values %PLAYER;
3691 3724
3692 warn "leaving sync_job"; 3725 warn "leaving sync_job";
3693 3726
3694 1 3727 1
3695 } or do { 3728 } or do {
3696 warn $@; 3729 warn $@;
3697 cf::cleanup "error while reloading, exiting."; 3730 cf::cleanup "error while reloading, exiting.";
3698 }; 3731 };
3699 3732
3700 warn "reloaded"; 3733 warn "reloaded";
3734 --$RELOAD;
3735 }
3701}; 3736};
3702 3737
3703our $RELOAD_WATCHER; # used only during reload 3738our $RELOAD_WATCHER; # used only during reload
3704 3739
3705sub reload_perl() { 3740sub reload_perl() {
… …
3787{ 3822{
3788 # configure BDB 3823 # configure BDB
3789 3824
3790 BDB::min_parallel 8; 3825 BDB::min_parallel 8;
3791 BDB::max_poll_reqs $TICK * 0.1; 3826 BDB::max_poll_reqs $TICK * 0.1;
3792 $Coro::BDB::WATCHER->priority (1); 3827 $AnyEvent::BDB::WATCHER->priority (1);
3793 3828
3794 unless ($DB_ENV) { 3829 unless ($DB_ENV) {
3795 $DB_ENV = BDB::db_env_create; 3830 $DB_ENV = BDB::db_env_create;
3796 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3831 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3797 | 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;
3798 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3834 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3799 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3835 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3800 3836
3801 cf::sync_job { 3837 cf::sync_job {
3802 eval { 3838 eval {
… …
3828{ 3864{
3829 # configure IO::AIO 3865 # configure IO::AIO
3830 3866
3831 IO::AIO::min_parallel 8; 3867 IO::AIO::min_parallel 8;
3832 IO::AIO::max_poll_time $TICK * 0.1; 3868 IO::AIO::max_poll_time $TICK * 0.1;
3833 $Coro::AIO::WATCHER->priority (1); 3869 undef $AnyEvent::AIO::WATCHER;
3834} 3870}
3835 3871
3836my $_log_backtrace; 3872my $_log_backtrace;
3837 3873
3838sub _log_backtrace { 3874sub _log_backtrace {

Diff Legend

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