--- deliantra/server/lib/cf.pm 2010/04/29 07:32:34 1.532
+++ deliantra/server/lib/cf.pm 2016/11/18 20:55:00 1.621
@@ -1,30 +1,28 @@
#
# This file is part of Deliantra, the Roguelike Realtime MMORPG.
-#
-# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
-#
+#
+# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 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 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 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;
@@ -36,7 +34,10 @@
use Storable ();
use Carp ();
-use Guard ();
+use AnyEvent ();
+use AnyEvent::IO ();
+use AnyEvent::DNS ();
+
use Coro ();
use Coro::State;
use Coro::Handle;
@@ -52,13 +53,13 @@
use Coro::Storable;
use Coro::Util ();
+use Guard ();
use JSON::XS 2.01 ();
use BDB ();
use Data::Dumper;
use Fcntl;
use YAML::XS ();
use IO::AIO ();
-use Time::HiRes;
use Compress::LZF;
use Digest::MD5 ();
@@ -80,12 +81,16 @@
sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
+our @ORIG_INC;
+
our %COMMAND = ();
our %COMMAND_TIME = ();
our @EXTS = (); # list of extension package names
our %EXTCMD = ();
+our %EXTACMD = ();
our %EXTICMD = ();
+our %EXTIACMD = ();
our %EXT_CORO = (); # coroutines bound to extensions
our %EXT_MAP = (); # pluggable maps
@@ -95,10 +100,12 @@
our %REFLECT; # set by us
our $CONFDIR = confdir;
+
our $DATADIR = datadir;
our $LIBDIR = "$DATADIR/ext";
our $PODDIR = "$DATADIR/pod";
our $MAPDIR = "$DATADIR/" . mapdir;
+
our $LOCALDIR = localdir;
our $TMPDIR = "$LOCALDIR/" . tmpdir;
our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
@@ -108,7 +115,7 @@
our $PIDFILE = "$LOCALDIR/pid";
our $RUNTIMEFILE = "$LOCALDIR/runtime";
-our %RESOURCE; # unused
+#our %RESOURCE; # unused
our $OUTPUT_RATE_MIN = 3000;
our $OUTPUT_RATE_MAX = 1000000;
@@ -126,12 +133,14 @@
our $BDB_TRICKLE_WATCHER;
our $DB_ENV;
-our @EXTRA_MODULES = qw(pod match mapscript);
+our @EXTRA_MODULES = qw(pod match mapscript incloader);
our %CFG;
+our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
our $UPTIME; $UPTIME ||= time;
-our $RUNTIME;
+our $RUNTIME = 0;
+our $SERVER_TICK = 0;
our $NOW;
our (%PLAYER, %PLAYER_LOADING); # all users
@@ -151,6 +160,9 @@
our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
our $REALLY_UNLOOP; # never set to true, please :)
+our $WAIT_FOR_TICK = new Coro::Signal;
+our @WAIT_FOR_TICK_BEGIN;
+
binmode STDOUT;
binmode STDERR;
@@ -193,30 +205,37 @@
=item $cf::UPTIME
-The timestamp of the server start (so not actually an uptime).
+The timestamp of the server start (so not actually an "uptime").
+
+=item $cf::SERVER_TICK
+
+An unsigned integer that starts at zero when the server is started and is
+incremented on every tick.
+
+=item $cf::NOW
+
+The (real) time of the last (current) server tick - updated before and
+after tick processing, so this is useful only as a rough "what time is it
+now" estimate.
+
+=item $cf::TICK
+
+The interval between each server tick, in seconds.
=item $cf::RUNTIME
The time this server has run, starts at 0 and is increased by $cf::TICK on
every server tick.
-=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
+=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
-$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
+$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
Various directories - "/etc", read-only install directory, perl-library
directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
unique-items directory, player file directory, random maps directory and
database environment.
-=item $cf::NOW
-
-The time of the last (current) server tick.
-
-=item $cf::TICK
-
-The interval between server ticks, in seconds.
-
=item $cf::LOADAVG
The current CPU load on the server (alpha-smoothed), as a value between 0
@@ -234,9 +253,27 @@
=item cf::wait_for_tick, cf::wait_for_tick_begin
-These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
-returns directly I the tick processing (and consequently, can only wake one process
-per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
+These are functions that inhibit the current coroutine one tick.
+cf::wait_for_tick_begin only returns directly I the tick
+processing (and consequently, can only wake one thread per tick), while
+cf::wait_for_tick wakes up all waiters after tick processing.
+
+Note that cf::wait_for_tick will immediately return when the server is not
+ticking, making it suitable for small pauses in threads that need to run
+when the server is paused. If that is not applicable (i.e. you I
+want to wait, use C<$cf::WAIT_FOR_TICK>).
+
+=item $cf::WAIT_FOR_TICK
+
+Note that C is probably the correct thing to use. This
+variable contains a L that is broadcats after every server
+tick. Calling C<< ->wait >> on it will suspend the caller until after the
+next server tick.
+
+=cut
+
+sub wait_for_tick();
+sub wait_for_tick_begin();
=item @cf::INVOKE_RESULTS
@@ -307,11 +344,16 @@
}
$EV::DIED = sub {
- Carp::cluck "error in event callback: @_";
+ warn "error in event callback: $@";
};
#############################################################################
+sub fork_call(&@);
+sub get_slot($;$$);
+
+#############################################################################
+
=head2 UTILITY FUNCTIONS
=over 4
@@ -339,6 +381,58 @@
} || "[unable to dump $_[0]: '$@']";
}
+=item $scalar = cf::load_file $path
+
+Loads the given file from path and returns its contents. Croaks on error
+and can block.
+
+=cut
+
+sub load_file($) {
+ 0 <= aio_load $_[0], my $data
+ or Carp::croak "$_[0]: $!";
+
+ $data
+}
+
+=item $success = cf::replace_file $path, $data, $sync
+
+Atomically replaces the file at the given $path with new $data, and
+optionally $sync the data to disk before replacing the file.
+
+=cut
+
+sub replace_file($$;$) {
+ my ($path, $data, $sync) = @_;
+
+ my $lock = cf::lock_acquire ("replace_file:$path");
+
+ my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
+ or return;
+
+ $data = $data->() if ref $data;
+
+ length $data == aio_write $fh, 0, (length $data), $data, 0
+ or return;
+
+ !$sync
+ or !aio_fsync $fh
+ or return;
+
+ aio_close $fh
+ and return;
+
+ aio_rename "$path~", $path
+ and return;
+
+ if ($sync) {
+ $path =~ s%/[^/]*$%%;
+ aio_pathsync $path;
+ }
+
+ 1
+}
+
=item $ref = cf::decode_json $json
Converts a JSON string into the corresponding perl data structure.
@@ -354,12 +448,43 @@
sub encode_json($) { $json_coder->encode ($_[0]) }
sub decode_json($) { $json_coder->decode ($_[0]) }
+=item $ref = cf::decode_storable $scalar
+
+Same as Coro::Storable::thaw, so blocks.
+
+=cut
+
+BEGIN { *decode_storable = \&Coro::Storable::thaw }
+
+=item $ref = cf::decode_yaml $scalar
+
+Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
+
+=cut
+
+sub decode_yaml($) {
+ fork_call { YAML::XS::Load $_[0] } @_
+}
+
+=item $scalar = cf::unlzf $scalar
+
+Same as Compress::LZF::compress, but takes server ticks into account, so
+blocks.
+
+=cut
+
+sub unlzf($) {
+ # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
+ cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
+ Compress::LZF::decompress $_[0]
+}
+
=item cf::post_init { BLOCK }
Execute the given codeblock, I all extensions have been (re-)loaded,
but I the server starts ticking again.
-The cdoeblock will have a single boolean argument to indicate whether this
+The codeblock will have a single boolean argument to indicate whether this
is a reload or not.
=cut
@@ -368,9 +493,26 @@
push @POST_INIT, shift;
}
+sub _post_init {
+ trace "running post_init jobs";
+
+ # run them in parallel...
+
+ my @join;
+
+ while () {
+ push @join, map &Coro::async ($_, 0), @POST_INIT;
+ @POST_INIT = ();
+
+ @join or last;
+
+ (pop @join)->join;
+ }
+}
+
=item cf::lock_wait $string
-Wait until the given lock is available. See cf::lock_acquire.
+Wait until the given lock is available. See cf::lock_acquire.
=item my $lock = cf::lock_acquire $string
@@ -428,9 +570,13 @@
=item cf::get_slot $time[, $priority[, $name]]
-Allocate $time seconds of blocking CPU time at priority C<$priority>:
-This call blocks and returns only when you have at least C<$time> seconds
-of cpu time till the next tick. The slot is only valid till the next cede.
+Allocate $time seconds of blocking CPU time at priority C<$priority>
+(default: 0): This call blocks and returns only when you have at least
+C<$time> seconds of cpu time till the next tick. The slot is only valid
+till the next cede.
+
+Background jobs should use a priority less than zero, interactive jobs
+should use 100 or more.
The optional C<$name> can be used to identify the job to run. It might be
used for statistical purposes and should identify the same time-class.
@@ -453,6 +599,8 @@
while () {
next_job:
+ Coro::cede;
+
my $avail = cf::till_tick;
for (0 .. $#SLOT_QUEUE) {
@@ -460,7 +608,6 @@
$busy = 0;
my $job = splice @SLOT_QUEUE, $_, 1, ();
$job->[2]->send;
- Coro::cede;
goto next_job;
} else {
$SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
@@ -468,9 +615,7 @@
}
if (@SLOT_QUEUE) {
- # we do not use wait_for_tick() as it returns immediately when tick is inactive
- push @cf::WAIT_FOR_TICK, $signal;
- $signal->wait;
+ wait_for_tick;
} else {
$busy = 0;
Coro::schedule;
@@ -506,7 +651,7 @@
=item cf::sync_job { BLOCK }
The design of Deliantra requires that the main coroutine ($Coro::main)
-is always able to handle events or runnable, as Deliantra is only
+is always able to handle events or is runnable, as Deliantra is only
partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
acceptable.
@@ -520,13 +665,13 @@
sub sync_job(&) {
my ($job) = @_;
- if ($Coro::current == $Coro::main) {
+ 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;
@@ -544,7 +689,7 @@
if (Coro::nready) {
Coro::cede_notself;
} else {
- EV::loop EV::LOOP_ONESHOT;
+ EV::run EV::RUN_ONCE;
}
}
@@ -580,7 +725,7 @@
$coro
}
-=item fork_call { }, $args
+=item fork_call { }, @args
Executes the given code block with the given arguments in a seperate
process, returning the results. Everything must be serialisable with
@@ -589,17 +734,17 @@
=cut
+sub post_fork {
+ reset_signals;
+}
+
sub fork_call(&@) {
my ($cb, @args) = @_;
- # we seemingly have to make a local copy of the whole thing,
- # otherwise perl prematurely frees the stuff :/
- # TODO: investigate and fix (likely this will be rather laborious)
-
my @res = Coro::Util::fork_eval {
- reset_signals;
+ cf::post_fork;
&$cb
- }, @args;
+ } @args;
wantarray ? @res : $res[-1]
}
@@ -659,6 +804,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;
@@ -678,20 +826,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($$$) {
@@ -729,8 +876,7 @@
my $md5;
for (0 .. $#$src) {
- 0 <= aio_load $src->[$_], $data[$_]
- or Carp::croak "$src->[$_]: $!";
+ $data[$_] = load_file $src->[$_];
}
# if processing is expensive, check
@@ -753,9 +899,9 @@
}
}
- my $t1 = Time::HiRes::time;
+ my $t1 = EV::time;
my $data = $process->(\@data);
- my $t2 = Time::HiRes::time;
+ my $t2 = EV::time;
info "cache: '$id' processed in ", $t2 - $t1, "s\n";
@@ -1285,7 +1431,7 @@
#############################################################################
# command handling &c
-=item cf::register_command $name => \&callback($ob,$args);
+=item cf::register_command $name => \&callback($ob,$args)
Register a callback for execution when the client sends the user command
$name.
@@ -1301,7 +1447,7 @@
push @{ $COMMAND{$name} }, [$caller, $cb];
}
-=item cf::register_extcmd $name => \&callback($pl,$packet);
+=item cf::register_extcmd $name => \&callback($pl,@args)
Register a callback for execution when the client sends an (synchronous)
extcmd packet. Ext commands will be processed in the order they are
@@ -1309,10 +1455,14 @@
the logged-in player. Ext commands can only be processed after a player
has logged in successfully.
-If the callback returns something, it is sent back as if reply was being
-called.
+The values will be sent back to the client.
+
+=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
-=item cf::register_exticmd $name => \&callback($ns,$packet);
+Same as C, but instead of returning values, the
+callback needs to clal the C<$reply> function.
+
+=item cf::register_exticmd $name => \&callback($ns,@args)
Register a callback for execution when the client sends an (asynchronous)
exticmd packet. Exti commands are processed by the server as soon as they
@@ -1320,23 +1470,39 @@
is a client socket. Exti commands can be received anytime, even before
log-in.
-If the callback returns something, it is sent back as if reply was being
-called.
+The values will be sent back to the client.
+
+=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
+
+Same as C, but instead of returning values, the
+callback needs to clal the C<$reply> function.
=cut
-sub register_extcmd {
+sub register_extcmd($$) {
my ($name, $cb) = @_;
$EXTCMD{$name} = $cb;
}
-sub register_exticmd {
+sub register_async_extcmd($$) {
+ my ($name, $cb) = @_;
+
+ $EXTACMD{$name} = $cb;
+}
+
+sub register_exticmd($$) {
my ($name, $cb) = @_;
$EXTICMD{$name} = $cb;
}
+sub register_async_exticmd($$) {
+ my ($name, $cb) = @_;
+
+ $EXTIACMD{$name} = $cb;
+}
+
use File::Glob ();
cf::player->attach (
@@ -1358,20 +1524,28 @@
my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
if (ref $msg) {
- my ($type, $reply, @payload) =
- "ARRAY" eq ref $msg
- ? @$msg
- : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
+ my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
+
+ if (my $cb = $EXTACMD{$type}) {
+ $cb->(
+ $pl,
+ sub {
+ $pl->ext_msg ("reply-$reply", @_)
+ if $reply;
+ },
+ @payload
+ );
+ } else {
+ my @reply;
- my @reply;
+ if (my $cb = $EXTCMD{$type}) {
+ @reply = $cb->($pl, @payload);
+ }
- if (my $cb = $EXTCMD{$type}) {
- @reply = $cb->($pl, @payload);
+ $pl->ext_msg ("reply-$reply", @reply)
+ if $reply;
}
- $pl->ext_reply ($reply, @reply)
- if $reply;
-
} else {
error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
}
@@ -1393,9 +1567,22 @@
$grp
}
+sub _ext_cfg_reg($$$$) {
+ my ($rvar, $varname, $cfgname, $default) = @_;
+
+ $cfgname = lc $varname
+ unless length $cfgname;
+
+ $EXT_CFG{$cfgname} = [$rvar, $default];
+
+ $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
+}
+
sub load_extensions {
info "loading extensions...";
+ %EXT_CFG = ();
+
cf::sync_job {
my %todo;
@@ -1423,7 +1610,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";
@@ -1447,7 +1634,16 @@
trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
- my $active = eval $v->{source};
+ my $source = $v->{source};
+
+ # support "CONF varname :confname = default" pseudo-statements
+ $source =~ s{
+ ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
+ }{
+ "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
+ }gmxe;
+
+ my $active = eval $source;
if (length $@) {
error "$v->{path}: $@\n";
@@ -1474,6 +1670,8 @@
cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
if exists $v->{meta}{mandatory};
}
+
+ last;
}
}
};
@@ -1641,10 +1839,13 @@
$pl->{deny_save} = 1;
$pl->password ("*"); # this should lock out the player until we have nuked the dir
- $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
+ $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
$pl->deactivate;
+
my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
- $pl->invoke (cf::EVENT_PLAYER_QUIT);
+ $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
+ ext::highscore::check ($pl->ob);
+
$pl->ns->destroy if $pl->ns;
my $path = playerdir $pl;
@@ -1740,18 +1941,6 @@
Expand deliantra pod fragments into protocol xml.
-=item $player->ext_reply ($msgid, @msg)
-
-Sends an ext reply to the player.
-
-=cut
-
-sub ext_reply($$@) {
- my ($self, $id, @msg) = @_;
-
- $self->ns->ext_reply ($id, @msg)
-}
-
=item $player->ext_msg ($type, @msg)
Sends an ext event to the client.
@@ -1820,20 +2009,7 @@
my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
- # 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->{miningstyle},
- $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
- $rmp->{exit_on_final_map},
- $rmp->{xsize}, $rmp->{ysize},
- $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
- $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
- $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
- $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
- $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
- (cf::region::find $rmp->{region}), $rmp->{custom}
- )
+ $self->_create_random_map ($rmp);
}
=item cf::map->register ($regex, $prio)
@@ -1848,7 +2024,6 @@
my (undef, $regex, $prio) = @_;
my $pkg = caller;
- no strict;
push @{"$pkg\::ISA"}, __PACKAGE__;
$EXT_MAP{$pkg} = [$prio, qr<$regex>];
@@ -1870,7 +2045,7 @@
sub normalise {
my ($path, $base) = @_;
- $path = "$path"; # make sure its a string
+ $path = "$path"; # make sure it's a string
$path =~ s/\.map$//;
@@ -1895,7 +2070,6 @@
}
for ($path) {
- redo if s{//}{/};
redo if s{/\.?/}{/};
redo if s{/[^/]+/\.\./}{/};
}
@@ -1919,10 +2093,11 @@
}
}
- Carp::cluck "unable to resolve path '$path' (base '$base').";
+ Carp::cluck "unable to resolve path '$path' (base '$base')";
()
}
+# may re-bless or do other evil things
sub init {
my ($self) = @_;
@@ -1997,18 +2172,21 @@
1
}
+# used to laod the header of an original map
sub load_header_orig {
my ($self) = @_;
$self->load_header_from ($self->load_path)
}
+# used to laod the header of an instantiated map
sub load_header_temp {
my ($self) = @_;
$self->load_header_from ($self->save_path)
}
+# called after loading the header from an instantiated map
sub prepare_temp {
my ($self) = @_;
@@ -2019,6 +2197,7 @@
if $self->{instantiate_time} > $cf::RUNTIME;
}
+# called after loading the header from an original map
sub prepare_orig {
my ($self) = @_;
@@ -2052,7 +2231,9 @@
sub find {
my ($path, $origin) = @_;
- $path = normalise $path, $origin && $origin->path;
+ cf::cede_to_tick;
+
+ $path = normalise $path, $origin;
my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
my $guard2 = cf::lock_acquire "map_find:$path";
@@ -2093,35 +2274,40 @@
my $guard = cf::lock_acquire "map_data:$path";
return unless $self->valid;
- return unless $self->in_memory == cf::MAP_SWAPPED;
-
- $self->in_memory (cf::MAP_LOADING);
+ return unless $self->state == cf::MAP_SWAPPED;
$self->alloc;
$self->pre_load;
cf::cede_to_tick;
- my $f = new_from_file cf::object::thawer $self->{load_path};
- $f->skip_block;
- $self->_load_objects ($f)
- or return;
+ if (exists $self->{load_path}) {
+ my $f = new_from_file cf::object::thawer $self->{load_path};
+ $f->skip_block;
+ $self->_load_objects ($f)
+ or return;
- $self->post_load_original
- if delete $self->{load_original};
+ $self->post_load_original
+ if delete $self->{load_original};
- if (my $uniq = $self->uniq_path) {
- utf8::encode $uniq;
- unless (aio_stat $uniq) {
- if (my $f = new_from_file cf::object::thawer $uniq) {
- $self->clear_unique_items;
- $self->_load_objects ($f);
- $f->resolve_delayed_derefs;
+ if (my $uniq = $self->uniq_path) {
+ utf8::encode $uniq;
+ unless (aio_stat $uniq) {
+ if (my $f = new_from_file cf::object::thawer $uniq) {
+ $self->clear_unique_items;
+ $self->_load_objects ($f);
+ $f->resolve_delayed_derefs;
+ }
}
}
+
+ $f->resolve_delayed_derefs;
+ } else {
+ $self->post_load_original
+ if delete $self->{load_original};
}
- $f->resolve_delayed_derefs;
+ $self->state (cf::MAP_INACTIVE);
cf::cede_to_tick;
# now do the right thing for maps
@@ -2135,16 +2321,16 @@
$self->fix_auto_apply;
$self->update_buttons;
cf::cede_to_tick;
- $self->activate;
+ #$self->activate; # no longer activate maps automatically
}
$self->{last_save} = $cf::RUNTIME;
$self->last_access ($cf::RUNTIME);
-
- $self->in_memory (cf::MAP_ACTIVE);
}
$self->post_load;
+
+ 1
}
# customize the map for a given player, i.e.
@@ -2162,46 +2348,24 @@
$self
}
-# find and load all maps in the 3x3 area around a map
-sub load_neighbours {
- my ($map) = @_;
-
- my @neigh; # diagonal neighbours
-
- for (0 .. 3) {
- my $neigh = $map->tile_path ($_)
- or next;
- $neigh = find $neigh, $map
- or next;
- $neigh->load;
-
- # now find the diagonal neighbours
- push @neigh,
- [$neigh->tile_path (($_ + 3) % 4), $neigh],
- [$neigh->tile_path (($_ + 1) % 4), $neigh];
- }
-
- for (grep defined $_->[0], @neigh) {
- my ($path, $origin) = @$_;
- my $neigh = find $path, $origin
- or next;
- $neigh->load;
- }
-}
-
sub find_sync {
my ($path, $origin) = @_;
- cf::sync_job { find $path, $origin }
+ # it's a bug to call this from the main context
+ 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"
+ # it's a bug to call this from the main context
+ 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;
@@ -2210,10 +2374,10 @@
sub find_async {
my ($path, $origin, $load) = @_;
- $path = normalise $path, $origin && $origin->{path};
+ $path = normalise $path, $origin;
if (my $map = $cf::MAP{$path}) {
- return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
+ return $map if !$load || $map->linkable;
}
$MAP_PREFETCH{$path} |= $load;
@@ -2222,9 +2386,9 @@
$Coro::current->{desc} = "map prefetcher";
while (%MAP_PREFETCH) {
- while (my ($k, $v) = each %MAP_PREFETCH) {
+ for my $k (keys %MAP_PREFETCH) {
if (my $map = find $k) {
- $map->load if $v;
+ $map->load if $MAP_PREFETCH{$k};
}
delete $MAP_PREFETCH{$k};
@@ -2282,14 +2446,14 @@
my $lock = cf::lock_acquire "map_data:$self->{path}";
- return if $self->in_memory != cf::MAP_ACTIVE;
+ return if !$self->linkable;
return if $self->{deny_save};
return if $self->players;
# 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);
+ $self->state (cf::MAP_SWAPPED);
# then atomically save
$self->_save;
@@ -2325,7 +2489,7 @@
cf::trace "resetting map ", $self->path, "\n";
- $self->in_memory (cf::MAP_SWAPPED);
+ $self->state (cf::MAP_SWAPPED);
# need to save uniques path
unless ($self->{deny_save}) {
@@ -2488,7 +2652,7 @@
=item $ob = cf::object::deref ($refstring)
-returns the objetc referenced by refstring. may return undef when it cnanot find the object,
+returns the objetc referenced by refstring. may return undef when it cannot find the object,
even if the object actually exists. May block.
=cut
@@ -2580,14 +2744,39 @@
Returns wether the given player is authorized to access resource "access"
(e.g. "command_wizcast").
+This is implemented by checking a config setting of C where
+C is replaced by the access string. The following alternatives are
+possible (and are tested in order):
+
+=over 4
+
+=item * Player is DM
+
+The request will succeed.
+
+=item * may_access is an array reference
+
+If either the player nickname or UUID is in the array, the request will
+succeed, otherwise it will fail.
+
+=item * may_access is a true value
+
+The request will succeed.
+
+=item * may_access is missing or false
+
+The request will fail.
+
+=back
+
=cut
sub cf::object::player::may {
my ($self, $access) = @_;
- $self->flag (cf::FLAG_WIZ) ||
+ $self->flag (cf::FLAG_WIZ) ||
(ref $cf::CFG{"may_$access"}
- ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
+ ? scalar grep $self->name eq $_ || $self->uuid eq $_, @{$cf::CFG{"may_$access"}}
: $cf::CFG{"may_$access"})
}
@@ -2600,7 +2789,13 @@
though, as the player cannot control the character while it is on the link
map.
-Will never block.
+This method will never block, which is the whole reaosn for it's
+existance: you can I put a player onto the link map, which is the
+only place to put objects that is guaranteed to exist.
+
+A typical usage pattern is to call C synchronously from the
+server, then start a new thread, do your blocking stuff there and then
+call C from that thread.
=item $player_object->leave_link ($map, $x, $y)
@@ -2665,7 +2860,6 @@
if $x <= 0 && $y <= 0;
$map->load;
- $map->load_neighbours;
return unless $self->contr->active;
@@ -2731,7 +2925,7 @@
}
my $map = eval {
- my $map = defined $path ? cf::map::find $path : undef;
+ my $map = defined $path ? cf::map::find $path, $self->map : undef;
if ($map) {
$map = $map->customise_for ($self);
@@ -2831,17 +3025,32 @@
unless (eval {
$self->deactivate_recursive; # just to be sure
- # random map handling
- {
+ my $map = cf::map::normalise $exit->slaying, $exit->map;
+ my $x = $exit->stats->hp;
+ my $y = $exit->stats->sp;
+
+ # special map handling
+ my $slaying = $exit->slaying;
+
+ # special map handling
+ if ($slaying eq "/!") {
my $guard = cf::lock_acquire "exit_prepare:$exit";
prepare_random_map $exit
- if $exit->slaying eq "/!";
- }
+ if $exit->slaying eq "/!"; # need to re-check after getting the lock
- my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
- my $x = $exit->stats->hp;
- my $y = $exit->stats->sp;
+ $map = $exit->slaying;
+
+ } elsif ($slaying eq '!up') {
+ $map = $exit->map->tile_path (cf::TILE_UP);
+ $x = $exit->x;
+ $y = $exit->y;
+
+ } elsif ($slaying eq '!down') {
+ $map = $exit->map->tile_path (cf::TILE_DOWN);
+ $x = $exit->x;
+ $y = $exit->y;
+ }
$self->goto ($map, $x, $y);
@@ -2866,20 +3075,6 @@
=over 4
-=item $client->send_drawinfo ($text, $flags)
-
-Sends a drawinfo packet to the client. Circumvents output buffering so
-should not be used under normal circumstances.
-
-=cut
-
-sub cf::client::send_drawinfo {
- my ($self, $text, $flags) = @_;
-
- utf8::encode $text;
- $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
@@ -2907,9 +3102,9 @@
=item $client->send_msg ($channel, $msg, $color, [extra...])
-Send a drawinfo or msg packet to the client, formatting the msg for the
-client if neccessary. C<$type> should be a string identifying the type of
-the message, with C being the default. If C<$color> is negative, suppress
+Send a msg packet to the client, formatting the msg for the client if
+necessary. C<$type> should be a string identifying the type of the
+message, with C being the default. If C<$color> is negative, suppress
the message unless the client supports the msg packet.
=cut
@@ -3024,6 +3219,12 @@
reply => undef,
tooltip => "Reason for and more info about your most recent death",
},
+ "c/fatal" => {
+ id => "fatal",
+ title => "Fatal Error",
+ reply => undef,
+ tooltip => "Reason for the server disconnect",
+ },
"c/say" => $SAY_CHANNEL,
"c/chat" => $CHAT_CHANNEL,
);
@@ -3076,30 +3277,7 @@
sub cf::client::ext_msg($$@) {
my ($self, $type, @msg) = @_;
- if ($self->extcmd == 2) {
- $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
- } elsif ($self->extcmd == 1) { # TODO: remove
- push @msg, msgtype => "event_$type";
- $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
- }
-}
-
-=item $client->ext_reply ($msgid, @msg)
-
-Sends an ext reply to the client.
-
-=cut
-
-sub cf::client::ext_reply($$@) {
- my ($self, $id, @msg) = @_;
-
- if ($self->extcmd == 2) {
- $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_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
- }
+ $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
}
=item $success = $client->query ($flags, "text", \&cb)
@@ -3131,6 +3309,45 @@
1
}
+=item $client->update_command_faces
+
+=cut
+
+our %COMMAND_FACE;
+
+sub cf::client::update_command_faces {
+ my ($self) = @_;
+
+ my @faces = grep $_,
+ $COMMAND_FACE{preferred},
+ $COMMAND_FACE{standard},
+ $COMMAND_FACE{skill},
+ $self->pl->ob->flag (cf::FLAG_WIZ) ? $COMMAND_FACE{dm} : (),
+ $COMMAND_FACE{emote},
+ ;
+
+ $self->send_face ($_)
+ for @faces;
+ $self->flush_fx;
+
+ $self->ext_msg (command_list => @faces);
+}
+
+=item cf::client::set_command_face $type, $commands
+
+=cut
+
+sub cf::client::set_command_face {
+ my ($type, $list) = @_;
+
+ my $idx = &cf::face::set ( #d# ugly forward reference
+ "command_list/$type" => cf::FT_RSRC,
+ JSON::XS->new->utf8->encode ([ sort @$list ])
+ );
+
+ $COMMAND_FACE{$type} = $idx;
+}
+
cf::client->attach (
on_connect => sub {
my ($ns) = @_;
@@ -3164,20 +3381,27 @@
my $msg = eval { $ns->{json_coder}->decode ($buf) };
if (ref $msg) {
- my ($type, $reply, @payload) =
- "ARRAY" eq ref $msg
- ? @$msg
- : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
+ my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
- my @reply;
-
- if (my $cb = $EXTICMD{$type}) {
- @reply = $cb->($ns, @payload);
- }
+ if (my $cb = $EXTIACMD{$type}) {
+ $cb->(
+ $ns,
+ sub {
+ $ns->ext_msg ("reply-$reply", @_)
+ if $reply;
+ },
+ @payload
+ );
+ } else {
+ my @reply;
- $ns->ext_reply ($reply, @reply)
- if $reply;
+ if (my $cb = $EXTICMD{$type}) {
+ @reply = $cb->($ns, @payload);
+ }
+ $ns->ext_msg ("reply-$reply", @reply)
+ if $reply;
+ }
} else {
error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
}
@@ -3270,7 +3494,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;
@@ -3356,47 +3579,118 @@
#############################################################################
# the server's init and main functions
+{
+ package cf::face;
+
+ our %HASH; # hash => idx
+ our @DATA; # dynamically-created facedata, only faceste 0 used
+ our @FOFS; # file offset, if > 0
+ our @SIZE; # size of face, in octets
+ our @META; # meta hash of face, if any
+ our $DATAFH; # facedata filehandle
+
+ # internal api, not finalised
+ sub set {
+ my ($name, $type, $data) = @_;
+
+ my $idx = cf::face::find $name;
+
+ if ($idx) {
+ delete $HASH{cf::face::get_csum $idx};
+ } else {
+ $idx = cf::face::alloc $name;
+ }
+
+ my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
+
+ cf::face::set_type $idx, $type;
+ cf::face::set_csum $idx, 0, $hash;
+
+ # we need to destroy the SV itself, not just modify it, as a running ix
+ # might hold a reference to it: "delete" achieves that.
+ delete $FOFS[0][$idx];
+ delete $DATA[0][$idx];
+ $DATA[0][$idx] = $data;
+ $SIZE[0][$idx] = length $data;
+ delete $META[$idx];
+ $HASH{$hash} = $idx;#d#
+
+ $idx
+ }
+
+ sub _get_data($$$) {
+ my ($idx, $set, $cb) = @_;
+
+ if (defined $DATA[$set][$idx]) {
+ $cb->($DATA[$set][$idx]);
+ } elsif (my $fofs = $FOFS[$set][$idx]) {
+ my $size = $SIZE[$set][$idx];
+ my $buf;
+ IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
+ if ($_[0] == $size) {
+ #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
+ $cb->($buf);
+ } else {
+ cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
+ }
+ };
+ } else {
+ cf::error "requested facedata for unknown face $idx#$set, ignoring.";
+ }
+ }
+
+ # rather ineffient
+ sub cf::face::get_data($;$) {
+ my ($idx, $set) = @_;
+
+ _get_data $idx, $set, Coro::rouse_cb;
+ Coro::rouse_wait
+ }
+
+ sub cf::face::ix {
+ my ($ns, $set, $idx, $pri) = @_;
+
+ _get_data $idx, $set, sub {
+ $ns->ix_send ($idx, $pri, $_[0]);
+ };
+ }
+}
+
sub load_facedata($) {
my ($path) = @_;
- # HACK to clear player env face cache, we need some signal framework
- # for this (global event?)
- %ext::player_env::MUSIC_FACE_CACHE = ();
-
my $enc = JSON::XS->new->utf8->canonical->relaxed;
trace "loading facedata from $path\n";
- my $facedata;
- 0 < aio_load $path, $facedata
- or die "$path: $!";
-
- $facedata = Coro::Storable::thaw $facedata;
+ my $facedata = decode_storable load_file "$path/faceinfo";
$facedata->{version} == 2
- or cf::cleanup "$path: version mismatch, cannot proceed.";
+ or cf::cleanup "$path/faceinfo: 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 => $exp_table,
- hash => (Digest::MD5::md5 $exp_table),
- };
- cf::cede_to_tick;
+ my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
+ or cf::cleanup "$path/facedata: $!, cannot proceed.";
+
+ get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
+
+ # BEGIN ATOMIC
+ # from here on, everything must be atomic - no thread switch allowed
+ my $t1 = EV::time;
{
my $faces = $facedata->{faceinfo};
- while (my ($face, $info) = each %$faces) {
+ for my $face (sort keys %$faces) {
+ my $info = $faces->{$face};
my $idx = (cf::face::find $face) || cf::face::alloc $face;
cf::face::set_visibility $idx, $info->{visibility};
cf::face::set_magicmap $idx, $info->{magicmap};
- cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
- cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
-
- cf::cede_to_tick;
+ cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
+ cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
+ cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
+ $cf::face::HASH{$info->{hash64}} = $idx;
+ delete $cf::face::META[$idx];
}
while (my ($face, $info) = each %$faces) {
@@ -3411,8 +3705,6 @@
} else {
error "smooth face '$info->{smooth}' not found for face '$face'";
}
-
- cf::cede_to_tick;
}
}
@@ -3421,7 +3713,6 @@
while (my ($anim, $info) = each %$anims) {
cf::anim::set $anim, $info->{frames}, $info->{facings};
- cf::cede_to_tick;
}
cf::anim::invalidate_all; # d'oh
@@ -3431,21 +3722,36 @@
my $res = $facedata->{resource};
while (my ($name, $info) = each %$res) {
- if (defined $info->{type}) {
+ if (defined (my $type = $info->{type})) {
+ # TODO: different hash - must free and use new index, or cache ixface data queue
my $idx = (cf::face::find $name) || cf::face::alloc $name;
- cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
- cf::face::set_type $idx, $info->{type};
+ cf::face::set_type $idx, $type;
+ cf::face::set_csum $idx, 0, $info->{hash};
+ $cf::face::SIZE[0][$idx] = $info->{size};
+ $cf::face::FOFS[0][$idx] = $info->{fofs};
+ $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
+ $cf::face::HASH{$info->{hash}} = $idx;
} else {
- $RESOURCE{$name} = $info; # unused
+# $RESOURCE{$name} = $info; # unused
}
-
- cf::cede_to_tick;
}
}
+ ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
+
+ # HACK to clear player env face cache, we need some signal framework
+ # for this (global event?)
+ %ext::player_env::MUSIC_FACE_CACHE = ();
+
+ # END ATOMIC
+
+ cf::debug "facedata atomic update time ", EV::time - $t1;
+
cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
+ aio_close $fh if $fh; # close old facedata
+
1
}
@@ -3467,6 +3773,20 @@
$status
}
+sub reload_exp_table {
+ _reload_exp_table;
+
+ cf::face::set
+ "res/exp_table" => FT_RSRC,
+ JSON::XS->new->utf8->canonical->encode (
+ [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
+ );
+}
+
+sub reload_materials {
+ _reload_materials;
+}
+
sub reload_regions {
# HACK to clear player env face cache, we need some signal framework
# for this (global event?)
@@ -3482,13 +3802,39 @@
}
sub reload_facedata {
- load_facedata "$DATADIR/facedata"
+ load_facedata $DATADIR
or die "unable to load facedata\n";
}
sub reload_archetypes {
load_resource_file "$DATADIR/archetypes"
or die "unable to load archetypes\n";
+
+ cf::face::set
+ "res/skill_info" => FT_RSRC,
+ JSON::XS->new->utf8->canonical->encode (
+ [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
+ );
+
+ cf::face::set
+ "res/spell_paths" => FT_RSRC,
+ JSON::XS->new->utf8->canonical->encode (
+ [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
+ );
+
+ # command completion
+ my @commands;
+
+ for (0..cf::arch::skillvec_size - 1) {
+ my $skill = cf::arch::skillvec $_;
+ my $name = $skill->name;
+ my $flags = cf::skill_flags $skill->subtype;
+
+ push @commands, "ready_skill $name" if $flags & (SF_COMBAT | SF_RANGED | SF_GRACE);
+ push @commands, "use_skill $name" if $flags & (SF_USE | SF_AUTARK | SF_GRACE);
+ }
+
+ cf::client::set_command_face skill => \@commands;
}
sub reload_treasures {
@@ -3499,10 +3845,7 @@
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);
+ my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
for (0 .. SOUND_CAST_SPELL_0 - 1) {
my $sound = $soundconf->{compat}[$_]
@@ -3522,7 +3865,9 @@
sub reload_resources {
trace "reloading resource files...\n";
+ reload_materials;
reload_facedata;
+ reload_exp_table;
reload_sound;
reload_archetypes;
reload_regions;
@@ -3534,11 +3879,9 @@
sub reload_config {
trace "reloading config file...\n";
- open my $fh, "<:utf8", "$CONFDIR/config"
- or return;
-
- local $/;
- *CFG = YAML::XS::Load scalar <$fh>;
+ my $config = load_file "$CONFDIR/config";
+ utf8::decode $config;
+ *CFG = decode_yaml $config;
$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
@@ -3552,8 +3895,6 @@
};
warn $@ if $@;
}
-
- trace "finished reloading resource files\n";
}
sub pidfile() {
@@ -3576,11 +3917,11 @@
}
sub main_loop {
- trace "EV::loop starting\n";
+ trace "EV::run starting\n";
if (1) {
- EV::loop;
+ EV::run;
}
- trace "EV::loop returned\n";
+ trace "EV::run returned\n";
goto &main_loop unless $REALLY_UNLOOP;
}
@@ -3588,35 +3929,36 @@
cf::init_globals; # initialise logging
LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
- LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
+ LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
# we must not ever block the main coroutine
- local $Coro::idle = sub {
+ $Coro::idle = sub {
Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
(async {
$Coro::current->{desc} = "IDLE BUG HANDLER";
- EV::loop EV::LOOP_ONESHOT;
+ EV::run EV::RUN_ONCE;
})->prio (Coro::PRIO_MAX);
};
evthread_start IO::AIO::poll_fileno;
cf::sync_job {
- cf::init_experience;
+ cf::incloader::init ();
+
+ db_init;
+
cf::init_anim;
cf::init_attackmess;
cf::init_dynamic;
cf::load_settings;
- cf::load_materials;
reload_resources;
reload_config;
- db_init;
cf::init_uuid;
cf::init_signals;
@@ -3634,13 +3976,17 @@
use POSIX ();
POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
- (pop @POST_INIT)->(0) while @POST_INIT;
+ cf::_post_init 0;
};
cf::object::thawer::errors_are_fatal 0;
info "parse errors in files are no longer fatal from this point on.\n";
- main_loop;
+ AE::postpone {
+ undef &main; # free gobs of memory :)
+ };
+
+ goto &main_loop;
}
#############################################################################
@@ -3749,11 +4095,13 @@
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
@@ -3767,6 +4115,8 @@
}
info "emergency_perl_save: end player 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;
@@ -3775,6 +4125,8 @@
}
info "emergency_perl_save: end map save\n";
+ cf::write_runtime_sync; # external watchdog should not bark
+
info "emergency_perl_save: begin database checkpoint\n";
BDB::db_env_txn_checkpoint $DB_ENV;
info "emergency_perl_save: end database checkpoint\n";
@@ -3782,11 +4134,25 @@
info "emergency_perl_save: begin write uuid\n";
write_uuid_sync 1;
info "emergency_perl_save: end write uuid\n";
- };
- 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
+
+ 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
+
+ trace "emergency_perl_save: flushing outstanding aio requests";
+ while (IO::AIO::nreqs || BDB::nreqs) {
+ Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
+ }
+
+ cf::write_runtime_sync; # external watchdog should not bark
};
info "emergency_perl_save: leave\n";
@@ -3795,6 +4161,8 @@
sub post_cleanup {
my ($make_core) = @_;
+ IO::AIO::flush;
+
error Carp::longmess "post_cleanup backtrace"
if $make_core;
@@ -3829,7 +4197,7 @@
sub do_reload_perl() {
# can/must only be called in main
- if (in_main) {
+ unless (in_main) {
error "can only reload from main coroutine";
return;
}
@@ -3839,37 +4207,26 @@
my $t1 = AE::time;
while ($RELOAD) {
- info "reloading...";
+ cf::get_slot 0.1, -1, "reload_perl";
+ info "perl_reload: reloading...";
- trace "entering sync_job";
+ trace "perl_reload: 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
-
- trace "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
-
- trace "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::emergency_save;
- trace "cancelling all extension coros";
+ trace "perl_reload: cancelling all extension coros";
$_->cancel for values %EXT_CORO;
%EXT_CORO = ();
- trace "removing commands";
+ trace "perl_reload: removing commands";
%COMMAND = ();
- trace "removing ext/exti commands";
+ trace "perl_reload: removing ext/exti commands";
%EXTCMD = ();
%EXTICMD = ();
- trace "unloading/nuking all extensions";
+ trace "perl_reload: unloading/nuking all extensions";
for my $pkg (@EXTS) {
trace "... unloading $pkg";
@@ -3884,7 +4241,7 @@
clear_package $pkg;
}
- trace "unloading all perl modules loaded from $LIBDIR";
+ trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
while (my ($k, $v) = each %INC) {
next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
@@ -3901,11 +4258,11 @@
clear_package $k;
}
- trace "getting rid of safe::, as good as possible";
+ trace "perl_reload: 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);
- trace "unloading cf.pm \"a bit\"";
+ trace "perl_reload: unloading cf.pm \"a bit\"";
delete $INC{"cf.pm"};
delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
@@ -3913,44 +4270,42 @@
# and global variables created in xs
#clear_package __PACKAGE__;
- info "unload completed, starting to reload now";
+ info "perl_reload: unload completed, starting to reload now";
- trace "reloading cf.pm";
+ trace "perl_reload: reloading cf.pm";
require cf;
cf::_connect_to_perl_1;
- trace "loading config and database again";
+ trace "perl_reload: loading config and database again";
cf::reload_config;
- trace "loading extensions";
+ trace "perl_reload: loading extensions";
cf::load_extensions;
if ($REATTACH_ON_RELOAD) {
- trace "reattaching attachments to objects/players";
+ trace "perl_reload: reattaching attachments to objects/players";
_global_reattach; # objects, sockets
- trace "reattaching attachments to maps";
+ trace "perl_reload: reattaching attachments to maps";
reattach $_ for values %MAP;
- trace "reattaching attachments to players";
+ trace "perl_reload: reattaching attachments to players";
reattach $_ for values %PLAYER;
}
- trace "running post_init jobs";
- (pop @POST_INIT)->(1) while @POST_INIT;
+ cf::_post_init 1;
- trace "leaving sync_job";
+ trace "perl_reload: leaving sync_job";
1
} or do {
error $@;
- cf::cleanup "error while reloading, exiting.";
+ cf::cleanup "perl_reload: error, exiting.";
};
- info "reloaded";
--$RELOAD;
}
$t1 = AE::time - $t1;
- info "reload completed in ${t1}s\n";
+ info "perl_reload: completed in ${t1}s\n";
};
our $RELOAD_WATCHER; # used only during reload
@@ -3981,23 +4336,18 @@
}
};
-unshift @INC, $LIBDIR;
+#############################################################################
my $bug_warning = 0;
-our @WAIT_FOR_TICK;
-our @WAIT_FOR_TICK_BEGIN;
+sub wait_for_tick() {
+ return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
-sub wait_for_tick {
- return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
-
- my $signal = new Coro::Signal;
- push @WAIT_FOR_TICK, $signal;
- $signal->wait;
+ $WAIT_FOR_TICK->wait;
}
-sub wait_for_tick_begin {
- return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
+sub wait_for_tick_begin() {
+ return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
my $signal = new Coro::Signal;
push @WAIT_FOR_TICK_BEGIN, $signal;
@@ -4011,7 +4361,7 @@
return;
}
- cf::server_tick; # one server iteration
+ cf::one_tick; # one server iteration
#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
@@ -4027,9 +4377,7 @@
if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
$sig->send;
}
- while (my $sig = shift @WAIT_FOR_TICK) {
- $sig->send;
- }
+ $WAIT_FOR_TICK->broadcast;
$LOAD = ($NOW - $TICK_START) / $TICK;
$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
@@ -4045,10 +4393,11 @@
{
# configure BDB
+ info "initialising database";
BDB::min_parallel 16;
BDB::max_poll_reqs $TICK * 0.1;
- $AnyEvent::BDB::WATCHER->priority (1);
+ #$AnyEvent::BDB::WATCHER->priority (1);
unless ($DB_ENV) {
$DB_ENV = BDB::db_env_create;
@@ -4083,25 +4432,34 @@
$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
};
+
+ info "database initialised";
}
{
# configure IO::AIO
+ info "initialising aio";
IO::AIO::min_parallel 8;
IO::AIO::max_poll_time $TICK * 0.1;
undef $AnyEvent::AIO::WATCHER;
+ info "aio initialised";
}
-my $_log_backtrace;
+our $_log_backtrace;
+our $_log_backtrace_last;
sub _log_backtrace {
my ($msg, @addr) = @_;
- $msg =~ s/\n//;
+ $msg =~ s/\n$//;
+ if ($_log_backtrace_last eq $msg) {
+ LOG llevInfo, "[ABT] $msg\n";
+ LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
# limit the # of concurrent backtraces
- if ($_log_backtrace < 2) {
+ } elsif ($_log_backtrace < 2) {
+ $_log_backtrace_last = $msg;
++$_log_backtrace;
my $perl_bt = Carp::longmess $msg;
async {
@@ -4131,7 +4489,7 @@
};
} else {
LOG llevInfo, "[ABT] $msg\n";
- LOG llevInfo, "[ABT] [suppressed]\n";
+ LOG llevInfo, "[ABT] [overload, suppressed]\n";
}
}