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.439 by root, Mon Jul 14 16:42:49 2008 UTC vs.
Revision 1.446 by root, Tue Sep 16 16:03:02 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;
… …
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
… …
2531 2448
2532=item $player_object->enter_link 2449=item $player_object->enter_link
2533 2450
2534Freezes the player and moves him/her to a special map (C<{link}>). 2451Freezes the player and moves him/her to a special map (C<{link}>).
2535 2452
2536The player should be reasonably safe there for short amounts of time. You 2453The player should be reasonably safe there for short amounts of time (e.g.
2537I<MUST> call C<leave_link> as soon as possible, though. 2454for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2455though, as the palyer cannot control the character while it is on the link
2456map.
2538 2457
2539Will never block. 2458Will never block.
2540 2459
2541=item $player_object->leave_link ($map, $x, $y) 2460=item $player_object->leave_link ($map, $x, $y)
2542 2461
… …
2600 2519
2601 $map->load; 2520 $map->load;
2602 $map->load_neighbours; 2521 $map->load_neighbours;
2603 2522
2604 return unless $self->contr->active; 2523 return unless $self->contr->active;
2524 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2605 $self->activate_recursive; 2525 $self->activate_recursive;
2606 2526
2607 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2527 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2608 $self->enter_map ($map, $x, $y); 2528 $self->enter_map ($map, $x, $y);
2609} 2529}
… …
2902 if ($self->can_msg) { 2822 if ($self->can_msg) {
2903 # default colour, mask it out 2823 # default colour, mask it out
2904 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2824 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2905 if $color & cf::NDI_DEF; 2825 if $color & cf::NDI_DEF;
2906 2826
2907 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2827 my $pkt = "msg "
2828 . $self->{json_coder}->encode (
2908 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2829 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2830 );
2831
2832 # try lzf for large packets
2833 $pkt = "lzf " . Compress::LZF::compress $pkt
2834 if 1024 <= length $pkt and $self->{can_lzf};
2835
2836 # split very large packets
2837 if (8192 < length $pkt and $self->{can_lzf}) {
2838 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2839 $pkt = "frag";
2840 }
2841
2842 $self->send_packet ($pkt);
2909 } else { 2843 } else {
2910 if ($color >= 0) { 2844 if ($color >= 0) {
2911 # replace some tags by gcfclient-compatible ones 2845 # replace some tags by gcfclient-compatible ones
2912 for ($msg) { 2846 for ($msg) {
2913 1 while 2847 1 while
… …
3425 }; 3359 };
3426 warn $@ if $@; 3360 warn $@ if $@;
3427 } 3361 }
3428} 3362}
3429 3363
3364sub pidfile() {
3365 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3366 or die "$PIDFILE: $!";
3367 flock $fh, &Fcntl::LOCK_EX
3368 or die "$PIDFILE: flock: $!";
3369 $fh
3370}
3371
3372# make sure only one server instance is running at any one time
3373sub atomic {
3374 my $fh = pidfile;
3375
3376 my $pid = <$fh>;
3377 kill 9, $pid if $pid > 0;
3378
3379 seek $fh, 0, 0;
3380 print $fh $$;
3381}
3382
3430sub main { 3383sub main {
3384 atomic;
3385
3431 # we must not ever block the main coroutine 3386 # we must not ever block the main coroutine
3432 local $Coro::idle = sub { 3387 local $Coro::idle = sub {
3433 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3388 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3434 (async { 3389 (async {
3435 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3390 $Coro::current->{desc} = "IDLE BUG HANDLER";
… …
3444 load_extensions; 3399 load_extensions;
3445 3400
3446 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3401 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3447 } 3402 }
3448 3403
3404 utime time, time, $RUNTIMEFILE;
3405
3406 # no (long-running) fork's whatsoever before this point(!)
3407 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3408
3449 EV::loop; 3409 EV::loop;
3450} 3410}
3451 3411
3452############################################################################# 3412#############################################################################
3453# initialisation and cleanup 3413# initialisation and cleanup
… …
3461 }; 3421 };
3462 } 3422 }
3463} 3423}
3464 3424
3465sub write_runtime_sync { 3425sub write_runtime_sync {
3466 my $runtime = "$LOCALDIR/runtime";
3467
3468 # first touch the runtime file to show we are still running: 3426 # first touch the runtime file to show we are still running:
3469 # the fsync below can take a very very long time. 3427 # the fsync below can take a very very long time.
3470 3428
3471 IO::AIO::aio_utime $runtime, undef, undef; 3429 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3472 3430
3473 my $guard = cf::lock_acquire "write_runtime"; 3431 my $guard = cf::lock_acquire "write_runtime";
3474 3432
3475 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3433 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3476 or return; 3434 or return;
3477 3435
3478 my $value = $cf::RUNTIME + 90 + 10; 3436 my $value = $cf::RUNTIME + 90 + 10;
3479 # 10 is the runtime save interval, for a monotonic clock 3437 # 10 is the runtime save interval, for a monotonic clock
3480 # 60 allows for the watchdog to kill the server. 3438 # 60 allows for the watchdog to kill the server.
… …
3490 aio_utime $fh, undef, undef; 3448 aio_utime $fh, undef, undef;
3491 3449
3492 close $fh 3450 close $fh
3493 or return; 3451 or return;
3494 3452
3495 aio_rename "$runtime~", $runtime 3453 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3496 and return; 3454 and return;
3497 3455
3498 warn "runtime file written.\n"; 3456 warn "runtime file written.\n";
3499 3457
3500 1 3458 1
… …
3584sub post_cleanup { 3542sub post_cleanup {
3585 my ($make_core) = @_; 3543 my ($make_core) = @_;
3586 3544
3587 warn Carp::longmess "post_cleanup backtrace" 3545 warn Carp::longmess "post_cleanup backtrace"
3588 if $make_core; 3546 if $make_core;
3547
3548 my $fh = pidfile;
3549 unlink $PIDFILE if <$fh> == $$;
3589} 3550}
3551
3552# a safer delete_package, copied from Symbol
3553sub clear_package($) {
3554 my $pkg = shift;
3555
3556 # expand to full symbol table name if needed
3557 unless ($pkg =~ /^main::.*::$/) {
3558 $pkg = "main$pkg" if $pkg =~ /^::/;
3559 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3560 $pkg .= '::' unless $pkg =~ /::$/;
3561 }
3562
3563 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3564 my $stem_symtab = *{$stem}{HASH};
3565
3566 defined $stem_symtab and exists $stem_symtab->{$leaf}
3567 or return;
3568
3569 # clear all symbols
3570 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3571 for my $name (keys %$leaf_symtab) {
3572 _gv_clear *{"$pkg$name"};
3573# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3574 }
3575 warn "cleared package #$pkg\n";#d#
3576}
3577
3578our $RELOAD; # how many times to reload
3590 3579
3591sub do_reload_perl() { 3580sub do_reload_perl() {
3592 # can/must only be called in main 3581 # can/must only be called in main
3593 if ($Coro::current != $Coro::main) { 3582 if ($Coro::current != $Coro::main) {
3594 warn "can only reload from main coroutine"; 3583 warn "can only reload from main coroutine";
3595 return; 3584 return;
3596 } 3585 }
3597 3586
3587 return if $RELOAD++;
3588
3589 while ($RELOAD) {
3598 warn "reloading..."; 3590 warn "reloading...";
3599 3591
3600 warn "entering sync_job"; 3592 warn "entering sync_job";
3601 3593
3602 cf::sync_job { 3594 cf::sync_job {
3603 cf::write_runtime_sync; # external watchdog should not bark 3595 cf::write_runtime_sync; # external watchdog should not bark
3604 cf::emergency_save; 3596 cf::emergency_save;
3605 cf::write_runtime_sync; # external watchdog should not bark 3597 cf::write_runtime_sync; # external watchdog should not bark
3606 3598
3607 warn "syncing database to disk"; 3599 warn "syncing database to disk";
3608 BDB::db_env_txn_checkpoint $DB_ENV; 3600 BDB::db_env_txn_checkpoint $DB_ENV;
3609 3601
3610 # if anything goes wrong in here, we should simply crash as we already saved 3602 # if anything goes wrong in here, we should simply crash as we already saved
3611 3603
3612 warn "flushing outstanding aio requests"; 3604 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; 3605 while (IO::AIO::nreqs || BDB::nreqs) {
3618 warn "iterate..."; 3606 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 } 3607 }
3644 3608
3645 warn "... nuking $pkg"; 3609 warn "cancelling all extension coros";
3646 Symbol::delete_package $pkg; 3610 $_->cancel for values %EXT_CORO;
3647 } 3611 %EXT_CORO = ();
3648 3612
3649 warn "unloading all perl modules loaded from $LIBDIR"; 3613 warn "removing commands";
3650 while (my ($k, $v) = each %INC) { 3614 %COMMAND = ();
3651 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3652 3615
3616 warn "removing ext/exti commands";
3617 %EXTCMD = ();
3618 %EXTICMD = ();
3619
3620 warn "unloading/nuking all extensions";
3621 for my $pkg (@EXTS) {
3653 warn "... unloading $k"; 3622 warn "... unloading $pkg";
3654 delete $INC{$k};
3655 3623
3656 $k =~ s/\.pm$//;
3657 $k =~ s/\//::/g;
3658
3659 if (my $cb = $k->can ("unload_module")) { 3624 if (my $cb = $pkg->can ("unload")) {
3625 eval {
3660 $cb->(); 3626 $cb->($pkg);
3627 1
3628 } or warn "$pkg unloaded, but with errors: $@";
3629 }
3630
3631 warn "... clearing $pkg";
3632 clear_package $pkg;
3661 } 3633 }
3662 3634
3663 Symbol::delete_package $k; 3635 warn "unloading all perl modules loaded from $LIBDIR";
3636 while (my ($k, $v) = each %INC) {
3637 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3638
3639 warn "... unloading $k";
3640 delete $INC{$k};
3641
3642 $k =~ s/\.pm$//;
3643 $k =~ s/\//::/g;
3644
3645 if (my $cb = $k->can ("unload_module")) {
3646 $cb->();
3647 }
3648
3649 clear_package $k;
3664 } 3650 }
3665 3651
3666 warn "getting rid of safe::, as good as possible"; 3652 warn "getting rid of safe::, as good as possible";
3667 Symbol::delete_package "safe::$_" 3653 clear_package "safe::$_"
3668 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3654 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3669 3655
3670 warn "unloading cf.pm \"a bit\""; 3656 warn "unloading cf.pm \"a bit\"";
3671 delete $INC{"cf.pm"}; 3657 delete $INC{"cf.pm"};
3672 delete $INC{"cf/pod.pm"}; 3658 delete $INC{"cf/pod.pm"};
3673 3659
3674 # don't, removes xs symbols, too, 3660 # don't, removes xs symbols, too,
3675 # and global variables created in xs 3661 # and global variables created in xs
3676 #Symbol::delete_package __PACKAGE__; 3662 #clear_package __PACKAGE__;
3677 3663
3678 warn "unload completed, starting to reload now"; 3664 warn "unload completed, starting to reload now";
3679 3665
3680 warn "reloading cf.pm"; 3666 warn "reloading cf.pm";
3681 require cf; 3667 require cf;
3682 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3668 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3683 3669
3684 warn "loading config and database again"; 3670 warn "loading config and database again";
3685 cf::reload_config; 3671 cf::reload_config;
3686 3672
3687 warn "loading extensions"; 3673 warn "loading extensions";
3688 cf::load_extensions; 3674 cf::load_extensions;
3689 3675
3690 warn "reattaching attachments to objects/players"; 3676 warn "reattaching attachments to objects/players";
3691 _global_reattach; # objects, sockets 3677 _global_reattach; # objects, sockets
3692 warn "reattaching attachments to maps"; 3678 warn "reattaching attachments to maps";
3693 reattach $_ for values %MAP; 3679 reattach $_ for values %MAP;
3694 warn "reattaching attachments to players"; 3680 warn "reattaching attachments to players";
3695 reattach $_ for values %PLAYER; 3681 reattach $_ for values %PLAYER;
3696 3682
3697 warn "leaving sync_job"; 3683 warn "leaving sync_job";
3698 3684
3699 1 3685 1
3700 } or do { 3686 } or do {
3701 warn $@; 3687 warn $@;
3702 cf::cleanup "error while reloading, exiting."; 3688 cf::cleanup "error while reloading, exiting.";
3703 }; 3689 };
3704 3690
3705 warn "reloaded"; 3691 warn "reloaded";
3692 --$RELOAD;
3693 }
3706}; 3694};
3707 3695
3708our $RELOAD_WATCHER; # used only during reload 3696our $RELOAD_WATCHER; # used only during reload
3709 3697
3710sub reload_perl() { 3698sub reload_perl() {
… …
3847 $msg =~ s/\n//; 3835 $msg =~ s/\n//;
3848 3836
3849 # limit the # of concurrent backtraces 3837 # limit the # of concurrent backtraces
3850 if ($_log_backtrace < 2) { 3838 if ($_log_backtrace < 2) {
3851 ++$_log_backtrace; 3839 ++$_log_backtrace;
3840 my $perl_bt = Carp::longmess $msg;
3852 async { 3841 async {
3853 $Coro::current->{desc} = "abt $msg"; 3842 $Coro::current->{desc} = "abt $msg";
3854 3843
3855 my @bt = fork_call { 3844 my @bt = fork_call {
3856 @addr = map { sprintf "%x", $_ } @addr; 3845 @addr = map { sprintf "%x", $_ } @addr;
… …
3867 } 3856 }
3868 3857
3869 @funcs 3858 @funcs
3870 }; 3859 };
3871 3860
3872 LOG llevInfo, "[ABT] $msg\n"; 3861 LOG llevInfo, "[ABT] $perl_bt\n";
3862 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3873 LOG llevInfo, "[ABT] $_\n" for @bt; 3863 LOG llevInfo, "[ABT] $_\n" for @bt;
3874 --$_log_backtrace; 3864 --$_log_backtrace;
3875 }; 3865 };
3876 } else { 3866 } else {
3877 LOG llevInfo, "[ABT] $msg\n"; 3867 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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