--- deliantra/server/lib/cf.pm 2009/07/21 06:17:00 1.475
+++ deliantra/server/lib/cf.pm 2010/05/04 22:49:21 1.539
@@ -1,29 +1,28 @@
-#
+#
# This file is part of Deliantra, the Roguelike Realtime MMORPG.
#
-# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
+# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
#
-# Deliantra is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
+# Deliantra is free software: you can redistribute it and/or modify it under
+# the terms of the Affero GNU General Public License as published by the
+# Free Software Foundation, either version 3 of the License, or (at your
+# option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see .
+# You should have received a copy of the Affero GNU General Public License
+# and the GNU General Public License along with this program. If not, see
+# .
#
# The authors can be reached via e-mail to
-#
+#
package cf;
-use 5.10.0;
-use utf8;
-use strict qw(vars subs);
+use common::sense;
use Symbol;
use List::Util;
@@ -33,6 +32,7 @@
use Safe;
use Safe::Hole;
use Storable ();
+use Carp ();
use Guard ();
use Coro ();
@@ -53,9 +53,8 @@
use JSON::XS 2.01 ();
use BDB ();
use Data::Dumper;
-use Digest::MD5;
use Fcntl;
-use YAML ();
+use YAML::XS ();
use IO::AIO ();
use Time::HiRes;
use Compress::LZF;
@@ -90,6 +89,8 @@
our $RELOAD; # number of reloads so far, non-zero while in reload
our @EVENT;
+our @REFLECT; # set by XS
+our %REFLECT; # set by us
our $CONFDIR = confdir;
our $DATADIR = datadir;
@@ -105,7 +106,13 @@
our $PIDFILE = "$LOCALDIR/pid";
our $RUNTIMEFILE = "$LOCALDIR/runtime";
-our %RESOURCE;
+our %RESOURCE; # unused
+
+our $OUTPUT_RATE_MIN = 3000;
+our $OUTPUT_RATE_MAX = 1000000;
+
+our $MAX_LINKS = 32; # how many chained exits to follow
+our $VERBOSE_IO = 1;
our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
@@ -117,7 +124,7 @@
our $BDB_TRICKLE_WATCHER;
our $DB_ENV;
-our @EXTRA_MODULES = qw(pod mapscript);
+our @EXTRA_MODULES = qw(pod match mapscript);
our %CFG;
@@ -161,6 +168,21 @@
sub cf::map::normalise;
+sub in_main() {
+ $Coro::current == $Coro::main
+}
+
+#############################################################################
+
+%REFLECT = ();
+for (@REFLECT) {
+ my $reflect = JSON::XS::decode_json $_;
+ $REFLECT{$reflect->{class}} = $reflect;
+}
+
+# this is decidedly evil
+$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
+
#############################################################################
=head2 GLOBAL VARIABLES
@@ -216,42 +238,51 @@
=item @cf::INVOKE_RESULTS
-This array contains the results of the last C call. When
+This array contains the results of the last C call. When
C is called C<@cf::INVOKE_RESULTS> is set to the parameters of
that call.
+=item %cf::REFLECT
+
+Contains, for each (C++) class name, a hash reference with information
+about object members (methods, scalars, arrays and flags) and other
+metadata, which is useful for introspection.
+
=back
=cut
-BEGIN {
- *CORE::GLOBAL::warn = sub {
- my $msg = join "", @_;
+sub error(@) { LOG llevError, join "", @_ }
+sub warn (@) { LOG llevWarn , join "", @_ }
+sub info (@) { LOG llevInfo , join "", @_ }
+sub debug(@) { LOG llevDebug, join "", @_ }
+sub trace(@) { LOG llevTrace, join "", @_ }
- $msg .= "\n"
- unless $msg =~ /\n$/;
+$Coro::State::WARNHOOK = sub {
+ my $msg = join "", @_;
- $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
+ $msg .= "\n"
+ unless $msg =~ /\n$/;
- LOG llevError, $msg;
- };
-}
+ $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
+
+ LOG llevWarn, $msg;
+};
$Coro::State::DIEHOOK = sub {
return unless $^S eq 0; # "eq", not "=="
- if ($Coro::current == $Coro::main) {#d#
- warn "DIEHOOK called in main context, Coro bug?\n";#d#
+ error Carp::longmess $_[0];
+
+ if (in_main) {#d#
+ error "DIEHOOK called in main context, Coro bug?\n";#d#
return;#d#
}#d#
# kill coroutine otherwise
- warn Carp::longmess $_[0];
Coro::terminate
};
-$SIG{__DIE__} = sub { }; #d#?
-
@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
@@ -274,7 +305,7 @@
}
$EV::DIED = sub {
- warn "error in event callback: @_";
+ Carp::cluck "error in event callback: @_";
};
#############################################################################
@@ -381,7 +412,7 @@
=item cf::periodic $interval, $cb
Like EV::periodic, but randomly selects a starting point so that the actions
-get spread over timer.
+get spread over time.
=cut
@@ -408,24 +439,29 @@
our @SLOT_QUEUE;
our $SLOT_QUEUE;
+our $SLOT_DECAY = 0.9;
$SLOT_QUEUE->cancel if $SLOT_QUEUE;
$SLOT_QUEUE = Coro::async {
$Coro::current->desc ("timeslot manager");
my $signal = new Coro::Signal;
+ my $busy;
while () {
next_job:
+
my $avail = cf::till_tick;
- if ($avail > 0.01) {
- for (0 .. $#SLOT_QUEUE) {
- if ($SLOT_QUEUE[$_][0] < $avail) {
- my $job = splice @SLOT_QUEUE, $_, 1, ();
- $job->[2]->send;
- Coro::cede;
- goto next_job;
- }
+
+ for (0 .. $#SLOT_QUEUE) {
+ if ($SLOT_QUEUE[$_][0] <= $avail) {
+ $busy = 0;
+ my $job = splice @SLOT_QUEUE, $_, 1, ();
+ $job->[2]->send;
+ Coro::cede;
+ goto next_job;
+ } else {
+ $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
}
}
@@ -434,6 +470,7 @@
push @cf::WAIT_FOR_TICK, $signal;
$signal->wait;
} else {
+ $busy = 0;
Coro::schedule;
}
}
@@ -444,7 +481,8 @@
my ($time, $pri, $name) = @_;
- $time = $TICK * .6 if $time > $TICK * .6;
+ $time = clamp $time, 0.01, $TICK * .6;
+
my $sig = new Coro::Signal;
push @SLOT_QUEUE, [$time, $pri, $sig, $name];
@@ -480,13 +518,13 @@
sub sync_job(&) {
my ($job) = @_;
- if ($Coro::current == $Coro::main) {
- my $time = EV::time;
+ if (in_main) {
+ my $time = AE::time;
# this is the main coro, too bad, we have to block
# till the operation succeeds, freezing the server :/
- LOG llevError, Carp::longmess "sync job";#d#
+ #LOG llevError, Carp::longmess "sync job";#d#
my $freeze_guard = freeze_mainloop;
@@ -496,7 +534,7 @@
(async {
$Coro::current->desc ("sync job coro");
@res = eval { $job->() };
- warn $@ if $@;
+ error $@ if $@;
undef $busy;
})->prio (Coro::PRIO_MAX);
@@ -508,7 +546,7 @@
}
}
- my $time = EV::time - $time;
+ my $time = AE::time - $time;
$TICK_START += $time; # do not account sync jobs to server load
@@ -564,6 +602,17 @@
wantarray ? @res : $res[-1]
}
+sub objinfo {
+ (
+ "counter value" => cf::object::object_count,
+ "objects created" => cf::object::create_count,
+ "objects destroyed" => cf::object::destroy_count,
+ "freelist size" => cf::object::free_count,
+ "allocated objects" => cf::object::objects_size,
+ "active objects" => cf::object::actives_size,
+ )
+}
+
=item $coin = coin_from_name $name
=cut
@@ -608,6 +657,9 @@
=cut
sub db_table($) {
+ cf::error "db_get called from main context"
+ if $Coro::current == $Coro::main;
+
my ($name) = @_;
my $db = BDB::db_create $DB_ENV;
@@ -627,20 +679,19 @@
our $DB;
sub db_init {
- cf::sync_job {
- $DB ||= db_table "db";
- };
+ $DB ||= db_table "db";
}
sub db_get($$) {
my $key = "$_[0]/$_[1]";
- cf::sync_job {
- BDB::db_get $DB, undef, $key, my $data;
+ cf::error "db_get called from main context"
+ if $Coro::current == $Coro::main;
- $! ? ()
- : $data
- }
+ BDB::db_get $DB, undef, $key, my $data;
+
+ $! ? ()
+ : $data
}
sub db_put($$$) {
@@ -706,7 +757,7 @@
my $data = $process->(\@data);
my $t2 = Time::HiRes::time;
- warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
+ info "cache: '$id' processed in ", $t2 - $t1, "s\n";
db_put cache => "$id/data", $data;
db_put cache => "$id/md5" , $md5;
@@ -726,7 +777,7 @@
sub datalog($@) {
my ($type, %kv) = @_;
- warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
+ info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
}
=back
@@ -931,11 +982,11 @@
_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
} elsif (ref $type) {
- warn "attaching objects not supported, ignoring.\n";
+ error "attaching objects not supported, ignoring.\n";
} else {
shift @arg;
- warn "attach argument '$type' not supported, ignoring.\n";
+ error "attach argument '$type' not supported, ignoring.\n";
}
}
}
@@ -955,7 +1006,7 @@
$obj->{$name} = \%arg;
} else {
- warn "object uses attachment '$name' which is not available, postponing.\n";
+ info "object uses attachment '$name' which is not available, postponing.\n";
}
$obj->{_attachment}{$name} = undef;
@@ -1024,8 +1075,7 @@
eval { &{$_->[1]} };
if ($@) {
- warn "$@";
- warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
+ error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
override;
}
@@ -1114,7 +1164,7 @@
_attach $registry, $klass, @attach;
}
} else {
- warn "object uses attachment '$name' that is not available, postponing.\n";
+ info "object uses attachment '$name' that is not available, postponing.\n";
}
}
}
@@ -1151,8 +1201,9 @@
sync_job {
if (length $$rdata) {
utf8::decode (my $decname = $filename);
- warn sprintf "saving %s (%d,%d)\n",
- $decname, length $$rdata, scalar @$objs;
+ trace sprintf "saving %s (%d,%d)\n",
+ $decname, length $$rdata, scalar @$objs
+ if $VERBOSE_IO;
if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
aio_chmod $fh, SAVE_MODE;
@@ -1184,7 +1235,7 @@
$filename =~ s%/[^/]+$%%;
aio_pathsync $filename if $cf::USE_FSYNC;
} else {
- warn "unable to save objects: $filename~: $!\n";
+ error "unable to save objects: $filename~: $!\n";
}
} else {
aio_unlink $filename;
@@ -1218,8 +1269,9 @@
}
utf8::decode (my $decname = $filename);
- warn sprintf "loading %s (%d,%d)\n",
- $decname, length $data, scalar @{$av || []};
+ trace sprintf "loading %s (%d,%d)\n",
+ $decname, length $data, scalar @{$av || []}
+ if $VERBOSE_IO;
($data, $av)
}
@@ -1288,7 +1340,7 @@
use File::Glob ();
cf::player->attach (
- on_command => sub {
+ on_unknown_command => sub {
my ($pl, $name, $params) = @_;
my $cb = $COMMAND{$name}
@@ -1321,7 +1373,7 @@
if $reply;
} else {
- warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
+ error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
}
cf::override;
@@ -1342,6 +1394,8 @@
}
sub load_extensions {
+ info "loading extensions...";
+
cf::sync_job {
my %todo;
@@ -1369,7 +1423,7 @@
if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
$ext{source} =
- "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
+ "package $pkg; use common::sense;\n"
. "#line 1 \"$path\"\n{\n"
. $source
. "\n};\n1";
@@ -1377,38 +1431,51 @@
$todo{$base} = \%ext;
}
+ my $pass = 0;
my %done;
while (%todo) {
my $progress;
+ ++$pass;
+
+ ext:
while (my ($k, $v) = each %todo) {
for (split /,\s*/, $v->{meta}{depends}) {
- goto skip
+ next ext
unless exists $done{$_};
}
- warn "... loading '$k' into '$v->{pkg}'\n";
+ trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
- unless (eval $v->{source}) {
- my $msg = $@ ? "$v->{path}: $@\n"
- : "$v->{base}: extension inactive.\n";
-
- if (exists $v->{meta}{mandatory}) {
- warn $msg;
- cf::cleanup "mandatory extension failed to load, exiting.";
- }
-
- warn $msg;
- }
+ my $active = eval $v->{source};
- $done{$k} = delete $todo{$k};
- push @EXTS, $v->{pkg};
- $progress = 1;
+ if (length $@) {
+ error "$v->{path}: $@\n";
+ undef $@; # work around perl 5.10.0 utf-8 caching bug
+
+ cf::cleanup "mandatory extension '$k' failed to load, exiting."
+ if exists $v->{meta}{mandatory};
+
+ warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
+ delete $todo{$k};
+ } else {
+ $done{$k} = delete $todo{$k};
+ push @EXTS, $v->{pkg};
+ $progress = 1;
+
+ info "$v->{base}: extension inactive.\n"
+ unless $active;
+ }
}
- skip:
- die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
- unless $progress;
+ unless ($progress) {
+ warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
+
+ while (my ($k, $v) = each %todo) {
+ cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
+ if exists $v->{meta}{mandatory};
+ }
+ }
}
};
}
@@ -1502,6 +1569,19 @@
}
}
+cf::player->attach (
+ on_load => sub {
+ my ($pl, $path) = @_;
+
+ # restore slots saved in save, below
+ my $slots = delete $pl->{_slots};
+
+ $pl->ob->current_weapon ($slots->[0]);
+ $pl->combat_ob ($slots->[1]);
+ $pl->ranged_ob ($slots->[2]);
+ },
+);
+
sub save($) {
my ($pl) = @_;
@@ -1517,6 +1597,9 @@
cf::get_slot 0.01;
+ # save slots, to be restored later
+ local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
+
$pl->save_pl ($path);
cf::cede_to_tick;
}
@@ -1562,7 +1645,6 @@
$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
$pl->deactivate;
my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
- $pl->ob->check_score;
$pl->invoke (cf::EVENT_PLAYER_QUIT);
$pl->ns->destroy if $pl->ns;
@@ -1627,6 +1709,8 @@
=item $player->maps
+=item cf::player::maps $login
+
Returns an arrayref of map paths that are private for this
player. May block.
@@ -1698,6 +1782,8 @@
sub find_by_path($) {
my ($path) = @_;
+ $path =~ s/^~[^\/]*//; # skip ~login
+
my ($match, $specificity);
for my $region (list) {
@@ -1738,7 +1824,7 @@
# mit "rum" bekleckern, nicht
$self->_create_random_map (
$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
- $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
+ $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
$rmp->{exit_on_final_map},
$rmp->{xsize}, $rmp->{ysize},
@@ -1763,14 +1849,13 @@
my (undef, $regex, $prio) = @_;
my $pkg = caller;
- no strict;
push @{"$pkg\::ISA"}, __PACKAGE__;
$EXT_MAP{$pkg} = [$prio, qr<$regex>];
}
# also paths starting with '/'
-$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
+$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
sub thawer_merge {
my ($self, $merge) = @_;
@@ -1994,8 +2079,8 @@
}
}
-sub pre_load { }
-sub post_load { }
+sub pre_load { }
+#sub post_load { } # XS
sub load {
my ($self) = @_;
@@ -2062,6 +2147,9 @@
$self->post_load;
}
+# customize the map for a given player, i.e.
+# return the _real_ map. used by e.g. per-player
+# maps to change the path to ~playername/mappath
sub customise_for {
my ($self, $ob) = @_;
@@ -2087,6 +2175,7 @@
or next;
$neigh->load;
+ # now find the diagonal neighbours
push @neigh,
[$neigh->tile_path (($_ + 3) % 4), $neigh],
[$neigh->tile_path (($_ + 1) % 4), $neigh];
@@ -2103,16 +2192,19 @@
sub find_sync {
my ($path, $origin) = @_;
- cf::sync_job { find $path, $origin }
+ return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
+ if $Coro::current == $Coro::main;
+
+ find $path, $origin
}
sub do_load_sync {
my ($map) = @_;
- cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
+ return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
if $Coro::current == $Coro::main;
- cf::sync_job { $map->load };
+ $map->load;
}
our %MAP_PREFETCH;
@@ -2148,11 +2240,10 @@
()
}
-sub save {
+# common code, used by both ->save and ->swapout
+sub _save {
my ($self) = @_;
- my $lock = cf::lock_acquire "map_data:$self->{path}";
-
$self->{last_save} = $cf::RUNTIME;
return unless $self->dirty;
@@ -2181,22 +2272,32 @@
}
}
-sub swap_out {
+sub save {
my ($self) = @_;
- # save first because save cedes
- $self->save;
+ my $lock = cf::lock_acquire "map_data:$self->{path}";
+
+ $self->_save;
+}
+
+sub swap_out {
+ my ($self) = @_;
my $lock = cf::lock_acquire "map_data:$self->{path}";
- return if $self->players;
return if $self->in_memory != cf::MAP_ACTIVE;
return if $self->{deny_save};
+ return if $self->players;
- $self->in_memory (cf::MAP_SWAPPED);
-
+ # first deactivate the map and "unlink" it from the core
$self->deactivate;
$_->clear_links_to ($self) for values %cf::MAP;
+ $self->in_memory (cf::MAP_SWAPPED);
+
+ # then atomically save
+ $self->_save;
+
+ # then free the map
$self->clear;
}
@@ -2225,7 +2326,7 @@
return if $self->players;
- warn "resetting map ", $self->path;
+ cf::trace "resetting map ", $self->path, "\n";
$self->in_memory (cf::MAP_SWAPPED);
@@ -2259,7 +2360,7 @@
$self->unlink_save;
- bless $self, "cf::map";
+ bless $self, "cf::map::wrap";
delete $self->{deny_reset};
$self->{deny_save} = 1;
$self->reset_timeout (1);
@@ -2326,6 +2427,38 @@
]
}
+=item cf::map::static_maps
+
+Returns an arrayref if paths of all static maps (all preinstalled F<.map>
+file in the shared directory excluding F and F). May
+block.
+
+=cut
+
+sub static_maps() {
+ my @dirs = "";
+ my @maps;
+
+ while (@dirs) {
+ my $dir = shift @dirs;
+
+ next if $dir eq "/styles" || $dir eq "/editor";
+
+ my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
+ or return;
+
+ for (@$files) {
+ s/\.map$// or next;
+ utf8::decode $_;
+ push @maps, "$dir/$_";
+ }
+
+ push @dirs, map "$dir/$_", @$dirs;
+ }
+
+ \@maps
+}
+
=back
=head3 cf::object
@@ -2467,7 +2600,7 @@
The player should be reasonably safe there for short amounts of time (e.g.
for loading a map). You I call C as soon as possible,
-though, as the palyer cannot control the character while it is on the link
+though, as the player cannot control the character while it is on the link
map.
Will never block.
@@ -2498,12 +2631,14 @@
$self->deactivate_recursive;
+ ++$self->{_link_recursion};
+
return if UNIVERSAL::isa $self->map, "ext::map_link";
$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
if $self->map && $self->map->{path} ne "{link}";
- $self->enter_map ($LINK_MAP || link_map, 10, 10);
+ $self->enter_map ($LINK_MAP || link_map, 3, 3);
}
sub cf::object::player::leave_link {
@@ -2530,20 +2665,24 @@
# use -1 or undef as default coordinates, not 0, 0
($x, $y) = ($map->enter_x, $map->enter_y)
- if $x <=0 && $y <= 0;
+ if $x <= 0 && $y <= 0;
$map->load;
$map->load_neighbours;
return unless $self->contr->active;
- $self->flag (cf::FLAG_DEBUG, 0);#d# temp
- $self->activate_recursive;
local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
- $self->enter_map ($map, $x, $y);
+ if ($self->enter_map ($map, $x, $y)) {
+ # entering was successful
+ delete $self->{_link_recursion};
+ # only activate afterwards, to support waiting in hooks
+ $self->activate_recursive;
+ }
+
}
-=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
+=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
Moves the player to the given map-path and coordinates by first freezing
her, loading and preparing them map, calling the provided $check callback
@@ -2561,6 +2700,12 @@
sub cf::object::player::goto {
my ($self, $path, $x, $y, $check, $done) = @_;
+ if ($self->{_link_recursion} >= $MAX_LINKS) {
+ error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
+ $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
+ ($path, $x, $y) = @$EMERGENCY_POSITION;
+ }
+
# do generation counting so two concurrent goto's will be executed in-order
my $gen = $self->{_goto_generation} = ++$GOTOGEN;
@@ -2593,7 +2738,7 @@
if ($map) {
$map = $map->customise_for ($self);
- $map = $check->($map) if $check && $map;
+ $map = $check->($map, $x, $y, $self) if $check && $map;
} else {
$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
}
@@ -2611,7 +2756,7 @@
$self->leave_link ($map, $x, $y);
}
- $done->() if $done;
+ $done->($self) if $done;
})->prio (1);
}
@@ -2714,7 +2859,7 @@
. "Please report this to the dungeon master!",
cf::NDI_UNIQUE | cf::NDI_RED);
- warn "ERROR in enter_exit: $@";
+ error "ERROR in enter_exit: $@";
$self->leave_link;
}
})->prio (1);
@@ -2738,6 +2883,31 @@
$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
}
+=item $client->send_big_packet ($pkt)
+
+Like C, but tries to compress large packets, and fragments
+them as required.
+
+=cut
+
+our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
+
+sub cf::client::send_big_packet {
+ my ($self, $pkt) = @_;
+
+ # try lzf for large packets
+ $pkt = "lzf " . Compress::LZF::compress $pkt
+ if 1024 <= length $pkt and $self->{can_lzf};
+
+ # split very large packets
+ if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
+ $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
+ $pkt = "frag";
+ }
+
+ $self->send_packet ($pkt);
+}
+
=item $client->send_msg ($channel, $msg, $color, [extra...])
Send a drawinfo or msg packet to the client, formatting the msg for the
@@ -2749,6 +2919,12 @@
# non-persistent channels (usually the info channel)
our %CHANNEL = (
+ "c/motd" => {
+ id => "infobox",
+ title => "MOTD",
+ reply => undef,
+ tooltip => "The message of the day",
+ },
"c/identify" => {
id => "infobox",
title => "Identify",
@@ -2761,6 +2937,12 @@
reply => undef,
tooltip => "Signs and other items you examined",
},
+ "c/shopinfo" => {
+ id => "infobox",
+ title => "Shop Info",
+ reply => undef,
+ tooltip => "What your bargaining skill tells you about the shop",
+ },
"c/book" => {
id => "infobox",
title => "Book",
@@ -2885,17 +3067,7 @@
[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
);
- # try lzf for large packets
- $pkt = "lzf " . Compress::LZF::compress $pkt
- if 1024 <= length $pkt and $self->{can_lzf};
-
- # split very large packets
- if (8192 < length $pkt and $self->{can_lzf}) {
- $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
- $pkt = "frag";
- }
-
- $self->send_packet ($pkt);
+ $self->send_big_packet ($pkt);
}
=item $client->ext_msg ($type, @msg)
@@ -2908,10 +3080,10 @@
my ($self, $type, @msg) = @_;
if ($self->extcmd == 2) {
- $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
+ $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
} elsif ($self->extcmd == 1) { # TODO: remove
push @msg, msgtype => "event_$type";
- $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
+ $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
}
}
@@ -2925,11 +3097,11 @@
my ($self, $id, @msg) = @_;
if ($self->extcmd == 2) {
- $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
+ $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
} elsif ($self->extcmd == 1) {
#TODO: version 1, remove
unshift @msg, msgtype => "reply", msgid => $id;
- $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
+ $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
}
}
@@ -3010,7 +3182,7 @@
if $reply;
} else {
- warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
+ error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
}
cf::override;
@@ -3040,7 +3212,7 @@
}
cf::client->attach (
- on_destroy => sub {
+ on_client_destroy => sub {
my ($ns) = @_;
$_->cancel for values %{ (delete $ns->{_coro}) || {} };
@@ -3066,7 +3238,7 @@
$SIG{FPE} = 'IGNORE';
$safe->permit_only (Opcode::opset qw(
- :base_core :base_mem :base_orig :base_math
+ :base_core :base_mem :base_orig :base_math :base_loop
grepstart grepwhile mapstart mapwhile
sort time
));
@@ -3101,7 +3273,6 @@
["cf::player" => qw(peaceful send_msg)],
["cf::map" => qw(trigger)],
) {
- no strict 'refs';
my ($pkg, @funs) = @$_;
*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
for @funs;
@@ -3128,8 +3299,8 @@
%vars = (_dummy => 0) unless %vars;
+ my @res;
local $_;
- local @safe::cf::_safe_eval_args = values %vars;
my $eval =
"do {\n"
@@ -3139,14 +3310,20 @@
. "\n}"
;
- sub_generation_inc;
- my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
- sub_generation_inc;
+ if ($CFG{safe_eval}) {
+ sub_generation_inc;
+ local @safe::cf::_safe_eval_args = values %vars;
+ @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
+ sub_generation_inc;
+ } else {
+ local @cf::_safe_eval_args = values %vars;
+ @res = wantarray ? eval eval : scalar eval $eval;
+ }
if ($@) {
- warn "$@";
- warn "while executing safe code '$code'\n";
- warn "with arguments " . (join " ", %vars) . "\n";
+ warn "$@",
+ "while executing safe code '$code'\n",
+ "with arguments " . (join " ", %vars) . "\n";
}
wantarray ? @res : $res[0]
@@ -3170,8 +3347,8 @@
sub register_script_function {
my ($fun, $cb) = @_;
- no strict 'refs';
- *{"safe::$fun"} = $safe_hole->wrap ($cb);
+ $fun = "safe::$fun" if $CFG{safe_eval};
+ *$fun = $safe_hole->wrap ($cb);
}
=back
@@ -3190,7 +3367,7 @@
my $enc = JSON::XS->new->utf8->canonical->relaxed;
- warn "loading facedata from $path\n";
+ trace "loading facedata from $path\n";
my $facedata;
0 < aio_load $path, $facedata
@@ -3202,9 +3379,11 @@
or cf::cleanup "$path: version mismatch, cannot proceed.";
# patch in the exptable
+ my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
$facedata->{resource}{"res/exp_table"} = {
type => FT_RSRC,
- data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
+ data => $exp_table,
+ hash => (Digest::MD5::md5 $exp_table),
};
cf::cede_to_tick;
@@ -3216,8 +3395,8 @@
cf::face::set_visibility $idx, $info->{visibility};
cf::face::set_magicmap $idx, $info->{magicmap};
- cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
- cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
+ cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
+ cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
cf::cede_to_tick;
}
@@ -3232,7 +3411,7 @@
cf::face::set_smooth $idx, $smooth;
cf::face::set_smoothlevel $idx, $info->{smoothlevel};
} else {
- warn "smooth face '$info->{smooth}' not found for face '$face'";
+ error "smooth face '$info->{smooth}' not found for face '$face'";
}
cf::cede_to_tick;
@@ -3251,32 +3430,16 @@
}
{
- # TODO: for gcfclient pleasure, we should give resources
- # that gcfclient doesn't grok a >10000 face index.
my $res = $facedata->{resource};
while (my ($name, $info) = each %$res) {
if (defined $info->{type}) {
my $idx = (cf::face::find $name) || cf::face::alloc $name;
- my $data;
-
- if ($info->{type} & 1) {
- # prepend meta info
-
- my $meta = $enc->encode ({
- name => $name,
- %{ $info->{meta} || {} },
- });
- $data = pack "(w/a*)*", $meta, $info->{data};
- } else {
- $data = $info->{data};
- }
-
- cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
+ cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
cf::face::set_type $idx, $info->{type};
} else {
- $RESOURCE{$name} = $info;
+ $RESOURCE{$name} = $info; # unused
}
cf::cede_to_tick;
@@ -3288,26 +3451,6 @@
1
}
-cf::global->attach (on_resource_update => sub {
- if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
- $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
-
- for (0 .. SOUND_CAST_SPELL_0 - 1) {
- my $sound = $soundconf->{compat}[$_]
- or next;
-
- my $face = cf::face::find "sound/$sound->[1]";
- cf::sound::set $sound->[0] => $face;
- cf::sound::old_sound_index $_, $face; # gcfclient-compat
- }
-
- while (my ($k, $v) = each %{$soundconf->{event}}) {
- my $face = cf::face::find "sound/$v";
- cf::sound::set $k => $face;
- }
- }
-});
-
register_exticmd fx_want => sub {
my ($ns, $want) = @_;
@@ -3355,25 +3498,51 @@
or die "unable to load treasurelists\n";
}
+sub reload_sound {
+ trace "loading sound config from $DATADIR/sound\n";
+
+ 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
+ or die "$DATADIR/sound $!";
+
+ my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
+
+ for (0 .. SOUND_CAST_SPELL_0 - 1) {
+ my $sound = $soundconf->{compat}[$_]
+ or next;
+
+ my $face = cf::face::find "sound/$sound->[1]";
+ cf::sound::set $sound->[0] => $face;
+ cf::sound::old_sound_index $_, $face; # gcfclient-compat
+ }
+
+ while (my ($k, $v) = each %{$soundconf->{event}}) {
+ my $face = cf::face::find "sound/$v";
+ cf::sound::set $k => $face;
+ }
+}
+
sub reload_resources {
- warn "reloading resource files...\n";
+ trace "reloading resource files...\n";
reload_facedata;
+ reload_sound;
reload_archetypes;
reload_regions;
reload_treasures;
- warn "finished reloading resource files\n";
+ trace "finished reloading resource files\n";
}
sub reload_config {
+ trace "reloading config file...\n";
+
open my $fh, "<:utf8", "$CONFDIR/config"
or return;
local $/;
- *CFG = YAML::Load <$fh>;
+ *CFG = YAML::XS::Load scalar <$fh>;
- $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
+ $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
@@ -3385,6 +3554,8 @@
};
warn $@ if $@;
}
+
+ trace "finished reloading resource files\n";
}
sub pidfile() {
@@ -3407,11 +3578,11 @@
}
sub main_loop {
- warn "EV::loop starting\n";
+ trace "EV::loop starting\n";
if (1) {
EV::loop;
}
- warn "EV::loop returned\n";
+ trace "EV::loop returned\n";
goto &main_loop unless $REALLY_UNLOOP;
}
@@ -3423,11 +3594,6 @@
LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
- cf::init_experience;
- cf::init_anim;
- cf::init_attackmess;
- cf::init_dynamic;
-
$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
# we must not ever block the main coroutine
@@ -3442,15 +3608,20 @@
evthread_start IO::AIO::poll_fileno;
cf::sync_job {
+ cf::init_experience;
+ cf::init_anim;
+ cf::init_attackmess;
+ cf::init_dynamic;
+
+ cf::load_settings;
+ cf::load_materials;
+
reload_resources;
reload_config;
db_init;
- cf::load_settings;
- cf::load_materials;
cf::init_uuid;
cf::init_signals;
- cf::init_commands;
cf::init_skills;
cf::init_beforeplay;
@@ -3468,6 +3639,9 @@
(pop @POST_INIT)->(0) while @POST_INIT;
};
+ cf::object::thawer::errors_are_fatal 0;
+ info "parse errors in files are no longer fatal from this point on.\n";
+
main_loop;
}
@@ -3478,13 +3652,15 @@
BEGIN {
our %SIGWATCHER = ();
for my $signal (qw(INT HUP TERM)) {
- $SIGWATCHER{$signal} = EV::signal $signal, sub {
+ $SIGWATCHER{$signal} = AE::signal $signal, sub {
cf::cleanup "SIG$signal";
};
}
}
sub write_runtime_sync {
+ my $t0 = AE::time;
+
# first touch the runtime file to show we are still running:
# the fsync below can take a very very long time.
@@ -3492,7 +3668,7 @@
my $guard = cf::lock_acquire "write_runtime";
- my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
+ my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
or return;
my $value = $cf::RUNTIME + 90 + 10;
@@ -3515,7 +3691,7 @@
aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
and return;
- warn "runtime file written.\n";
+ trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
1
}
@@ -3537,7 +3713,7 @@
my $value = uuid_seq uuid_cur;
unless ($value) {
- warn "cowardly refusing to write zero uuid value!\n";
+ info "cowardly refusing to write zero uuid value!\n";
return;
}
@@ -3557,7 +3733,7 @@
aio_rename "$uuid~", $uuid
and return;
- warn "uuid file written ($value).\n";
+ trace "uuid file written ($value).\n";
1
@@ -3573,55 +3749,77 @@
sub emergency_save() {
my $freeze_guard = cf::freeze_mainloop;
- warn "emergency_perl_save: enter\n";
+ info "emergency_perl_save: enter\n";
+
+ # this is a trade-off: we want to be very quick here, so
+ # save all maps without fsync, and later call a global sync
+ # (which in turn might be very very slow)
+ local $USE_FSYNC = 0;
cf::sync_job {
- # this is a trade-off: we want to be very quick here, so
- # save all maps without fsync, and later call a global sync
- # (which in turn might be very very slow)
- local $USE_FSYNC = 0;
+ cf::write_runtime_sync; # external watchdog should not bark
# use a peculiar iteration method to avoid tripping on perl
# refcount bugs in for. also avoids problems with players
# and maps saved/destroyed asynchronously.
- warn "emergency_perl_save: begin player save\n";
+ info "emergency_perl_save: begin player save\n";
for my $login (keys %cf::PLAYER) {
my $pl = $cf::PLAYER{$login} or next;
$pl->valid or next;
delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
$pl->save;
}
- warn "emergency_perl_save: end player save\n";
+ info "emergency_perl_save: end player save\n";
- warn "emergency_perl_save: begin map save\n";
+ cf::write_runtime_sync; # external watchdog should not bark
+
+ info "emergency_perl_save: begin map save\n";
for my $path (keys %cf::MAP) {
my $map = $cf::MAP{$path} or next;
$map->valid or next;
$map->save;
}
- warn "emergency_perl_save: end map save\n";
+ info "emergency_perl_save: end map save\n";
+
+ cf::write_runtime_sync; # external watchdog should not bark
- warn "emergency_perl_save: begin database checkpoint\n";
+ info "emergency_perl_save: begin database checkpoint\n";
BDB::db_env_txn_checkpoint $DB_ENV;
- warn "emergency_perl_save: end database checkpoint\n";
+ info "emergency_perl_save: end database checkpoint\n";
- warn "emergency_perl_save: begin write uuid\n";
+ info "emergency_perl_save: begin write uuid\n";
write_uuid_sync 1;
- warn "emergency_perl_save: end write uuid\n";
- };
+ info "emergency_perl_save: end write uuid\n";
+
+ cf::write_runtime_sync; # external watchdog should not bark
+
+ trace "emergency_perl_save: syncing database to disk";
+ BDB::db_env_txn_checkpoint $DB_ENV;
+
+ info "emergency_perl_save: starting sync\n";
+ IO::AIO::aio_sync sub {
+ info "emergency_perl_save: finished sync\n";
+ };
+
+ cf::write_runtime_sync; # external watchdog should not bark
- warn "emergency_perl_save: starting sync()\n";
- IO::AIO::aio_sync sub {
- warn "emergency_perl_save: finished sync()\n";
+ trace "emergency_perl_save: flushing outstanding aio requests";
+ while (IO::AIO::nreqs || BDB::nreqs) {
+ Coro::EV::timer_once 0.01; # let the sync_job do it's thing
+ }
+
+ cf::write_runtime_sync; # external watchdog should not bark
};
- warn "emergency_perl_save: leave\n";
+ info "emergency_perl_save: leave\n";
}
sub post_cleanup {
my ($make_core) = @_;
- warn Carp::longmess "post_cleanup backtrace"
+ IO::AIO::flush;
+
+ error Carp::longmess "post_cleanup backtrace"
if $make_core;
my $fh = pidfile;
@@ -3651,71 +3849,58 @@
_gv_clear *{"$pkg$name"};
# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
}
- warn "cleared package $pkg\n";#d#
}
sub do_reload_perl() {
# can/must only be called in main
- if ($Coro::current != $Coro::main) {
- warn "can only reload from main coroutine";
+ if (in_main) {
+ error "can only reload from main coroutine";
return;
}
return if $RELOAD++;
- my $t1 = EV::time;
+ my $t1 = AE::time;
while ($RELOAD) {
- warn "reloading...";
+ info "reloading...";
- warn "entering sync_job";
+ trace "entering sync_job";
cf::sync_job {
- cf::write_runtime_sync; # external watchdog should not bark
cf::emergency_save;
- cf::write_runtime_sync; # external watchdog should not bark
-
- warn "syncing database to disk";
- BDB::db_env_txn_checkpoint $DB_ENV;
-
- # if anything goes wrong in here, we should simply crash as we already saved
- warn "flushing outstanding aio requests";
- while (IO::AIO::nreqs || BDB::nreqs) {
- Coro::EV::timer_once 0.01; # let the sync_job do it's thing
- }
-
- warn "cancelling all extension coros";
+ trace "cancelling all extension coros";
$_->cancel for values %EXT_CORO;
%EXT_CORO = ();
- warn "removing commands";
+ trace "removing commands";
%COMMAND = ();
- warn "removing ext/exti commands";
+ trace "removing ext/exti commands";
%EXTCMD = ();
%EXTICMD = ();
- warn "unloading/nuking all extensions";
+ trace "unloading/nuking all extensions";
for my $pkg (@EXTS) {
- warn "... unloading $pkg";
+ trace "... unloading $pkg";
if (my $cb = $pkg->can ("unload")) {
eval {
$cb->($pkg);
1
- } or warn "$pkg unloaded, but with errors: $@";
+ } or error "$pkg unloaded, but with errors: $@";
}
- warn "... clearing $pkg";
+ trace "... clearing $pkg";
clear_package $pkg;
}
- warn "unloading all perl modules loaded from $LIBDIR";
+ trace "unloading all perl modules loaded from $LIBDIR";
while (my ($k, $v) = each %INC) {
next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
- warn "... unloading $k";
+ trace "... unloading $k";
delete $INC{$k};
$k =~ s/\.pm$//;
@@ -3728,11 +3913,11 @@
clear_package $k;
}
- warn "getting rid of safe::, as good as possible";
+ trace "getting rid of safe::, as good as possible";
clear_package "safe::$_"
for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
- warn "unloading cf.pm \"a bit\"";
+ trace "unloading cf.pm \"a bit\"";
delete $INC{"cf.pm"};
delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
@@ -3740,44 +3925,44 @@
# and global variables created in xs
#clear_package __PACKAGE__;
- warn "unload completed, starting to reload now";
+ info "unload completed, starting to reload now";
- warn "reloading cf.pm";
+ trace "reloading cf.pm";
require cf;
- cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
+ cf::_connect_to_perl_1;
- warn "loading config and database again";
+ trace "loading config and database again";
cf::reload_config;
- warn "loading extensions";
+ trace "loading extensions";
cf::load_extensions;
if ($REATTACH_ON_RELOAD) {
- warn "reattaching attachments to objects/players";
+ trace "reattaching attachments to objects/players";
_global_reattach; # objects, sockets
- warn "reattaching attachments to maps";
+ trace "reattaching attachments to maps";
reattach $_ for values %MAP;
- warn "reattaching attachments to players";
+ trace "reattaching attachments to players";
reattach $_ for values %PLAYER;
}
- warn "running post_init jobs";
+ trace "running post_init jobs";
(pop @POST_INIT)->(1) while @POST_INIT;
- warn "leaving sync_job";
+ trace "leaving sync_job";
1
} or do {
- warn $@;
+ error $@;
cf::cleanup "error while reloading, exiting.";
};
- warn "reloaded";
+ info "reloaded";
--$RELOAD;
}
- $t1 = EV::time - $t1;
- warn "reload completed in ${t1}s\n";
+ $t1 = AE::time - $t1;
+ info "reload completed in ${t1}s\n";
};
our $RELOAD_WATCHER; # used only during reload
@@ -3789,7 +3974,7 @@
$RELOAD_WATCHER ||= cf::async {
Coro::AIO::aio_wait cache_extensions;
- $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
+ $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
do_reload_perl;
undef $RELOAD_WATCHER;
};
@@ -3816,7 +4001,7 @@
our @WAIT_FOR_TICK_BEGIN;
sub wait_for_tick {
- return if tick_inhibit || $Coro::current == $Coro::main;
+ return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
my $signal = new Coro::Signal;
push @WAIT_FOR_TICK, $signal;
@@ -3824,7 +4009,7 @@
}
sub wait_for_tick_begin {
- return if tick_inhibit || $Coro::current == $Coro::main;
+ return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
my $signal = new Coro::Signal;
push @WAIT_FOR_TICK_BEGIN, $signal;
@@ -3840,12 +4025,14 @@
cf::server_tick; # one server iteration
+ #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
+
if ($NOW >= $NEXT_RUNTIME_WRITE) {
$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
Coro::async_pool {
$Coro::current->{desc} = "runtime saver";
write_runtime_sync
- or warn "ERROR: unable to write runtime file: $!";
+ or error "ERROR: unable to write runtime file: $!";
};
}
@@ -3863,7 +4050,7 @@
if ($NEXT_TICK) {
my $jitter = $TICK_START - $NEXT_TICK;
$JITTER = $JITTER * 0.75 + $jitter * 0.25;
- warn "jitter $JITTER\n";#d#
+ debug "jitter $JITTER\n";#d#
}
}
}
@@ -3871,7 +4058,7 @@
{
# configure BDB
- BDB::min_parallel 8;
+ BDB::min_parallel 16;
BDB::max_poll_reqs $TICK * 0.1;
$AnyEvent::BDB::WATCHER->priority (1);
@@ -3962,6 +4149,7 @@
# load additional modules
require "cf/$_.pm" for @EXTRA_MODULES;
+cf::_connect_to_perl_2;
END { cf::emergency_save }