--- deliantra/server/lib/cf.pm 2008/04/02 11:13:55 1.412
+++ deliantra/server/lib/cf.pm 2012/11/20 14:30:22 1.609
@@ -1,112 +1,146 @@
-#
+#
# This file is part of Deliantra, the Roguelike Realtime MMORPG.
-#
-# Copyright (©) 2006,2007,2008 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.
-#
+#
+# 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 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 utf8;
-use strict;
+use common::sense;
use Symbol;
use List::Util;
use Socket;
-use EV 1.86;
+use EV;
use Opcode;
use Safe;
use Safe::Hole;
use Storable ();
+use Carp ();
+
+use AnyEvent ();
+use AnyEvent::IO ();
+use AnyEvent::DNS ();
-use Coro 4.32 ();
+use Coro ();
use Coro::State;
use Coro::Handle;
use Coro::EV;
+use Coro::AnyEvent;
use Coro::Timer;
use Coro::Signal;
use Coro::Semaphore;
+use Coro::SemaphoreSet;
+use Coro::AnyEvent;
use Coro::AIO;
-use Coro::BDB;
+use Coro::BDB 1.6;
use Coro::Storable;
use Coro::Util ();
+use Guard ();
use JSON::XS 2.01 ();
use BDB ();
use Data::Dumper;
-use Digest::MD5;
use Fcntl;
-use YAML ();
-use IO::AIO 2.51 ();
-use Time::HiRes;
+use YAML::XS ();
+use IO::AIO ();
use Compress::LZF;
use Digest::MD5 ();
+AnyEvent::detect;
+
# configure various modules to our taste
#
$Storable::canonical = 1; # reduce rsync transfers
Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
-Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
+# make sure c-lzf reinitialises itself
+Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
+Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
+
+# strictly for debugging
+$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
+
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
-our $RELOAD; # number of reloads so far
+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 $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;
-our $PLAYERDIR = "$LOCALDIR/" . playerdir;
-our $RANDOMDIR = "$LOCALDIR/random";
-our $BDBDIR = "$LOCALDIR/db";
-our %RESOURCE;
+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;
+our $PLAYERDIR = "$LOCALDIR/" . playerdir;
+our $RANDOMDIR = "$LOCALDIR/random";
+our $BDBDIR = "$LOCALDIR/db";
+our $PIDFILE = "$LOCALDIR/pid";
+our $RUNTIMEFILE = "$LOCALDIR/runtime";
+
+#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 $AIO_POLL_WATCHER;
our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
our $NEXT_TICK;
-our $USE_FSYNC = 1; # use fsync to write maps - default off
+our $USE_FSYNC = 1; # use fsync to write maps - default on
-our $BDB_POLL_WATCHER;
our $BDB_DEADLOCK_WATCHER;
our $BDB_CHECKPOINT_WATCHER;
our $BDB_TRICKLE_WATCHER;
our $DB_ENV;
+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
@@ -121,16 +155,26 @@
our $JITTER; # average jitter
our $TICK_START; # for load detecting purposes
+our @POST_INIT;
+
+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;
# read virtual server time, if available
-unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
- open my $fh, "<", "$LOCALDIR/runtime"
- or die "unable to read runtime file: $!";
+unless ($RUNTIME || !-e $RUNTIMEFILE) {
+ open my $fh, "<", $RUNTIMEFILE
+ or die "unable to read $RUNTIMEFILE file: $!";
$RUNTIME = <$fh> + 0.;
}
+eval "sub TICK() { $TICK } 1" or die;
+
mkdir $_
for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
@@ -138,6 +182,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
@@ -146,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
@@ -187,48 +253,75 @@
=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
-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';
@@ -244,18 +337,23 @@
cf::object cf::object::player
cf::client cf::player
cf::arch cf::living
- cf::map cf::party cf::region
+ cf::map cf::mapspace
+ cf::party cf::region
)) {
- no strict 'refs';
@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
}
$EV::DIED = sub {
- warn "error in event callback: @_";
+ warn "error in event callback: $@";
};
#############################################################################
+sub fork_call(&@);
+sub get_slot($;$$);
+
+#############################################################################
+
=head2 UTILITY FUNCTIONS
=over 4
@@ -283,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.
@@ -298,6 +448,68 @@
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 codeblock will have a single boolean argument to indicate whether this
+is a reload or not.
+
+=cut
+
+sub post_init(&) {
+ 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.
@@ -305,7 +517,7 @@
=item my $lock = cf::lock_acquire $string
Wait until the given lock is available and then acquires it and returns
-a Coro::guard object. If the guard object gets destroyed (goes out of scope,
+a L object. If the guard object gets destroyed (goes out of scope,
for example when the coroutine gets canceled), the lock is automatically
returned.
@@ -321,56 +533,30 @@
=cut
-our %LOCK;
-our %LOCKER;#d#
+our $LOCKS = new Coro::SemaphoreSet;
sub lock_wait($) {
- my ($key) = @_;
-
- if ($LOCKER{$key} == $Coro::current) {#d#
- Carp::cluck "lock_wait($key) for already-acquired lock";#d#
- return;#d#
- }#d#
-
- # wait for lock, if any
- while ($LOCK{$key}) {
- push @{ $LOCK{$key} }, $Coro::current;
- Coro::schedule;
- }
+ $LOCKS->wait ($_[0]);
}
sub lock_acquire($) {
- my ($key) = @_;
-
- # wait, to be sure we are not locked
- lock_wait $key;
-
- $LOCK{$key} = [];
- $LOCKER{$key} = $Coro::current;#d#
-
- Coro::guard {
- delete $LOCKER{$key};#d#
- # wake up all waiters, to be on the safe side
- $_->ready for @{ delete $LOCK{$key} };
- }
+ $LOCKS->guard ($_[0])
}
sub lock_active($) {
- my ($key) = @_;
-
- ! ! $LOCK{$key}
+ $LOCKS->count ($_[0]) < 1
}
sub freeze_mainloop {
tick_inhibit_inc;
- Coro::guard \&tick_inhibit_dec;
+ &Guard::guard (\&tick_inhibit_dec);
}
=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
@@ -384,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.
@@ -397,41 +587,49 @@
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;
}
}
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->wait;
} else {
+ $busy = 0;
Coro::schedule;
}
}
};
sub get_slot($;$$) {
+ return if tick_inhibit || $Coro::current == $Coro::main;
+
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];
@@ -467,13 +665,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;
@@ -483,7 +681,7 @@
(async {
$Coro::current->desc ("sync job coro");
@res = eval { $job->() };
- warn $@ if $@;
+ error $@ if $@;
undef $busy;
})->prio (Coro::PRIO_MAX);
@@ -495,7 +693,7 @@
}
}
- my $time = EV::time - $time;
+ my $time = AE::time - $time;
$TICK_START += $time; # do not account sync jobs to server load
@@ -527,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
@@ -536,21 +734,59 @@
=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]
}
+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
+
+our %coin_alias = (
+ "silver" => "silvercoin",
+ "silvercoin" => "silvercoin",
+ "silvercoins" => "silvercoin",
+ "gold" => "goldcoin",
+ "goldcoin" => "goldcoin",
+ "goldcoins" => "goldcoin",
+ "platinum" => "platinacoin",
+ "platinumcoin" => "platinacoin",
+ "platinumcoins" => "platinacoin",
+ "platina" => "platinacoin",
+ "platinacoin" => "platinacoin",
+ "platinacoins" => "platinacoin",
+ "royalty" => "royalty",
+ "royalties" => "royalty",
+);
+
+sub coin_from_name($) {
+ $coin_alias{$_[0]}
+ ? cf::arch::find $coin_alias{$_[0]}
+ : undef
+}
+
=item $value = cf::db_get $family => $key
Returns a single value from the environment database.
@@ -568,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;
@@ -587,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($$$) {
@@ -638,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
@@ -662,11 +899,11 @@
}
}
- my $t1 = Time::HiRes::time;
+ my $t1 = EV::time;
my $data = $process->(\@data);
- my $t2 = Time::HiRes::time;
+ my $t2 = EV::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;
@@ -686,7 +923,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
@@ -697,7 +934,7 @@
=head2 ATTACHABLE OBJECTS
-Many objects in crossfire are so-called attachable objects. That means you can
+Many objects in deliantra are so-called attachable objects. That means you can
attach callbacks/event handlers (a collection of which is called an "attachment")
to it. All such attachable objects support the following methods.
@@ -757,7 +994,7 @@
Register an attachment by C<$name> through which attachable objects of the
given CLASS can refer to this attachment.
-Some classes such as crossfire maps and objects can specify attachments
+Some classes such as deliantra maps and objects can specify attachments
that are attached at load/instantiate time, thus the need for a name.
These calls expect any number of the following handler/hook descriptions:
@@ -891,11 +1128,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";
}
}
}
@@ -915,7 +1152,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;
@@ -984,8 +1221,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;
}
@@ -1058,7 +1294,8 @@
# basically do the same as instantiate, without calling instantiate
my ($obj) = @_;
- bless $obj, ref $obj; # re-bless in case extensions have been reloaded
+ # no longer needed after getting rid of delete_package?
+ #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
my $registry = $obj->registry;
@@ -1073,7 +1310,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";
}
}
}
@@ -1110,22 +1347,29 @@
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) {
- chmod SAVE_MODE, $fh;
+ aio_chmod $fh, SAVE_MODE;
aio_write $fh, 0, (length $$rdata), $$rdata, 0;
- aio_fsync $fh if $cf::USE_FSYNC;
- close $fh;
+ if ($cf::USE_FSYNC) {
+ aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
+ aio_fsync $fh;
+ }
+ aio_close $fh;
if (@$objs) {
if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
- chmod SAVE_MODE, $fh;
+ aio_chmod $fh, SAVE_MODE;
my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
aio_write $fh, 0, (length $data), $data, 0;
- aio_fsync $fh if $cf::USE_FSYNC;
- close $fh;
+ if ($cf::USE_FSYNC) {
+ aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
+ aio_fsync $fh;
+ }
+ aio_close $fh;
aio_rename "$filename.pst~", "$filename.pst";
}
} else {
@@ -1133,8 +1377,11 @@
}
aio_rename "$filename~", $filename;
+
+ $filename =~ s%/[^/]+$%%;
+ aio_pathsync $filename if $cf::USE_FSYNC;
} else {
- warn "FATAL: $filename~: $!\n";
+ error "unable to save objects: $filename~: $!\n";
}
} else {
aio_unlink $filename;
@@ -1168,8 +1415,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)
}
@@ -1183,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.
@@ -1199,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
@@ -1207,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_exticmd $name => \&callback($ns,$packet);
+=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
+
+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
@@ -1218,25 +1470,43 @@
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 (
- on_command => sub {
+ on_unknown_command => sub {
my ($pl, $name, $params) = @_;
my $cb = $COMMAND{$name}
@@ -1254,29 +1524,65 @@
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
- my @reply;
+ if (my $cb = $EXTACMD{$type}) {
+ $cb->(
+ $pl,
+ sub {
+ $pl->ext_msg ("reply-$reply", @_)
+ if $reply;
+ },
+ @payload
+ );
+ } else {
+ my @reply;
- if (my $cb = $EXTCMD{$type}) {
- @reply = $cb->($pl, @payload);
- }
+ if (my $cb = $EXTCMD{$type}) {
+ @reply = $cb->($pl, @payload);
+ }
- $pl->ext_reply ($reply, @reply)
- if $reply;
+ $pl->ext_msg ("reply-$reply", @reply)
+ 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;
},
);
+# "readahead" all extensions
+sub cache_extensions {
+ my $grp = IO::AIO::aio_group;
+
+ add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
+ for (grep /\.ext$/, @{$_[0]}) {
+ add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
+ }
+ };
+
+ $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;
@@ -1304,7 +1610,7 @@
if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
$ext{source} =
- "package $pkg; use strict; use utf8;\n"
+ "package $pkg; use common::sense;\n"
. "#line 1 \"$path\"\n{\n"
. $source
. "\n};\n1";
@@ -1312,38 +1618,61 @@
$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 $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";
- $done{$k} = delete $todo{$k};
- push @EXTS, $v->{pkg};
- $progress = 1;
+ 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};
+ }
+
+ last;
+ }
}
};
}
@@ -1354,7 +1683,7 @@
=head2 CORE EXTENSIONS
-Functions and methods that extend core crossfire objects.
+Functions and methods that extend core deliantra objects.
=cut
@@ -1407,7 +1736,7 @@
my ($login) = @_;
$cf::PLAYER{$login}
- or cf::sync_job { !aio_stat path $login }
+ or !aio_stat path $login
}
sub find($) {
@@ -1429,6 +1758,7 @@
my $pl = cf::player::load_pl $f
or return;
+
local $cf::PLAYER_LOADING{$login} = $pl;
$f->resolve_delayed_derefs;
$cf::PLAYER{$login} = $pl
@@ -1436,6 +1766,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) = @_;
@@ -1449,6 +1792,11 @@
aio_mkdir playerdir $pl, 0770;
$pl->{last_save} = $cf::RUNTIME;
+ 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;
}
@@ -1489,11 +1837,15 @@
my $name = $pl->ob->name;
$pl->{deny_save} = 1;
- $pl->password ("*"); # this should lock out the player until we nuked the dir
+ $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;
- $pl->invoke (cf::EVENT_PLAYER_QUIT);
+
+ my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
+ $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
+ ext::highscore::check ($pl->ob);
+
$pl->ns->destroy if $pl->ns;
my $path = playerdir $pl;
@@ -1541,7 +1893,8 @@
my $path = path $login;
# a .pst is a dead give-away for a valid player
- unless (-e "$path.pst") {
+ # if no pst file found, open and chekc for blocked users
+ if (aio_stat "$path.pst") {
my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
aio_read $fh, 0, 512, my $buf, 0 or next;
$buf !~ /^password -------------$/m or next; # official not-valid tag
@@ -1556,6 +1909,8 @@
=item $player->maps
+=item cf::player::maps $login
+
Returns an arrayref of map paths that are private for this
player. May block.
@@ -1582,110 +1937,9 @@
\@paths
}
-=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
-
-Expand crossfire pod fragments into protocol xml.
-
-=cut
-
-use re 'eval';
-
-my $group;
-my $interior; $interior = qr{
- # match a pod interior sequence sans C<< >>
- (?:
- \ (.*?)\ (?{ $group = $^N })
- | < (??{$interior}) >
- )
-}x;
-
-sub expand_cfpod {
- my ($self, $pod) = @_;
-
- my $xml;
-
- while () {
- if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
- $group = $1;
-
- $group =~ s/&/&/g;
- $group =~ s/</g;
-
- $xml .= $group;
- } elsif ($pod =~ m%\G
- ([BCGHITU])
- <
- (?:
- ([^<>]*) (?{ $group = $^N })
- | < $interior >
- )
- >
- %gcsx
- ) {
- my ($code, $data) = ($1, $group);
-
- if ($code eq "B") {
- $xml .= "" . expand_cfpod ($self, $data) . "";
- } elsif ($code eq "I") {
- $xml .= "" . expand_cfpod ($self, $data) . "";
- } elsif ($code eq "U") {
- $xml .= "" . expand_cfpod ($self, $data) . "";
- } elsif ($code eq "C") {
- $xml .= "" . expand_cfpod ($self, $data) . "";
- } elsif ($code eq "T") {
- $xml .= "" . expand_cfpod ($self, $data) . "";
- } elsif ($code eq "G") {
- my ($male, $female) = split /\|/, $data;
- $data = $self->gender ? $female : $male;
- $xml .= expand_cfpod ($self, $data);
- } elsif ($code eq "H") {
- $xml .= ("[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]",
- "[Hint suppressed, see hintmode]",
- "")
- [$self->{hintmode}];
- } else {
- $xml .= "error processing '$code($data)' directive";
- }
- } else {
- if ($pod =~ /\G(.+)/) {
- warn "parse error while expanding $pod (at $1)";
- }
- last;
- }
- }
-
- for ($xml) {
- # create single paragraphs (very hackish)
- s/(?<=\S)\n(?=\w)/ /g;
-
- # compress some whitespace
- s/\s+\n/\n/g; # ws line-ends
- s/\n\n+/\n/g; # double lines
- s/^\n+//; # beginning lines
- s/\n+$//; # ending lines
- }
-
- $xml
-}
-
-no re 'eval';
-
-sub hintmode {
- $_[0]{hintmode} = $_[1] if @_ > 1;
- $_[0]{hintmode}
-}
-
-=item $player->ext_reply ($msgid, @msg)
-
-Sends an ext reply to the player.
-
-=cut
-
-sub ext_reply($$@) {
- my ($self, $id, @msg) = @_;
+=item $protocol_xml = $player->expand_cfpod ($cfpod)
- $self->ns->ext_reply ($id, @msg)
-}
+Expand deliantra pod fragments into protocol xml.
=item $player->ext_msg ($type, @msg)
@@ -1716,6 +1970,8 @@
sub find_by_path($) {
my ($path) = @_;
+ $path =~ s/^~[^\/]*//; # skip ~login
+
my ($match, $specificity);
for my $region (list) {
@@ -1750,20 +2006,10 @@
sub generate_random_map {
my ($self, $rmp) = @_;
- # 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->{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}
- )
+
+ my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
+
+ $self->_create_random_map ($rmp);
}
=item cf::map->register ($regex, $prio)
@@ -1778,14 +2024,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) = @_;
@@ -1800,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$//;
@@ -1825,7 +2070,6 @@
}
for ($path) {
- redo if s{//}{/};
redo if s{/\.?/}{/};
redo if s{/[^/]+/\.\./}{/};
}
@@ -1849,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) = @_;
@@ -1881,7 +2126,7 @@
sub save_path {
my ($self) = @_;
- (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
+ (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
"$TMPDIR/$path.map"
}
@@ -1889,19 +2134,10 @@
sub uniq_path {
my ($self) = @_;
- (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
+ (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
"$UNIQUEDIR/$path"
}
-# and all this just because we cannot iterate over
-# all maps in C++...
-sub change_all_map_light {
- my ($change) = @_;
-
- $_->change_map_light ($change)
- for grep $_->outdoor, values %cf::MAP;
-}
-
sub decay_objects {
my ($self) = @_;
@@ -1936,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) = @_;
@@ -1958,6 +2197,7 @@
if $self->{instantiate_time} > $cf::RUNTIME;
}
+# called after loading the header from an original map
sub prepare_orig {
my ($self) = @_;
@@ -1991,15 +2231,14 @@
sub find {
my ($path, $origin) = @_;
- $path = normalise $path, $origin && $origin->path;
+ cf::cede_to_tick;
- cf::lock_wait "map_data:$path";#d#remove
- cf::lock_wait "map_find:$path";
+ $path = normalise $path, $origin;
- $cf::MAP{$path} || do {
- my $guard1 = cf::lock_acquire "map_find:$path";
- my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
+ my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
+ my $guard2 = cf::lock_acquire "map_find:$path";
+ $cf::MAP{$path} || do {
my $map = new_from_path cf::map $path
or return;
@@ -2011,8 +2250,8 @@
if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
# doing this can freeze the server in a sync job, obviously
#$cf::WAIT_FOR_TICK->wait;
- undef $guard1;
undef $guard2;
+ undef $guard1;
$map->reset;
return find $path;
}
@@ -2021,8 +2260,8 @@
}
}
-sub pre_load { }
-sub post_load { }
+sub pre_load { }
+#sub post_load { } # XS
sub load {
my ($self) = @_;
@@ -2035,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->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
- 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
@@ -2077,20 +2321,21 @@
$self->fix_auto_apply;
$self->update_buttons;
cf::cede_to_tick;
- $self->set_darkness_map;
- 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_IN_MEMORY);
}
$self->post_load;
+
+ 1
}
+# 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) = @_;
@@ -2103,45 +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;
-
- 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;
@@ -2150,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_IN_MEMORY;
+ return $map if !$load || $map->linkable;
}
$MAP_PREFETCH{$path} |= $load;
@@ -2177,11 +2401,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;
@@ -2200,6 +2423,8 @@
$_->contr->save for $self->players;
};
+ cf::get_slot 0.02;
+
if ($uniq) {
$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
$self->_save_objects ($uniq, cf::IO_UNIQUES);
@@ -2208,22 +2433,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_IN_MEMORY;
+ return if !$self->linkable;
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->state (cf::MAP_SWAPPED);
+
+ # then atomically save
+ $self->_save;
+
+ # then free the map
$self->clear;
}
@@ -2252,9 +2487,9 @@
return if $self->players;
- warn "resetting map ", $self->path;
+ 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}) {
@@ -2286,7 +2521,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);
@@ -2345,14 +2580,45 @@
[
map {
utf8::decode $_;
- /\.map$/
- ? normalise $_
- : ()
+ s/\.map$//; # TODO future compatibility hack
+ /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
+ ? ()
+ : normalise $_
} @{ aio_readdir $UNIQUEDIR or [] }
]
}
-package cf;
+=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
@@ -2366,7 +2632,8 @@
=item $ob->inv_recursive
-Returns the inventory of the object _and_ their inventories, recursively.
+Returns the inventory of the object I their inventories, recursively,
+but I the object itself.
=cut
@@ -2381,11 +2648,11 @@
=item $ref = $ob->ref
-creates and returns a persistent reference to an objetc that can be stored as a string.
+Creates and returns a persistent reference to an object that can be stored as a string.
=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
@@ -2423,6 +2690,20 @@
=cut
+our $SAY_CHANNEL = {
+ id => "say",
+ title => "Map",
+ reply => "say ",
+ tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
+};
+
+our $CHAT_CHANNEL = {
+ id => "chat",
+ title => "Chat",
+ reply => "chat ",
+ tooltip => "Player chat and shouts, global to the server.",
+};
+
# rough implementation of a future "reply" method that works
# with dialog boxes.
#TODO: the first argument must go, split into a $npc->reply_to ( method
@@ -2443,7 +2724,7 @@
} else {
$msg = $npc->name . " says: $msg" if $npc;
- $self->message ($msg, $flags);
+ $self->send_msg ($SAY_CHANNEL => $msg, $flags);
}
}
}
@@ -2478,8 +2759,10 @@
Freezes the player and moves him/her to a special map (C<{link}>).
-The player should be reasonably safe there for short amounts of time. You
-I call C as soon as possible, though.
+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 player cannot control the character while it is on the link
+map.
Will never block.
@@ -2509,12 +2792,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 {
@@ -2541,19 +2826,23 @@
# 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->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 +2850,9 @@
the new (success) or old (failed) map position. In either case, $done will
be called at the end of this process.
+Note that $check will be called with a potentially non-loaded map, so if
+it needs a loaded map it has to call C<< ->load >>.
+
=cut
our $GOTOGEN;
@@ -2568,6 +2860,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;
@@ -2596,11 +2894,11 @@
}
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);
- $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);
}
@@ -2618,7 +2916,7 @@
$self->leave_link ($map, $x, $y);
}
- $done->() if $done;
+ $done->($self) if $done;
})->prio (1);
}
@@ -2648,8 +2946,6 @@
sub prepare_random_map {
my ($exit) = @_;
- my $guard = cf::lock_acquire "exit_prepare:$exit";
-
# all this does is basically replace the /! path by
# a new random map path (?random/...) with a seed
# that depends on the exit object
@@ -2661,11 +2957,13 @@
$rmp->{origin_map} = $exit->map->path;
$rmp->{origin_x} = $exit->x;
$rmp->{origin_y} = $exit->y;
+
+ $exit->map->touch;
}
$rmp->{random_seed} ||= $exit->random_seed;
- my $data = cf::encode_json $rmp;
+ my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
my $md5 = Digest::MD5::md5_hex $data;
my $meta = "$RANDOMDIR/$md5.meta";
@@ -2674,8 +2972,12 @@
undef $fh;
aio_rename "$meta~", $meta;
- $exit->slaying ("?random/$md5");
- $exit->msg (undef);
+ my $slaying = "?random/$md5";
+
+ if ($exit->valid) {
+ $exit->slaying ("?random/$md5");
+ $exit->msg (undef);
+ }
}
}
@@ -2684,38 +2986,55 @@
return unless $self->type == cf::PLAYER;
- if ($exit->slaying eq "/!") {
- #TODO: this should de-fi-ni-te-ly not be a sync-job
- # the problem is that $exit might not survive long enough
- # so it needs to be done right now, right here
- cf::sync_job { prepare_random_map $exit };
- }
-
- my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
- my $hp = $exit->stats->hp;
- my $sp = $exit->stats->sp;
-
$self->enter_link;
- # if exit is damned, update players death & WoR home-position
- $self->contr->savebed ($slaying, $hp, $sp)
- if $exit->flag (FLAG_DAMNED);
-
(async {
- $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
+ $Coro::current->{desc} = "enter_exit";
- $self->deactivate_recursive; # just to be sure
unless (eval {
- $self->goto ($slaying, $hp, $sp);
+ $self->deactivate_recursive; # just to be sure
+
+ 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 "/!"; # need to re-check after getting the lock
- 1;
+ $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);
+
+ # if exit is damned, update players death & WoR home-position
+ $self->contr->savebed ($map, $x, $y)
+ if $exit->flag (cf::FLAG_DAMNED);
+
+ 1
}) {
- $self->message ("Something went wrong deep within the crossfire server. "
+ $self->message ("Something went wrong deep within the deliantra server. "
. "I'll try to bring you back to the map you were before. "
. "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);
@@ -2725,31 +3044,48 @@
=over 4
-=item $client->send_drawinfo ($text, $flags)
+=item $client->send_big_packet ($pkt)
-Sends a drawinfo packet to the client. Circumvents output buffering so
-should not be used under normal circumstances.
+Like C, but tries to compress large packets, and fragments
+them as required.
=cut
-sub cf::client::send_drawinfo {
- my ($self, $text, $flags) = @_;
+our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
- utf8::encode $text;
- $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
+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
-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
# 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",
@@ -2762,6 +3098,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",
@@ -2786,6 +3128,42 @@
reply => undef,
tooltip => "Shows which body parts you posess and are available",
},
+ "c/statistics" => {
+ id => "infobox",
+ title => "Statistics",
+ reply => undef,
+ tooltip => "Shows your primary statistics",
+ },
+ "c/skills" => {
+ id => "infobox",
+ title => "Skills",
+ reply => undef,
+ tooltip => "Shows your experience per skill and item power",
+ },
+ "c/shopitems" => {
+ id => "infobox",
+ title => "Shop Items",
+ reply => undef,
+ tooltip => "Shows the items currently for sale in this shop",
+ },
+ "c/resistances" => {
+ id => "infobox",
+ title => "Resistances",
+ reply => undef,
+ tooltip => "Shows your resistances",
+ },
+ "c/pets" => {
+ id => "infobox",
+ title => "Pets",
+ reply => undef,
+ tooltip => "Shows information abotu your pets/a specific pet",
+ },
+ "c/perceiveself" => {
+ id => "infobox",
+ title => "Perceive Self",
+ reply => undef,
+ tooltip => "You gained detailed knowledge about yourself",
+ },
"c/uptime" => {
id => "infobox",
title => "Uptime",
@@ -2798,12 +3176,33 @@
reply => undef,
tooltip => "Information related to the maps",
},
+ "c/party" => {
+ id => "party",
+ title => "Party",
+ reply => "gsay ",
+ tooltip => "Messages and chat related to your party",
+ },
+ "c/death" => {
+ id => "death",
+ title => "Death",
+ 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,
);
sub cf::client::send_msg {
my ($self, $channel, $msg, $color, @extra) = @_;
- $msg = $self->pl->expand_cfpod ($msg);
+ $msg = $self->pl->expand_cfpod ($msg)
+ unless $color & cf::NDI_VERBATIM;
$color &= cf::NDI_CLIENT_MASK; # just in case...
@@ -2811,17 +3210,14 @@
if ($CHANNEL{$channel}) {
$channel = $CHANNEL{$channel};
- $self->ext_msg (channel_info => $channel)
- if $self->can_msg;
-
+ $self->ext_msg (channel_info => $channel);
$channel = $channel->{id};
} elsif (ref $channel) {
# send meta info to client, if not yet sent
unless (exists $self->{channel}{$channel->{id}}) {
$self->{channel}{$channel->{id}} = $channel;
- $self->ext_msg (channel_info => $channel)
- if $self->can_msg;
+ $self->ext_msg (channel_info => $channel);
}
$channel = $channel->{id};
@@ -2829,38 +3225,16 @@
return unless @extra || length $msg;
- if ($self->can_msg) {
- # default colour, mask it out
- $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
- if $color & cf::NDI_DEF;
+ # default colour, mask it out
+ $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
+ if $color & cf::NDI_DEF;
+
+ my $pkt = "msg "
+ . $self->{json_coder}->encode (
+ [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
+ );
- $self->send_packet ("msg " . $self->{json_coder}->encode (
- [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
- } else {
- if ($color >= 0) {
- # replace some tags by gcfclient-compatible ones
- for ($msg) {
- 1 while
- s/([^<]*)<\/b>/[b]${1}[\/b]/
- || s/([^<]*)<\/i>/[i]${1}[\/i]/
- || s/([^<]*)<\/u>/[ul]${1}[\/ul]/
- || s/([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
- || s/([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
- }
-
- $color &= cf::NDI_COLOR_MASK;
-
- utf8::encode $msg;
-
- if (0 && $msg =~ /\[/) {
- # COMMAND/INFO
- $self->send_packet ("drawextinfo $color 10 8 $msg")
- } else {
- $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
- $self->send_packet ("drawinfo $color $msg")
- }
- }
- }
+ $self->send_big_packet ($pkt);
}
=item $client->ext_msg ($type, @msg)
@@ -2872,30 +3246,7 @@
sub cf::client::ext_msg($$@) {
my ($self, $type, @msg) = @_;
- if ($self->extcmd == 2) {
- $self->send_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}));
- }
-}
-
-=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_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 ([$type, @msg]));
}
=item $success = $client->query ($flags, "text", \&cb)
@@ -2927,6 +3278,36 @@
1
}
+=item $client->update_command_faces
+
+=cut
+
+our @COMMAND_FACES; # [normal commands, emotes, dm commands]
+
+sub cf::client::update_command_faces {
+ my ($self) = @_;
+
+ my @faces = (
+ $COMMAND_FACES[0],
+ $COMMAND_FACES[1],
+ $self->pl->ob->flag (cf::FLAG_WIZ) ? $COMMAND_FACES[2] : ()
+ );
+
+ $self->send_face ($_)
+ for @faces;
+ $self->flush_fx;
+
+ $self->ext_msg (command_list => @faces);
+}
+
+=item cf::client::set_command_faces $normal_commands, $emotes, $dm_commands
+
+=cut
+
+sub cf::client::set_command_faces {
+ @COMMAND_FACES = @_;
+}
+
cf::client->attach (
on_connect => sub {
my ($ns) = @_;
@@ -2960,22 +3341,29 @@
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 @reply;
+ my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
- 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 {
- 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;
@@ -3005,7 +3393,7 @@
}
cf::client->attach (
- on_destroy => sub {
+ on_client_destroy => sub {
my ($ns) = @_;
$_->cancel for values %{ (delete $ns->{_coro}) || {} };
@@ -3031,7 +3419,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
));
@@ -3044,7 +3432,8 @@
cf::object
contr pay_amount pay_player map x y force_find force_add destroy
- insert remove name archname title slaying race decrease_ob_nr
+ insert remove name archname title slaying race decrease split
+ value
cf::object::player
player
@@ -3059,13 +3448,12 @@
for (
["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
- insert remove inv name archname title slaying race
- decrease_ob_nr destroy)],
+ insert remove inv nrof name archname title slaying race
+ decrease split destroy change_exp value msg lore send_msg)],
["cf::object::player" => qw(player)],
- ["cf::player" => qw(peaceful)],
+ ["cf::player" => qw(peaceful send_msg)],
["cf::map" => qw(trigger)],
) {
- no strict 'refs';
my ($pkg, @funs) = @$_;
*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
for @funs;
@@ -3090,8 +3478,10 @@
$qcode =~ s/"/‟/g; # not allowed in #line filenames
$qcode =~ s/\n/\\n/g;
+ %vars = (_dummy => 0) unless %vars;
+
+ my @res;
local $_;
- local @safe::cf::_safe_eval_args = values %vars;
my $eval =
"do {\n"
@@ -3101,14 +3491,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]
@@ -3132,8 +3528,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
@@ -3143,45 +3539,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;
- warn "loading facedata from $path\n";
-
- my $facedata;
- 0 < aio_load $path, $facedata
- or die "$path: $!";
+ trace "loading facedata from $path\n";
- $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
- $facedata->{resource}{"res/exp_table"} = {
- type => FT_RSRC,
- data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
- };
- 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}, Digest::MD5::md5 $info->{data32};
- cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
-
- 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) {
@@ -3194,10 +3663,8 @@
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;
}
}
@@ -3206,69 +3673,47 @@
while (my ($anim, $info) = each %$anims) {
cf::anim::set $anim, $info->{frames}, $info->{facings};
- cf::cede_to_tick;
}
cf::anim::invalidate_all; # d'oh
}
{
- # 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}) {
+ 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;
- 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_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;
+# $RESOURCE{$name} = $info; # unused
}
-
- cf::cede_to_tick;
}
}
- cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
+ ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
- 1
-}
+ # HACK to clear player env face cache, we need some signal framework
+ # for this (global event?)
+ %ext::player_env::MUSIC_FACE_CACHE = ();
-cf::global->attach (on_resource_update => sub {
- if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
- $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
+ # END ATOMIC
- for (0 .. SOUND_CAST_SPELL_0 - 1) {
- my $sound = $soundconf->{compat}[$_]
- or next;
+ cf::debug "facedata atomic update time ", EV::time - $t1;
- my $face = cf::face::find "sound/$sound->[1]";
- cf::sound::set $sound->[0] => $face;
- cf::sound::old_sound_index $_, $face; # gcfclient-compat
- }
+ cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
- while (my ($k, $v) = each %{$soundconf->{event}}) {
- my $face = cf::face::find "sound/$v";
- cf::sound::set $k => $face;
- }
- }
-});
+ aio_close $fh if $fh; # close old facedata
+
+ 1
+}
register_exticmd fx_want => sub {
my ($ns, $want) = @_;
@@ -3278,6 +3723,30 @@
}
};
+sub load_resource_file($) {
+ my $guard = lock_acquire "load_resource_file";
+
+ my $status = load_resource_file_ $_[0];
+ get_slot 0.1, 100;
+ cf::arch::commit_load;
+
+ $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?)
@@ -3293,18 +3762,25 @@
}
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";
- #d# NEED to laod twice to resolve forward references
- # this really needs to be done in an extra post-pass
- # (which needs to be synchronous, so solve it differently)
- 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]
+ );
}
sub reload_treasures {
@@ -3312,30 +3788,48 @@
or die "unable to load treasurelists\n";
}
+sub reload_sound {
+ trace "loading sound config from $DATADIR/sound\n";
+
+ my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
+
+ 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_regions;
+ reload_materials;
reload_facedata;
- #reload_archetypes;#d#
+ reload_exp_table;
+ reload_sound;
reload_archetypes;
+ reload_regions;
reload_treasures;
- warn "finished reloading resource files\n";
-}
-
-sub init {
- reload_resources;
+ trace "finished reloading resource files\n";
}
sub reload_config {
- open my $fh, "<:utf8", "$CONFDIR/config"
- or return;
+ trace "reloading config file...\n";
- local $/;
- *CFG = YAML::Load <$fh>;
+ my $config = load_file "$CONFDIR/config";
+ utf8::decode $config;
+ *CFG = decode_yaml $config;
- $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};
@@ -3349,9 +3843,46 @@
}
}
+sub pidfile() {
+ sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
+ or die "$PIDFILE: $!";
+ flock $fh, &Fcntl::LOCK_EX
+ or die "$PIDFILE: flock: $!";
+ $fh
+}
+
+# make sure only one server instance is running at any one time
+sub atomic {
+ my $fh = pidfile;
+
+ my $pid = <$fh>;
+ kill 9, $pid if $pid > 0;
+
+ seek $fh, 0, 0;
+ print $fh $$;
+}
+
+sub main_loop {
+ trace "EV::loop starting\n";
+ if (1) {
+ EV::loop;
+ }
+ trace "EV::loop returned\n";
+ goto &main_loop unless $REALLY_UNLOOP;
+}
+
sub main {
+ cf::init_globals; # initialise logging
+
+ LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
+ 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";
@@ -3359,13 +3890,49 @@
})->prio (Coro::PRIO_MAX);
};
- reload_config;
- db_init;
- load_extensions;
+ evthread_start IO::AIO::poll_fileno;
- $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
- evthread_start;
- EV::loop;
+ cf::sync_job {
+ cf::incloader::init ();
+
+ db_init;
+
+ cf::init_anim;
+ cf::init_attackmess;
+ cf::init_dynamic;
+
+ cf::load_settings;
+
+ reload_resources;
+ reload_config;
+
+ cf::init_uuid;
+ cf::init_signals;
+ cf::init_skills;
+
+ cf::init_beforeplay;
+
+ atomic;
+
+ load_extensions;
+
+ utime time, time, $RUNTIMEFILE;
+
+ # no (long-running) fork's whatsoever before this point(!)
+ use POSIX ();
+ POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
+
+ 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";
+
+ AE::postpone {
+ undef &main; # free gobs of memory :)
+ };
+
+ goto &main_loop;
}
#############################################################################
@@ -3375,23 +3942,23 @@
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 {
- my $runtime = "$LOCALDIR/runtime";
+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.
- IO::AIO::aio_utime $runtime, undef, undef;
+ IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
my $guard = cf::lock_acquire "write_runtime";
- my $fh = aio_open "$runtime~", 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;
@@ -3411,170 +3978,280 @@
close $fh
or return;
- aio_rename "$runtime~", $runtime
+ aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
+ and return;
+
+ trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
+
+ 1
+}
+
+our $uuid_lock;
+our $uuid_skip;
+
+sub write_uuid_sync($) {
+ $uuid_skip ||= $_[0];
+
+ return if $uuid_lock;
+ local $uuid_lock = 1;
+
+ my $uuid = "$LOCALDIR/uuid";
+
+ my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
+ or return;
+
+ my $value = uuid_seq uuid_cur;
+
+ unless ($value) {
+ info "cowardly refusing to write zero uuid value!\n";
+ return;
+ }
+
+ my $value = uuid_str $value + $uuid_skip;
+ $uuid_skip = 0;
+
+ (aio_write $fh, 0, (length $value), $value, 0) <= 0
+ and return;
+
+ # always fsync - this file is important
+ aio_fsync $fh
+ and return;
+
+ close $fh
+ or return;
+
+ aio_rename "$uuid~", $uuid
and return;
- warn "runtime file written.\n";
+ trace "uuid file written ($value).\n";
1
+
+}
+
+sub write_uuid($$) {
+ my ($skip, $sync) = @_;
+
+ $sync ? write_uuid_sync $skip
+ : async { write_uuid_sync $skip };
}
sub emergency_save() {
my $freeze_guard = cf::freeze_mainloop;
- warn "enter emergency perl save\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 {
+ 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 "begin emergency 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 "end emergency player save\n";
+ info "emergency_perl_save: end player save\n";
+
+ cf::write_runtime_sync; # external watchdog should not bark
- warn "begin emergency map save\n";
+ 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 "end emergency map save\n";
+ 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";
+
+ info "emergency_perl_save: begin write uuid\n";
+ write_uuid_sync 1;
+ info "emergency_perl_save: end write uuid\n";
+
+ cf::write_runtime_sync; # external watchdog should not bark
- warn "begin emergency database checkpoint\n";
+ trace "emergency_perl_save: syncing database to disk";
BDB::db_env_txn_checkpoint $DB_ENV;
- warn "end emergency database checkpoint\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: 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
};
- warn "leave emergency perl save\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;
+ unlink $PIDFILE if <$fh> == $$;
}
-sub do_reload_perl() {
- # can/must only be called in main
- if ($Coro::current != $Coro::main) {
- warn "can only reload from main coroutine";
- return;
- }
+# a safer delete_package, copied from Symbol
+sub clear_package($) {
+ my $pkg = shift;
- warn "reloading...";
+ # expand to full symbol table name if needed
+ unless ($pkg =~ /^main::.*::$/) {
+ $pkg = "main$pkg" if $pkg =~ /^::/;
+ $pkg = "main::$pkg" unless $pkg =~ /^main::/;
+ $pkg .= '::' unless $pkg =~ /::$/;
+ }
- warn "entering sync_job";
+ my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+ my $stem_symtab = *{$stem}{HASH};
- cf::sync_job {
- cf::write_runtime; # external watchdog should not bark
- cf::emergency_save;
- cf::write_runtime; # external watchdog should not bark
+ defined $stem_symtab and exists $stem_symtab->{$leaf}
+ or return;
- warn "syncing database to disk";
- BDB::db_env_txn_checkpoint $DB_ENV;
+ # clear all symbols
+ my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
+ for my $name (keys %$leaf_symtab) {
+ _gv_clear *{"$pkg$name"};
+# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
+ }
+}
- # if anything goes wrong in here, we should simply crash as we already saved
+sub do_reload_perl() {
+ # can/must only be called in main
+ unless (in_main) {
+ error "can only reload from main coroutine";
+ return;
+ }
- warn "flushing outstanding aio requests";
- for (;;) {
- BDB::flush;
- IO::AIO::flush;
- Coro::cede_notself;
- last unless IO::AIO::nreqs || BDB::nreqs;
- warn "iterate...";
- }
+ return if $RELOAD++;
- ++$RELOAD;
+ my $t1 = AE::time;
- warn "cancelling all extension coros";
- $_->cancel for values %EXT_CORO;
- %EXT_CORO = ();
+ while ($RELOAD) {
+ cf::get_slot 0.1, -1, "reload_perl";
+ info "perl_reload: reloading...";
- warn "removing commands";
- %COMMAND = ();
+ trace "perl_reload: entering sync_job";
- warn "removing ext/exti commands";
- %EXTCMD = ();
- %EXTICMD = ();
+ cf::sync_job {
+ #cf::emergency_save;
- warn "unloading/nuking all extensions";
- for my $pkg (@EXTS) {
- warn "... unloading $pkg";
+ trace "perl_reload: cancelling all extension coros";
+ $_->cancel for values %EXT_CORO;
+ %EXT_CORO = ();
+
+ trace "perl_reload: removing commands";
+ %COMMAND = ();
+
+ trace "perl_reload: removing ext/exti commands";
+ %EXTCMD = ();
+ %EXTICMD = ();
+
+ trace "perl_reload: unloading/nuking all extensions";
+ for my $pkg (@EXTS) {
+ trace "... unloading $pkg";
+
+ if (my $cb = $pkg->can ("unload")) {
+ eval {
+ $cb->($pkg);
+ 1
+ } or error "$pkg unloaded, but with errors: $@";
+ }
- if (my $cb = $pkg->can ("unload")) {
- eval {
- $cb->($pkg);
- 1
- } or warn "$pkg unloaded, but with errors: $@";
+ trace "... clearing $pkg";
+ clear_package $pkg;
}
- warn "... nuking $pkg";
- Symbol::delete_package $pkg;
- }
+ trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
+ while (my ($k, $v) = each %INC) {
+ next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
- warn "unloading all perl modules loaded from $LIBDIR";
- while (my ($k, $v) = each %INC) {
- next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
+ trace "... unloading $k";
+ delete $INC{$k};
- warn "... unloading $k";
- delete $INC{$k};
+ $k =~ s/\.pm$//;
+ $k =~ s/\//::/g;
- $k =~ s/\.pm$//;
- $k =~ s/\//::/g;
+ if (my $cb = $k->can ("unload_module")) {
+ $cb->();
+ }
- if (my $cb = $k->can ("unload_module")) {
- $cb->();
+ clear_package $k;
}
- Symbol::delete_package $k;
- }
-
- warn "getting rid of safe::, as good as possible";
- Symbol::delete_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\"";
- delete $INC{"cf.pm"};
- delete $INC{"cf/pod.pm"};
-
- # don't, removes xs symbols, too,
- # and global variables created in xs
- #Symbol::delete_package __PACKAGE__;
-
- warn "unload completed, starting to reload now";
-
- warn "reloading cf.pm";
- require cf;
- cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
-
- warn "loading config and database again";
- cf::reload_config;
+ 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 "perl_reload: unloading cf.pm \"a bit\"";
+ delete $INC{"cf.pm"};
+ delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
+
+ # don't, removes xs symbols, too,
+ # and global variables created in xs
+ #clear_package __PACKAGE__;
+
+ info "perl_reload: unload completed, starting to reload now";
+
+ trace "perl_reload: reloading cf.pm";
+ require cf;
+ cf::_connect_to_perl_1;
+
+ trace "perl_reload: loading config and database again";
+ cf::reload_config;
+
+ trace "perl_reload: loading extensions";
+ cf::load_extensions;
+
+ if ($REATTACH_ON_RELOAD) {
+ trace "perl_reload: reattaching attachments to objects/players";
+ _global_reattach; # objects, sockets
+ trace "perl_reload: reattaching attachments to maps";
+ reattach $_ for values %MAP;
+ trace "perl_reload: reattaching attachments to players";
+ reattach $_ for values %PLAYER;
+ }
- warn "loading extensions";
- cf::load_extensions;
+ cf::_post_init 1;
- warn "reattaching attachments to objects/players";
- _global_reattach; # objects, sockets
- warn "reattaching attachments to maps";
- reattach $_ for values %MAP;
- warn "reattaching attachments to players";
- reattach $_ for values %PLAYER;
+ trace "perl_reload: leaving sync_job";
- warn "leaving sync_job";
+ 1
+ } or do {
+ error $@;
+ cf::cleanup "perl_reload: error, exiting.";
+ };
- 1
- } or do {
- warn $@;
- cf::cleanup "error while reloading, exiting.";
- };
+ --$RELOAD;
+ }
- warn "reloaded";
+ $t1 = AE::time - $t1;
+ info "perl_reload: completed in ${t1}s\n";
};
our $RELOAD_WATCHER; # used only during reload
@@ -3583,9 +4260,13 @@
# doing reload synchronously and two reloads happen back-to-back,
# coro crashes during coro_state_free->destroy here.
- $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
- do_reload_perl;
- undef $RELOAD_WATCHER;
+ $RELOAD_WATCHER ||= cf::async {
+ Coro::AIO::aio_wait cache_extensions;
+
+ $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
+ do_reload_perl;
+ undef $RELOAD_WATCHER;
+ };
};
}
@@ -3601,25 +4282,18 @@
}
};
-unshift @INC, $LIBDIR;
+#############################################################################
my $bug_warning = 0;
-our @WAIT_FOR_TICK;
-our @WAIT_FOR_TICK_BEGIN;
-
-sub wait_for_tick {
- return if tick_inhibit;
- return if $Coro::current == $Coro::main;
+sub wait_for_tick() {
+ return Coro::AnyEvent::poll 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 if tick_inhibit;
- return if $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;
@@ -3633,23 +4307,23 @@
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#
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
- or warn "ERROR: unable to write runtime file: $!";
+ write_runtime_sync
+ or error "ERROR: unable to write runtime file: $!";
};
}
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;
@@ -3658,22 +4332,24 @@
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#
}
}
}
{
# configure BDB
+ info "initialising database";
- BDB::min_parallel 8;
+ BDB::min_parallel 16;
BDB::max_poll_reqs $TICK * 0.1;
- $Coro::BDB::WATCHER->priority (1);
+ #$AnyEvent::BDB::WATCHER->priority (1);
unless ($DB_ENV) {
$DB_ENV = BDB::db_env_create;
- $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
- | BDB::LOG_AUTOREMOVE, 1);
+ $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
+ $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
+ $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
@@ -3702,26 +4378,36 @@
$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;
- $Coro::AIO::WATCHER->priority (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 {
$Coro::current->{desc} = "abt $msg";
@@ -3742,18 +4428,20 @@
@funcs
};
- LOG llevInfo, "[ABT] $msg\n";
+ LOG llevInfo, "[ABT] $perl_bt\n";
+ LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
LOG llevInfo, "[ABT] $_\n" for @bt;
--$_log_backtrace;
};
} else {
LOG llevInfo, "[ABT] $msg\n";
- LOG llevInfo, "[ABT] [suppressed]\n";
+ LOG llevInfo, "[ABT] [overload, suppressed]\n";
}
}
# load additional modules
-use cf::pod;
+require "cf/$_.pm" for @EXTRA_MODULES;
+cf::_connect_to_perl_2;
END { cf::emergency_save }