--- deliantra/server/lib/cf.pm	2012/11/09 02:50:50	1.594
+++ deliantra/server/lib/cf.pm	2012/11/20 14:40:01	1.610
@@ -60,7 +60,6 @@
 use Fcntl;
 use YAML::XS ();
 use IO::AIO ();
-use Time::HiRes;
 use Compress::LZF;
 use Digest::MD5 ();
 
@@ -254,11 +253,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>).
@@ -575,7 +575,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
@@ -741,10 +741,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 +899,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";
 
@@ -2656,7 +2652,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
@@ -3048,20 +3044,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 +3071,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 +3188,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 +3278,44 @@
    1
 }
 
+=item $client->update_command_faces
+
+=cut
+
+our %COMMAND_FACE;
+
+sub cf::client::update_command_faces {
+   my ($self) = @_;
+
+   my @faces = grep $_,
+      $COMMAND_FACE{standard},
+      $COMMAND_FACE{emote},
+      $COMMAND_FACE{skill},
+      $self->pl->ob->flag (cf::FLAG_WIZ) ? $COMMAND_FACE{dm} : (),
+   ;
+
+   $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 +3547,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 +3654,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 +3673,6 @@
          } else {
             error "smooth face '$info->{smooth}' not found for face '$face'";
          }
-
-         cf::cede_to_tick;
       }
    }
 
@@ -3602,7 +3681,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 +3695,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 +3744,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 +3770,7 @@
 }
 
 sub reload_facedata {
-   load_facedata "$DATADIR/facedata"
+   load_facedata $DATADIR
       or die "unable to load facedata\n";
 }
 
@@ -3687,14 +3778,17 @@
    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]
+      );
 }
 
 sub reload_treasures {
@@ -3722,68 +3816,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 +3826,6 @@
    reload_archetypes;
    reload_regions;
    reload_treasures;
-   reload_pod;
 
    trace "finished reloading resource files\n";
 }