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.435 by root, Thu May 29 03:33:20 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) {
… …
2613Moves the player to the given map-path and coordinates by first freezing 2530Moves the player to the given map-path and coordinates by first freezing
2614her, loading and preparing them map, calling the provided $check callback 2531her, loading and preparing them map, calling the provided $check callback
2615that has to return the map if sucecssful, and then unfreezes the player on 2532that 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 2533the new (success) or old (failed) map position. In either case, $done will
2617be called at the end of this process. 2534be called at the end of this process.
2535
2536Note that $check will be called with a potentially non-loaded map, so if
2537it needs a loaded map it has to call C<< ->load >>.
2618 2538
2619=cut 2539=cut
2620 2540
2621our $GOTOGEN; 2541our $GOTOGEN;
2622 2542
… …
2899 if ($self->can_msg) { 2819 if ($self->can_msg) {
2900 # default colour, mask it out 2820 # default colour, mask it out
2901 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2821 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2902 if $color & cf::NDI_DEF; 2822 if $color & cf::NDI_DEF;
2903 2823
2904 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2824 my $pkt = "msg "
2825 . $self->{json_coder}->encode (
2905 [$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);
2906 } else { 2840 } else {
2907 if ($color >= 0) { 2841 if ($color >= 0) {
2908 # replace some tags by gcfclient-compatible ones 2842 # replace some tags by gcfclient-compatible ones
2909 for ($msg) { 2843 for ($msg) {
2910 1 while 2844 1 while
… …
3125=cut 3059=cut
3126 3060
3127for ( 3061for (
3128 ["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
3129 insert remove inv nrof name archname title slaying race 3063 insert remove inv nrof name archname title slaying race
3130 decrease split destroy)], 3064 decrease split destroy change_exp)],
3131 ["cf::object::player" => qw(player)], 3065 ["cf::object::player" => qw(player)],
3132 ["cf::player" => qw(peaceful)], 3066 ["cf::player" => qw(peaceful)],
3133 ["cf::map" => qw(trigger)], 3067 ["cf::map" => qw(trigger)],
3134) { 3068) {
3135 no strict 'refs'; 3069 no strict 'refs';
… …
3422 }; 3356 };
3423 warn $@ if $@; 3357 warn $@ if $@;
3424 } 3358 }
3425} 3359}
3426 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
3427sub main { 3380sub main {
3381 atomic;
3382
3428 # we must not ever block the main coroutine 3383 # we must not ever block the main coroutine
3429 local $Coro::idle = sub { 3384 local $Coro::idle = sub {
3430 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#
3431 (async { 3386 (async {
3432 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3387 $Coro::current->{desc} = "IDLE BUG HANDLER";
… …
3441 load_extensions; 3396 load_extensions;
3442 3397
3443 $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
3444 } 3399 }
3445 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
3446 EV::loop; 3406 EV::loop;
3447} 3407}
3448 3408
3449############################################################################# 3409#############################################################################
3450# initialisation and cleanup 3410# initialisation and cleanup
… …
3458 }; 3418 };
3459 } 3419 }
3460} 3420}
3461 3421
3462sub write_runtime_sync { 3422sub write_runtime_sync {
3463 my $runtime = "$LOCALDIR/runtime";
3464
3465 # first touch the runtime file to show we are still running: 3423 # first touch the runtime file to show we are still running:
3466 # the fsync below can take a very very long time. 3424 # the fsync below can take a very very long time.
3467 3425
3468 IO::AIO::aio_utime $runtime, undef, undef; 3426 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3469 3427
3470 my $guard = cf::lock_acquire "write_runtime"; 3428 my $guard = cf::lock_acquire "write_runtime";
3471 3429
3472 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3430 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3473 or return; 3431 or return;
3474 3432
3475 my $value = $cf::RUNTIME + 90 + 10; 3433 my $value = $cf::RUNTIME + 90 + 10;
3476 # 10 is the runtime save interval, for a monotonic clock 3434 # 10 is the runtime save interval, for a monotonic clock
3477 # 60 allows for the watchdog to kill the server. 3435 # 60 allows for the watchdog to kill the server.
… …
3487 aio_utime $fh, undef, undef; 3445 aio_utime $fh, undef, undef;
3488 3446
3489 close $fh 3447 close $fh
3490 or return; 3448 or return;
3491 3449
3492 aio_rename "$runtime~", $runtime 3450 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3493 and return; 3451 and return;
3494 3452
3495 warn "runtime file written.\n"; 3453 warn "runtime file written.\n";
3496 3454
3497 1 3455 1
… …
3581sub post_cleanup { 3539sub post_cleanup {
3582 my ($make_core) = @_; 3540 my ($make_core) = @_;
3583 3541
3584 warn Carp::longmess "post_cleanup backtrace" 3542 warn Carp::longmess "post_cleanup backtrace"
3585 if $make_core; 3543 if $make_core;
3544
3545 my $fh = pidfile;
3546 unlink $PIDFILE if <$fh> == $$;
3586} 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
3587 3576
3588sub do_reload_perl() { 3577sub do_reload_perl() {
3589 # can/must only be called in main 3578 # can/must only be called in main
3590 if ($Coro::current != $Coro::main) { 3579 if ($Coro::current != $Coro::main) {
3591 warn "can only reload from main coroutine"; 3580 warn "can only reload from main coroutine";
3592 return; 3581 return;
3593 } 3582 }
3594 3583
3584 return if $RELOAD++;
3585
3586 while ($RELOAD) {
3595 warn "reloading..."; 3587 warn "reloading...";
3596 3588
3597 warn "entering sync_job"; 3589 warn "entering sync_job";
3598 3590
3599 cf::sync_job { 3591 cf::sync_job {
3600 cf::write_runtime_sync; # external watchdog should not bark 3592 cf::write_runtime_sync; # external watchdog should not bark
3601 cf::emergency_save; 3593 cf::emergency_save;
3602 cf::write_runtime_sync; # external watchdog should not bark 3594 cf::write_runtime_sync; # external watchdog should not bark
3603 3595
3604 warn "syncing database to disk"; 3596 warn "syncing database to disk";
3605 BDB::db_env_txn_checkpoint $DB_ENV; 3597 BDB::db_env_txn_checkpoint $DB_ENV;
3606 3598
3607 # 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
3608 3600
3609 warn "flushing outstanding aio requests"; 3601 warn "flushing outstanding aio requests";
3610 for (;;) {
3611 BDB::flush;
3612 IO::AIO::flush;
3613 Coro::cede_notself;
3614 last unless IO::AIO::nreqs || BDB::nreqs; 3602 while (IO::AIO::nreqs || BDB::nreqs) {
3615 warn "iterate..."; 3603 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3616 }
3617
3618 ++$RELOAD;
3619
3620 warn "cancelling all extension coros";
3621 $_->cancel for values %EXT_CORO;
3622 %EXT_CORO = ();
3623
3624 warn "removing commands";
3625 %COMMAND = ();
3626
3627 warn "removing ext/exti commands";
3628 %EXTCMD = ();
3629 %EXTICMD = ();
3630
3631 warn "unloading/nuking all extensions";
3632 for my $pkg (@EXTS) {
3633 warn "... unloading $pkg";
3634
3635 if (my $cb = $pkg->can ("unload")) {
3636 eval {
3637 $cb->($pkg);
3638 1
3639 } or warn "$pkg unloaded, but with errors: $@";
3640 } 3604 }
3641 3605
3642 warn "... nuking $pkg"; 3606 warn "cancelling all extension coros";
3643 Symbol::delete_package $pkg; 3607 $_->cancel for values %EXT_CORO;
3644 } 3608 %EXT_CORO = ();
3645 3609
3646 warn "unloading all perl modules loaded from $LIBDIR"; 3610 warn "removing commands";
3647 while (my ($k, $v) = each %INC) { 3611 %COMMAND = ();
3648 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3649 3612
3613 warn "removing ext/exti commands";
3614 %EXTCMD = ();
3615 %EXTICMD = ();
3616
3617 warn "unloading/nuking all extensions";
3618 for my $pkg (@EXTS) {
3650 warn "... unloading $k"; 3619 warn "... unloading $pkg";
3651 delete $INC{$k};
3652 3620
3653 $k =~ s/\.pm$//;
3654 $k =~ s/\//::/g;
3655
3656 if (my $cb = $k->can ("unload_module")) { 3621 if (my $cb = $pkg->can ("unload")) {
3622 eval {
3657 $cb->(); 3623 $cb->($pkg);
3624 1
3625 } or warn "$pkg unloaded, but with errors: $@";
3626 }
3627
3628 warn "... clearing $pkg";
3629 clear_package $pkg;
3658 } 3630 }
3659 3631
3660 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;
3661 } 3647 }
3662 3648
3663 warn "getting rid of safe::, as good as possible"; 3649 warn "getting rid of safe::, as good as possible";
3664 Symbol::delete_package "safe::$_" 3650 clear_package "safe::$_"
3665 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);
3666 3652
3667 warn "unloading cf.pm \"a bit\""; 3653 warn "unloading cf.pm \"a bit\"";
3668 delete $INC{"cf.pm"}; 3654 delete $INC{"cf.pm"};
3669 delete $INC{"cf/pod.pm"}; 3655 delete $INC{"cf/pod.pm"};
3670 3656
3671 # don't, removes xs symbols, too, 3657 # don't, removes xs symbols, too,
3672 # and global variables created in xs 3658 # and global variables created in xs
3673 #Symbol::delete_package __PACKAGE__; 3659 #clear_package __PACKAGE__;
3674 3660
3675 warn "unload completed, starting to reload now"; 3661 warn "unload completed, starting to reload now";
3676 3662
3677 warn "reloading cf.pm"; 3663 warn "reloading cf.pm";
3678 require cf; 3664 require cf;
3679 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3665 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3680 3666
3681 warn "loading config and database again"; 3667 warn "loading config and database again";
3682 cf::reload_config; 3668 cf::reload_config;
3683 3669
3684 warn "loading extensions"; 3670 warn "loading extensions";
3685 cf::load_extensions; 3671 cf::load_extensions;
3686 3672
3687 warn "reattaching attachments to objects/players"; 3673 warn "reattaching attachments to objects/players";
3688 _global_reattach; # objects, sockets 3674 _global_reattach; # objects, sockets
3689 warn "reattaching attachments to maps"; 3675 warn "reattaching attachments to maps";
3690 reattach $_ for values %MAP; 3676 reattach $_ for values %MAP;
3691 warn "reattaching attachments to players"; 3677 warn "reattaching attachments to players";
3692 reattach $_ for values %PLAYER; 3678 reattach $_ for values %PLAYER;
3693 3679
3694 warn "leaving sync_job"; 3680 warn "leaving sync_job";
3695 3681
3696 1 3682 1
3697 } or do { 3683 } or do {
3698 warn $@; 3684 warn $@;
3699 cf::cleanup "error while reloading, exiting."; 3685 cf::cleanup "error while reloading, exiting.";
3700 }; 3686 };
3701 3687
3702 warn "reloaded"; 3688 warn "reloaded";
3689 --$RELOAD;
3690 }
3703}; 3691};
3704 3692
3705our $RELOAD_WATCHER; # used only during reload 3693our $RELOAD_WATCHER; # used only during reload
3706 3694
3707sub reload_perl() { 3695sub reload_perl() {
… …
3793 BDB::max_poll_reqs $TICK * 0.1; 3781 BDB::max_poll_reqs $TICK * 0.1;
3794 $AnyEvent::BDB::WATCHER->priority (1); 3782 $AnyEvent::BDB::WATCHER->priority (1);
3795 3783
3796 unless ($DB_ENV) { 3784 unless ($DB_ENV) {
3797 $DB_ENV = BDB::db_env_create; 3785 $DB_ENV = BDB::db_env_create;
3798 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3786 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3799 | 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;
3800 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3789 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3801 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3790 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3802 3791
3803 cf::sync_job { 3792 cf::sync_job {
3804 eval { 3793 eval {

Diff Legend

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