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.436 by root, Sun Jun 15 20:32:51 2008 UTC vs.
Revision 1.445 by root, Wed Sep 10 18:18:10 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 ();
… …
79our %EXT_MAP = (); # pluggable maps 81our %EXT_MAP = (); # pluggable maps
80 82
81our $RELOAD; # number of reloads so far 83our $RELOAD; # number of reloads so far
82our @EVENT; 84our @EVENT;
83 85
84our $CONFDIR = confdir; 86our $CONFDIR = confdir;
85our $DATADIR = datadir; 87our $DATADIR = datadir;
86our $LIBDIR = "$DATADIR/ext"; 88our $LIBDIR = "$DATADIR/ext";
87our $PODDIR = "$DATADIR/pod"; 89our $PODDIR = "$DATADIR/pod";
88our $MAPDIR = "$DATADIR/" . mapdir; 90our $MAPDIR = "$DATADIR/" . mapdir;
89our $LOCALDIR = localdir; 91our $LOCALDIR = localdir;
90our $TMPDIR = "$LOCALDIR/" . tmpdir; 92our $TMPDIR = "$LOCALDIR/" . tmpdir;
91our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 93our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
92our $PLAYERDIR = "$LOCALDIR/" . playerdir; 94our $PLAYERDIR = "$LOCALDIR/" . playerdir;
93our $RANDOMDIR = "$LOCALDIR/random"; 95our $RANDOMDIR = "$LOCALDIR/random";
94our $BDBDIR = "$LOCALDIR/db"; 96our $BDBDIR = "$LOCALDIR/db";
97our $PIDFILE = "$LOCALDIR/pid";
98our $RUNTIMEFILE = "$LOCALDIR/runtime";
99
95our %RESOURCE; 100our %RESOURCE;
96 101
97our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 102our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
98our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 103our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
99our $NEXT_TICK; 104our $NEXT_TICK;
… …
124 129
125binmode STDOUT; 130binmode STDOUT;
126binmode STDERR; 131binmode STDERR;
127 132
128# read virtual server time, if available 133# read virtual server time, if available
129unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 134unless ($RUNTIME || !-e $RUNTIMEFILE) {
130 open my $fh, "<", "$LOCALDIR/runtime" 135 open my $fh, "<", $RUNTIMEFILE
131 or die "unable to read runtime file: $!"; 136 or die "unable to read $RUNTIMEFILE file: $!";
132 $RUNTIME = <$fh> + 0.; 137 $RUNTIME = <$fh> + 0.;
133} 138}
134 139
135mkdir $_ 140mkdir $_
136 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 141 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
… …
243for my $pkg (qw( 248for my $pkg (qw(
244 cf::global cf::attachable 249 cf::global cf::attachable
245 cf::object cf::object::player 250 cf::object cf::object::player
246 cf::client cf::player 251 cf::client cf::player
247 cf::arch cf::living 252 cf::arch cf::living
253 cf::map cf::mapspace
248 cf::map cf::party cf::region 254 cf::party cf::region
249)) { 255)) {
250 no strict 'refs';
251 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 256 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
252} 257}
253 258
254$EV::DIED = sub { 259$EV::DIED = sub {
255 warn "error in event callback: @_"; 260 warn "error in event callback: @_";
… …
1086 1091
1087sub reattach { 1092sub reattach {
1088 # basically do the same as instantiate, without calling instantiate 1093 # basically do the same as instantiate, without calling instantiate
1089 my ($obj) = @_; 1094 my ($obj) = @_;
1090 1095
1096 # no longer needed after getting rid of delete_package?
1091 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1097 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1092 1098
1093 my $registry = $obj->registry; 1099 my $registry = $obj->registry;
1094 1100
1095 @$registry = (); 1101 @$registry = ();
1096 1102
… …
1332 1338
1333 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1339 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1334 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1340 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1335 1341
1336 $ext{source} = 1342 $ext{source} =
1337 "package $pkg; use strict; use utf8;\n" 1343 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1338 . "#line 1 \"$path\"\n{\n" 1344 . "#line 1 \"$path\"\n{\n"
1339 . $source 1345 . $source
1340 . "\n};\n1"; 1346 . "\n};\n1";
1341 1347
1342 $todo{$base} = \%ext; 1348 $todo{$base} = \%ext;
… …
1520 my ($pl) = @_; 1526 my ($pl) = @_;
1521 1527
1522 my $name = $pl->ob->name; 1528 my $name = $pl->ob->name;
1523 1529
1524 $pl->{deny_save} = 1; 1530 $pl->{deny_save} = 1;
1525 $pl->password ("*"); # this should lock out the player until we nuked the dir 1531 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1526 1532
1527 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1533 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1528 $pl->deactivate; 1534 $pl->deactivate;
1529 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1535 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1530 $pl->ob->check_score; 1536 $pl->ob->check_score;
… …
1619} 1625}
1620 1626
1621=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1627=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1622 1628
1623Expand crossfire pod fragments into protocol xml. 1629Expand crossfire pod fragments into protocol xml.
1624
1625=cut
1626
1627use re 'eval';
1628
1629my $group;
1630my $interior; $interior = qr{
1631 # match a pod interior sequence sans C<< >>
1632 (?:
1633 \ (.*?)\ (?{ $group = $^N })
1634 | < (??{$interior}) >
1635 )
1636}x;
1637
1638sub expand_cfpod {
1639 my ($self, $pod) = @_;
1640
1641 my $xml;
1642
1643 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1645 $group = $1;
1646
1647 $group =~ s/&/&amp;/g;
1648 $group =~ s/</&lt;/g;
1649
1650 $xml .= $group;
1651 } elsif ($pod =~ m%\G
1652 ([BCGHITU])
1653 <
1654 (?:
1655 ([^<>]*) (?{ $group = $^N })
1656 | < $interior >
1657 )
1658 >
1659 %gcsx
1660 ) {
1661 my ($code, $data) = ($1, $group);
1662
1663 if ($code eq "B") {
1664 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1665 } elsif ($code eq "I") {
1666 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1667 } elsif ($code eq "U") {
1668 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1669 } elsif ($code eq "C") {
1670 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1671 } elsif ($code eq "T") {
1672 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1673 } elsif ($code eq "G") {
1674 my ($male, $female) = split /\|/, $data;
1675 $data = $self->gender ? $female : $male;
1676 $xml .= expand_cfpod ($self, $data);
1677 } elsif ($code eq "H") {
1678 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1680 "")
1681 [$self->{hintmode}];
1682 } else {
1683 $xml .= "error processing '$code($data)' directive";
1684 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 }
1689 last;
1690 }
1691 }
1692
1693 for ($xml) {
1694 # create single paragraphs (very hackish)
1695 s/(?<=\S)\n(?=\w)/ /g;
1696
1697 # compress some whitespace
1698 s/\s+\n/\n/g; # ws line-ends
1699 s/\n\n+/\n/g; # double lines
1700 s/^\n+//; # beginning lines
1701 s/\n+$//; # ending lines
1702 }
1703
1704 $xml
1705}
1706
1707no re 'eval';
1708
1709sub hintmode {
1710 $_[0]{hintmode} = $_[1] if @_ > 1;
1711 $_[0]{hintmode}
1712}
1713 1630
1714=item $player->ext_reply ($msgid, @msg) 1631=item $player->ext_reply ($msgid, @msg)
1715 1632
1716Sends an ext reply to the player. 1633Sends an ext reply to the player.
1717 1634
… …
2086 my $f = new_from_file cf::object::thawer $self->{load_path}; 2003 my $f = new_from_file cf::object::thawer $self->{load_path};
2087 $f->skip_block; 2004 $f->skip_block;
2088 $self->_load_objects ($f) 2005 $self->_load_objects ($f)
2089 or return; 2006 or return;
2090 2007
2091 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2008 $self->post_load_original
2092 if delete $self->{load_original}; 2009 if delete $self->{load_original};
2093 2010
2094 if (my $uniq = $self->uniq_path) { 2011 if (my $uniq = $self->uniq_path) {
2095 utf8::encode $uniq; 2012 utf8::encode $uniq;
2096 unless (aio_stat $uniq) { 2013 unless (aio_stat $uniq) {
… …
2902 if ($self->can_msg) { 2819 if ($self->can_msg) {
2903 # default colour, mask it out 2820 # default colour, mask it out
2904 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2821 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2905 if $color & cf::NDI_DEF; 2822 if $color & cf::NDI_DEF;
2906 2823
2907 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2824 my $pkt = "msg "
2825 . $self->{json_coder}->encode (
2908 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2826 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2827 );
2828
2829 # try lzf for large packets
2830 $pkt = "lzf " . Compress::LZF::compress $pkt
2831 if 1024 <= length $pkt and $self->{can_lzf};
2832
2833 # split very large packets
2834 if (8192 < length $pkt and $self->{can_lzf}) {
2835 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2836 $pkt = "frag";
2837 }
2838
2839 $self->send_packet ($pkt);
2909 } else { 2840 } else {
2910 if ($color >= 0) { 2841 if ($color >= 0) {
2911 # replace some tags by gcfclient-compatible ones 2842 # replace some tags by gcfclient-compatible ones
2912 for ($msg) { 2843 for ($msg) {
2913 1 while 2844 1 while
… …
3128=cut 3059=cut
3129 3060
3130for ( 3061for (
3131 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3062 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3132 insert remove inv nrof name archname title slaying race 3063 insert remove inv nrof name archname title slaying race
3133 decrease split destroy)], 3064 decrease split destroy change_exp)],
3134 ["cf::object::player" => qw(player)], 3065 ["cf::object::player" => qw(player)],
3135 ["cf::player" => qw(peaceful)], 3066 ["cf::player" => qw(peaceful)],
3136 ["cf::map" => qw(trigger)], 3067 ["cf::map" => qw(trigger)],
3137) { 3068) {
3138 no strict 'refs'; 3069 no strict 'refs';
… …
3425 }; 3356 };
3426 warn $@ if $@; 3357 warn $@ if $@;
3427 } 3358 }
3428} 3359}
3429 3360
3361sub pidfile() {
3362 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3363 or die "$PIDFILE: $!";
3364 flock $fh, &Fcntl::LOCK_EX
3365 or die "$PIDFILE: flock: $!";
3366 $fh
3367}
3368
3369# make sure only one server instance is running at any one time
3370sub atomic {
3371 my $fh = pidfile;
3372
3373 my $pid = <$fh>;
3374 kill 9, $pid if $pid > 0;
3375
3376 seek $fh, 0, 0;
3377 print $fh $$;
3378}
3379
3430sub main { 3380sub main {
3381 atomic;
3382
3431 # we must not ever block the main coroutine 3383 # we must not ever block the main coroutine
3432 local $Coro::idle = sub { 3384 local $Coro::idle = sub {
3433 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3385 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3434 (async { 3386 (async {
3435 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3387 $Coro::current->{desc} = "IDLE BUG HANDLER";
… …
3444 load_extensions; 3396 load_extensions;
3445 3397
3446 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3398 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3447 } 3399 }
3448 3400
3401 utime time, time, $RUNTIMEFILE;
3402
3403 # no (long-running) fork's whatsoever before this point(!)
3404 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3405
3449 EV::loop; 3406 EV::loop;
3450} 3407}
3451 3408
3452############################################################################# 3409#############################################################################
3453# initialisation and cleanup 3410# initialisation and cleanup
… …
3461 }; 3418 };
3462 } 3419 }
3463} 3420}
3464 3421
3465sub write_runtime_sync { 3422sub write_runtime_sync {
3466 my $runtime = "$LOCALDIR/runtime";
3467
3468 # first touch the runtime file to show we are still running: 3423 # first touch the runtime file to show we are still running:
3469 # the fsync below can take a very very long time. 3424 # the fsync below can take a very very long time.
3470 3425
3471 IO::AIO::aio_utime $runtime, undef, undef; 3426 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3472 3427
3473 my $guard = cf::lock_acquire "write_runtime"; 3428 my $guard = cf::lock_acquire "write_runtime";
3474 3429
3475 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3430 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3476 or return; 3431 or return;
3477 3432
3478 my $value = $cf::RUNTIME + 90 + 10; 3433 my $value = $cf::RUNTIME + 90 + 10;
3479 # 10 is the runtime save interval, for a monotonic clock 3434 # 10 is the runtime save interval, for a monotonic clock
3480 # 60 allows for the watchdog to kill the server. 3435 # 60 allows for the watchdog to kill the server.
… …
3490 aio_utime $fh, undef, undef; 3445 aio_utime $fh, undef, undef;
3491 3446
3492 close $fh 3447 close $fh
3493 or return; 3448 or return;
3494 3449
3495 aio_rename "$runtime~", $runtime 3450 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3496 and return; 3451 and return;
3497 3452
3498 warn "runtime file written.\n"; 3453 warn "runtime file written.\n";
3499 3454
3500 1 3455 1
… …
3584sub post_cleanup { 3539sub post_cleanup {
3585 my ($make_core) = @_; 3540 my ($make_core) = @_;
3586 3541
3587 warn Carp::longmess "post_cleanup backtrace" 3542 warn Carp::longmess "post_cleanup backtrace"
3588 if $make_core; 3543 if $make_core;
3544
3545 my $fh = pidfile;
3546 unlink $PIDFILE if <$fh> == $$;
3589} 3547}
3548
3549# a safer delete_package, copied from Symbol
3550sub clear_package($) {
3551 my $pkg = shift;
3552
3553 # expand to full symbol table name if needed
3554 unless ($pkg =~ /^main::.*::$/) {
3555 $pkg = "main$pkg" if $pkg =~ /^::/;
3556 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3557 $pkg .= '::' unless $pkg =~ /::$/;
3558 }
3559
3560 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3561 my $stem_symtab = *{$stem}{HASH};
3562
3563 defined $stem_symtab and exists $stem_symtab->{$leaf}
3564 or return;
3565
3566 # clear all symbols
3567 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3568 for my $name (keys %$leaf_symtab) {
3569 _gv_clear *{"$pkg$name"};
3570# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3571 }
3572 warn "cleared package #$pkg\n";#d#
3573}
3574
3575our $RELOAD; # how many times to reload
3590 3576
3591sub do_reload_perl() { 3577sub do_reload_perl() {
3592 # can/must only be called in main 3578 # can/must only be called in main
3593 if ($Coro::current != $Coro::main) { 3579 if ($Coro::current != $Coro::main) {
3594 warn "can only reload from main coroutine"; 3580 warn "can only reload from main coroutine";
3595 return; 3581 return;
3596 } 3582 }
3597 3583
3584 return if $RELOAD++;
3585
3586 while ($RELOAD) {
3598 warn "reloading..."; 3587 warn "reloading...";
3599 3588
3600 warn "entering sync_job"; 3589 warn "entering sync_job";
3601 3590
3602 cf::sync_job { 3591 cf::sync_job {
3603 cf::write_runtime_sync; # external watchdog should not bark 3592 cf::write_runtime_sync; # external watchdog should not bark
3604 cf::emergency_save; 3593 cf::emergency_save;
3605 cf::write_runtime_sync; # external watchdog should not bark 3594 cf::write_runtime_sync; # external watchdog should not bark
3606 3595
3607 warn "syncing database to disk"; 3596 warn "syncing database to disk";
3608 BDB::db_env_txn_checkpoint $DB_ENV; 3597 BDB::db_env_txn_checkpoint $DB_ENV;
3609 3598
3610 # if anything goes wrong in here, we should simply crash as we already saved 3599 # if anything goes wrong in here, we should simply crash as we already saved
3611 3600
3612 warn "flushing outstanding aio requests"; 3601 warn "flushing outstanding aio requests";
3613 for (;;) {
3614 BDB::flush;
3615 IO::AIO::flush;
3616 Coro::cede_notself;
3617 last unless IO::AIO::nreqs || BDB::nreqs; 3602 while (IO::AIO::nreqs || BDB::nreqs) {
3618 warn "iterate..."; 3603 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3619 }
3620
3621 ++$RELOAD;
3622
3623 warn "cancelling all extension coros";
3624 $_->cancel for values %EXT_CORO;
3625 %EXT_CORO = ();
3626
3627 warn "removing commands";
3628 %COMMAND = ();
3629
3630 warn "removing ext/exti commands";
3631 %EXTCMD = ();
3632 %EXTICMD = ();
3633
3634 warn "unloading/nuking all extensions";
3635 for my $pkg (@EXTS) {
3636 warn "... unloading $pkg";
3637
3638 if (my $cb = $pkg->can ("unload")) {
3639 eval {
3640 $cb->($pkg);
3641 1
3642 } or warn "$pkg unloaded, but with errors: $@";
3643 } 3604 }
3644 3605
3645 warn "... nuking $pkg"; 3606 warn "cancelling all extension coros";
3646 Symbol::delete_package $pkg; 3607 $_->cancel for values %EXT_CORO;
3647 } 3608 %EXT_CORO = ();
3648 3609
3649 warn "unloading all perl modules loaded from $LIBDIR"; 3610 warn "removing commands";
3650 while (my ($k, $v) = each %INC) { 3611 %COMMAND = ();
3651 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3652 3612
3613 warn "removing ext/exti commands";
3614 %EXTCMD = ();
3615 %EXTICMD = ();
3616
3617 warn "unloading/nuking all extensions";
3618 for my $pkg (@EXTS) {
3653 warn "... unloading $k"; 3619 warn "... unloading $pkg";
3654 delete $INC{$k};
3655 3620
3656 $k =~ s/\.pm$//;
3657 $k =~ s/\//::/g;
3658
3659 if (my $cb = $k->can ("unload_module")) { 3621 if (my $cb = $pkg->can ("unload")) {
3622 eval {
3660 $cb->(); 3623 $cb->($pkg);
3624 1
3625 } or warn "$pkg unloaded, but with errors: $@";
3626 }
3627
3628 warn "... clearing $pkg";
3629 clear_package $pkg;
3661 } 3630 }
3662 3631
3663 Symbol::delete_package $k; 3632 warn "unloading all perl modules loaded from $LIBDIR";
3633 while (my ($k, $v) = each %INC) {
3634 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3635
3636 warn "... unloading $k";
3637 delete $INC{$k};
3638
3639 $k =~ s/\.pm$//;
3640 $k =~ s/\//::/g;
3641
3642 if (my $cb = $k->can ("unload_module")) {
3643 $cb->();
3644 }
3645
3646 clear_package $k;
3664 } 3647 }
3665 3648
3666 warn "getting rid of safe::, as good as possible"; 3649 warn "getting rid of safe::, as good as possible";
3667 Symbol::delete_package "safe::$_" 3650 clear_package "safe::$_"
3668 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3651 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3669 3652
3670 warn "unloading cf.pm \"a bit\""; 3653 warn "unloading cf.pm \"a bit\"";
3671 delete $INC{"cf.pm"}; 3654 delete $INC{"cf.pm"};
3672 delete $INC{"cf/pod.pm"}; 3655 delete $INC{"cf/pod.pm"};
3673 3656
3674 # don't, removes xs symbols, too, 3657 # don't, removes xs symbols, too,
3675 # and global variables created in xs 3658 # and global variables created in xs
3676 #Symbol::delete_package __PACKAGE__; 3659 #clear_package __PACKAGE__;
3677 3660
3678 warn "unload completed, starting to reload now"; 3661 warn "unload completed, starting to reload now";
3679 3662
3680 warn "reloading cf.pm"; 3663 warn "reloading cf.pm";
3681 require cf; 3664 require cf;
3682 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3665 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3683 3666
3684 warn "loading config and database again"; 3667 warn "loading config and database again";
3685 cf::reload_config; 3668 cf::reload_config;
3686 3669
3687 warn "loading extensions"; 3670 warn "loading extensions";
3688 cf::load_extensions; 3671 cf::load_extensions;
3689 3672
3690 warn "reattaching attachments to objects/players"; 3673 warn "reattaching attachments to objects/players";
3691 _global_reattach; # objects, sockets 3674 _global_reattach; # objects, sockets
3692 warn "reattaching attachments to maps"; 3675 warn "reattaching attachments to maps";
3693 reattach $_ for values %MAP; 3676 reattach $_ for values %MAP;
3694 warn "reattaching attachments to players"; 3677 warn "reattaching attachments to players";
3695 reattach $_ for values %PLAYER; 3678 reattach $_ for values %PLAYER;
3696 3679
3697 warn "leaving sync_job"; 3680 warn "leaving sync_job";
3698 3681
3699 1 3682 1
3700 } or do { 3683 } or do {
3701 warn $@; 3684 warn $@;
3702 cf::cleanup "error while reloading, exiting."; 3685 cf::cleanup "error while reloading, exiting.";
3703 }; 3686 };
3704 3687
3705 warn "reloaded"; 3688 warn "reloaded";
3689 --$RELOAD;
3690 }
3706}; 3691};
3707 3692
3708our $RELOAD_WATCHER; # used only during reload 3693our $RELOAD_WATCHER; # used only during reload
3709 3694
3710sub reload_perl() { 3695sub reload_perl() {
… …
3796 BDB::max_poll_reqs $TICK * 0.1; 3781 BDB::max_poll_reqs $TICK * 0.1;
3797 $AnyEvent::BDB::WATCHER->priority (1); 3782 $AnyEvent::BDB::WATCHER->priority (1);
3798 3783
3799 unless ($DB_ENV) { 3784 unless ($DB_ENV) {
3800 $DB_ENV = BDB::db_env_create; 3785 $DB_ENV = BDB::db_env_create;
3801 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3786 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3802 | BDB::LOG_AUTOREMOVE, 1); 3787 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3788 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3803 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3789 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3804 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3790 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3805 3791
3806 cf::sync_job { 3792 cf::sync_job {
3807 eval { 3793 eval {

Diff Legend

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