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.433 by root, Sat May 10 22:38:52 2008 UTC vs.
Revision 1.443 by root, Sun Aug 31 10:05:26 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;
… …
35 36
36use Coro (); 37use Coro ();
37use Coro::State; 38use Coro::State;
38use Coro::Handle; 39use Coro::Handle;
39use Coro::EV; 40use Coro::EV;
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 ();
… …
243for my $pkg (qw( 245for my $pkg (qw(
244 cf::global cf::attachable 246 cf::global cf::attachable
245 cf::object cf::object::player 247 cf::object cf::object::player
246 cf::client cf::player 248 cf::client cf::player
247 cf::arch cf::living 249 cf::arch cf::living
250 cf::map cf::mapspace
248 cf::map cf::party cf::region 251 cf::party cf::region
249)) { 252)) {
250 no strict 'refs';
251 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 253 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
252} 254}
253 255
254$EV::DIED = sub { 256$EV::DIED = sub {
255 warn "error in event callback: @_"; 257 warn "error in event callback: @_";
… …
1086 1088
1087sub reattach { 1089sub reattach {
1088 # basically do the same as instantiate, without calling instantiate 1090 # basically do the same as instantiate, without calling instantiate
1089 my ($obj) = @_; 1091 my ($obj) = @_;
1090 1092
1093 # no longer needed after getting rid of delete_package?
1091 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1094 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1092 1095
1093 my $registry = $obj->registry; 1096 my $registry = $obj->registry;
1094 1097
1095 @$registry = (); 1098 @$registry = ();
1096 1099
… …
1332 1335
1333 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1336 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1334 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1337 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1335 1338
1336 $ext{source} = 1339 $ext{source} =
1337 "package $pkg; use strict; use utf8;\n" 1340 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1338 . "#line 1 \"$path\"\n{\n" 1341 . "#line 1 \"$path\"\n{\n"
1339 . $source 1342 . $source
1340 . "\n};\n1"; 1343 . "\n};\n1";
1341 1344
1342 $todo{$base} = \%ext; 1345 $todo{$base} = \%ext;
… …
1520 my ($pl) = @_; 1523 my ($pl) = @_;
1521 1524
1522 my $name = $pl->ob->name; 1525 my $name = $pl->ob->name;
1523 1526
1524 $pl->{deny_save} = 1; 1527 $pl->{deny_save} = 1;
1525 $pl->password ("*"); # this should lock out the player until we nuked the dir 1528 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1526 1529
1527 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1530 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1528 $pl->deactivate; 1531 $pl->deactivate;
1529 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1532 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1530 $pl->ob->check_score; 1533 $pl->ob->check_score;
… …
1622 1625
1623Expand crossfire pod fragments into protocol xml. 1626Expand crossfire pod fragments into protocol xml.
1624 1627
1625=cut 1628=cut
1626 1629
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 { 1630sub expand_cfpod {
1639 my ($self, $pod) = @_; 1631 my ($self, $pod) = @_;
1640 1632
1633 my @nest = [qr<\G$>, undef, ""];
1641 my $xml; 1634 my $xml;
1642 1635
1636 for ($pod) {
1643 while () { 1637 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) { 1638 if (/\G( (?: [^BCEGHITUZ&>\n\ ]+ | [BCEGHITUZ](?!<) | \ (?!>) )+ )/xgcs) {
1645 $group = $1;
1646
1647 $group =~ s/&/&amp;/g;
1648 $group =~ s/</&lt;/g;
1649
1650 $xml .= $group; 1639 $xml .= $1;
1651 } elsif ($pod =~ m%\G 1640 } elsif (/\G\n(?=\S)/xgcs) {
1652 ([BCGHITU]) 1641 $xml .= " ";
1653 < 1642 } elsif (/\G\n/xgcs) {
1654 (?: 1643 $xml .= "\n";
1655 ([^<>]*) (?{ $group = $^N }) 1644 } elsif (/\G ([BCEGHITUZ]) (< (?: <+\ | (?!<) ) )/xgcs) {
1656 | < $interior > 1645 my ($code, $delim) = ($1, scalar reverse $2);
1657 ) 1646 $delim =~ y/</>/; # delim now contains the stop sequence
1658 > 1647 $delim = qr{\G\Q$delim};
1659 %gcsx
1660 ) {
1661 my ($code, $data) = ($1, $group);
1662 1648
1649 my $cb;
1650
1663 if ($code eq "B") { 1651 if ($code eq "B") {
1664 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>"; 1652 $cb = sub { "<b>$_[0]</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") { 1653 } elsif ($code eq "C") {
1670 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>"; 1654 $cb = sub { "<tt>$_[0]</tt>" };
1671 } elsif ($code eq "T") { 1655 } elsif ($code eq "E") {
1672 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>"; 1656 $cb = sub { warn "E<$_[0]>\n";"&$_[0];" };
1673 } elsif ($code eq "G") { 1657 } elsif ($code eq "G") {
1658 $cb = sub {
1674 my ($male, $female) = split /\|/, $data; 1659 my ($male, $female) = split /\|/, $_[0];
1675 $data = $self->gender ? $female : $male; 1660 $self->gender ? $female : $male
1676 $xml .= expand_cfpod ($self, $data); 1661 };
1677 } elsif ($code eq "H") { 1662 } elsif ($code eq "H") {
1678 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>", 1663 $cb = sub {
1664 (
1665 "<fg name=\"lightblue\">[$_[0] (Use hintmode to suppress hints)]</fg>",
1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1666 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1680 "") 1667 "",
1681 [$self->{hintmode}]; 1668 )[$self->{hintmode}];
1669 };
1670 } elsif ($code eq "I") {
1671 $cb = sub { "<i>$_[0]</i>" };
1672 } elsif ($code eq "T") {
1673 $cb = sub { "<big><b>$_[0]</b></big>" };
1674 } elsif ($code eq "U") {
1675 $cb = sub { "<u>$_[0]</u>" };
1676 } elsif ($code eq "Z") {
1677 $cb = sub { };
1678 } else {
1679 die "FATAL error in expand_cfpod";
1680 }
1681
1682 push @nest, [$delim, $cb, $xml];
1683 undef $xml;
1684
1685 } elsif ($_ =~ /$nest[-1][0]/gcs) {
1686 my $nest = pop @nest;
1687
1688 if ($nest->[1]) {
1689 $xml = $nest->[2] . $nest->[1]->($xml);
1690 } else {
1691 last;
1692 }
1693 } elsif (/\G</xgcs) {
1694 $xml .= "&lt;";
1695 } elsif (/\G&/xgcs) {
1696 $xml .= "&amp;";
1697 } elsif (/\G>/xgcs) {
1698 $xml .= ">";
1682 } else { 1699 } else {
1683 $xml .= "error processing '$code($data)' directive"; 1700 if ($pod =~ /\G(.+)/xgcs) {
1701 warn "parse error (at $1)($nest[-1][0]) while expanding cfpod:\n$pod";
1702 last;
1703 } else {
1704 warn "parse error (unclosed interior sequence at end of cfpod) while expanding cfpod:\n$pod";
1705 return "<b>Sorry, the server encountered an internal error when formatting this message, please report this.</b>";
1706 }
1684 } 1707 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 } 1708 }
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 } 1709 }
1703 1710
1704 $xml 1711 $xml
1705} 1712}
1706
1707no re 'eval';
1708 1713
1709sub hintmode { 1714sub hintmode {
1710 $_[0]{hintmode} = $_[1] if @_ > 1; 1715 $_[0]{hintmode} = $_[1] if @_ > 1;
1711 $_[0]{hintmode} 1716 $_[0]{hintmode}
1712} 1717}
… …
2086 my $f = new_from_file cf::object::thawer $self->{load_path}; 2091 my $f = new_from_file cf::object::thawer $self->{load_path};
2087 $f->skip_block; 2092 $f->skip_block;
2088 $self->_load_objects ($f) 2093 $self->_load_objects ($f)
2089 or return; 2094 or return;
2090 2095
2091 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2096 $self->post_load_original
2092 if delete $self->{load_original}; 2097 if delete $self->{load_original};
2093 2098
2094 if (my $uniq = $self->uniq_path) { 2099 if (my $uniq = $self->uniq_path) {
2095 utf8::encode $uniq; 2100 utf8::encode $uniq;
2096 unless (aio_stat $uniq) { 2101 unless (aio_stat $uniq) {
… …
2613Moves the player to the given map-path and coordinates by first freezing 2618Moves the player to the given map-path and coordinates by first freezing
2614her, loading and preparing them map, calling the provided $check callback 2619her, loading and preparing them map, calling the provided $check callback
2615that has to return the map if sucecssful, and then unfreezes the player on 2620that 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 2621the new (success) or old (failed) map position. In either case, $done will
2617be called at the end of this process. 2622be called at the end of this process.
2623
2624Note that $check will be called with a potentially non-loaded map, so if
2625it needs a loaded map it has to call C<< ->load >>.
2618 2626
2619=cut 2627=cut
2620 2628
2621our $GOTOGEN; 2629our $GOTOGEN;
2622 2630
… …
2899 if ($self->can_msg) { 2907 if ($self->can_msg) {
2900 # default colour, mask it out 2908 # default colour, mask it out
2901 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2909 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2902 if $color & cf::NDI_DEF; 2910 if $color & cf::NDI_DEF;
2903 2911
2904 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2912 my $pkt = "msg "
2913 . $self->{json_coder}->encode (
2905 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2914 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2915 );
2916
2917 # try lzf for large packets
2918 $pkt = "lzf " . Compress::LZF::compress $pkt
2919 if 1024 <= length $pkt and $self->{can_lzf};
2920
2921 # split very large packets
2922 if (8192 < length $pkt and $self->{can_lzf}) {
2923 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2924 $pkt = "frag";
2925 }
2926
2927 $self->send_packet ($pkt);
2906 } else { 2928 } else {
2907 if ($color >= 0) { 2929 if ($color >= 0) {
2908 # replace some tags by gcfclient-compatible ones 2930 # replace some tags by gcfclient-compatible ones
2909 for ($msg) { 2931 for ($msg) {
2910 1 while 2932 1 while
… …
3125=cut 3147=cut
3126 3148
3127for ( 3149for (
3128 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3150 ["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 3151 insert remove inv nrof name archname title slaying race
3130 decrease split destroy)], 3152 decrease split destroy change_exp)],
3131 ["cf::object::player" => qw(player)], 3153 ["cf::object::player" => qw(player)],
3132 ["cf::player" => qw(peaceful)], 3154 ["cf::player" => qw(peaceful)],
3133 ["cf::map" => qw(trigger)], 3155 ["cf::map" => qw(trigger)],
3134) { 3156) {
3135 no strict 'refs'; 3157 no strict 'refs';
… …
3395 warn "finished reloading resource files\n"; 3417 warn "finished reloading resource files\n";
3396} 3418}
3397 3419
3398sub init { 3420sub init {
3399 my $guard = freeze_mainloop; 3421 my $guard = freeze_mainloop;
3422
3423 evthread_start IO::AIO::poll_fileno;
3400 3424
3401 reload_resources; 3425 reload_resources;
3402} 3426}
3403 3427
3404sub reload_config { 3428sub reload_config {
… …
3437 reload_config; 3461 reload_config;
3438 db_init; 3462 db_init;
3439 load_extensions; 3463 load_extensions;
3440 3464
3441 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3465 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3442 evthread_start IO::AIO::poll_fileno;
3443 } 3466 }
3444 3467
3445 EV::loop; 3468 EV::loop;
3446} 3469}
3447 3470
… …
3582 3605
3583 warn Carp::longmess "post_cleanup backtrace" 3606 warn Carp::longmess "post_cleanup backtrace"
3584 if $make_core; 3607 if $make_core;
3585} 3608}
3586 3609
3610# a safer delete_package, copied from Symbol
3611sub clear_package($) {
3612 my $pkg = shift;
3613
3614 # expand to full symbol table name if needed
3615 unless ($pkg =~ /^main::.*::$/) {
3616 $pkg = "main$pkg" if $pkg =~ /^::/;
3617 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3618 $pkg .= '::' unless $pkg =~ /::$/;
3619 }
3620
3621 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3622 my $stem_symtab = *{$stem}{HASH};
3623
3624 defined $stem_symtab and exists $stem_symtab->{$leaf}
3625 or return;
3626
3627 # clear all symbols
3628 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3629 for my $name (keys %$leaf_symtab) {
3630 _gv_clear *{"$pkg$name"};
3631# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3632 }
3633 warn "cleared package #$pkg\n";#d#
3634}
3635
3636our $RELOAD; # how many times to reload
3637
3587sub do_reload_perl() { 3638sub do_reload_perl() {
3588 # can/must only be called in main 3639 # can/must only be called in main
3589 if ($Coro::current != $Coro::main) { 3640 if ($Coro::current != $Coro::main) {
3590 warn "can only reload from main coroutine"; 3641 warn "can only reload from main coroutine";
3591 return; 3642 return;
3592 } 3643 }
3593 3644
3645 return if $RELOAD++;
3646
3647 while ($RELOAD) {
3594 warn "reloading..."; 3648 warn "reloading...";
3595 3649
3596 warn "entering sync_job"; 3650 warn "entering sync_job";
3597 3651
3598 cf::sync_job { 3652 cf::sync_job {
3599 cf::write_runtime_sync; # external watchdog should not bark 3653 cf::write_runtime_sync; # external watchdog should not bark
3600 cf::emergency_save; 3654 cf::emergency_save;
3601 cf::write_runtime_sync; # external watchdog should not bark 3655 cf::write_runtime_sync; # external watchdog should not bark
3602 3656
3603 warn "syncing database to disk"; 3657 warn "syncing database to disk";
3604 BDB::db_env_txn_checkpoint $DB_ENV; 3658 BDB::db_env_txn_checkpoint $DB_ENV;
3605 3659
3606 # if anything goes wrong in here, we should simply crash as we already saved 3660 # if anything goes wrong in here, we should simply crash as we already saved
3607 3661
3608 warn "flushing outstanding aio requests"; 3662 warn "flushing outstanding aio requests";
3609 for (;;) {
3610 BDB::flush;
3611 IO::AIO::flush;
3612 Coro::cede_notself;
3613 last unless IO::AIO::nreqs || BDB::nreqs; 3663 while (IO::AIO::nreqs || BDB::nreqs) {
3614 warn "iterate..."; 3664 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3615 }
3616
3617 ++$RELOAD;
3618
3619 warn "cancelling all extension coros";
3620 $_->cancel for values %EXT_CORO;
3621 %EXT_CORO = ();
3622
3623 warn "removing commands";
3624 %COMMAND = ();
3625
3626 warn "removing ext/exti commands";
3627 %EXTCMD = ();
3628 %EXTICMD = ();
3629
3630 warn "unloading/nuking all extensions";
3631 for my $pkg (@EXTS) {
3632 warn "... unloading $pkg";
3633
3634 if (my $cb = $pkg->can ("unload")) {
3635 eval {
3636 $cb->($pkg);
3637 1
3638 } or warn "$pkg unloaded, but with errors: $@";
3639 } 3665 }
3640 3666
3641 warn "... nuking $pkg"; 3667 warn "cancelling all extension coros";
3642 Symbol::delete_package $pkg; 3668 $_->cancel for values %EXT_CORO;
3643 } 3669 %EXT_CORO = ();
3644 3670
3645 warn "unloading all perl modules loaded from $LIBDIR"; 3671 warn "removing commands";
3646 while (my ($k, $v) = each %INC) { 3672 %COMMAND = ();
3647 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3648 3673
3674 warn "removing ext/exti commands";
3675 %EXTCMD = ();
3676 %EXTICMD = ();
3677
3678 warn "unloading/nuking all extensions";
3679 for my $pkg (@EXTS) {
3649 warn "... unloading $k"; 3680 warn "... unloading $pkg";
3650 delete $INC{$k};
3651 3681
3652 $k =~ s/\.pm$//;
3653 $k =~ s/\//::/g;
3654
3655 if (my $cb = $k->can ("unload_module")) { 3682 if (my $cb = $pkg->can ("unload")) {
3683 eval {
3656 $cb->(); 3684 $cb->($pkg);
3685 1
3686 } or warn "$pkg unloaded, but with errors: $@";
3687 }
3688
3689 warn "... clearing $pkg";
3690 clear_package $pkg;
3657 } 3691 }
3658 3692
3659 Symbol::delete_package $k; 3693 warn "unloading all perl modules loaded from $LIBDIR";
3694 while (my ($k, $v) = each %INC) {
3695 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3696
3697 warn "... unloading $k";
3698 delete $INC{$k};
3699
3700 $k =~ s/\.pm$//;
3701 $k =~ s/\//::/g;
3702
3703 if (my $cb = $k->can ("unload_module")) {
3704 $cb->();
3705 }
3706
3707 clear_package $k;
3660 } 3708 }
3661 3709
3662 warn "getting rid of safe::, as good as possible"; 3710 warn "getting rid of safe::, as good as possible";
3663 Symbol::delete_package "safe::$_" 3711 clear_package "safe::$_"
3664 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3712 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3665 3713
3666 warn "unloading cf.pm \"a bit\""; 3714 warn "unloading cf.pm \"a bit\"";
3667 delete $INC{"cf.pm"}; 3715 delete $INC{"cf.pm"};
3668 delete $INC{"cf/pod.pm"}; 3716 delete $INC{"cf/pod.pm"};
3669 3717
3670 # don't, removes xs symbols, too, 3718 # don't, removes xs symbols, too,
3671 # and global variables created in xs 3719 # and global variables created in xs
3672 #Symbol::delete_package __PACKAGE__; 3720 #clear_package __PACKAGE__;
3673 3721
3674 warn "unload completed, starting to reload now"; 3722 warn "unload completed, starting to reload now";
3675 3723
3676 warn "reloading cf.pm"; 3724 warn "reloading cf.pm";
3677 require cf; 3725 require cf;
3678 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3726 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3679 3727
3680 warn "loading config and database again"; 3728 warn "loading config and database again";
3681 cf::reload_config; 3729 cf::reload_config;
3682 3730
3683 warn "loading extensions"; 3731 warn "loading extensions";
3684 cf::load_extensions; 3732 cf::load_extensions;
3685 3733
3686 warn "reattaching attachments to objects/players"; 3734 warn "reattaching attachments to objects/players";
3687 _global_reattach; # objects, sockets 3735 _global_reattach; # objects, sockets
3688 warn "reattaching attachments to maps"; 3736 warn "reattaching attachments to maps";
3689 reattach $_ for values %MAP; 3737 reattach $_ for values %MAP;
3690 warn "reattaching attachments to players"; 3738 warn "reattaching attachments to players";
3691 reattach $_ for values %PLAYER; 3739 reattach $_ for values %PLAYER;
3692 3740
3693 warn "leaving sync_job"; 3741 warn "leaving sync_job";
3694 3742
3695 1 3743 1
3696 } or do { 3744 } or do {
3697 warn $@; 3745 warn $@;
3698 cf::cleanup "error while reloading, exiting."; 3746 cf::cleanup "error while reloading, exiting.";
3699 }; 3747 };
3700 3748
3701 warn "reloaded"; 3749 warn "reloaded";
3750 --$RELOAD;
3751 }
3702}; 3752};
3703 3753
3704our $RELOAD_WATCHER; # used only during reload 3754our $RELOAD_WATCHER; # used only during reload
3705 3755
3706sub reload_perl() { 3756sub reload_perl() {
… …
3792 BDB::max_poll_reqs $TICK * 0.1; 3842 BDB::max_poll_reqs $TICK * 0.1;
3793 $AnyEvent::BDB::WATCHER->priority (1); 3843 $AnyEvent::BDB::WATCHER->priority (1);
3794 3844
3795 unless ($DB_ENV) { 3845 unless ($DB_ENV) {
3796 $DB_ENV = BDB::db_env_create; 3846 $DB_ENV = BDB::db_env_create;
3797 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3847 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3798 | BDB::LOG_AUTOREMOVE, 1); 3848 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3849 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3799 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3850 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3800 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3851 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3801 3852
3802 cf::sync_job { 3853 cf::sync_job {
3803 eval { 3854 eval {
… …
3829{ 3880{
3830 # configure IO::AIO 3881 # configure IO::AIO
3831 3882
3832 IO::AIO::min_parallel 8; 3883 IO::AIO::min_parallel 8;
3833 IO::AIO::max_poll_time $TICK * 0.1; 3884 IO::AIO::max_poll_time $TICK * 0.1;
3834 $AnyEvent::AIO::WATCHER->priority (1); 3885 undef $AnyEvent::AIO::WATCHER;
3835} 3886}
3836 3887
3837my $_log_backtrace; 3888my $_log_backtrace;
3838 3889
3839sub _log_backtrace { 3890sub _log_backtrace {

Diff Legend

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