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.534 by root, Thu Apr 29 08:13:51 2010 UTC vs.
Revision 1.540 by root, Tue May 4 23:32:29 2010 UTC

20# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
21# 21#
22 22
23package cf; 23package cf;
24 24
25use 5.10.0; 25use common::sense;
26use utf8;
27use strict qw(vars subs);
28 26
29use Symbol; 27use Symbol;
30use List::Util; 28use List::Util;
31use Socket; 29use Socket;
32use EV; 30use EV;
77 75
78# strictly for debugging 76# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; 77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
80 78
81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
82 82
83our %COMMAND = (); 83our %COMMAND = ();
84our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
85 85
86our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
1423 1423
1424 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1424 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1425 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1425 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1426 1426
1427 $ext{source} = 1427 $ext{source} =
1428 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1428 "package $pkg; use common::sense;\n"
1429 . "#line 1 \"$path\"\n{\n" 1429 . "#line 1 \"$path\"\n{\n"
1430 . $source 1430 . $source
1431 . "\n};\n1"; 1431 . "\n};\n1";
1432 1432
1433 $todo{$base} = \%ext; 1433 $todo{$base} = \%ext;
1451 1451
1452 my $active = eval $v->{source}; 1452 my $active = eval $v->{source};
1453 1453
1454 if (length $@) { 1454 if (length $@) {
1455 error "$v->{path}: $@\n"; 1455 error "$v->{path}: $@\n";
1456 undef $@; # work around perl 5.10.0 utf-8 caching bug
1456 1457
1457 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1458 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1458 if exists $v->{meta}{mandatory}; 1459 if exists $v->{meta}{mandatory};
1459 1460
1460 warn "$v->{base}: optional extension cannot be loaded, skipping.\n"; 1461 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1848 1849
1849sub register { 1850sub register {
1850 my (undef, $regex, $prio) = @_; 1851 my (undef, $regex, $prio) = @_;
1851 my $pkg = caller; 1852 my $pkg = caller;
1852 1853
1853 no strict;
1854 push @{"$pkg\::ISA"}, __PACKAGE__; 1854 push @{"$pkg\::ISA"}, __PACKAGE__;
1855 1855
1856 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1856 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1857} 1857}
1858 1858
3273 decrease split destroy change_exp value msg lore send_msg)], 3273 decrease split destroy change_exp value msg lore send_msg)],
3274 ["cf::object::player" => qw(player)], 3274 ["cf::object::player" => qw(player)],
3275 ["cf::player" => qw(peaceful send_msg)], 3275 ["cf::player" => qw(peaceful send_msg)],
3276 ["cf::map" => qw(trigger)], 3276 ["cf::map" => qw(trigger)],
3277) { 3277) {
3278 no strict 'refs';
3279 my ($pkg, @funs) = @$_; 3278 my ($pkg, @funs) = @$_;
3280 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3279 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3281 for @funs; 3280 for @funs;
3282} 3281}
3283 3282
3359=cut 3358=cut
3360 3359
3361############################################################################# 3360#############################################################################
3362# the server's init and main functions 3361# the server's init and main functions
3363 3362
3363# async inc loader. yay.
3364sub inc_loader {
3365 my $mod = $_[1];
3366
3367 if (in_main && !tick_inhibit) {
3368 Carp::cluck "ERROR: attempted synchronous perl module load ($mod)";
3369 } else {
3370 debug "loading perl module $mod\n";
3371 }
3372
3373 # 1. find real file
3374 for my $dir (@ORIG_INC) {
3375 warn "$dir/$mod\n";#d#
3376 ref $dir and next;
3377 0 <= Coro::AIO::aio_load "$dir/$mod", my $data
3378 or next;
3379
3380 $data = "#line 1 $dir/$mod\n$data";
3381
3382 open my $fh, "<", \$data or die;
3383
3384 return $fh;
3385 }
3386
3387 ()
3388}
3389
3390sub init_inc {
3391 # save original @INC
3392 @ORIG_INC = ($LIBDIR, @INC) unless @ORIG_INC;
3393
3394 # make sure we can do scalar-opens
3395 open my $dummy, "<", \my $dummy2;
3396
3397 # execute some stuff so perl load's some of the core modules
3398 /Ü/ =~ /ü/i;
3399 eval { &Storable::nstore_fd };
3400
3401 @INC = (\&inc_loader, @ORIG_INC); # @ORIG_INC is needed for DynaLoader, AutoLoad etc.
3402
3403 debug "module loading will be asynchronous from this point on.";
3404}
3405
3364sub load_facedata($) { 3406sub load_facedata($) {
3365 my ($path) = @_; 3407 my ($path) = @_;
3366 3408
3367 # HACK to clear player env face cache, we need some signal framework 3409 # HACK to clear player env face cache, we need some signal framework
3368 # for this (global event?) 3410 # for this (global event?)
3591 3633
3592sub main { 3634sub main {
3593 cf::init_globals; # initialise logging 3635 cf::init_globals; # initialise logging
3594 3636
3595 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3637 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3596 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3638 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3597 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3639 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3598 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3640 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3599 3641
3600 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3642 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3601 3643
3609 }; 3651 };
3610 3652
3611 evthread_start IO::AIO::poll_fileno; 3653 evthread_start IO::AIO::poll_fileno;
3612 3654
3613 cf::sync_job { 3655 cf::sync_job {
3656 init_inc;
3657
3614 cf::init_experience; 3658 cf::init_experience;
3615 cf::init_anim; 3659 cf::init_anim;
3616 cf::init_attackmess; 3660 cf::init_attackmess;
3617 cf::init_dynamic; 3661 cf::init_dynamic;
3618 3662
3643 }; 3687 };
3644 3688
3645 cf::object::thawer::errors_are_fatal 0; 3689 cf::object::thawer::errors_are_fatal 0;
3646 info "parse errors in files are no longer fatal from this point on.\n"; 3690 info "parse errors in files are no longer fatal from this point on.\n";
3647 3691
3692 my $free_main; $free_main = EV::idle sub {
3693 undef $free_main;
3694 undef &main; # free gobs of memory :)
3695 };
3696
3648 main_loop; 3697 goto &main_loop;
3649} 3698}
3650 3699
3651############################################################################# 3700#############################################################################
3652# initialisation and cleanup 3701# initialisation and cleanup
3653 3702
3758 # save all maps without fsync, and later call a global sync 3807 # save all maps without fsync, and later call a global sync
3759 # (which in turn might be very very slow) 3808 # (which in turn might be very very slow)
3760 local $USE_FSYNC = 0; 3809 local $USE_FSYNC = 0;
3761 3810
3762 cf::sync_job { 3811 cf::sync_job {
3812 cf::write_runtime_sync; # external watchdog should not bark
3813
3763 # use a peculiar iteration method to avoid tripping on perl 3814 # use a peculiar iteration method to avoid tripping on perl
3764 # refcount bugs in for. also avoids problems with players 3815 # refcount bugs in for. also avoids problems with players
3765 # and maps saved/destroyed asynchronously. 3816 # and maps saved/destroyed asynchronously.
3766 info "emergency_perl_save: begin player save\n"; 3817 info "emergency_perl_save: begin player save\n";
3767 for my $login (keys %cf::PLAYER) { 3818 for my $login (keys %cf::PLAYER) {
3770 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3821 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3771 $pl->save; 3822 $pl->save;
3772 } 3823 }
3773 info "emergency_perl_save: end player save\n"; 3824 info "emergency_perl_save: end player save\n";
3774 3825
3826 cf::write_runtime_sync; # external watchdog should not bark
3827
3775 info "emergency_perl_save: begin map save\n"; 3828 info "emergency_perl_save: begin map save\n";
3776 for my $path (keys %cf::MAP) { 3829 for my $path (keys %cf::MAP) {
3777 my $map = $cf::MAP{$path} or next; 3830 my $map = $cf::MAP{$path} or next;
3778 $map->valid or next; 3831 $map->valid or next;
3779 $map->save; 3832 $map->save;
3780 } 3833 }
3781 info "emergency_perl_save: end map save\n"; 3834 info "emergency_perl_save: end map save\n";
3782 3835
3836 cf::write_runtime_sync; # external watchdog should not bark
3837
3783 info "emergency_perl_save: begin database checkpoint\n"; 3838 info "emergency_perl_save: begin database checkpoint\n";
3784 BDB::db_env_txn_checkpoint $DB_ENV; 3839 BDB::db_env_txn_checkpoint $DB_ENV;
3785 info "emergency_perl_save: end database checkpoint\n"; 3840 info "emergency_perl_save: end database checkpoint\n";
3786 3841
3787 info "emergency_perl_save: begin write uuid\n"; 3842 info "emergency_perl_save: begin write uuid\n";
3788 write_uuid_sync 1; 3843 write_uuid_sync 1;
3789 info "emergency_perl_save: end write uuid\n"; 3844 info "emergency_perl_save: end write uuid\n";
3790 };
3791 3845
3846 cf::write_runtime_sync; # external watchdog should not bark
3847
3848 trace "emergency_perl_save: syncing database to disk";
3849 BDB::db_env_txn_checkpoint $DB_ENV;
3850
3792 info "emergency_perl_save: starting sync()\n"; 3851 info "emergency_perl_save: starting sync\n";
3793 IO::AIO::aio_sync sub { 3852 IO::AIO::aio_sync sub {
3794 info "emergency_perl_save: finished sync()\n"; 3853 info "emergency_perl_save: finished sync\n";
3854 };
3855
3856 cf::write_runtime_sync; # external watchdog should not bark
3857
3858 trace "emergency_perl_save: flushing outstanding aio requests";
3859 while (IO::AIO::nreqs || BDB::nreqs) {
3860 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3861 }
3862
3863 cf::write_runtime_sync; # external watchdog should not bark
3795 }; 3864 };
3796 3865
3797 info "emergency_perl_save: leave\n"; 3866 info "emergency_perl_save: leave\n";
3798} 3867}
3799 3868
3800sub post_cleanup { 3869sub post_cleanup {
3801 my ($make_core) = @_; 3870 my ($make_core) = @_;
3871
3872 IO::AIO::flush;
3802 3873
3803 error Carp::longmess "post_cleanup backtrace" 3874 error Carp::longmess "post_cleanup backtrace"
3804 if $make_core; 3875 if $make_core;
3805 3876
3806 my $fh = pidfile; 3877 my $fh = pidfile;
3847 info "reloading..."; 3918 info "reloading...";
3848 3919
3849 trace "entering sync_job"; 3920 trace "entering sync_job";
3850 3921
3851 cf::sync_job { 3922 cf::sync_job {
3852 cf::write_runtime_sync; # external watchdog should not bark
3853 cf::emergency_save; 3923 cf::emergency_save;
3854 cf::write_runtime_sync; # external watchdog should not bark
3855
3856 trace "syncing database to disk";
3857 BDB::db_env_txn_checkpoint $DB_ENV;
3858
3859 # if anything goes wrong in here, we should simply crash as we already saved
3860
3861 trace "flushing outstanding aio requests";
3862 while (IO::AIO::nreqs || BDB::nreqs) {
3863 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3864 }
3865 3924
3866 trace "cancelling all extension coros"; 3925 trace "cancelling all extension coros";
3867 $_->cancel for values %EXT_CORO; 3926 $_->cancel for values %EXT_CORO;
3868 %EXT_CORO = (); 3927 %EXT_CORO = ();
3869 3928
3984 reload_perl; 4043 reload_perl;
3985 }; 4044 };
3986 } 4045 }
3987}; 4046};
3988 4047
3989unshift @INC, $LIBDIR; 4048#############################################################################
3990 4049
3991my $bug_warning = 0; 4050my $bug_warning = 0;
3992 4051
3993our @WAIT_FOR_TICK; 4052our @WAIT_FOR_TICK;
3994our @WAIT_FOR_TICK_BEGIN; 4053our @WAIT_FOR_TICK_BEGIN;

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines