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 Digest::MD5;
use Fcntl;
use IO::AIO 2.31 ();
use YAML::Syck ();
use Time::HiRes;

use Event; $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 (2); # 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 %EXTCMD       = ();

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 %MAP; # all maps
our $LINK_MAP; # the special {link} map
our $FREEZE;
our $RANDOM_MAPS = cf::localdir . "/random";
our %EXT_CORO;

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;

# a special map that is always available
our $LINK_MAP;

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

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

=back

=cut

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

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

      LOG llevError, "cfperl: $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: @_";
};

my %ext_pkg;
my @exts;
my @hook;

=head2 UTILITY FUNCTIONS

=over 4

=cut

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

   my $busy = 1;
   my @res;

   # TODO: use suspend/resume instead
   local $FREEZE = 1;

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

   if ($Coro::current == $Coro::main) {
      $coro->prio (Coro::PRIO_MAX);
      while ($busy) {
         Coro::cede_notself;
         Event::one_event unless Coro::nready;
      }
   } else {
      $coro->join;
   }

   wantarray ? @res : $res[0]
}

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

Creates and returns a new coro. This coro is automcatially being canceled
when the extension calling this is being unloaded.

=cut

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

   my $coro; $coro = async {
      eval {
         $cb->();
      };
      warn $@ if $@;
   };

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

   $coro
}

sub write_runtime {
   my $runtime = cf::localdir . "/runtime";

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

   my $value = $cf::RUNTIME;
   (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

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

package cf::path;

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

   my $self = bless { }, $class;

   if ($path =~ s{^\?random/}{}) {
      $self->{random} = cf::from_json $path;
   } else {
      if ($path =~ s{^~([^/]+)?}{}) {
         $self->{user_rel} = 1;

         if (defined $1) {
            $self->{user} = $1;
         } elsif ($base =~ m{^~([^/]+)/}) {
            $self->{user} = $1;
         } else {
            warn "cannot resolve user-relative path without user <$path,$base>\n";
         }
      } elsif ($path =~ /^\//) {
         # already absolute
      } else {
         $base =~ s{[^/]+/?$}{};
         return $class->new ("$base/$path");
      }

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

   $self->{path} = $path;

   $self
}

# the name / primary key / in-game path
sub as_string {
   my ($self) = @_;

   $self->{user_rel} ? "~$self->{user}$self->{path}"
   : $self->{random} ? "?random/$self->{path}"
                     : $self->{path}
}

# the displayed name, this is a one way mapping
sub visible_name {
   my ($self) = @_;

   $self->{random} ? "?random/$self->{random}{origin_map}+$self->{random}{origin_x}+$self->{random}{origin_y}/$self->{random}{dungeon_level}"
                   : $self->as_string
}

# escape the /'s in the path
sub _escaped_path  {
   # ∕ is U+2215
   (my $path = $_[0]{path}) =~ s/\//∕/g;
   $path
}

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

   $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
   : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, Digest::MD5::md5_hex $self->{path}
                     : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
}

# the unique path, might be eq to save_path
sub uniq_path {
   my ($self) = @_;

   $self->{user_rel} || $self->{random}
      ? undef
      : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
}

# return random map parameters, or undef
sub random_map_params {
   my ($self) = @_;

   $self->{random}
}

# this is somewhat ugly, but style maps do need special treatment
sub is_style_map {
   $_[0]{path} =~ m{^/styles/}
}

package cf;

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

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

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

   my $caller = caller;
   #warn "registering extcmd '$name' to '$caller'";

   $EXTCMD{$name} = [$cb, $caller];
}

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->[0]->($pl, $msg)) {
               $pl->ext_reply ($msg->{msgid}, %reply);
            }
         }
      } else {
         warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
      }

      cf::override;
   },
);

sub register {
   my ($base, $pkg) = @_;

   #TODO
}

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

   eval $source
      or die $@ ? "$path: $@\n"
                : "extension disabled.\n";

   push @exts, $pkg;
   $ext_pkg{$base} = $pkg;

#   no strict 'refs';
#   @{"$pkg\::ISA"} = ext::;

   register $base, $pkg;
}

sub unload_extension {
   my ($pkg) = @_;

   warn "removing extension $pkg\n";

   # remove hooks
   #TODO
#   for my $idx (0 .. $#PLUGIN_EVENT) {
#      delete $hook[$idx]{$pkg};
#   }

   # remove commands
   for my $name (keys %COMMAND) {
      my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };

      if (@cb) {
         $COMMAND{$name} = \@cb;
      } else {
         delete $COMMAND{$name};
      }
   }

   # remove extcmds
   for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
      delete $EXTCMD{$name};
   }

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

   Symbol::delete_package $pkg;
}

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

#############################################################################
# load/save/clean perl data associated with a map

*cf::mapsupport::on_clean = sub {
   my ($map) = @_;

   my $path = $map->tmpname;
   defined $path or return;

   unlink "$path.pst";
};

cf::map->attach (prio => -10000, package => cf::mapsupport::);

#############################################################################
# load/save perl data associated with player->ob objects

sub all_objects(@) {
   @_, map all_objects ($_->inv), @_
}

# TODO: compatibility cruft, remove when no longer needed
cf::player->attach (
   on_load => sub {
      my ($pl, $path) = @_;

      for my $o (all_objects $pl->ob) {
         if (my $value = $o->get_ob_key_value ("_perl_data")) {
            $o->set_ob_key_value ("_perl_data");

            %$o = %{ Storable::thaw pack "H*", $value };
         }
      }
   },
);

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

=head2 CORE EXTENSIONS

Functions and methods that extend core crossfire objects.

=head3 cf::player

=over 4

=item cf::player::exists $login

Returns true when the given account exists.

=cut

sub cf::player::exists($) {
   cf::player::find $_[0]
      or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
}

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

Sends an ext reply to the player.

=cut

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

   $msg{msgid} = $id;

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

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

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

      (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->coro (\&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::coro {
   my ($self, $cb) = @_;

   my $coro; $coro = async {
      eval {
         $cb->();
      };
      warn $@ if $@;
   };

   $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() {
      warn "loading database $path\n";#d# remove later
      $DB = stat $path ? Storable::retrieve $path : { };
   }

   my $pid;

   sub db_save() {
      warn "saving database $path\n";#d# remove later
      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>;
}

sub main {
   # we must not ever block the main coroutine
   local $Coro::idle = sub {
      Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
      (Coro::unblock_sub {
         Event::one_event;
      })->();
   };

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

#############################################################################
# initialisation

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

   warn "reloading...";

   local $FREEZE = 1;
   cf::emergency_save;

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

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

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

      # unload all extensions
      for (@exts) {
         warn "unloading <$_>";
         unload_extension $_;
      }

      # unload all 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;
      }

      # sync database to disk
      cf::db_sync;
      IO::AIO::flush;

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

      # remove register_script_function callbacks
      # TODO
      
      # 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__;

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

      # load config and database again
      cf::cfg_load;
      cf::db_load;

      # load extensions
      warn "load extensions";
      cf::load_extensions;

      # reattach attachments to objects
      warn "reattach";
      _global_reattach;
   };

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

   warn "reloaded successfully";
};

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

unless ($LINK_MAP) {
   $LINK_MAP = cf::map::new;

   $LINK_MAP->width  (41);
   $LINK_MAP->height (41);
   $LINK_MAP->alloc;
   $LINK_MAP->path ("{link}");
   $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
   $LINK_MAP->in_memory (MAP_IN_MEMORY);
}

register "<global>", __PACKAGE__;

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

   if ($who->flag (FLAG_WIZ)) {
      $who->message ("start of reload.");
      perl_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 {
      unless ($FREEZE) {
         cf::server_tick; # one server iteration
         $RUNTIME += $TICK;
      }

      $NEXT_TICK += $TICK;

      # 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: $!";
      })->();
   },
);

1

Revision:	1.108
Committed:	Sun Dec 31 21:02:05 2006 UTC (17 years, 4 months ago) by root
Branch:	MAIN
Changes since 1.107:	+171 -15 lines
Log Message:	more use of shstr where it makes sense naturally