--- deliantra/server/lib/cf.pm	2012/11/09 02:50:50	1.594
+++ deliantra/server/lib/cf.pm	2016/11/23 06:05:33	1.622
@@ -59,8 +59,8 @@
 use Data::Dumper;
 use Fcntl;
 use YAML::XS ();
+use CBOR::XS ();
 use IO::AIO ();
-use Time::HiRes;
 use Compress::LZF;
 use Digest::MD5 ();
 
@@ -228,7 +228,7 @@
 The time this server has run, starts at 0 and is increased by $cf::TICK on
 every server tick.
 
-=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR  $cf::PODDIR
+=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
 $cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
 $cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
 
@@ -254,11 +254,12 @@
 
 =item cf::wait_for_tick, cf::wait_for_tick_begin
 
-These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
-returns directly I<after> the tick processing (and consequently, can only wake one thread
-per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
+These are functions that inhibit the current coroutine one tick.
+cf::wait_for_tick_begin only returns directly I<after> the tick
+processing (and consequently, can only wake one thread per tick), while
+cf::wait_for_tick wakes up all waiters after tick processing.
 
-Note that cf::Wait_for_tick will immediately return when the server is not
+Note that cf::wait_for_tick will immediately return when the server is not
 ticking, making it suitable for small pauses in threads that need to run
 when the server is paused. If that is not applicable (i.e. you I<really>
 want to wait, use C<$cf::WAIT_FOR_TICK>).
@@ -466,6 +467,20 @@
    fork_call { YAML::XS::Load $_[0] } @_
 }
 
+=item $scalar = cf::decode_cbor $scalar
+
+Same as CBOR::XS::decode_cbor, but takes server ticks into account, so
+blocks. For small amounts of data, C<CBOR::XS::decode_cbor> is the better
+alternative.
+
+=cut
+
+sub decode_cbor($) {
+   # we assume 10mb/s minimum decoding speed (on a ~2ghz machine)
+   cf::get_slot +(length $_[0]) / 10_000_000, 0, "decode_cbor";
+   CBOR::XS::decode_cbor $_[0]
+}
+
 =item $scalar = cf::unlzf $scalar
 
 Same as Compress::LZF::compress, but takes server ticks into account, so
@@ -512,7 +527,7 @@
 
 =item cf::lock_wait $string
 
-Wait until the given lock is available. See cf::lock_acquire. 
+Wait until the given lock is available. See cf::lock_acquire.
 
 =item my $lock = cf::lock_acquire $string
 
@@ -575,7 +590,7 @@
 C<$time> seconds of cpu time till the next tick. The slot is only valid
 till the next cede.
 
-Background jobs should use a priority les than zero, interactive jobs
+Background jobs should use a priority less than zero, interactive jobs
 should use 100 or more.
 
 The optional C<$name> can be used to identify the job to run. It might be
@@ -599,6 +614,8 @@
    while () {
       next_job:
 
+      Coro::cede;
+
       my $avail = cf::till_tick;
 
       for (0 .. $#SLOT_QUEUE) {
@@ -606,7 +623,6 @@
             $busy = 0;
             my $job = splice @SLOT_QUEUE, $_, 1, ();
             $job->[2]->send;
-            Coro::cede;
             goto next_job;
          } else {
             $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
@@ -614,8 +630,7 @@
       }
 
       if (@SLOT_QUEUE) {
-         # we do not use wait_for_tick() as it returns immediately when tick is inactive
-         $WAIT_FOR_TICK->wait;
+         wait_for_tick;
       } else {
          $busy = 0;
          Coro::schedule;
@@ -651,7 +666,7 @@
 =item cf::sync_job { BLOCK }
 
 The design of Deliantra requires that the main coroutine ($Coro::main)
-is always able to handle events or runnable, as Deliantra is only
+is always able to handle events or is runnable, as Deliantra is only
 partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
 acceptable.
 
@@ -689,7 +704,7 @@
          if (Coro::nready) {
             Coro::cede_notself;
          } else {
-            EV::loop EV::LOOP_ONESHOT;
+            EV::run EV::RUN_ONCE;
          }
       }
 
@@ -741,10 +756,6 @@
 sub fork_call(&@) {
    my ($cb, @args) = @_;
 
-   # we seemingly have to make a local copy of the whole thing,
-   # otherwise perl prematurely frees the stuff :/
-   # TODO: investigate and fix (likely this will be rather laborious)
-
    my @res = Coro::Util::fork_eval {
       cf::post_fork;
       &$cb
@@ -903,9 +914,9 @@
          }
       }
 
-      my $t1 = Time::HiRes::time;
+      my $t1 = EV::time;
       my $data = $process->(\@data);
-      my $t2 = Time::HiRes::time;
+      my $t2 = EV::time;
 
       info "cache: '$id' processed in ", $t2 - $t1, "s\n";
 
@@ -2390,9 +2401,9 @@
       $Coro::current->{desc} = "map prefetcher";
 
       while (%MAP_PREFETCH) {
-         while (my ($k, $v) = each %MAP_PREFETCH) {
+         for my $k (keys %MAP_PREFETCH) {
             if (my $map = find $k) {
-               $map->load if $v;
+               $map->load if $MAP_PREFETCH{$k};
             }
 
             delete $MAP_PREFETCH{$k};
@@ -2656,7 +2667,7 @@
 
 =item $ob = cf::object::deref ($refstring)
 
-returns the objetc referenced by refstring. may return undef when it cnanot find the object,
+returns the objetc referenced by refstring. may return undef when it cannot find the object,
 even if the object actually exists. May block.
 
 =cut
@@ -2748,14 +2759,39 @@
 Returns wether the given player is authorized to access resource "access"
 (e.g. "command_wizcast").
 
+This is implemented by checking a config setting of C<may_access> where
+C<access> is replaced by the access string. The following alternatives are
+possible (and are tested in order):
+
+=over 4
+
+=item * Player is DM
+
+The request will succeed.
+
+=item * may_access is an array reference
+
+If either the player nickname or UUID is in the array, the request will
+succeed, otherwise it will fail.
+
+=item * may_access is a true value
+
+The request will succeed.
+
+=item * may_access is missing or false
+
+The request will fail.
+
+=back
+
 =cut
 
 sub cf::object::player::may {
    my ($self, $access) = @_;
 
-   $self->flag (cf::FLAG_WIZ) || 
+   $self->flag (cf::FLAG_WIZ) ||
       (ref $cf::CFG{"may_$access"}
-         ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
+         ? scalar grep $self->name eq $_ || $self->uuid eq $_, @{$cf::CFG{"may_$access"}}
          : $cf::CFG{"may_$access"})
 }
 
@@ -2768,7 +2804,13 @@
 though, as the player cannot control the character while it is on the link
 map.
 
-Will never block.
+This method will never block, which is the whole reaosn for it's
+existance: you can I<always> put a player onto the link map, which is the
+only place to put objects that is guaranteed to exist.
+
+A typical usage pattern is to call C<enter_link> synchronously from the
+server, then start a new thread, do your blocking stuff there and then
+call C<leave_link> from that thread.
 
 =item $player_object->leave_link ($map, $x, $y)
 
@@ -3048,20 +3090,6 @@
 
 =over 4
 
-=item $client->send_drawinfo ($text, $flags)
-
-Sends a drawinfo packet to the client. Circumvents output buffering so
-should not be used under normal circumstances.
-
-=cut
-
-sub cf::client::send_drawinfo {
-   my ($self, $text, $flags) = @_;
-
-   utf8::encode $text;
-   $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
-}
-
 =item $client->send_big_packet ($pkt)
 
 Like C<send_packet>, but tries to compress large packets, and fragments
@@ -3089,9 +3117,9 @@
 
 =item $client->send_msg ($channel, $msg, $color, [extra...])
 
-Send a drawinfo or msg packet to the client, formatting the msg for the
-client if neccessary. C<$type> should be a string identifying the type of
-the message, with C<log> being the default. If C<$color> is negative, suppress
+Send a msg packet to the client, formatting the msg for the client if
+necessary. C<$type> should be a string identifying the type of the
+message, with C<log> being the default. If C<$color> is negative, suppress
 the message unless the client supports the msg packet.
 
 =cut
@@ -3206,6 +3234,12 @@
       reply   => undef,
       tooltip => "Reason for and more info about your most recent death",
    },
+   "c/fatal" => {
+      id      => "fatal",
+      title   => "Fatal Error",
+      reply   => undef,
+      tooltip => "Reason for the server disconnect",
+   },
    "c/say"     => $SAY_CHANNEL,
    "c/chat"    => $CHAT_CHANNEL,
 );
@@ -3290,6 +3324,45 @@
    1
 }
 
+=item $client->update_command_faces
+
+=cut
+
+our %COMMAND_FACE;
+
+sub cf::client::update_command_faces {
+   my ($self) = @_;
+
+   my @faces = grep $_,
+      $COMMAND_FACE{preferred},
+      $COMMAND_FACE{standard},
+      $COMMAND_FACE{skill},
+      $self->pl->ob->flag (cf::FLAG_WIZ) ? $COMMAND_FACE{dm} : (),
+      $COMMAND_FACE{emote},
+   ;
+
+   $self->send_face ($_)
+      for @faces;
+   $self->flush_fx;
+
+   $self->ext_msg (command_list => @faces);
+}
+
+=item cf::client::set_command_face $type, $commands
+
+=cut
+
+sub cf::client::set_command_face {
+   my ($type, $list) = @_;
+
+   my $idx = &cf::face::set ( #d# ugly forward reference
+      "command_list/$type" => cf::FT_RSRC,
+      JSON::XS->new->utf8->encode ([ sort @$list ])
+   );
+
+   $COMMAND_FACE{$type} = $idx;
+}
+
 cf::client->attach (
    on_connect => sub {
       my ($ns) = @_;
@@ -3521,47 +3594,103 @@
 #############################################################################
 # the server's init and main functions
 
-our %FACEHASH; # hash => idx, #d# HACK for http server
+{
+   package cf::face;
 
-# internal api, not fianlised
-sub add_face {
-   my ($name, $type, $data) = @_;
+   our %HASH; # hash => idx
+   our @DATA; # dynamically-created facedata, only faceste 0 used
+   our @FOFS; # file offset, if > 0
+   our @SIZE; # size of face, in octets
+   our @META; # meta hash of face, if any
+   our $DATAFH; # facedata filehandle
+
+   # internal api, not finalised
+   sub set {
+      my ($name, $type, $data) = @_;
 
-   my $idx = cf::face::find $name;
+      my $idx = cf::face::find $name;
 
-   if ($idx) {
-      delete $FACEHASH{cf::face::get_chksum $idx};
-   } else {
-      $idx = cf::face::alloc $name;
+      if ($idx) {
+         delete $HASH{cf::face::get_csum $idx};
+      } else {
+         $idx = cf::face::alloc $name;
+      }
+
+      my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
+
+      cf::face::set_type $idx, $type;
+      cf::face::set_csum $idx, 0, $hash;
+
+      # we need to destroy the SV itself, not just modify it, as a running ix
+      # might hold a reference to it: "delete" achieves that.
+      delete $FOFS[0][$idx];
+      delete $DATA[0][$idx];
+      $DATA[0][$idx] = $data;
+      $SIZE[0][$idx] = length $data;
+      delete $META[$idx];
+      $HASH{$hash} = $idx;#d#
+
+      $idx
+   }
+
+   sub _get_data($$$) {
+      my ($idx, $set, $cb) = @_;
+
+      if (defined $DATA[$set][$idx]) {
+         $cb->($DATA[$set][$idx]);
+      } elsif (my $fofs = $FOFS[$set][$idx]) {
+         my $size = $SIZE[$set][$idx];
+         my $buf;
+         IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
+            if ($_[0] == $size) {
+               #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
+               $cb->($buf);
+            } else {
+               cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
+            }
+         };
+      } else {
+         cf::error "requested facedata for unknown face $idx#$set, ignoring.";
+      }
    }
 
-   my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
+   # rather ineffient
+   sub cf::face::get_data($;$) {
+      my ($idx, $set) = @_;
+
+      _get_data $idx, $set, Coro::rouse_cb;
+      Coro::rouse_wait
+   }
 
-   cf::face::set_type $idx, $type;
-   cf::face::set_data $idx, 0, $data, $hash;
-   cf::face::set_meta $idx, $type & 1 ? undef : undef;
-   $FACEHASH{$hash} = $idx;#d#
+   sub cf::face::ix {
+      my ($ns, $set, $idx, $pri) = @_;
 
-   $idx
+      _get_data $idx, $set, sub {
+         $ns->ix_send ($idx, $pri, $_[0]);
+      };
+   }
 }
 
 sub load_facedata($) {
    my ($path) = @_;
 
-   # HACK to clear player env face cache, we need some signal framework
-   # for this (global event?)
-   %ext::player_env::MUSIC_FACE_CACHE = ();
-
    my $enc = JSON::XS->new->utf8->canonical->relaxed;
 
    trace "loading facedata from $path\n";
 
-   my $facedata = decode_storable load_file $path;
+   my $facedata = decode_storable load_file "$path/faceinfo";
 
    $facedata->{version} == 2
-      or cf::cleanup "$path: version mismatch, cannot proceed.";
+      or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
 
-   cf::cede_to_tick;
+   my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
+      or cf::cleanup "$path/facedata: $!, cannot proceed.";
+
+   get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
+
+   # BEGIN ATOMIC
+   # from here on, everything must be atomic - no thread switch allowed
+   my $t1 = EV::time;
 
    {
       my $faces = $facedata->{faceinfo};
@@ -3572,12 +3701,11 @@
 
          cf::face::set_visibility $idx, $info->{visibility};
          cf::face::set_magicmap   $idx, $info->{magicmap};
-         cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
-         cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
-         cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
-         $FACEHASH{$info->{hash64}} = $idx;#d#
-
-         cf::cede_to_tick;
+         cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
+         cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
+         cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
+         $cf::face::HASH{$info->{hash64}} = $idx;
+         delete $cf::face::META[$idx];
       }
 
       while (my ($face, $info) = each %$faces) {
@@ -3592,8 +3720,6 @@
          } else {
             error "smooth face '$info->{smooth}' not found for face '$face'";
          }
-
-         cf::cede_to_tick;
       }
    }
 
@@ -3602,7 +3728,6 @@
 
       while (my ($anim, $info) = each %$anims) {
          cf::anim::set $anim, $info->{frames}, $info->{facings};
-         cf::cede_to_tick;
       }
 
       cf::anim::invalidate_all; # d'oh
@@ -3617,19 +3742,31 @@
             my $idx = (cf::face::find $name) || cf::face::alloc $name;
 
             cf::face::set_type $idx, $type;
-            cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
-            cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
-            $FACEHASH{$info->{hash}} = $idx;#d#
+            cf::face::set_csum $idx, 0, $info->{hash};
+            $cf::face::SIZE[0][$idx] = $info->{size};
+            $cf::face::FOFS[0][$idx] = $info->{fofs};
+            $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
+            $cf::face::HASH{$info->{hash}} = $idx;
          } else {
 #            $RESOURCE{$name} = $info; # unused
          }
-
-         cf::cede_to_tick;
       }
    }
 
+   ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
+
+   # HACK to clear player env face cache, we need some signal framework
+   # for this (global event?)
+   %ext::player_env::MUSIC_FACE_CACHE = ();
+
+   # END ATOMIC
+
+   cf::debug "facedata atomic update time ", EV::time - $t1;
+
    cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
 
+   aio_close $fh if $fh; # close old facedata
+
    1
 }
 
@@ -3654,10 +3791,11 @@
 sub reload_exp_table {
    _reload_exp_table;
 
-   add_face "res/exp_table" => FT_RSRC,
-            JSON::XS->new->utf8->canonical->encode (
-               [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
-            );
+   cf::face::set
+      "res/exp_table" => FT_RSRC,
+      JSON::XS->new->utf8->canonical->encode (
+         [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
+      );
 }
 
 sub reload_materials {
@@ -3679,7 +3817,7 @@
 }
 
 sub reload_facedata {
-   load_facedata "$DATADIR/facedata"
+   load_facedata $DATADIR
       or die "unable to load facedata\n";
 }
 
@@ -3687,14 +3825,31 @@
    load_resource_file "$DATADIR/archetypes"
       or die "unable to load archetypes\n";
 
-   add_face "res/skill_info" => FT_RSRC,
-            JSON::XS->new->utf8->canonical->encode (
-               [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
-            );
-   add_face "res/spell_paths" => FT_RSRC,
-            JSON::XS->new->utf8->canonical->encode (
-               [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
-            );
+   cf::face::set
+      "res/skill_info" => FT_RSRC,
+      JSON::XS->new->utf8->canonical->encode (
+         [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
+      );
+
+   cf::face::set
+      "res/spell_paths" => FT_RSRC,
+      JSON::XS->new->utf8->canonical->encode (
+         [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
+      );
+
+   # command completion
+   my @commands;
+
+   for (0..cf::arch::skillvec_size - 1) {
+      my $skill = cf::arch::skillvec $_;
+      my $name  = $skill->name;
+      my $flags = cf::skill_flags $skill->subtype;
+
+      push @commands, "ready_skill $name" if $flags & (SF_COMBAT | SF_RANGED | SF_GRACE);
+      push @commands, "use_skill $name"   if $flags & (SF_USE    | SF_AUTARK | SF_GRACE);
+   }
+
+   cf::client::set_command_face skill => \@commands;
 }
 
 sub reload_treasures {
@@ -3722,68 +3877,6 @@
    }
 }
 
-#d# move docstuff to help or so
-our %DOCSTRING;
-
-sub reload_pod {
-   trace "loading pods $PODDIR\n";
-
-   %DOCSTRING = ();
-   my @command_list;
-
-   for (
-      [0, "command_help"],
-      [1, "emote_help"],
-      [2, "dmcommand_help"],
-   ) {
-      my ($type, $path) = @$_;
-
-      my $paragraphs = &cf::pod::load_pod ("$PODDIR/$path.pod")
-         or die "unable to load $path";
-
-      my $level = 1e9;
-      my $rpar;
-
-      for my $par (@$paragraphs) {
-         if ($par->{type} eq "head2") {
-            # this code taken almost verbatim from DC/Protocol.pm
-
-            if ($par->{markup} =~ /^(\S+) (?:\s+ \( ([^\)]*) \) )?/x) {
-               my $cmd = $1;
-               my @args = split /\|/, $2;
-               @args = (".*") unless @args;
-
-               $_ = $_ eq ".*" ? "" : " $_"
-                  for @args;
-
-               my @variants = map "$cmd$_", sort { (length $a) <=> (length $b) } @args;
-
-               $rpar = \($DOCSTRING{"command/$cmd"} = &cf::pod::as_cfpod ([$par]));
-
-               push @command_list, [$type, \@variants];
-               $level = $par->{level};
-            } else {
-               error "$par->{markup}: unparsable command heading";
-            }
-         } elsif ($par->{level} > $level) {
-            $$rpar .= &cf::pod::as_cfpod ([$par]);
-         }
-
-         cf::cede_to_tick;
-      }
-   }
-
-   @command_list = sort {
-      $a->[0] <=> $b->[0]
-         or $a->[1] cmp $b->[1]
-   } @command_list;
-
-   cf::cede_to_tick;
-
-   add_face "res/command_list" => FT_RSRC,
-            JSON::XS->new->utf8->encode (\@command_list);
-}
-
 sub reload_resources {
    trace "reloading resource files...\n";
 
@@ -3794,7 +3887,6 @@
    reload_archetypes;
    reload_regions;
    reload_treasures;
-   reload_pod;
 
    trace "finished reloading resource files\n";
 }
@@ -3840,11 +3932,11 @@
 }
 
 sub main_loop {
-   trace "EV::loop starting\n";
+   trace "EV::run starting\n";
    if (1) {
-      EV::loop;
+      EV::run;
    }
-   trace "EV::loop returned\n";
+   trace "EV::run returned\n";
    goto &main_loop unless $REALLY_UNLOOP;
 }
 
@@ -3863,7 +3955,7 @@
       Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
       (async {
          $Coro::current->{desc} = "IDLE BUG HANDLER";
-         EV::loop EV::LOOP_ONESHOT;
+         EV::run EV::RUN_ONCE;
       })->prio (Coro::PRIO_MAX);
    };