server/lib/cf.pm

#
# This file is part of Deliantra, the Roguelike Realtime MMORPG.
#
# 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
# <http://www.gnu.org/licenses/>.
#
# The authors can be reached via e-mail to <support@deliantra.net>
#

package cf;

use common::sense;

use Symbol;
use List::Util;
use Socket;
use EV;
use Opcode;
use Safe;
use Safe::Hole;
use Storable ();
use Carp ();

use AnyEvent ();
use AnyEvent::IO ();
use AnyEvent::DNS ();

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 1.6;
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 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

$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, non-zero while in reload
our @EVENT;
our @REFLECT; # set by XS
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;
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 $NEXT_RUNTIME_WRITE; # when should the runtime file be written
our $NEXT_TICK;
our $USE_FSYNC = 1; # use fsync to write maps - default on

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     = 0;
our $SERVER_TICK = 0;
our $NOW;

our (%PLAYER, %PLAYER_LOADING); # all users
our (%MAP,    %MAP_LOADING   ); # all maps
our $LINK_MAP; # the special {link} map, which is always available

# used to convert map paths into valid unix filenames by replacing / by ∕
our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons

our $LOAD;       # a number between 0 (idle) and 1 (too many objects)
our $LOADAVG;    # same thing, but with alpha-smoothing
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 $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;

our $EMERGENCY_POSITION;

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

=over 4

=item $cf::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
$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
$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::LOADAVG

The current CPU load on the server (alpha-smoothed), as a value between 0
(none) and 1 (overloaded), indicating how much time is spent on processing
objects per tick. Healthy values are < 0.5.

=item $cf::LOAD

The raw value load value from the last tick.

=item %cf::CFG

Configuration for the server, loaded from C</etc/deliantra-server/config>, or
from wherever your confdir points to.

=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<after> 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<really>
want to wait, use C<$cf::WAIT_FOR_TICK>).

=item $cf::WAIT_FOR_TICK

Note that C<cf::wait_for_tick> is probably the correct thing to use. This
variable contains a L<Coro::Signal> 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<invoke ()> call. When
C<cf::override> 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

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 "", @_ }

$Coro::State::WARNHOOK = sub {
   my $msg = join "", @_;

   $msg .= "\n"
      unless $msg =~ /\n$/;

   $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 "=="

   error Carp::longmess $_[0];

   if (in_main) {#d#
      error "DIEHOOK called in main context, Coro bug?\n";#d#
      return;#d#
   }#d#

   # kill coroutine otherwise
   Coro::terminate
};

@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';
@safe::cf::client::ISA         = @cf::client::ISA         = 'cf::attachable';
@safe::cf::map::ISA            = @cf::map::ISA            = 'cf::attachable';
@safe::cf::arch::ISA           = @cf::arch::ISA           = 'cf::object';
@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)

# we bless all objects into (empty) derived classes to force a method lookup
# within the Safe compartment.
for my $pkg (qw(
   cf::global cf::attachable
   cf::object cf::object::player
   cf::client cf::player
   cf::arch cf::living
   cf::map cf::mapspace
   cf::party cf::region
)) {
   @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
}

$EV::DIED = sub {
   warn "error in event callback: $@";
};

#############################################################################

sub fork_call(&@);
sub get_slot($;$$);

#############################################################################

=head2 UTILITY FUNCTIONS

=over 4

=item dumpval $ref

=cut

sub dumpval {
   eval {
      local $SIG{__DIE__};
      my $d;
      if (1) {
         $d = new Data::Dumper([$_[0]], ["*var"]);
         $d->Terse(1);
         $d->Indent(2);
         $d->Quotekeys(0);
         $d->Useqq(1);
         #$d->Bless(...);
         $d->Seen($_[1]) if @_ > 1;
         $d = $d->Dump();
      }
      $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
      $d
   } || "[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.

=item $json = cf::encode_json $ref

Converts a perl data structure into its JSON representation.

=cut

our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max

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<after> all extensions have been (re-)loaded,
but I<before> 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. 

=item my $lock = cf::lock_acquire $string

Wait until the given lock is available and then acquires it and returns
a L<Guard> object. If the guard object gets destroyed (goes out of scope,
for example when the coroutine gets canceled), the lock is automatically
returned.

Locks are *not* recursive, locking from the same coro twice results in a
deadlocked coro.

Lock names should begin with a unique identifier (for example, cf::map::find
uses map_find and cf::map::load uses map_load).

=item $locked = cf::lock_active $string

Return true if the lock is currently active, i.e. somebody has locked it.

=cut

our $LOCKS = new Coro::SemaphoreSet;

sub lock_wait($) {
   $LOCKS->wait ($_[0]);
}

sub lock_acquire($) {
   $LOCKS->guard ($_[0])
}

sub lock_active($) {
   $LOCKS->count ($_[0]) < 1
}

sub freeze_mainloop {
   tick_inhibit_inc;

   &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 time.

=cut

sub periodic($$) {
   my ($interval, $cb) = @_;

   my $start = rand List::Util::min 180, $interval;

   EV::periodic $start, $interval, 0, $cb
}

=item cf::get_slot $time[, $priority[, $name]]

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.

Useful for short background jobs.

=cut

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:

      Coro::cede;

      my $avail = cf::till_tick;

      for (0 .. $#SLOT_QUEUE) {
         if ($SLOT_QUEUE[$_][0] <= $avail) {
            $busy = 0;
            my $job = splice @SLOT_QUEUE, $_, 1, ();
            $job->[2]->send;
            goto next_job;
         } else {
            $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
         }
      }

      if (@SLOT_QUEUE) {
         wait_for_tick;
      } else {
         $busy = 0;
         Coro::schedule;
      }
   }
};

sub get_slot($;$$) {
   return if tick_inhibit || $Coro::current == $Coro::main;

   my ($time, $pri, $name) = @_;

   $time = clamp $time, 0.01, $TICK * .6;

   my $sig = new Coro::Signal;

   push @SLOT_QUEUE, [$time, $pri, $sig, $name];
   @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
   $SLOT_QUEUE->ready;
   $sig->wait;
}

=item cf::async { BLOCK }

Currently the same as Coro::async_pool, meaning you cannot use
C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
thing you are allowed to do is call C<prio> on it.

=cut

BEGIN { *async = \&Coro::async_pool }

=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
partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
acceptable.

If it must be done, put the blocking parts into C<sync_job>. This will run
the given BLOCK in another coroutine while waiting for the result. The
server will be frozen during this time, so the block should either finish
fast or be very important.

=cut

sub sync_job(&) {
   my ($job) = @_;

   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#

      my $freeze_guard = freeze_mainloop;

      my $busy = 1;
      my @res;

      (async {
         $Coro::current->desc ("sync job coro");
         @res = eval { $job->() };
         error $@ if $@;
         undef $busy;
      })->prio (Coro::PRIO_MAX);

      while ($busy) {
         if (Coro::nready) {
            Coro::cede_notself;
         } else {
            EV::run EV::RUN_ONCE;
         }
      }

      my $time = AE::time - $time;

      $TICK_START += $time; # do not account sync jobs to server load

      wantarray ? @res : $res[0]
   } else {
      # we are in another coroutine, how wonderful, everything just works
 
      $job->()
   }
}

=item $coro = cf::async_ext { BLOCK }

Like async, but this coro is automatically being canceled when the
extension calling this is being unloaded.

=cut

sub async_ext(&) {
   my $cb = shift;

   my $coro = &Coro::async ($cb);

   $coro->on_destroy (sub {
      delete $EXT_CORO{$coro+0};
   });
   $EXT_CORO{$coro+0} = $coro;

   $coro
}

=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
Coro::Storable. May, of course, block. Note that the executed sub may
never block itself or use any form of event handling.

=cut

sub post_fork {
   reset_signals;
}

sub fork_call(&@) {
   my ($cb, @args) = @_;

   my @res = Coro::Util::fork_eval {
      cf::post_fork;
      &$cb
   } @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.

=item cf::db_put $family => $key => $value

Stores the given C<$value> in the family. It can currently store binary
data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).

=item $db = cf::db_table "name"

Create and/or open a new database table. The string must not be "db" and must be unique
within each server.

=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;

   eval {
      $db->set_flags (BDB::CHKSUM);

      utf8::encode $name;
      BDB::db_open $db, undef, $name, undef, BDB::BTREE,
                   BDB::CREATE | BDB::AUTO_COMMIT, 0666;
      cf::cleanup "db_open(db): $!" if $!;
   };
   cf::cleanup "db_open(db): $@" if $@;

   $db
}

our $DB;

sub db_init {
   $DB ||= db_table "db";
}

sub db_get($$) {
   my $key = "$_[0]/$_[1]";

   cf::error "db_get called from main context"
      if $Coro::current == $Coro::main;

   BDB::db_get $DB, undef, $key, my $data;

   $! ? ()
      : $data
}

sub db_put($$$) {
   BDB::dbreq_pri 4;
   BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
}

=item cf::cache $id => [$paths...], $processversion => $process

Generic caching function that returns the value of the resource $id,
caching and regenerating as required.

This function can block.

=cut

sub cache {
   my ($id, $src, $processversion, $process) = @_;

   my $meta =
      join "\x00",
         $processversion,
         map {
            aio_stat $_
               and Carp::croak "$_: $!";

            ($_, (stat _)[7,9])
         } @$src;

   my $dbmeta = db_get cache => "$id/meta";
   if ($dbmeta ne $meta) {
      # changed, we may need to process

      my @data;
      my $md5;

      for (0 .. $#$src) {
         $data[$_] = load_file $src->[$_];
      }

      # if processing is expensive, check
      # checksum first
      if (1) {
         $md5 =
            join "\x00",
               $processversion,
               map {
                  cf::cede_to_tick;
                  ($src->[$_], Digest::MD5::md5_hex $data[$_])
               } 0.. $#$src;
           

         my $dbmd5 = db_get cache => "$id/md5";
         if ($dbmd5 eq $md5) {
            db_put cache => "$id/meta", $meta;

            return db_get cache => "$id/data";
         }
      }

      my $t1 = EV::time;
      my $data = $process->(\@data);
      my $t2 = EV::time;

      info "cache: '$id' processed in ", $t2 - $t1, "s\n";

      db_put cache => "$id/data", $data;
      db_put cache => "$id/md5" , $md5;
      db_put cache => "$id/meta", $meta;

      return $data;
   }

   db_get cache => "$id/data"
}

=item cf::datalog type => key => value, ...

Log a datalog packet of the given type with the given key-value pairs.

=cut

sub datalog($@) {
  my ($type, %kv) = @_;
  info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
}

=back

=cut

#############################################################################

=head2 ATTACHABLE OBJECTS

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.

In the following description, CLASS can be any of C<global>, C<object>
C<player>, C<client> or C<map> (i.e. the attachable objects in
Deliantra).

=over 4

=item $attachable->attach ($attachment, key => $value...)

=item $attachable->detach ($attachment)

Attach/detach a pre-registered attachment to a specific object and give it
the specified key/value pairs as arguments.

Example, attach a minesweeper attachment to the given object, making it a
10x10 minesweeper game:

   $obj->attach (minesweeper => width => 10, height => 10);

=item $bool = $attachable->attached ($name)

Checks wether the named attachment is currently attached to the object.

=item cf::CLASS->attach ...

=item cf::CLASS->detach ...

Define an anonymous attachment and attach it to all objects of the given
CLASS. See the next function for an explanation of its arguments.

You can attach to global events by using the C<cf::global> class.

Example, log all player logins:

   cf::player->attach (
      on_login => sub {
         my ($pl) = @_;
         ...
      },
   );

Example, attach to the jeweler skill:

   cf::object->attach (
      type         => cf::SKILL,
      subtype      => cf::SK_JEWELER,
      on_use_skill => sub {
         my ($sk, $ob, $part, $dir, $msg) = @_;
         ...
      },
   );

=item cf::CLASS::attachment $name, ...

Register an attachment by C<$name> through which attachable objects of the
given CLASS can refer to this attachment.

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:

=over 4

=item prio => $number

Set the priority for all following handlers/hooks (unless overwritten
by another C<prio> setting). Lower priority handlers get executed
earlier. The default priority is C<0>, and many built-in handlers are
registered at priority C<-1000>, so lower priorities should not be used
unless you know what you are doing.

=item type => $type

(Only for C<< cf::object->attach >> calls), limits the attachment to the
given type of objects only (the additional parameter C<subtype> can be
used to further limit to the given subtype).

=item on_I<event> => \&cb

Call the given code reference whenever the named event happens (event is
something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
handlers are recognised generally depends on the type of object these
handlers attach to).

See F<include/eventinc.h> for the full list of events supported, and their
class.

=item package => package::

Look for sub functions of the name C<< on_I<event> >> in the given
package and register them.  Only handlers for eevents supported by the
object/class are recognised.

=back

Example, define an attachment called "sockpuppet" that calls the given
event handler when a monster attacks:

   cf::object::attachment sockpuppet =>
      on_skill_attack => sub {
         my ($self, $victim) = @_;
         ...
      }
   }

=item $attachable->valid

Just because you have a perl object does not mean that the corresponding
C-level object still exists. If you try to access an object that has no
valid C counterpart anymore you get an exception at runtime. This method
can be used to test for existence of the C object part without causing an
exception.

=cut

# the following variables are defined in .xs and must not be re-created
our @CB_GLOBAL     = (); # registry for all global events
our @CB_ATTACHABLE = (); # registry for all attachables
our @CB_OBJECT     = (); # all objects (should not be used except in emergency)
our @CB_PLAYER     = ();
our @CB_CLIENT     = ();
our @CB_TYPE       = (); # registry for type (cf-object class) based events
our @CB_MAP        = ();

my %attachment;

sub cf::attachable::thawer_merge {
   # simply override everything except _meta
   local $_[0]{_meta};
   %{$_[0]} = %{$_[1]};
}

sub _attach_cb($$$$) {
   my ($registry, $event, $prio, $cb) = @_;

   use sort 'stable';

   $cb = [$prio, $cb];

   @{$registry->[$event]} = sort
                           { $a->[0] cmp $b->[0] }
                           @{$registry->[$event] || []}, $cb;
}

# hack
my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;

# attach handles attaching event callbacks
# the only thing the caller has to do is pass the correct
# registry (== where the callback attaches to).
sub _attach {
   my ($registry, $klass, @arg) = @_;

   my $object_type;
   my $prio = 0;
   my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;

   #TODO: get rid of this hack
   if ($attachable_klass{$klass}) {
      %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
   }

   while (@arg) {
      my $type = shift @arg;

      if ($type eq "prio") {
         $prio = shift @arg;

      } elsif ($type eq "type") {
         $object_type = shift @arg;
         $registry = $CB_TYPE[$object_type] ||= [];

      } elsif ($type eq "subtype") {
         defined $object_type or Carp::croak "subtype specified without type";
         my $object_subtype = shift @arg;
         $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];

      } elsif ($type eq "package") {
         my $pkg = shift @arg;

         while (my ($name, $id) = each %cb_id) {
            if (my $cb = $pkg->can ($name)) {
               _attach_cb $registry, $id, $prio, $cb;
            }
         }

      } elsif (exists $cb_id{$type}) {
         _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;

      } elsif (ref $type) {
         error "attaching objects not supported, ignoring.\n";

      } else {
         shift @arg;
         error "attach argument '$type' not supported, ignoring.\n";
      }
   }
}

sub _object_attach {
   my ($obj, $name, %arg) = @_;

   return if exists $obj->{_attachment}{$name};

   if (my $attach = $attachment{$name}) {
      my $registry = $obj->registry;

      for (@$attach) {
         my ($klass, @attach) = @$_;
         _attach $registry, $klass, @attach;
      }

      $obj->{$name} = \%arg;
   } else {
      info "object uses attachment '$name' which is not available, postponing.\n";
   }

   $obj->{_attachment}{$name} = undef;
}

sub cf::attachable::attach {
   if (ref $_[0]) {
      _object_attach @_;
   } else {
      _attach shift->_attach_registry, @_;
   }
   _recalc_want;
};

# all those should be optimised
sub cf::attachable::detach {
   my ($obj, $name) = @_;

   if (ref $obj) {
      delete $obj->{_attachment}{$name};
      reattach ($obj);
   } else {
      Carp::croak "cannot, currently, detach class attachments";
   }
   _recalc_want;
};

sub cf::attachable::attached {
   my ($obj, $name) = @_;

   exists $obj->{_attachment}{$name}
}

for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
   eval "#line " . __LINE__ . " 'cf.pm'
      sub cf::\L$klass\E::_attach_registry {
         (\\\@CB_$klass, KLASS_$klass)
      }

      sub cf::\L$klass\E::attachment {
         my \$name = shift;

         \$attachment{\$name} = [[KLASS_$klass, \@_]];
      }
   ";
   die if $@;
}

our $override;
our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?

sub override {
   $override = 1;
   @INVOKE_RESULTS = (@_);
}

sub do_invoke {
   my $event = shift;
   my $callbacks = shift;

   @INVOKE_RESULTS = ();

   local $override;

   for (@$callbacks) {
      eval { &{$_->[1]} };

      if ($@) {
         error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
         override;
      }

      return 1 if $override;
   }

   0
}

=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)

=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)

Generate an object-specific event with the given arguments.

This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
removed in future versions), and there is no public API to access override
results (if you must, access C<@cf::INVOKE_RESULTS> directly).

=back

=cut

#############################################################################
# object support

sub _object_equal($$);
sub _object_equal($$) {
   my ($a, $b) = @_;

   return 0 unless (ref $a) eq (ref $b);

   if ("HASH" eq ref $a) {
      my @ka = keys %$a;
      my @kb = keys %$b;

      return 0 if @ka != @kb;

      for (0 .. $#ka) {
         return 0 unless $ka[$_] eq $kb[$_];
         return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
      }

   } elsif ("ARRAY" eq ref $a) {

      return 0 if @$a != @$b;

      for (0 .. $#$a) {
         return 0 unless _object_equal $a->[$_], $b->[$_];
      }

   } elsif ($a ne $b) {
      return 0;
   }

   1
}

our $SLOW_MERGES;#d#
sub _can_merge {
   my ($ob1, $ob2) = @_;

   ++$SLOW_MERGES;#d#

   # we do the slow way here
   return _object_equal $ob1, $ob2
}

sub reattach {
   # basically do the same as instantiate, without calling instantiate
   my ($obj) = @_;

   # 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;

   @$registry = ();

   delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };

   for my $name (keys %{ $obj->{_attachment} || {} }) {
      if (my $attach = $attachment{$name}) {
         for (@$attach) {
            my ($klass, @attach) = @$_;
            _attach $registry, $klass, @attach;
         }
      } else {
         info "object uses attachment '$name' that is not available, postponing.\n";
      }
   }
}

cf::attachable->attach (
   prio           => -1000000,
   on_instantiate => sub {
      my ($obj, $data) = @_;

      $data = decode_json $data;

      for (@$data) {
         my ($name, $args) = @$_;

         $obj->attach ($name, %{$args || {} });
      }
   },
   on_reattach => \&reattach,
   on_clone => sub {
      my ($src, $dst) = @_;

      @{$dst->registry} = @{$src->registry};

      %$dst = %$src;

      %{$dst->{_attachment}} = %{$src->{_attachment}}
         if exists $src->{_attachment};
   },
);

sub object_freezer_save {
   my ($filename, $rdata, $objs) = @_;

   sync_job {
      if (length $$rdata) {
         utf8::decode (my $decname = $filename);
         trace sprintf "saving %s (%d,%d)\n",
                       $decname, length $$rdata, scalar @$objs
            if $VERBOSE_IO;

         if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
            aio_chmod $fh, SAVE_MODE;
            aio_write $fh, 0, (length $$rdata), $$rdata, 0;
            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) {
                  aio_chmod $fh, SAVE_MODE;
                  my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
                  aio_write $fh, 0, (length $data), $data, 0;
                  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 {
               aio_unlink "$filename.pst";
            }

            aio_rename "$filename~", $filename;

            $filename =~ s%/[^/]+$%%;
            aio_pathsync $filename if $cf::USE_FSYNC;
         } else {
            error "unable to save objects: $filename~: $!\n";
         }
      } else {
         aio_unlink $filename;
         aio_unlink "$filename.pst";
      }
   };
}

sub object_freezer_as_string {
   my ($rdata, $objs) = @_;

   use Data::Dumper;

   $$rdata . Dumper $objs
}

sub object_thawer_load {
   my ($filename) = @_;

   my ($data, $av);

   (aio_load $filename, $data) >= 0
      or return;

   unless (aio_stat "$filename.pst") {
      (aio_load "$filename.pst", $av) >= 0
         or return;

      my $st = eval { Coro::Storable::thaw $av };
      $av = $st->{objs};
   }

   utf8::decode (my $decname = $filename);
   trace sprintf "loading %s (%d,%d)\n",
                 $decname, length $data, scalar @{$av || []}
      if $VERBOSE_IO;

   ($data, $av)
}

=head2 COMMAND CALLBACKS

=over 4

=cut

#############################################################################
# command handling &c

=item cf::register_command $name => \&callback($ob,$args)

Register a callback for execution when the client sends the user command
$name.

=cut

sub register_command {
   my ($name, $cb) = @_;

   my $caller = caller;
   #warn "registering command '$name/$time' to '$caller'";

   push @{ $COMMAND{$name} }, [$caller, $cb];
}

=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
received by the server, like other user commands. The first argument is
the logged-in player. Ext commands can only be processed after a player
has logged in successfully.

The values will be sent back to the client.

=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)

Same as C<cf::register_extcmd>, 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
are received, i.e. out of order w.r.t. other commands. The first argument
is a client socket. Exti commands can be received anytime, even before
log-in.

The values will be sent back to the client.

=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)

Same as C<cf::register_extcmd>, but instead of returning values, the
callback needs to clal the C<$reply> function.

=cut

sub register_extcmd($$) {
   my ($name, $cb) = @_;

   $EXTCMD{$name} = $cb;
}

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_unknown_command => sub {
      my ($pl, $name, $params) = @_;

      my $cb = $COMMAND{$name}
         or return;

      for my $cmd (@$cb) {
         $cmd->[1]->($pl->ob, $params);
      }

      cf::override;
   },
   on_extcmd => sub {
      my ($pl, $buf) = @_;

      my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };

      if (ref $msg) {
         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;

            if (my $cb = $EXTCMD{$type}) {
               @reply = $cb->($pl, @payload);
            }

            $pl->ext_msg ("reply-$reply", @reply)
               if $reply;
         }

      } else {
         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;

      for my $path (<$LIBDIR/*.ext>) {
         next unless -r $path;

         $path =~ /([^\/\\]+)\.ext$/ or die "$path";
         my $base = $1;
         my $pkg = $1;
         $pkg =~ s/[^[:word:]]/_/g;
         $pkg = "ext::$pkg";

         open my $fh, "<:utf8", $path
            or die "$path: $!";

         my $source = do { local $/; <$fh> };

         my %ext = (
            path => $path,
            base => $base,
            pkg  => $pkg,
         );

         $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
            if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;

         $ext{source} =
            "package $pkg; use common::sense;\n"
            . "#line 1 \"$path\"\n{\n"
            . $source
            . "\n};\n1";

         $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}) {
               next ext
                  unless exists $done{$_};
            }

            trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";

            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";

               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;
            }
         }

         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;
         }
      }
   };
}

#############################################################################

=back

=head2 CORE EXTENSIONS

Functions and methods that extend core deliantra objects.

=cut

package cf::player;

use Coro::AIO;

=head3 cf::player

=over 4

=item cf::player::num_playing

Returns the official number of playing players, as per the Crossfire metaserver rules.

=cut

sub num_playing {
   scalar grep
      $_->ob->map
      && !$_->hidden
      && !$_->ob->flag (cf::FLAG_WIZ),
      cf::player::list
}

=item cf::player::find $login

Returns the given player object, loading it if necessary (might block).

=cut

sub playerdir($) {
   "$PLAYERDIR/"
     . (ref $_[0] ? $_[0]->ob->name : $_[0])
}

sub path($) {
   my $login = ref $_[0] ? $_[0]->ob->name : $_[0];

   (playerdir $login) . "/playerdata"
}

sub find_active($) {
   $cf::PLAYER{$_[0]}
      and $cf::PLAYER{$_[0]}->active
      and $cf::PLAYER{$_[0]}
}

sub exists($) {
   my ($login) = @_;

   $cf::PLAYER{$login}
      or !aio_stat path $login
}

sub find($) {
   return $cf::PLAYER{$_[0]} || do {
      my $login = $_[0];

      my $guard = cf::lock_acquire "user_find:$login";

      $cf::PLAYER{$_[0]} || do {
         # rename old playerfiles to new ones
         #TODO: remove when no longer required
         aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
         aio_link +(playerdir $login) . "/$login.pl"    , (playerdir $login) . "/playerdata";
         aio_unlink +(playerdir $login) . "/$login.pl.pst";
         aio_unlink +(playerdir $login) . "/$login.pl";

         my $f = new_from_file cf::object::thawer path $login
            or return;

         my $pl = cf::player::load_pl $f
            or return;

         local $cf::PLAYER_LOADING{$login} = $pl;
         $f->resolve_delayed_derefs;
         $cf::PLAYER{$login} = $pl
      }
   }
}

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) = @_;

   return if $pl->{deny_save};

   my $path = path $pl;
   my $guard = cf::lock_acquire "user_save:$path";

   return if $pl->{deny_save};

   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;
}

sub new($) {
   my ($login) = @_;

   my $self = create;

   $self->ob->name ($login);
   $self->{deny_save} = 1;

   $cf::PLAYER{$login} = $self;

   $self
}

=item $player->send_msg ($channel, $msg, $color, [extra...])

=cut

sub send_msg {
   my $ns = shift->ns
      or return;
   $ns->send_msg (@_);
}

=item $pl->quit_character

Nukes the player without looking back. If logged in, the connection will
be destroyed. May block for a long time.

=cut

sub quit_character {
   my ($pl) = @_;

   my $name = $pl->ob->name;

   $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->ns;
   $pl->deactivate;

   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;
   my $temp = "$path~$cf::RUNTIME~deleting~";
   aio_rename $path, $temp;
   delete $cf::PLAYER{$pl->ob->name};
   $pl->destroy;

   my $prefix = qr<^~\Q$name\E/>;

   # nuke player maps
   $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;

   IO::AIO::aio_rmtree $temp;
}

=item $pl->kick

Kicks a player out of the game. This destroys the connection.

=cut

sub kick {
   my ($pl, $kicker) = @_;

   $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
   $pl->killer ("kicked");
   $pl->ns->destroy;
}

=item cf::player::list_logins

Returns am arrayref of all valid playernames in the system, can take a
while and may block, so not sync_job-capable, ever.

=cut

sub list_logins {
   my $dirs = aio_readdir $PLAYERDIR
      or return [];

   my @logins;

   for my $login (@$dirs) {
      my $path = path $login;

      # a .pst is a dead give-away for a valid player
      # 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
      }

      utf8::decode $login;
      push @logins, $login;
   }

   \@logins
}

=item $player->maps

=item cf::player::maps $login

Returns an arrayref of map paths that are private for this
player. May block.

=cut

sub maps($) {
   my ($pl) = @_;

   $pl = ref $pl ? $pl->ob->name : $pl;

   my $files = aio_readdir playerdir $pl
      or return;

   my @paths;

   for (@$files) {
      utf8::decode $_;
      next if /\.(?:pl|pst)$/;
      next unless /^$PATH_SEP/o;

      push @paths, cf::map::normalise "~$pl/$_";
   }

   \@paths
}

=item $protocol_xml = $player->expand_cfpod ($cfpod)

Expand deliantra pod fragments into protocol xml.

=item $player->ext_msg ($type, @msg)

Sends an ext event to the client.

=cut

sub ext_msg($$@) {
   my ($self, $type, @msg) = @_;

   $self->ns->ext_msg ($type, @msg);
}

=head3 cf::region

=over 4

=cut

package cf::region;

=item cf::region::find_by_path $path

Tries to decuce the likely region for a map knowing only its path.

=cut

sub find_by_path($) {
   my ($path) = @_;

   $path =~ s/^~[^\/]*//; # skip ~login

   my ($match, $specificity);

   for my $region (list) {
      if ($region->{match} && $path =~ $region->{match}) {
         ($match, $specificity) = ($region, $region->specificity)
            if $region->specificity > $specificity;
      }
   }

   $match
}

=back

=head3 cf::map

=over 4

=cut

package cf::map;

use Fcntl;
use Coro::AIO;

use overload
   '""'     => \&as_string,
   fallback => 1;

our $MAX_RESET     = 3600;
our $DEFAULT_RESET = 3000;

sub generate_random_map {
   my ($self, $rmp) = @_;

   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)

Register a handler for the map path matching the given regex at the
givne priority (higher is better, built-in handlers have priority 0, the
default).

=cut

sub register {
   my (undef, $regex, $prio) = @_;
   my $pkg = caller;

   push @{"$pkg\::ISA"}, __PACKAGE__;

   $EXT_MAP{$pkg} = [$prio, qr<$regex>];
}

# also paths starting with '/'
$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];

sub thawer_merge {
   my ($self, $merge) = @_;

   # we have to keep some variables in memory intact
   local $self->{path};
   local $self->{load_path};

   $self->SUPER::thawer_merge ($merge);
}

sub normalise {
   my ($path, $base) = @_;

   $path = "$path"; # make sure it's a string

   $path =~ s/\.map$//;

   # map plan:
   #
   # /!          non-realised random map exit (special hack!)
   # {...        are special paths that are not being touched
   # ?xxx/...    are special absolute paths
   # ?random/... random maps
   # /...        normal maps
   # ~user/...   per-player map of a specific user

   $path =~ s/$PATH_SEP/\//go;

   # treat it as relative path if it starts with
   # something that looks reasonable
   if ($path =~ m{^(?:\./|\.\./|\w)}) {
      $base or Carp::carp "normalise called with relative path and no base: '$path'";

      $base =~ s{[^/]+/?$}{};
      $path = "$base/$path";
   }

   for ($path) {
      redo if s{/\.?/}{/};
      redo if s{/[^/]+/\.\./}{/};
   }

   $path
}

sub new_from_path {
   my (undef, $path, $base) = @_;

   return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object

   $path = normalise $path, $base;

   for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
      if ($path =~ $EXT_MAP{$pkg}[1]) {
         my $self = bless cf::map::new, $pkg;
         $self->{path} = $path; $self->path ($path);
         $self->init; # pass $1 etc.
         return $self;
      }
   }

   Carp::cluck "unable to resolve path '$path' (base '$base')";
   ()
}

# may re-bless or do other evil things
sub init {
   my ($self) = @_;

   $self
}

sub as_string {
   my ($self) = @_;

   "$self->{path}"
}

# the displayed name, this is a one way mapping
sub visible_name {
   &as_string
}

# the original (read-only) location
sub load_path {
   my ($self) = @_;

   "$MAPDIR/$self->{path}.map"
}

# the temporary/swap location
sub save_path {
   my ($self) = @_;

   (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
   "$TMPDIR/$path.map"
}

# the unique path, undef == no special unique path
sub uniq_path {
   my ($self) = @_;

   (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
   "$UNIQUEDIR/$path"
}

sub decay_objects {
   my ($self) = @_;

   return if $self->{deny_reset};

   $self->do_decay_objects;
}

sub unlink_save {
   my ($self) = @_;

   utf8::encode (my $save = $self->save_path);
   IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
   IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
}

sub load_header_from($) {
   my ($self, $path) = @_;

   utf8::encode $path;
   my $f = new_from_file cf::object::thawer $path
      or return;

   $self->_load_header ($f)
      or return;

   local $MAP_LOADING{$self->{path}} = $self;
   $f->resolve_delayed_derefs;

   $self->{load_path} = $path;

   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) = @_;

   $self->last_access ((delete $self->{last_access})
                       || $cf::RUNTIME); #d#
   # safety
   $self->{instantiate_time} = $cf::RUNTIME
      if $self->{instantiate_time} > $cf::RUNTIME;
}

# called after loading the header from an original map
sub prepare_orig {
   my ($self) = @_;

   $self->{load_original} = 1;
   $self->{instantiate_time} = $cf::RUNTIME;
   $self->last_access ($cf::RUNTIME);
   $self->instantiate;
}

sub load_header {
   my ($self) = @_;

   if ($self->load_header_temp) {
      $self->prepare_temp;
   } else {
      $self->load_header_orig
         or return;
      $self->prepare_orig;
   }

   $self->{deny_reset} = 1
      if $self->no_reset;

   $self->default_region (cf::region::find_by_path $self->{path})
      unless $self->default_region;

   1
}

sub find;
sub find {
   my ($path, $origin) = @_;

   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";

   $cf::MAP{$path} || do {
      my $map = new_from_path cf::map $path
         or return;

      $map->{last_save} = $cf::RUNTIME;

      $map->load_header
         or return;

      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 $guard2;
         undef $guard1;
         $map->reset;
         return find $path;
      }

      $cf::MAP{$path} = $map
   }
}

sub pre_load { }
#sub post_load { } # XS

sub load {
   my ($self) = @_;

   local $self->{deny_reset} = 1; # loading can take a long time

   my $path = $self->{path};

   {
      my $guard = cf::lock_acquire "map_data:$path";

      return unless $self->valid;
      return unless $self->state == cf::MAP_SWAPPED;

      $self->alloc;

      $self->pre_load;
      cf::cede_to_tick;

      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};

         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};
      }

      $self->state (cf::MAP_INACTIVE);

      cf::cede_to_tick;
      # now do the right thing for maps
      $self->link_multipart_objects;
      $self->difficulty ($self->estimate_difficulty)
         unless $self->difficulty;
      cf::cede_to_tick;

      unless ($self->{deny_activate}) {
         $self->decay_objects;
         $self->fix_auto_apply;
         $self->update_buttons;
         cf::cede_to_tick;
         #$self->activate; # no longer activate maps automatically
      }

      $self->{last_save} = $cf::RUNTIME;
      $self->last_access ($cf::RUNTIME);
   }

   $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) = @_;

   return find "~" . $ob->name . "/" . $self->{path}
      if $self->per_player;

#   return find "?party/" . $ob->name . "/" . $self->{path}
#      if $self->per_party;

   $self
}

sub find_sync {
   my ($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) = @_;

   # 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;

   $map->load;
}

our %MAP_PREFETCH;
our $MAP_PREFETCHER = undef;

sub find_async {
   my ($path, $origin, $load) = @_;

   $path = normalise $path, $origin;

   if (my $map = $cf::MAP{$path}) {
      return $map if !$load || $map->linkable;
   }

   $MAP_PREFETCH{$path} |= $load;

   $MAP_PREFETCHER ||= cf::async {
      $Coro::current->{desc} = "map prefetcher";

      while (%MAP_PREFETCH) {
         while (my ($k, $v) = each %MAP_PREFETCH) {
            if (my $map = find $k) {
               $map->load if $v;
            }

            delete $MAP_PREFETCH{$k};
         }
      }
      undef $MAP_PREFETCHER;
   };
   $MAP_PREFETCHER->prio (6);

   ()
}

# common code, used by both ->save and ->swapout
sub _save {
   my ($self) = @_;

   $self->{last_save} = $cf::RUNTIME;

   return unless $self->dirty;

   my $save = $self->save_path; utf8::encode $save;
   my $uniq = $self->uniq_path; utf8::encode $uniq;

   $self->{load_path} = $save;

   return if $self->{deny_save};

   local $self->{last_access} = $self->last_access;#d#

   cf::async {
      $Coro::current->{desc} = "map player save";
      $_->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);
   } else {
      $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
   }
}

sub save {
   my ($self) = @_;

   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->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->state (cf::MAP_SWAPPED);

   # then atomically save
   $self->_save;

   # then free the map
   $self->clear;
}

sub reset_at {
   my ($self) = @_;

   # TODO: safety, remove and allow resettable per-player maps
   return 1e99 if $self->{deny_reset};

   my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
   my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;

   $time + $to
}

sub should_reset {
   my ($self) = @_;

   $self->reset_at <= $cf::RUNTIME
}

sub reset {
   my ($self) = @_;

   my $lock = cf::lock_acquire "map_data:$self->{path}";

   return if $self->players;

   cf::trace "resetting map ", $self->path, "\n";

   $self->state (cf::MAP_SWAPPED);

   # need to save uniques path
   unless ($self->{deny_save}) {
      my $uniq = $self->uniq_path; utf8::encode $uniq;

      $self->_save_objects ($uniq, cf::IO_UNIQUES)
         if $uniq;
   }

   delete $cf::MAP{$self->path};

   $self->deactivate;
   $_->clear_links_to ($self) for values %cf::MAP;
   $self->clear;

   $self->unlink_save;
   $self->destroy;
}

my $nuke_counter = "aaaa";

sub nuke {
   my ($self) = @_;

   {
      my $lock = cf::lock_acquire "map_data:$self->{path}";

      delete $cf::MAP{$self->path};

      $self->unlink_save;

      bless $self, "cf::map::wrap";
      delete $self->{deny_reset};
      $self->{deny_save} = 1;
      $self->reset_timeout (1);
      $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));

      $cf::MAP{$self->path} = $self;
   }

   $self->reset; # polite request, might not happen
}

=item $maps = cf::map::tmp_maps

Returns an arrayref with all map paths of currently instantiated and saved
maps. May block.

=cut

sub tmp_maps() {
   [
      map {
         utf8::decode $_;
         /\.map$/
            ? normalise $_
            : ()
      } @{ aio_readdir $TMPDIR or [] }
   ]
}

=item $maps = cf::map::random_maps

Returns an arrayref with all map paths of currently instantiated and saved
random maps. May block.

=cut

sub random_maps() {
   [
      map {
         utf8::decode $_;
         /\.map$/
            ? normalise "?random/$_"
            : ()
      } @{ aio_readdir $RANDOMDIR or [] }
   ]
}

=item cf::map::unique_maps

Returns an arrayref of paths of all shared maps that have
instantiated unique items. May block.

=cut

sub unique_maps() {
   [
      map {
         utf8::decode $_;
         s/\.map$//; # TODO future compatibility hack
         /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
            ? ()
            : normalise $_
      } @{ aio_readdir $UNIQUEDIR or [] }
   ]
}

=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</styles> and F</editor>). May
block.

=cut

sub static_maps() {
   my @dirs = "";
   my @maps;

   while (@dirs) {
      my $dir = shift @dirs;

      next if $dir eq "/styles" || $dir eq "/editor";

      my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
         or return;

      for (@$files) {
         s/\.map$// or next;
         utf8::decode $_;
         push @maps, "$dir/$_";
      }

      push @dirs, map "$dir/$_", @$dirs;
   }

   \@maps
}

=back

=head3 cf::object

=cut

package cf::object;

=over 4

=item $ob->inv_recursive

Returns the inventory of the object I<and> their inventories, recursively,
but I<not> the object itself.

=cut

sub inv_recursive_;
sub inv_recursive_ {
   map { $_, inv_recursive_ $_->inv } @_
}

sub inv_recursive {
   inv_recursive_ inv $_[0]
}

=item $ref = $ob->ref

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 cannot find the object,
even if the object actually exists. May block.

=cut

sub deref {
   my ($ref) = @_;

   if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
      my ($uuid, $name) = ($1, $2);
      my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
         or return;
      $pl->ob->uuid eq $uuid
         or return;

      $pl->ob
   } else {
      warn "$ref: cannot resolve object reference\n";
      undef
   }
}

package cf;

=back

=head3 cf::object::player

=over 4

=item $player_object->reply ($npc, $msg[, $flags])

Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
can be C<undef>. Does the right thing when the player is currently in a
dialogue with the given NPC character.

=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
sub cf::object::player::reply($$$;$) {
   my ($self, $npc, $msg, $flags) = @_;

   $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;

   if ($self->{record_replies}) {
      push @{ $self->{record_replies} }, [$npc, $msg, $flags];

   } else {
      my $pl = $self->contr;

      if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
         my $dialog = $pl->{npc_dialog};
         $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));

      } else {
         $msg = $npc->name . " says: $msg" if $npc;
         $self->send_msg ($SAY_CHANNEL => $msg, $flags);
      }
   }
}

=item $object->send_msg ($channel, $msg, $color, [extra...])

=cut

sub cf::object::send_msg {
   my $pl = shift->contr
      or return;
   $pl->send_msg (@_);
}

=item $player_object->may ("access")

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<may_access> where
C<access> 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) ||
      (ref $cf::CFG{"may_$access"}
         ? scalar grep $self->name eq $_ || $self->uuid eq $_, @{$cf::CFG{"may_$access"}}
         : $cf::CFG{"may_$access"})
}

=item $player_object->enter_link

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 (e.g.
for loading a map). You I<MUST> call C<leave_link> as soon as possible,
though, as the player cannot control the character while it is on the link
map.

This method will never block, which is the whole reaosn for it's
existance: you can I<always> 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<enter_link> synchronously from the
server, then start a new thread, do your blocking stuff there and then
call C<leave_link> from that thread.

=item $player_object->leave_link ($map, $x, $y)

Moves the player out of the special C<{link}> map onto the specified
map. If the map is not valid (or omitted), the player will be moved back
to the location he/she was before the call to C<enter_link>, or, if that
fails, to the emergency map position.

Might block.

=cut

sub link_map {
   unless ($LINK_MAP) {
      $LINK_MAP = cf::map::find "{link}"
         or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
      $LINK_MAP->load;
   }

   $LINK_MAP
}

sub cf::object::player::enter_link {
   my ($self) = @_;

   $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, 3, 3);
}

sub cf::object::player::leave_link {
   my ($self, $map, $x, $y) = @_;

   return unless $self->contr->active;

   my $link_pos = delete $self->{_link_pos};

   unless ($map) {
      # restore original map position
      ($map, $x, $y) = @{ $link_pos || [] };
      $map = cf::map::find $map;

      unless ($map) {
         ($map, $x, $y) = @$EMERGENCY_POSITION;
         $map = cf::map::find $map
            or die "FATAL: cannot load emergency map\n";
      }
   }

   ($x, $y) = (-1, -1)
      unless (defined $x) && (defined $y);

   # use -1 or undef as default coordinates, not 0, 0
   ($x, $y) = ($map->enter_x, $map->enter_y)
      if $x <= 0 && $y <= 0;

   $map->load;

   return unless $self->contr->active;

   local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
   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, $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
that has to return the map if sucecssful, and then unfreezes the player on
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;

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;

   $self->enter_link;

   (async {
      $Coro::current->{desc} = "player::goto $path $x $y";

      # *tag paths override both path and x|y
      if ($path =~ /^\*(.*)$/) {
         if (my @obs = grep $_->map, ext::map_tags::find $1) {
            my $ob = $obs[rand @obs];

            # see if we actually can go there
            if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
               $ob = $obs[rand @obs];
            } else {
               $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
            }
            # else put us there anyways for now #d#

            ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
         } else {
            ($path, $x, $y) = (undef, undef, undef);
         }
      }

      my $map = eval {
         my $map = defined $path ? cf::map::find $path, $self->map : undef;

         if ($map) {
            $map = $map->customise_for ($self);
            $map = $check->($map, $x, $y, $self) if $check && $map;
         } else {
            $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
         }

         $map
      };

      if ($@) {
         $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
         LOG llevError | logBacktrace, Carp::longmess $@;
      }

      if ($gen == $self->{_goto_generation}) {
         delete $self->{_goto_generation};
         $self->leave_link ($map, $x, $y);
      }

      $done->($self) if $done;
   })->prio (1);
}

=item $player_object->enter_exit ($exit_object)

=cut

sub parse_random_map_params {
   my ($spec) = @_;

   my $rmp = { # defaults
      xsize    => (cf::rndm 15, 40),
      ysize    => (cf::rndm 15, 40),
      symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
      #layout   => string,
   };

   for (split /\n/, $spec) {
      my ($k, $v) = split /\s+/, $_, 2;

      $rmp->{lc $k} = $v if (length $k) && (length $v);
   }

   $rmp
}

sub prepare_random_map {
   my ($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

   my $rmp = parse_random_map_params $exit->msg;

   if ($exit->map) {
      $rmp->{region}     = $exit->region->name;
      $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 = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
   my $md5 = Digest::MD5::md5_hex $data;
   my $meta = "$RANDOMDIR/$md5.meta";

   if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
      aio_write $fh, 0, (length $data), $data, 0;
      undef $fh;
      aio_rename "$meta~", $meta;

      my $slaying = "?random/$md5";

      if ($exit->valid) {
         $exit->slaying ("?random/$md5");
         $exit->msg (undef);
      }
   }
}

sub cf::object::player::enter_exit {
   my ($self, $exit) = @_;

   return unless $self->type == cf::PLAYER;

   $self->enter_link;

   (async {
      $Coro::current->{desc} = "enter_exit";

      unless (eval {
         $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

            $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 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);

         error "ERROR in enter_exit: $@";
         $self->leave_link;
      }
   })->prio (1);
}

=head3 cf::client

=over 4

=item $client->send_big_packet ($pkt)

Like C<send_packet>, but tries to compress large packets, and fragments
them as required.

=cut

our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;

sub cf::client::send_big_packet {
   my ($self, $pkt) = @_;

   # try lzf for large packets
   $pkt = "lzf " . Compress::LZF::compress $pkt
      if 1024 <= length $pkt and $self->{can_lzf};

   # split very large packets
   if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
      $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
      $pkt = "frag";
   }

   $self->send_packet ($pkt);
}

=item $client->send_msg ($channel, $msg, $color, [extra...])

Send a 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<log> 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",
      reply   => undef,
      tooltip => "Items recently identified",
   },
   "c/examine" => {
      id      => "infobox",
      title   => "Examine",
      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",
      reply   => undef,
      tooltip => "The contents of a note or book",
   },
   "c/lookat" => {
      id      => "infobox",
      title   => "Look",
      reply   => undef,
      tooltip => "What you saw there",
   },
   "c/who" => {
      id      => "infobox",
      title   => "Players",
      reply   => undef,
      tooltip => "Shows players who are currently online",
   },
   "c/body" => {
      id      => "infobox",
      title   => "Body Parts",
      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",
      reply   => undef,
      tooltip => "How long the server has been running since last restart",
   },
   "c/mapinfo" => {
      id      => "infobox",
      title   => "Map Info",
      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)
      unless $color & cf::NDI_VERBATIM;

   $color &= cf::NDI_CLIENT_MASK; # just in case...

   # check predefined channels, for the benefit of C
   if ($CHANNEL{$channel}) {
      $channel = $CHANNEL{$channel};

      $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);
      }

      $channel = $channel->{id};
   }

   return unless @extra || length $msg;

   # 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_big_packet ($pkt);
}

=item $client->ext_msg ($type, @msg)

Sends an ext event to the client.

=cut

sub cf::client::ext_msg($$@) {
   my ($self, $type, @msg) = @_;

   $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
}

=item $success = $client->query ($flags, "text", \&cb)

Queues a query to the client, calling the given callback with
the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.

Queries can fail, so check the return code. Or don't, as queries will
become reliable at some point in the future.

=cut

sub cf::client::query {
   my ($self, $flags, $text, $cb) = @_;

   return unless $self->state == ST_PLAYING
              || $self->state == ST_SETUP
              || $self->state == ST_CUSTOM;

   $self->state (ST_CUSTOM);

   utf8::encode $text;
   push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];

   $self->send_packet ($self->{query_queue}[0][0])
      if @{ $self->{query_queue} } == 1;

   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) = @_;

      $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
   },
   on_reply => sub {
      my ($ns, $msg) = @_;

      # this weird shuffling is so that direct followup queries
      # get handled first
      my $queue = delete $ns->{query_queue}
         or return; # be conservative, not sure how that can happen, but we saw a crash here

      (shift @$queue)->[1]->($msg);
      return unless $ns->valid; # temporary(?) workaround for callback destroying socket

      push @{ $ns->{query_queue} }, @$queue;

      if (@{ $ns->{query_queue} } == @$queue) {
         if (@$queue) {
            $ns->send_packet ($ns->{query_queue}[0][0]);
         } else {
            $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
         }
      }
   },
   on_exticmd => sub {
      my ($ns, $buf) = @_;

      my $msg = eval { $ns->{json_coder}->decode ($buf) };

      if (ref $msg) {
         my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash

         if (my $cb = $EXTIACMD{$type}) {
            $cb->(
               $ns,
               sub {
                  $ns->ext_msg ("reply-$reply", @_)
                     if $reply;
               },
               @payload
            );
         } else {
            my @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";
      }

      cf::override;
   },
);

=item $client->async (\&cb)

Create a new coroutine, running the specified callback. The coroutine will
be automatically cancelled when the client gets destroyed (e.g. on logout,
or loss of connection).

=cut

sub cf::client::async {
   my ($self, $cb) = @_;

   my $coro = &Coro::async ($cb);

   $coro->on_destroy (sub {
      delete $self->{_coro}{$coro+0};
   });

   $self->{_coro}{$coro+0} = $coro;

   $coro
}

cf::client->attach (
   on_client_destroy => sub {
      my ($ns) = @_;

      $_->cancel for values %{ (delete $ns->{_coro}) || {} };
   },
);

=back


=head2 SAFE SCRIPTING

Functions that provide a safe environment to compile and execute
snippets of perl code without them endangering the safety of the server
itself. Looping constructs, I/O operators and other built-in functionality
is not available in the safe scripting environment, and the number of
functions and methods that can be called is greatly reduced.

=cut

our $safe = new Safe "safe";
our $safe_hole = new Safe::Hole;

$SIG{FPE} = 'IGNORE';

$safe->permit_only (Opcode::opset qw(
   :base_core :base_mem :base_orig :base_math :base_loop
   grepstart grepwhile mapstart mapwhile
   sort time
));

# here we export the classes and methods available to script code

=pod

The following functions and methods are available within a safe environment:

  cf::object
     contr pay_amount pay_player map x y force_find force_add destroy
     insert remove name archname title slaying race decrease split
     value

  cf::object::player
     player

  cf::player
     peaceful

  cf::map
     trigger

=cut

for (
   ["cf::object"         => qw(contr pay_amount pay_player map force_find force_add x y
                               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 send_msg)],
   ["cf::map"            => qw(trigger)],
) {
   my ($pkg, @funs) = @$_;
   *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
      for @funs;
}

=over 4

=item @retval = safe_eval $code, [var => value, ...]

Compiled and executes the given perl code snippet. additional var/value
pairs result in temporary local (my) scalar variables of the given name
that are available in the code snippet. Example:

   my $five = safe_eval '$first + $second', first => 1, second => 4;

=cut

sub safe_eval($;@) {
   my ($code, %vars) = @_;

   my $qcode = $code;
   $qcode =~ s/"/‟/g; # not allowed in #line filenames
   $qcode =~ s/\n/\\n/g;

   %vars = (_dummy => 0) unless %vars;

   my @res;
   local $_;

   my $eval =
      "do {\n"
      . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
      . "#line 0 \"{$qcode}\"\n"
      . $code
      . "\n}"
   ;

   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 "$@",
           "while executing safe code '$code'\n",
           "with arguments " . (join " ", %vars) . "\n";
   }

   wantarray ? @res : $res[0]
}

=item cf::register_script_function $function => $cb

Register a function that can be called from within map/npc scripts. The
function should be reasonably secure and should be put into a package name
like the extension.

Example: register a function that gets called whenever a map script calls
C<rent::overview>, as used by the C<rent> extension.

   cf::register_script_function "rent::overview" => sub {
     ...
   };

=cut

sub register_script_function {
   my ($fun, $cb) = @_;

   $fun = "safe::$fun" if $CFG{safe_eval};
   *$fun = $safe_hole->wrap ($cb);
}

=back

=cut

#############################################################################
# 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) = @_;

   my $enc = JSON::XS->new->utf8->canonical->relaxed;

   trace "loading facedata from $path\n";

   my $facedata = decode_storable load_file "$path/faceinfo";

   $facedata->{version} == 2
      or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";

   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};

      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_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) {
         next unless $info->{smooth};

         my $idx = cf::face::find $face
            or next;

         if (my $smooth = cf::face::find $info->{smooth}) {
            cf::face::set_smooth      $idx, $smooth;
            cf::face::set_smoothlevel $idx, $info->{smoothlevel};
         } else {
            error "smooth face '$info->{smooth}' not found for face '$face'";
         }
      }
   }

   {
      my $anims = $facedata->{animinfo};

      while (my ($anim, $info) = each %$anims) {
         cf::anim::set $anim, $info->{frames}, $info->{facings};
      }

      cf::anim::invalidate_all; # d'oh
   }

   {
      my $res = $facedata->{resource};

      while (my ($name, $info) = each %$res) {
         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_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
         }
      }
   }

   ($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
}

register_exticmd fx_want => sub {
   my ($ns, $want) = @_;

   while (my ($k, $v) = each %$want) {
      $ns->fx_want ($k, $v);
   }
};

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?)
   %ext::player_env::MUSIC_FACE_CACHE = ();

   load_resource_file "$MAPDIR/regions"
      or die "unable to load regions file\n";

   for (cf::region::list) {
      $_->{match} = qr/$_->{match}/
         if exists $_->{match};
   }
}

sub reload_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 {
   load_resource_file "$DATADIR/treasures"
      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 {
   trace "reloading resource files...\n";

   reload_materials;
   reload_facedata;
   reload_exp_table;
   reload_sound;
   reload_archetypes;
   reload_regions;
   reload_treasures;

   trace "finished reloading resource files\n";
}

sub reload_config {
   trace "reloading config file...\n";

   my $config = load_file "$CONFDIR/config";
   utf8::decode $config;
   *CFG = decode_yaml $config;

   $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};

   if (exists $CFG{mlockall}) {
      eval {
         $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
            and die "WARNING: m(un)lockall failed: $!\n";
      };
      warn $@ if $@;
   }
}

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::run starting\n";
   if (1) {
      EV::run;
   }
   trace "EV::run 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
   $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::run EV::RUN_ONCE;
      })->prio (Coro::PRIO_MAX);
   };

   evthread_start IO::AIO::poll_fileno;

   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;
}

#############################################################################
# initialisation and cleanup

# install some emergency cleanup handlers
BEGIN {
   our %SIGWATCHER = ();
   for my $signal (qw(INT HUP TERM)) {
      $SIGWATCHER{$signal} = AE::signal $signal, sub {
         cf::cleanup "SIG$signal";
      };
   }
}

sub write_runtime_sync {
   my $t0 = AE::time;

   # first touch the runtime file to show we are still running:
   # the fsync below can take a very very long time.

   IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;

   my $guard = cf::lock_acquire "write_runtime";

   my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
      or return;

   my $value = $cf::RUNTIME + 90 + 10;
   # 10 is the runtime save interval, for a monotonic clock
   # 60 allows for the watchdog to kill the server.

   (aio_write $fh, 0, (length $value), $value, 0) <= 0
      and return;

   # always fsync - this file is important
   aio_fsync $fh
      and return;

   # touch it again to show we are up-to-date
   aio_utime $fh, undef, undef;

   close $fh
      or return;

   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;

   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;

   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.
      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;
      }
      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;
         $map->valid or next;
         $map->save;
      }
      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

      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";
}

sub post_cleanup {
   my ($make_core) = @_;

   IO::AIO::flush;

   error Carp::longmess "post_cleanup backtrace"
      if $make_core;

   my $fh = pidfile;
   unlink $PIDFILE if <$fh> == $$;
}

# a safer delete_package, copied from Symbol
sub clear_package($) {
   my $pkg = shift;

   # 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 =~ /::$/;
   }

   my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
   my $stem_symtab = *{$stem}{HASH};

   defined $stem_symtab and exists $stem_symtab->{$leaf}
      or return;

   # 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"};
   }
}

sub do_reload_perl() {
   # can/must only be called in main
   unless (in_main) {
      error "can only reload from main coroutine";
      return;
   }

   return if $RELOAD++;

   my $t1 = AE::time;

   while ($RELOAD) {
      cf::get_slot 0.1, -1, "reload_perl";
      info "perl_reload: reloading...";

      trace "perl_reload: entering sync_job";

      cf::sync_job {
         #cf::emergency_save;

         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: $@";
            }

            trace "... clearing $pkg";
            clear_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$/;

            trace "... unloading $k";
            delete $INC{$k};

            $k =~ s/\.pm$//;
            $k =~ s/\//::/g;

            if (my $cb = $k->can ("unload_module")) {
               $cb->();
            }

            clear_package $k;
         }

         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;
         }

         cf::_post_init 1;

         trace "perl_reload: leaving sync_job";

         1
      } or do {
         error $@;
         cf::cleanup "perl_reload: error, exiting.";
      };

      --$RELOAD;
   }

   $t1 = AE::time - $t1;
   info "perl_reload: completed in ${t1}s\n";
};

our $RELOAD_WATCHER; # used only during reload

sub reload_perl() {
   # doing reload synchronously and two reloads happen back-to-back,
   # coro crashes during coro_state_free->destroy here.

   $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;
      };
   };
}

register_command "reload" => sub {
   my ($who, $arg) = @_;

   if ($who->flag (FLAG_WIZ)) {
      $who->message ("reloading server.");
      async {
         $Coro::current->{desc} = "perl_reload";
         reload_perl;
      };
   }
};

#############################################################################

my $bug_warning = 0;

sub wait_for_tick() {
   return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;

   $WAIT_FOR_TICK->wait;
}

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;
   $signal->wait;
}

sub tick {
   if ($Coro::current != $Coro::main) {
      Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
         unless ++$bug_warning > 10;
      return;
   }

   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_sync
            or error "ERROR: unable to write runtime file: $!";
      };
   }

   if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
      $sig->send;
   }
   $WAIT_FOR_TICK->broadcast;

   $LOAD = ($NOW - $TICK_START) / $TICK;
   $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;

   if (0) {
      if ($NEXT_TICK) {
         my $jitter = $TICK_START - $NEXT_TICK;
         $JITTER = $JITTER * 0.75 + $jitter * 0.25;
         debug "jitter $JITTER\n";#d#
      }
   }
}

{
   # configure BDB
   info "initialising database";

   BDB::min_parallel 16;
   BDB::max_poll_reqs $TICK * 0.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);
      $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);

      cf::sync_job {
         eval {
            BDB::db_env_open
               $DB_ENV,
               $BDBDIR,
               BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
               | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
               0666;

            cf::cleanup "db_env_open($BDBDIR): $!" if $!;
         };

         cf::cleanup "db_env_open(db): $@" if $@;
      };
   }

   $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
      BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
   };
   $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
      BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
   };
   $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";
}

our $_log_backtrace;
our $_log_backtrace_last;

sub _log_backtrace {
   my ($msg, @addr) = @_;

   $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
   } elsif ($_log_backtrace < 2) {
      $_log_backtrace_last = $msg;
      ++$_log_backtrace;
      my $perl_bt = Carp::longmess $msg;
      async {
         $Coro::current->{desc} = "abt $msg";

         my @bt = fork_call {
            @addr = map { sprintf "%x", $_ } @addr;
            my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
            open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
               or die "addr2line: $!";

            my @funcs;
            my @res = <$fh>;
            chomp for @res;
            while (@res) {
               my ($func, $line) = splice @res, 0, 2, ();
               push @funcs, "[$func] $line";
            }

            @funcs
         };

         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] [overload, suppressed]\n";
   }
}

# load additional modules
require "cf/$_.pm" for @EXTRA_MODULES;
cf::_connect_to_perl_2;

END { cf::emergency_save }

1

Revision:	1.618
Committed:	Mon Aug 10 18:48:41 2015 UTC (8 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.617:	+1 -1 lines
Log Message:	* empty log message *