server/lib/cf.pm

package cf;

use utf8;
use strict;

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

use Coro 3.3 ();
use Coro::Event;
use Coro::Timer;
use Coro::Signal;
use Coro::Semaphore;
use Coro::AIO;

use Data::Dumper;
use Digest::MD5;
use Fcntl;
use IO::AIO 2.32 ();
use YAML::Syck ();
use Time::HiRes;

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

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

# 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

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 @EVENT;
our $LIBDIR = datadir . "/ext";

our $TICK = MAX_TIME * 1e-6;
our $TICK_WATCHER;
our $NEXT_TICK;
our $NOW;

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
our $RANDOM_MAPS = cf::localdir . "/random";

our $WAIT_FOR_TICK;     $WAIT_FOR_TICK     ||= new Coro::Signal;
our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;

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

binmode STDOUT;
binmode STDERR;

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

mkdir cf::localdir;
mkdir cf::localdir . "/" . cf::playerdir;
mkdir cf::localdir . "/" . cf::tmpdir;
mkdir cf::localdir . "/" . cf::uniquedir;
mkdir $RANDOM_MAPS;

our $EMERGENCY_POSITION;

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

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

The perl library directory, where extensions and cf-specific modules can
be found. It will be added to C<@INC> automatically.

=item $cf::NOW

The time of the last (current) server tick.

=item $cf::TICK

The interval between server ticks, in seconds.

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

These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
processing has been done. Call C<< ->wait >> on them to maximise the
window of cpu time available, or simply to synchronise to the server tick.

=back

=cut

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

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

      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::Syck (); # TODO# replace by JSON::PC once working

=item $ref = cf::from_json $json

Converts a JSON string into the corresponding perl data structure.

=cut

sub from_json($) {
   $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
   JSON::Syck::Load $_[0]
}

=item $json = cf::to_json $ref

Converts a perl data structure into its JSON representation.

=cut

sub to_json($) {
   $JSON::Syck::ImplicitUnicode = 0;  # work around JSON::Syck bugs
   JSON::Syck::Dump $_[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.

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

=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 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) {
      # 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;
      }

      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 {
   return unless $TICK_WATCHER->is_active;

   my $runtime = cf::localdir . "/runtime";

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

   my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
   (aio_write $fh, 0, (length $value), $value, 0) <= 0
      and return;

   aio_fsync $fh
      and return;

   close $fh
      or return;

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

   1
}

=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 _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_SUBTYPES] ||= [];

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

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

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

   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;
            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;
                  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($) {
   cf::localdir
     . "/"
     . cf::playerdir
     . "/"
     . (ref $_[0] ? $_[0]->ob->name : $_[0])
}

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

   (playerdir $login) . "/$login.pl"
}

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

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

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

      $cf::PLAYER{$_[0]} || do {
         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) = @_;

   $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;
   IO::AIO::aio_rmtree $temp;
}

=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 cf::localdir . "/" . cf::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) = @_;

   my $files = aio_readdir playerdir $pl
      or return;

   my @paths;

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

      s/\.map$//;
      push @paths, "~" . $pl->ob->name . "/" . $_;
   }

   \@paths
}

=item $player->ext_reply ($msgid, $msgtype, %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);
}

package cf;

=back


=head3 cf::map

=over 4

=cut

package cf::map;

use Fcntl;
use Coro::AIO;

use overload
   '""' => \&as_string;

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

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

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

   $EXT_MAP{$pkg} = qr<$regex>;
}

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

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

   # 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 (keys %EXT_MAP) {
      if ($path =~ $EXT_MAP{$pkg}) {
         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'.";
   ()
}

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

   sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
}

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

   (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
   sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path
}

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

   (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
   sprintf "%s/%s/%s", cf::localdir, cf::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; IO::AIO::aio_unlink $save;
   IO::AIO::aioreq_pri 4; IO::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_orig {
   my ($self) = @_;

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

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

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

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

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

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

   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) {
         $map->reset;
         undef $guard;
         $map = find $path
            or return;
      }

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

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

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

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

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

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 = Coro::async {
   while () {
      for my $path (keys %MAP_PREFETCH) {
         my $map = find $path
            or next;
         $map->load;

         delete $MAP_PREFETCH{$path};
      }
      Coro::schedule;
   }
};

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

   $MAP_PREFETCH{$path} = 0;
   $MAP_PREFETCHER->ready;

   ()
}

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");
   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 rename {
   my ($self, $new_path) = @_;

   normalise $new_path;

   $self->unlink_save;

   delete $cf::MAP{$self->path};
   $self->{path} = $new_path; $self->path ($self->{path});
   $cf::MAP{$self->path} = $self;

   $self->save;
}

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#

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

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

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

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

my $nuke_counter = "aaaa";

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

   $self->{deny_save} = 1;
   $self->reset_timeout (1);
   $self->rename ("{nuke}/" . ($nuke_counter++));
   $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 cf::localdir . "/" . cf::uniquedir
      or return;

   my @paths;

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

      s/\.map$//;
      push @paths, $_;
   }

   \@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 do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
      $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, 20, 20);
}

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;
   $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 {
            # 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
            $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);
            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 = cf::map::find $path;
      $map = $map->customise_for ($self) if $map;

#      warn "entering ", $map->path, " at ($x, $y)\n"
#         if $map;

      $map or $self->message ("The exit to '" . ($path->visible_name) . "' 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 => 10,
      ysize => 10,
   };

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

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

   $rmp
}

sub prepare_random_map {
   my ($exit) = @_;

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

   my $rmp = parse_random_map_params $exit->msg;

   if ($exit->map) {
      $rmp->{region}     = $exit->map->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;

   if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
      aio_write $fh, 0, (length $data), $data, 0;

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

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

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

   $self->enter_link;

   (async {
      $self->deactivate_recursive; # just to be sure
      unless (eval {
         prepare_random_map $exit
            if $exit->slaying eq "/!";

         my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
         $self->goto ($path, $exit->stats->hp, $exit->stats->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, $text);
}


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

      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 fucntions and emthods 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 anything that can be serialised using Storable, which
excludes objects.

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

=over 4

=item $hashref = cf::db_get $family

Return a hashref for use by the extension C<$family>, which can be
modified. After modifications, you have to call C<cf::db_dirty> or
C<cf::db_sync>.

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

Returns a single value from the database

=item cf::db_put $family => $hashref

Stores the given family hashref into the database. Updates are delayed, if
you want the data to be synced to disk immediately, use C<cf::db_sync>.

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

Stores the given C<$value> in the family hash. Updates are delayed, if you
want the data to be synced to disk immediately, use C<cf::db_sync>.

=item cf::db_dirty

Marks the database as dirty, to be updated at a later time.

=item cf::db_sync

Immediately write the database to disk I<if it is dirty>.

=cut

our $DB;

{
   my $path = cf::localdir . "/database.pst";

   sub db_load() {
      $DB = stat $path ? Storable::retrieve $path : { };
   }

   my $pid;

   sub db_save() {
      waitpid $pid, 0 if $pid;
      if (0 == ($pid = fork)) {
         $DB->{_meta}{version} = 1;
         Storable::nstore $DB, "$path~";
         rename "$path~", $path;
         cf::_exit 0 if defined $pid;
      }
   }

   my $dirty;

   sub db_sync() {
      db_save if $dirty;
      undef $dirty;
   }

   my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
      db_sync;
   });

   sub db_dirty() {
      $dirty = 1;
      $idle->start;
   }

   sub db_get($;$) {
      @_ >= 2
         ? $DB->{$_[0]}{$_[1]}
         : ($DB->{$_[0]} ||= { })
   }

   sub db_put($$;$) {
      if (@_ >= 3) {
         $DB->{$_[0]}{$_[1]} = $_[2];
      } else {
         $DB->{$_[0]} = $_[1];
      }
      db_dirty;
   }

   cf::global->attach (
      prio       => 10000,
      on_cleanup => sub {
         db_sync;
      },
   );
}

#############################################################################
# the server's main()

sub cfg_load {
   open my $fh, "<:utf8", cf::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 };
   };

   cfg_load;
   db_load;
   load_extensions;
   Event::loop;
}

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

# install some emergency cleanup handlers
BEGIN {
   for my $signal (qw(INT HUP TERM)) {
      Event->signal (
         data   => WF_AUTOCANCEL,
         signal => $signal,
         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 "leave emergency perl save\n";
}

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

   warn "reloading...";

   warn "freezing server";
   my $guard = freeze_mainloop;
   cf::emergency_save;

   warn "sync database to disk";
   cf::db_sync;
   IO::AIO::flush;

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

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

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

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

      warn "remove ext commands";
      %EXTCMD = ();

      warn "unload/nuke 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 "unload all perl modules loaded from $LIBDIR";
      while (my ($k, $v) = each %INC) {
         next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;

         warn "removing <$k>";
         delete $INC{$k};

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

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

         Symbol::delete_package $k;
      }

      warn "get 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 "unload cf.pm \"a bit\"";
      delete $INC{"cf.pm"};

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

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

      warn "load config and database again";
      cf::cfg_load;
      cf::db_load;

      warn "load extensions";
      cf::load_extensions;

      warn "reattach attachments to objects/players";
      _global_reattach;
      warn "reattach attachments to maps";
      reattach $_ for values %MAP;
   };

   if ($@) {
      warn $@;
      warn "error while reloading, exiting.";
      exit 1;
   }

   warn "reloaded";
};

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

   if ($who->flag (FLAG_WIZ)) {
      $who->message ("start of reload.");
      reload;
      $who->message ("end of reload.");
   }
};

unshift @INC, $LIBDIR;

$TICK_WATCHER = Event->timer (
   reentrant => 0,
   prio      => 0,
   at        => $NEXT_TICK || $TICK,
   data      => WF_AUTOCANCEL,
   cb        => sub {
      $NOW = Event::time;

      cf::server_tick; # one server iteration
      $RUNTIME   += $TICK;
      $NEXT_TICK += $TICK;

      $WAIT_FOR_TICK->broadcast;
      $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;

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

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

IO::AIO::max_poll_time $TICK * 0.2;

Event->io (
   fd   => IO::AIO::poll_fileno,
   poll => 'r',
   prio => 5,
   data => WF_AUTOCANCEL,
   cb   => \&IO::AIO::poll_cb,
);

Event->timer (
   data     => WF_AUTOCANCEL,
   after    => 0,
   interval => 10,
   cb       => sub {
      (Coro::unblock_sub {
         write_runtime
            or warn "ERROR: unable to write runtime file: $!";
      })->();
   },
);

END { cf::emergency_save }

1

Revision:	1.167
Committed:	Sat Jan 13 23:32:43 2007 UTC (17 years, 4 months ago) by root
Branch:	MAIN
Changes since 1.166:	+11 -25 lines
Log Message:	fixes, starting to look good again