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

Diff Legend

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