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.61 ();
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 BDB ();
use Data::Dumper;
use Digest::MD5;
use Fcntl;
use YAML::Syck ();
use IO::AIO 2.32 ();
use Time::HiRes;
use Compress::LZF;

# 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 %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.

=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::object::player::ISA = @cf::object::player::ISA = 'cf::object';

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

use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working

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

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

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::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+ requires that the main coro ($Coro::main) is
always able to handle events or runnable, as crossfire+ 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
}

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.

   if (my $fh = aio_open $runtime, O_WRONLY, 0) {
      utime undef, undef, $fh;
   }

   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
   utime undef, undef, $fh;

   close $fh
      or return;

   aio_rename "$runtime~", $runtime
      and return;

   warn "runtime file written.\n";#d#

   1
}

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

=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' that 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 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 || []};#d#
   return ($data, $av);
}

#############################################################################
# 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 callbackf ro execution when the client sends an extcmd packet.

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

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 { from_json $buf };

      if (ref $msg) {
         if (my $cb = $EXTCMD{$msg->{msgtype}}) {
            if (my %reply = $cb->($pl, $msg)) {
               $pl->ext_reply ($msg->{msgid}, %reply);
            }
         }
      } else {
         warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
      }

      cf::override;
   },
);

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

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

   warn "... loading '$path' into '$pkg'\n";

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

   my $source =
      "package $pkg; use strict; use utf8;\n"
      . "#line 1 \"$path\"\n{\n"
      . (do { local $/; <$fh> })
      . "\n};\n1";

   unless (eval $source) {
      my $msg = $@ ? "$path: $@\n"
                   : "extension disabled.\n";
      if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
         warn $@;
         warn "mandatory extension failed to load, exiting.\n";
         exit 1;
      }
      die $@;
   }

   push @EXTS, $pkg;
}

sub load_extensions {
   for my $ext (<$LIBDIR/*.ext>) {
      next unless -r $ext;
      eval {
         load_extension $ext;
         1
      } or warn "$ext not loaded: $@";
   }
}

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

=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);
   Coro::cede;
}

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

   my $self = create;

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

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

   $self
}

=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 $fh = aio_open path $login, 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 $player->ext_reply ($msgid, %msg)

Sends an ext reply to the player.

=cut

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

   $msg{msgid} = $id;

   $self->send ("ext " . cf::to_json \%msg);
}

=item $player->ext_event ($type, %msg)

Sends an ext event to the client.

=cut

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

   $self->ns->ext_event ($type, %msg);
}

=head3 cf::region

=over 4

=cut

package cf::region;

=item cf::region::find_by_path $path

Tries to decuce the probable 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};
   local $self->{deny_save};
   local $self->{deny_reset};

   $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::carp "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 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->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 && 0) {#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 $guard = 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;
      Coro::cede;

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

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

      unless ($self->{deny_activate}) {
         $self->decay_objects;
         $self->fix_auto_apply;
         $self->update_buttons;
         Coro::cede;
         $self->set_darkness_map;
         Coro::cede;
         $self->activate;
      }

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

   $self
}

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

   my @diag; # diagonal neighbours

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

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

   for (@diag) {
      my $neigh = find @$_
         or next;
      $neigh->load;
   }
}

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

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

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

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

our %MAP_PREFETCH;
our $MAP_PREFETCHER = undef;

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

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

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

   undef $MAP_PREFETCH{$path};
   $MAP_PREFETCHER ||= cf::async {
      while (%MAP_PREFETCH) {
         for my $path (keys %MAP_PREFETCH) {
            my $map = find $path
               or next;
            $map->load;

            delete $MAP_PREFETCH{$path};
         }
      }
      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->isa ("ext::map_per_player");#d#
   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;
   return if $self->isa ("ext::map_per_player");#d#

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

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

   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 cf::map::unique_maps

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

=cut

sub unique_maps() {
   my $files = aio_readdir $UNIQUEDIR
      or return;

   my @paths;

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

      push @paths, cf::map::normalise $_;
   }

   \@paths
}

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 {
      $msg = $npc->name . " says: $msg" if $npc;
      $self->message ($msg, $flags);
   }
}

=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->enter_map ($LINK_MAP || link_map, 10, 10);
}

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

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

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

cf::player->attach (
   on_logout => sub {
      my ($pl) = @_;

      # abort map switching before logout
      if ($pl->ob->{_link_pos}) {
         cf::sync_job {
            $pl->ob->leave_link
         };
      }
   },
   on_login => sub {
      my ($pl) = @_;

      # try to abort aborted map switching on player login :)
      # should happen only on crashes
      if ($pl->ob->{_link_pos}) {
         $pl->ob->enter_link;
         (async {
            $pl->ob->reply (undef,
                            "There was an internal problem at your last logout, "
                          . "the server will try to bring you to your intended destination in a second.",
                            cf::NDI_RED);
            # we need this sleep as the login has a concurrent enter_exit running
            # and this sleep increases chances of the player not ending up in scorn
            Coro::Timer::sleep 1;
            $pl->ob->leave_link;
         })->prio (2);
      }
   },
);

=item $player_object->goto ($path, $x, $y)

=cut

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

   $self->enter_link;

   (async {
      my $map = eval {
         my $map = cf::map::find $path;
         $map = $map->customise_for ($self) if $map;
         $map
      } or
         $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);

      $self->leave_link ($map, $x, $y);
   })->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;

   (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->ext_event ($type, %msg)

Sends an exti event to the client.

=cut

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

   $msg{msgtype} = "event_$type";
   $self->send_packet ("ext " . cf::to_json \%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;
}

cf::client->attach (
   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;
         }
      }
   },
);

=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 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
  cf::object::player player
  cf::player peaceful
  cf::map trigger

=cut

for (
   ["cf::object"         => qw(contr pay_amount pay_player map)],
   ["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

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

=head2 EXTENSION DATABASE SUPPORT

Crossfire maintains a very simple database for extension use. It can
currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
convert to/from binary).

The parameter C<$family> should best start with the name of the extension
using it, it should be unique.

=over 4

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

Returns a single value from the database.

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

Stores the given C<$value> in the family.

=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 {
                  Coro::cede;
                  ($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 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) = @_;

#   socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
#      or die "socketpair: $!";
   pipe my $fh1, my $fh2
      or die "pipe: $!";

   if (my $pid = fork) {
      close $fh2;

      my $res = (Coro::Handle::unblock $fh1)->readline (undef);
      $res = Coro::Storable::thaw $res;

      waitpid $pid, 0; # should not block anymore, we expect the child to simply behave

      die $$res unless "ARRAY" eq ref $res;

      return wantarray ? @$res : $res->[-1];
   } else {
      reset_signals;
      local $SIG{__WARN__};
      local $SIG{__DIE__};
      eval {
         close $fh1;

         my @res = eval { $cb->(@args) };
         syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
      };

      warn $@ if $@;
      _exit 0;
   }
}


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

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

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

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

      while (my ($face, $info) = each %$faces) {
         my $idx = (cf::face::find $face) || cf::face::alloc $face;
         cf::face::set $idx, $info->{visibility}, $info->{magicmap};
         cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
         cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
         Coro::cede;
      }

      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, $info->{smoothlevel};
         } else {
            warn "smooth face '$info->{smooth}' not found for face '$face'";
         }
         Coro::cede;
      }
   }

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

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

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

   1
}

sub reload_regions {
   load_resource_file "$MAPDIR/regions"
      or die "unable to load regions file\n";
}

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

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

   warn "finished reloading resource files\n";
}

sub init {
   reload_resources;
}

sub cfg_load {
   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);
   };

   cfg_load;
   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 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 commands";
      %EXTCMD = ();

      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::cfg_load;

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

$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

      $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.267
Committed:	Sat May 19 00:08:11 2007 UTC (17 years ago) by root
Branch:	MAIN
Changes since 1.266:	+3 -1 lines
Log Message:	- optimise invoke by using an inline check on a bitset (kind of a simplified bloom filter for all events).