server/lib/cf.pm

package cf;

use utf8;
use strict;

use Symbol;
use List::Util;
use Socket;
use Storable;
use Event;
use Opcode;
use Safe;
use Safe::Hole;

use Coro 3.64 ();
use Coro::State;
use Coro::Handle;
use Coro::Event;
use Coro::Timer;
use Coro::Signal;
use Coro::Semaphore;
use Coro::AIO;
use Coro::Storable;
use Coro::Util ();

use JSON::XS ();
use BDB ();
use Data::Dumper;
use Digest::MD5;
use Fcntl;
use YAML::Syck ();
use IO::AIO 2.32 ();
use Time::HiRes;
use Compress::LZF;
use Digest::MD5 ();

# configure various modules to our taste
#
$Storable::canonical = 1; # reduce rsync transfers
Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later

$Event::Eval = 1; # no idea why this is required, but it is

# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
$YAML::Syck::ImplicitUnicode = 1;

$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority

sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload

our %COMMAND      = ();
our %COMMAND_TIME = ();

our @EXTS         = (); # list of extension package names
our %EXTCMD       = ();
our %EXTICMD      = ();
our %EXT_CORO     = (); # coroutines bound to extensions
our %EXT_MAP      = (); # pluggable maps

our $RELOAD; # number of reloads so far
our @EVENT;

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 $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
our $TICK_WATCHER;
our $AIO_POLL_WATCHER;
our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
our $NEXT_TICK;
our $NOW;
our $USE_FSYNC = 1; # use fsync to write maps - default off

our $BDB_POLL_WATCHER;
our $DB_ENV;

our %CFG;

our $UPTIME; $UPTIME ||= time;
our $RUNTIME;

our %PLAYER; # all users
our %MAP;    # 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 $tick_start; # for load detecting purposes

binmode STDOUT;
binmode STDERR;

# read virtual server time, if available
unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
   open my $fh, "<", "$LOCALDIR/runtime"
      or die "unable to read runtime file: $!";
   $RUNTIME = <$fh> + 0.;
}

mkdir $_
   for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;

our $EMERGENCY_POSITION;

sub cf::map::normalise;

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

=head2 GLOBAL VARIABLES

=over 4

=item $cf::UPTIME

The timestamp of the server start (so not actually an uptime).

=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::NOW

The time of the last (current) server tick.

=item $cf::TICK

The interval between server ticks, in seconds.

=item $cf::LOADAVG

The current CPU load on the server (alpha-smoothed), as a value between 0
(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/crossfire/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 process
per tick), while cf::wait_for_tick wakes up all waiters after tick processing.

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

=back

=cut

BEGIN {
   *CORE::GLOBAL::warn = sub {
      my $msg = join "", @_;

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

      $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;

      utf8::encode $msg;
      LOG llevError, $msg;
   };
}

@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::party cf::region
)) {
   no strict 'refs';
   @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
}

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

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

=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 $ref = cf::from_json $json

Converts a JSON string into the corresponding perl data structure.

=item $json = cf::to_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 to_json   ($) { $json_coder->encode ($_[0]) }
sub from_json ($) { $json_coder->decode ($_[0]) }

=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 Coro::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 %LOCK;

sub lock_wait($) {
   my ($key) = @_;

   # wait for lock, if any
   while ($LOCK{$key}) {
      push @{ $LOCK{$key} }, $Coro::current;
      Coro::schedule;
   }
}

sub lock_acquire($) {
   my ($key) = @_;

   # wait, to be sure we are not locked
   lock_wait $key;

   $LOCK{$key} = [];

   Coro::guard {
      # wake up all waiters, to be on the safe side
      $_->ready for @{ delete $LOCK{$key} };
   }
}

sub lock_active($) {
   my ($key) = @_;

   ! ! $LOCK{$key}
}

sub freeze_mainloop {
   return unless $TICK_WATCHER->is_active;

   my $guard = Coro::guard {
      $TICK_WATCHER->start;
   };
   $TICK_WATCHER->stop;
   $guard
}

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

Allocate $time seconds of blocking CPU time at priority C<$priority>:
This call blocks and returns only when you have at least C<$time> seconds
of cpu time till the next tick. The slot is only valid till the next cede.

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;

$SLOT_QUEUE->cancel if $SLOT_QUEUE;
$SLOT_QUEUE = Coro::async {
   my $signal = new Coro::Signal;

   while () {
      next_job:
      my $avail = cf::till_tick;
      if ($avail > 0.01) {
         for (0 .. $#SLOT_QUEUE) {
            if ($SLOT_QUEUE[$_][0] < $avail) {
               my $job = splice @SLOT_QUEUE, $_, 1, ();
               $job->[2]->send;
               Coro::cede;
               goto next_job;
            }
         }
      }

      if (@SLOT_QUEUE) {
         # we do not use wait_For_tick() as it returns immediately when tick is inactive
         push @cf::WAIT_FOR_TICK, $signal;
         $signal->wait;
      } else {
         Coro::schedule;
      }
   }
};

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

   $time = $TICK * .6 if $time > $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 Crossfire TRT requires that the main coroutine ($Coro::main)
is always able to handle events or runnable, as Crossfire TRT 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 ($Coro::current == $Coro::main) {
      my $time = Event::time;

      # this is the main coro, too bad, we have to block
      # till the operation succeeds, freezing the server :/
      
      # TODO: use suspend/resume instead
      # (but this is cancel-safe)
      my $freeze_guard = freeze_mainloop;

      my $busy = 1;
      my @res;

      (async {
         @res = eval { $job->() };
         warn $@ if $@;
         undef $busy;
      })->prio (Coro::PRIO_MAX);

      while ($busy) {
         Coro::cede or Event::one_event;
      }

      $time = Event::time - $time;

      LOG llevError | logBacktrace, Carp::longmess "long sync job"
         if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;

      $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 fork_call(&@) {
   my ($cb, @args) = @_;

   # we seemingly have to make a local copy of the whole thing,
   # otherwise perl prematurely frees the stuff :/
   # TODO: investigate and fix (liekly this will be rather laborious)

   my @res = Coro::Util::fork_eval {
      reset_signals;
      &$cb
   }, @args;

   wantarray ? @res : $res[-1]
}

=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).

=cut

our $DB;

sub db_init {
   unless ($DB) {
      $DB = BDB::db_create $DB_ENV;

      cf::sync_job {
         eval {
            $DB->set_flags (BDB::CHKSUM);

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

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

   cf::sync_job {
      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) {
         0 <= aio_load $src->[$_], $data[$_]
            or Carp::croak "$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 = Time::HiRes::time;
      my $data = $process->(\@data);
      my $t2 = Time::HiRes::time;

      warn "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) = @_;
  warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
}

=back

=cut

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

=head2 ATTACHABLE OBJECTS

Many objects in crossfire 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
Crossfire TRT).

=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 crossfire 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) {
         warn "attaching objects not supported, ignoring.\n";

      } else {
         shift @arg;
         warn "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 {
      warn "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 ($@) {
         warn "$@";
         warn "... 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 _can_merge {
   my ($ob1, $ob2) = @_;

   local $Storable::canonical = 1;
   my $fob1 = Storable::freeze $ob1;
   my $fob2 = Storable::freeze $ob2;

   $fob1 eq $fob2
}

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

   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 {
         warn "object uses attachment '$name' that is not available, postponing.\n";
      }
   }
}

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

      $data = from_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) {
         warn sprintf "saving %s (%d,%d)\n",
            $filename, length $$rdata, scalar @$objs;

         if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
            chmod SAVE_MODE, $fh;
            aio_write $fh, 0, (length $$rdata), $$rdata, 0;
            aio_fsync $fh if $cf::USE_FSYNC;
            close $fh;

            if (@$objs) {
               if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
                  chmod SAVE_MODE, $fh;
                  my $data = Storable::nfreeze { version => 1, objs => $objs };
                  aio_write $fh, 0, (length $data), $data, 0;
                  aio_fsync $fh if $cf::USE_FSYNC;
                  close $fh;
                  aio_rename "$filename.pst~", "$filename.pst";
               }
            } else {
               aio_unlink "$filename.pst";
            }

            aio_rename "$filename~", $filename;
         } else {
            warn "FATAL: $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;
      $av = eval { (Storable::thaw $av)->{objs} };
   }

   warn sprintf "loading %s (%d)\n",
      $filename, length $data, scalar @{$av || []};
   return ($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,$packet);

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.

If the callback returns something, it is sent back as if reply was being
called.

=item cf::register_exticmd $name => \&callback($ns,$packet);

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.

If the callback returns something, it is sent back as if reply was being
called.

=cut

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

   $EXTCMD{$name} = $cb;
}

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

   $EXTICMD{$name} = $cb;
}

cf::player->attach (
   on_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) =
            "ARRAY" eq ref $msg
               ? @$msg
               : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove

         my @reply;

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

         $pl->ext_reply ($reply, @reply)
            if $reply;

      } else {
         warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
      }

      cf::override;
   },
);

sub load_extensions {
   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 strict; use utf8;\n"
            . "#line 1 \"$path\"\n{\n"
            . $source
            . "\n};\n1";

         $todo{$base} = \%ext;
      }

      my %done;
      while (%todo) {
         my $progress;

         while (my ($k, $v) = each %todo) {
            for (split /,\s*/, $v->{meta}{depends}) {
               goto skip
                  unless exists $done{$_};
            }

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

            unless (eval $v->{source}) {
               my $msg = $@ ? "$v->{path}: $@\n"
                            : "$v->{base}: extension inactive.\n";

               if (exists $v->{meta}{mandatory}) {
                  warn $msg;
                  warn "mandatory extension failed to load, exiting.\n";
                  exit 1;
               }
               
               warn $msg;
            }

            $done{$k} = delete $todo{$k};
            push @EXTS, $v->{pkg};
            $progress = 1;
         }

         skip:
         die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
            unless $progress;
      }
   };
}

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

=back

=head2 CORE EXTENSIONS

Functions and methods that extend core crossfire objects.

=cut

package cf::player;

use Coro::AIO;

=head3 cf::player

=over 4

=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 cf::sync_job { !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 $pl = load_pl path $login
            or return;
         $cf::PLAYER{$login} = $pl
      }
   }
}

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;

   $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 nuked the dir

   $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
   $pl->deactivate;
   $pl->invoke (cf::EVENT_PLAYER_QUIT);
   $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
      unless (-e "$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

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 ($crossfire_pod)

Expand crossfire pod fragments into protocol xml.

=cut

sub expand_cfpod {
   ((my $self), (local $_)) = @_;

   # escape & and <
   s/&/&amp;/g;
   s/(?<![BIUGHT])</&lt;/g;

   # this is buggy, it needs to properly take care of nested <'s

   1 while
      # replace B<>, I<>, U<> etc.
      s/B<([^\>]*)>/<b>$1<\/b>/
      || s/I<([^\>]*)>/<i>$1<\/i>/
      || s/U<([^\>]*)>/<u>$1<\/u>/
      || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
      # replace G<male|female> tags
      || s{G<([^>|]*)\|([^>]*)>}{
         $self->gender ? $2 : $1
      }ge
      # replace H<hint text>
      || s{H<([^\>]*)>}
          {
             ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
              "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
              "")
                [$self->{hintmode}]
          }ge;

   # create single paragraphs (very hackish)
   s/(?<=\S)\n(?=\w)/ /g;

   # compress some whitespace
   s/\s+\n/\n/g; # ws line-ends
   s/\n\n+/\n/g; # double lines
   s/^\n+//;     # beginning lines
   s/\n+$//;     # ending lines

   $_
}

sub hintmode {
   $_[0]{hintmode} = $_[1] if @_ > 1;
   $_[0]{hintmode}
}

=item $player->ext_reply ($msgid, @msg)

Sends an ext reply to the player.

=cut

sub ext_reply($$@) {
   my ($self, $id, @msg) = @_;

   $self->ns->ext_reply ($id, @msg)
}

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

   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) = @_;
   # mit "rum" bekleckern, nicht
   $self->_create_random_map (
      $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
      $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
      $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
      $rmp->{exit_on_final_map},
      $rmp->{xsize}, $rmp->{ysize},
      $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
      $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
      $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
      $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
      $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
      (cf::region::find $rmp->{region}), $rmp->{custom}
   )
}

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

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

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

# also paths starting with '/'
$EXT_MAP{"cf::map"} = [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 its 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{/\.?/}{/};
      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').";
   ()
}

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/g;
   "$TMPDIR/$path.map"
}

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

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

# and all this just because we cannot iterate over
# all maps in C++...
sub change_all_map_light {
   my ($change) = @_;

   $_->change_map_light ($change)
      for grep $_->outdoor, values %cf::MAP;
}

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

   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;
   #aio_open $path, O_RDONLY, 0
   #   or return;

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

   $self->{load_path} = $path;

   1
}

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

   $self->load_header_from ($self->load_path)
}

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

   $self->load_header_from ($self->save_path)
}

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

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

   $path = normalise $path, $origin && $origin->path;

   cf::lock_wait "map_find:$path";

   $cf::MAP{$path} || do {
      my $guard = cf::lock_acquire "map_find:$path";
      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;
         $map->reset;
         undef $guard;
         return find $path;
      }

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

sub pre_load  { }
sub post_load { }

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

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

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

   {
      my $guard1 = cf::lock_acquire "map_data:$path";
      my $guard2 = cf::lock_acquire "map_load:$path";

      return if $self->in_memory != cf::MAP_SWAPPED;

      $self->in_memory (cf::MAP_LOADING);

      $self->alloc;

      $self->pre_load;
      cf::cede_to_tick;

      $self->_load_objects ($self->{load_path}, 1)
         or return;

      $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
         if delete $self->{load_original};

      if (my $uniq = $self->uniq_path) {
         utf8::encode $uniq;
         if (aio_open $uniq, O_RDONLY, 0) {
            $self->clear_unique_items;
            $self->_load_objects ($uniq, 0);
         }
      }

      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->set_darkness_map;
         cf::cede_to_tick;
         $self->activate;
      }

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

      $self->in_memory (cf::MAP_IN_MEMORY);
   }

   $self->post_load;
}

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
}

# find and load all maps in the 3x3 area around a map
sub load_neighbours {
   my ($map) = @_;

   my @neigh; # diagonal neighbours

   for (0 .. 3) {
      my $neigh = $map->tile_path ($_)
         or next;
      $neigh = find $neigh, $map
         or next;
      $neigh->load;

      push @neigh,
         [$neigh->tile_path (($_ + 3) % 4), $neigh],
         [$neigh->tile_path (($_ + 1) % 4), $neigh];
   }

   for (grep defined $_->[0], @neigh) {
      my ($path, $origin) = @$_;
      my $neigh = find $path, $origin
         or next;
      $neigh->load;
   }
}

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

   cf::sync_job { find $path, $origin }
}

sub do_load_sync {
   my ($map) = @_;

   cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
      if $Coro::current == $Coro::main;

   cf::sync_job { $map->load };
}

our %MAP_PREFETCH;
our $MAP_PREFETCHER = undef;

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

   $path = normalise $path, $origin && $origin->{path};

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

   $MAP_PREFETCH{$path} |= $load;

   $MAP_PREFETCHER ||= cf::async {
      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);

   ()
}

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

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

   $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 {
      $_->contr->save for $self->players;
   };

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

   # save first because save cedes
   $self->save;

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

   return if $self->players;
   return if $self->in_memory != cf::MAP_IN_MEMORY;
   return if $self->{deny_save};

   $self->clear;
   $self->in_memory (cf::MAP_SWAPPED);
}

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;

   warn "resetting map ", $self->path;

   $self->in_memory (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->clear;

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

   $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";
      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 $_;
         /\.map$/
            ? normalise $_
            : ()
      } @{ aio_readdir $UNIQUEDIR or [] }
   ]
}

package cf;

=back

=head3 cf::object

=cut

package cf::object;

=over 4

=item $ob->inv_recursive

Returns the inventory of the object _and_ their inventories, recursively.

=cut

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

sub inv_recursive {
   inv_recursive_ inv $_[0]
}

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

# 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->message ($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").

=cut

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

   $self->flag (cf::FLAG_WIZ) || 
      (ref $cf::CFG{"may_$access"}
         ? scalar grep $self->name 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. You
I<MUST> call C<leave_link> as soon as possible, though.

Will never block.

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

   return if UNIVERSAL::isa $self->map, "ext::map_link";

   $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
      if $self->map && $self->map->{path} ne "{link}";

   $self->enter_map ($LINK_MAP || link_map, 10, 10);
}

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;
   $map->load_neighbours;

   return unless $self->contr->active;
   $self->activate_recursive;

   local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
   $self->enter_map ($map, $x, $y);
}

=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])

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.

=cut

our $GOTOGEN;

sub cf::object::player::goto {
   my ($self, $path, $x, $y, $check, $done) = @_;

   # do generation counting so two concurrent goto's will be executed in-order
   my $gen = $self->{_goto_generation} = ++$GOTOGEN;

   $self->enter_link;

   (async {
      my $map = eval {
         my $map = cf::map::find $path;

         if ($map) {
            $map = $map->customise_for ($self);
            $map = $check->($map) 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->() 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) = @_;

   my $guard = cf::lock_acquire "exit_prepare:$exit";

   # all this does is basically replace the /! path by
   # a new random map path (?random/...) with a seed
   # that depends on the exit object

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

   $rmp->{random_seed} ||= $exit->random_seed;

   my $data = cf::to_json $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;

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

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

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

   if ($exit->slaying eq "/!") {
      #TODO: this should de-fi-ni-te-ly not be a sync-job
      # the problem is that $exit might not survive long enough
      # so it needs to be done right now, right here
      cf::sync_job { prepare_random_map $exit };
   }

   my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
   my $hp      = $exit->stats->hp;
   my $sp      = $exit->stats->sp;

   $self->enter_link;

   # if exit is damned, update players death & WoR home-position
   $self->contr->savebed ($slaying, $hp, $sp)
      if $exit->flag (FLAG_DAMNED);

   (async {
      $self->deactivate_recursive; # just to be sure
      unless (eval {
         $self->goto ($slaying, $hp, $sp);

         1;
      }) {
         $self->message ("Something went wrong deep within the crossfire server. "
                       . "I'll try to bring you back to the map you were before. "
                       . "Please report this to the dungeon master!",
                         cf::NDI_UNIQUE | cf::NDI_RED);

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

=head3 cf::client

=over 4

=item $client->send_drawinfo ($text, $flags)

Sends a drawinfo packet to the client. Circumvents output buffering so
should not be used under normal circumstances.

=cut

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

   utf8::encode $text;
   $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
}

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

Send a drawinfo or msg packet to the client, formatting the msg for the
client if neccessary. C<$type> should be a string identifying the type of
the message, with C<log> being the default. If C<$color> is negative, suppress
the message unless the client supports the msg packet.

=cut

our %CHANNEL = (
   "c/identify" => {
      id      => "identify",
      title   => "Identify",
      reply   => undef,
      tooltip => "Items recently identified",
   },
   "c/examine" => {
      id      => "examine",
      title   => "Examine",
      reply   => undef,
      tooltip => "Signs and other items you examined",
   },
);

sub cf::client::send_msg {
   my ($self, $channel, $msg, $color, @extra) = @_;

   $msg = $self->pl->expand_cfpod ($msg);

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

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

   if (ref $channel) {
      # send meta info to client, if not yet sent
      unless (exists $self->{channel}{$channel->{id}}) {
         $self->{channel}{$channel->{id}} = $channel;
         $self->ext_msg (channel_info => $channel)
            if $self->can_msg;
      }

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

   return unless @extra || length $msg;

   if ($self->can_msg) {
      # default colour, mask it out
      $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
         if $color & cf::NDI_DEF;

      $self->send_packet ("msg " . $self->{json_coder}->encode (
         [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
   } else {
      if ($color >= 0) {
         # replace some tags by gcfclient-compatible ones
         for ($msg) {
            1 while
               s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
               || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
               || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
               || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
               || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
         }

         $color &= cf::NDI_COLOR_MASK;

         utf8::encode $msg;

         if (0 && $msg =~ /\[/) {
            # COMMAND/INFO
            $self->send_packet ("drawextinfo $color 10 8 $msg")
         } else {
            $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
            $self->send_packet ("drawinfo $color $msg")
         }
      }
   }
}

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

Sends an ext event to the client.

=cut

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

   if ($self->extcmd == 2) {
      $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
   } elsif ($self->extcmd == 1) { # TODO: remove
      push @msg, msgtype => "event_$type";
      $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
   }
}

=item $client->ext_reply ($msgid, @msg)

Sends an ext reply to the client.

=cut

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

   if ($self->extcmd == 2) {
      $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
   } elsif ($self->extcmd == 1) {
      #TODO: version 1, remove
      unshift @msg, msgtype => "reply", msgid => $id;
      $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
   }
}

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

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) =
            "ARRAY" eq ref $msg
               ? @$msg
               : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove

         my @reply;

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

         $ns->ext_reply ($reply, @reply)
            if $reply;

      } else {
         warn "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_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
   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
     insert remove name archname title slaying race decrease_ob_nr

  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 name archname title slaying race
                               decrease_ob_nr)],
   ["cf::object::player" => qw(player)],
   ["cf::player"         => qw(peaceful)],
   ["cf::map"            => qw(trigger)],
) {
   no strict 'refs';
   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;

   local $_;
   local @safe::cf::_safe_eval_args = values %vars;

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

   sub_generation_inc;
   my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
   sub_generation_inc;

   if ($@) {
      warn "$@";
      warn "while executing safe code '$code'\n";
      warn "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) = @_;

   no strict 'refs';
   *{"safe::$fun"} = $safe_hole->wrap ($cb);
}

=back

=cut

#############################################################################
# the server's init and main functions

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

   # HACK to clear player env face cache, we need some signal framework
   # for this (global event?)
   %ext::player_env::MUSIC_FACE_CACHE = ();

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

   warn "loading facedata from $path\n";

   my $facedata;
   0 < aio_load $path, $facedata
      or die "$path: $!";

   $facedata = Coro::Storable::thaw $facedata;

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

   # patch in the exptable
   $facedata->{resource}{"res/exp_table"} = {
      type => FT_RSRC,
      data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
   };
   cf::cede_to_tick;

   {
      my $faces = $facedata->{faceinfo};

      while (my ($face, $info) = each %$faces) {
         my $idx = (cf::face::find $face) || cf::face::alloc $face;
         cf::face::set_visibility $idx, $info->{visibility};
         cf::face::set_magicmap   $idx, $info->{magicmap};
         cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
         cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};

         cf::cede_to_tick;
      }

      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 {
            warn "smooth face '$info->{smooth}' not found for face '$face'";
         }

         cf::cede_to_tick;
      }
   }

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

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

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

   {
      # TODO: for gcfclient pleasure, we should give resources
      # that gcfclient doesn't grok a >10000 face index.
      my $res = $facedata->{resource};

      my $soundconf = delete $res->{"res/sound.conf"};

      while (my ($name, $info) = each %$res) {
         my $idx = (cf::face::find $name) || cf::face::alloc $name;
         my $data;

         if ($info->{type} & 1) {
            # prepend meta info

            my $meta = $enc->encode ({
               name => $name,
               %{ $info->{meta} || {} },
            });

            $data = pack "(w/a*)*", $meta, $info->{data};
         } else {
            $data = $info->{data};
         }

         cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
         cf::face::set_type $idx, $info->{type};

         cf::cede_to_tick;
      }

      if ($soundconf) {
         $soundconf = $enc->decode (delete $soundconf->{data});

         for (0 .. SOUND_CAST_SPELL_0 - 1) {
            my $sound = $soundconf->{compat}[$_]
               or next;

            my $face = cf::face::find "sound/$sound->[1]";
            cf::sound::set $sound->[0] => $face;
            cf::sound::old_sound_index $_, $face; # gcfclient-compat
         }

         while (my ($k, $v) = each %{$soundconf->{event}}) {
            my $face = cf::face::find "sound/$v";
            cf::sound::set $k => $face;
         }
      }
   }

   1
}

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

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

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/facedata"
      or die "unable to load facedata\n";
}

sub reload_archetypes {
   load_resource_file "$DATADIR/archetypes"
      or die "unable to load archetypes\n";
   #d# NEED to laod twice to resolve forward references
   # this really needs to be done in an extra post-pass
   # (which needs to be synchronous, so solve it differently)
   load_resource_file "$DATADIR/archetypes"
      or die "unable to load archetypes\n";
}

sub reload_treasures {
   load_resource_file "$DATADIR/treasures"
      or die "unable to load treasurelists\n";
}

sub reload_resources {
   warn "reloading resource files...\n";

   reload_regions;
   reload_facedata;
   #reload_archetypes;#d#
   reload_archetypes;
   reload_treasures;

   warn "finished reloading resource files\n";
}

sub init {
   reload_resources;
}

sub reload_config {
   open my $fh, "<:utf8", "$CONFDIR/config"
      or return;

   local $/;
   *CFG = YAML::Syck::Load <$fh>;

   $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];

   $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 main {
   # we must not ever block the main coroutine
   local $Coro::idle = sub {
      Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
      (async {
         Event::one_event;
      })->prio (Coro::PRIO_MAX);
   };

   reload_config;
   db_init;
   load_extensions;

   $TICK_WATCHER->start;
   Event::loop;
}

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

# install some emergency cleanup handlers
BEGIN {
   for my $signal (qw(INT HUP TERM)) {
      Event->signal (
         reentrant => 0,
         data      => WF_AUTOCANCEL,
         signal    => $signal,
         prio      => 0,
         cb        => sub {
            cf::cleanup "SIG$signal";
         },
      );
   }
}

sub write_runtime {
   my $runtime = "$LOCALDIR/runtime";

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

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

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

   my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 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 "$runtime~", $runtime
      and return;

   warn "runtime file written.\n";

   1
}

sub emergency_save() {
   my $freeze_guard = cf::freeze_mainloop;

   warn "enter emergency perl save\n";

   cf::sync_job {
      # use a peculiar iteration method to avoid tripping on perl
      # refcount bugs in for. also avoids problems with players
      # and maps saved/destroyed asynchronously.
      warn "begin emergency player save\n";
      for my $login (keys %cf::PLAYER) {
         my $pl = $cf::PLAYER{$login} or next;
         $pl->valid or next;
         $pl->save;
      }
      warn "end emergency player save\n";

      warn "begin emergency map save\n";
      for my $path (keys %cf::MAP) {
         my $map = $cf::MAP{$path} or next;
         $map->valid or next;
         $map->save;
      }
      warn "end emergency map save\n";

      warn "begin emergency database checkpoint\n";
      BDB::db_env_txn_checkpoint $DB_ENV;
      warn "end emergency database checkpoint\n";
   };

   warn "leave emergency perl save\n";
}

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

   warn Carp::longmess "post_cleanup backtrace"
      if $make_core;
}

sub do_reload_perl() {
   # can/must only be called in main
   if ($Coro::current != $Coro::main) {
      warn "can only reload from main coroutine";
      return;
   }

   warn "reloading...";

   warn "entering sync_job";

   cf::sync_job {
      cf::write_runtime; # external watchdog should not bark
      cf::emergency_save;
      cf::write_runtime; # external watchdog should not bark

      warn "syncing database to disk";
      BDB::db_env_txn_checkpoint $DB_ENV;

      # if anything goes wrong in here, we should simply crash as we already saved

      warn "cancelling all WF_AUTOCANCEL watchers";
      for (Event::all_watchers) {
         $_->cancel if $_->data & WF_AUTOCANCEL;
      }

      warn "flushing outstanding aio requests";
      for (;;) {
         BDB::flush;
         IO::AIO::flush;
         Coro::cede;
         last unless IO::AIO::nreqs || BDB::nreqs;
         warn "iterate...";
      }

      ++$RELOAD;

      warn "cancelling all extension coros";
      $_->cancel for values %EXT_CORO;
      %EXT_CORO = ();

      warn "removing commands";
      %COMMAND = ();

      warn "removing ext/exti commands";
      %EXTCMD  = ();
      %EXTICMD = ();

      warn "unloading/nuking all extensions";
      for my $pkg (@EXTS) {
         warn "... unloading $pkg";

         if (my $cb = $pkg->can ("unload")) {
            eval {
               $cb->($pkg);
               1
            } or warn "$pkg unloaded, but with errors: $@";
         }

         warn "... nuking $pkg";
         Symbol::delete_package $pkg;
      }

      warn "unloading all perl modules loaded from $LIBDIR";
      while (my ($k, $v) = each %INC) {
         next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;

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

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

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

         Symbol::delete_package $k;
      }

      warn "getting rid of safe::, as good as possible";
      Symbol::delete_package "safe::$_"
         for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);

      warn "unloading cf.pm \"a bit\"";
      delete $INC{"cf.pm"};
      delete $INC{"cf/pod.pm"};

      # don't, removes xs symbols, too,
      # and global variables created in xs
      #Symbol::delete_package __PACKAGE__;

      warn "unload completed, starting to reload now";

      warn "reloading cf.pm";
      require cf;
      cf::_connect_to_perl; # nominally unnecessary, but cannot hurt

      warn "loading config and database again";
      cf::reload_config;

      warn "loading extensions";
      cf::load_extensions;

      warn "reattaching attachments to objects/players";
      _global_reattach; # objects, sockets
      warn "reattaching attachments to maps";
      reattach $_ for values %MAP;
      warn "reattaching attachments to players";
      reattach $_ for values %PLAYER;

      warn "leaving sync_job";

      1
   } or do {
      warn $@;
      warn "error while reloading, exiting.";
      exit 1;
   };

   warn "reloaded";
};

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 ||= Event->timer (
      reentrant => 0,
      after     => 0,
      data      => WF_AUTOCANCEL,
      cb => sub {
         do_reload_perl;
         undef $RELOAD_WATCHER;
      },
   );
}

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

   if ($who->flag (FLAG_WIZ)) {
      $who->message ("reloading server.");
      async { reload_perl };
   }
};

unshift @INC, $LIBDIR;

my $bug_warning = 0;

our @WAIT_FOR_TICK;
our @WAIT_FOR_TICK_BEGIN;

sub wait_for_tick {
   return unless $TICK_WATCHER->is_active;
   return if $Coro::current == $Coro::main;

   my $signal = new Coro::Signal;
   push @WAIT_FOR_TICK, $signal;
   $signal->wait;
}

sub wait_for_tick_begin {
   return unless $TICK_WATCHER->is_active;
   return if $Coro::current == $Coro::main;

   my $signal = new Coro::Signal;
   push @WAIT_FOR_TICK_BEGIN, $signal;
   $signal->wait;
}

      my $min = 1e6;#d#
      my $avg = 10;
$TICK_WATCHER = Event->timer (
   reentrant => 0,
   parked    => 1,
   prio      => 0,
   at        => $NEXT_TICK || $TICK,
   data      => WF_AUTOCANCEL,
   cb        => sub {
      if ($Coro::current != $Coro::main) {
         Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
            unless ++$bug_warning > 10;
         return;
      }

      $NOW = $tick_start = Event::time;

      cf::server_tick; # one server iteration

      0 && sync_job {#d#
         for(1..10)  {
            my $t = Event::time;
            my $map = my $map = new_from_path cf::map "/tmp/x.map"
                     or die;

            $map->width (50);
            $map->height (50);
            $map->alloc;
            $map->_load_objects ("/tmp/x.map", 1);
            my $t = Event::time - $t;

            #next unless $t < 0.0013;#d#
            if ($t < $min) {
               $min = $t;
            }
            $avg = $avg * 0.99 + $t * 0.01;
         }
         warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
         exit 0;
         # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
      };

      $RUNTIME   += $TICK;
      $NEXT_TICK += $TICK;

      if ($NOW >= $NEXT_RUNTIME_WRITE) {
         $NEXT_RUNTIME_WRITE = $NOW + 10;
         Coro::async_pool {
            write_runtime
               or warn "ERROR: unable to write runtime file: $!";
         };
      }

#      my $AFTER = Event::time;
#      warn $AFTER - $NOW;#d#

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

      $NOW = Event::time;

      # if we are delayed by four ticks or more, skip them all
      $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;

      $TICK_WATCHER->at ($NEXT_TICK);
      $TICK_WATCHER->start;

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

      _post_tick;


   },
);

{
   BDB::max_poll_time $TICK * 0.1;
   $BDB_POLL_WATCHER = Event->io (
      reentrant => 0,
      fd        => BDB::poll_fileno,
      poll      => 'r',
      prio      => 0,
      data      => WF_AUTOCANCEL,
      cb        => \&BDB::poll_cb,
   );
   BDB::min_parallel 8;

   BDB::set_sync_prepare {
      my $status;
      my $current = $Coro::current;
      (
         sub {
            $status = $!;
            $current->ready; undef $current;
         },
         sub {
            Coro::schedule while defined $current;
            $! = $status;
         },
      )
   };

   unless ($DB_ENV) {
      $DB_ENV = BDB::db_env_create;

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

            $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
            $DB_ENV->set_lk_detect;
         };

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

{
   IO::AIO::min_parallel 8;

   undef $Coro::AIO::WATCHER;
   IO::AIO::max_poll_time $TICK * 0.1;
   $AIO_POLL_WATCHER = Event->io (
      reentrant => 0,
      data      => WF_AUTOCANCEL,
      fd        => IO::AIO::poll_fileno,
      poll      => 'r',
      prio      => 6,
      cb        => \&IO::AIO::poll_cb,
   );
}

my $_log_backtrace;

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

   $msg =~ s/\n//;

   # limit the # of concurrent backtraces
   if ($_log_backtrace < 2) {
      ++$_log_backtrace;
      async {
         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] $msg\n";
         LOG llevInfo, "[ABT] $_\n" for @bt;
         --$_log_backtrace;
      };
   } else {
      LOG llevInfo, "[ABT] $msg\n";
      LOG llevInfo, "[ABT] [suppressed]\n";
   }
}

# load additional modules
use cf::pod;

END { cf::emergency_save }

1

Revision:	1.354
Committed:	Sun Sep 2 12:26:54 2007 UTC (16 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.353:	+8 -3 lines
Log Message:	optimisation