--- deliantra/server/lib/cf.pm	2012/11/01 13:02:52	1.588
+++ deliantra/server/lib/cf.pm	2012/11/17 11:03:28	1.605
@@ -60,7 +60,6 @@
 use Fcntl;
 use YAML::XS ();
 use IO::AIO ();
-use Time::HiRes;
 use Compress::LZF;
 use Digest::MD5 ();
 
@@ -89,7 +88,9 @@
 
 our @EXTS         = (); # list of extension package names
 our %EXTCMD       = ();
+our %EXTACMD      = ();
 our %EXTICMD      = ();
+our %EXTIACMD     = ();
 our %EXT_CORO     = (); # coroutines bound to extensions
 our %EXT_MAP      = (); # pluggable maps
 
@@ -226,9 +227,9 @@
 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   
+$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
 
 Various directories - "/etc", read-only install directory, perl-library
 directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
@@ -252,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>).
@@ -573,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
@@ -739,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
@@ -901,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";
 
@@ -1433,7 +1431,7 @@
 #############################################################################
 # command handling &c
 
-=item cf::register_command $name => \&callback($ob,$args);
+=item cf::register_command $name => \&callback($ob,$args)
 
 Register a callback for execution when the client sends the user command
 $name.
@@ -1449,7 +1447,7 @@
    push @{ $COMMAND{$name} }, [$caller, $cb];
 }
 
-=item cf::register_extcmd $name => \&callback($pl,$packet);
+=item cf::register_extcmd $name => \&callback($pl,@args)
 
 Register a callback for execution when the client sends an (synchronous)
 extcmd packet. Ext commands will be processed in the order they are
@@ -1457,10 +1455,14 @@
 the logged-in player. Ext commands can only be processed after a player
 has logged in successfully.
 
-If the callback returns something, it is sent back as if reply was being
-called.
+The values will be sent back to the client.
+
+=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
 
-=item cf::register_exticmd $name => \&callback($ns,$packet);
+Same as C<cf::register_extcmd>, but instead of returning values, the
+callback needs to clal the C<$reply> function.
+
+=item cf::register_exticmd $name => \&callback($ns,@args)
 
 Register a callback for execution when the client sends an (asynchronous)
 exticmd packet. Exti commands are processed by the server as soon as they
@@ -1468,23 +1470,39 @@
 is a client socket. Exti commands can be received anytime, even before
 log-in.
 
-If the callback returns something, it is sent back as if reply was being
-called.
+The values will be sent back to the client.
+
+=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
+
+Same as C<cf::register_extcmd>, but instead of returning values, the
+callback needs to clal the C<$reply> function.
 
 =cut
 
-sub register_extcmd {
+sub register_extcmd($$) {
    my ($name, $cb) = @_;
 
    $EXTCMD{$name} = $cb;
 }
 
-sub register_exticmd {
+sub register_async_extcmd($$) {
+   my ($name, $cb) = @_;
+
+   $EXTACMD{$name} = $cb;
+}
+
+sub register_exticmd($$) {
    my ($name, $cb) = @_;
 
    $EXTICMD{$name} = $cb;
 }
 
+sub register_async_exticmd($$) {
+   my ($name, $cb) = @_;
+
+   $EXTIACMD{$name} = $cb;
+}
+
 use File::Glob ();
 
 cf::player->attach (
@@ -1508,14 +1526,25 @@
       if (ref $msg) {
          my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
 
-         my @reply;
+         if (my $cb = $EXTACMD{$type}) {
+            $cb->(
+               $pl,
+               sub {
+                  $pl->ext_msg ("reply-$reply", @_)
+                     if $reply;
+               },
+               @payload
+            );
+         } else {
+            my @reply;
 
-         if (my $cb = $EXTCMD{$type}) {
-            @reply = $cb->($pl, @payload);
-         }
+            if (my $cb = $EXTCMD{$type}) {
+               @reply = $cb->($pl, @payload);
+            }
 
-         $pl->ext_reply ($reply, @reply)
-            if $reply;
+            $pl->ext_msg ("reply-$reply", @reply)
+               if $reply;
+         }
 
       } else {
          error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
@@ -1912,18 +1941,6 @@
 
 Expand deliantra pod fragments into protocol xml.
 
-=item $player->ext_reply ($msgid, @msg)
-
-Sends an ext reply to the player.
-
-=cut
-
-sub ext_reply($$@) {
-   my ($self, $id, @msg) = @_;
-
-   $self->ns->ext_reply ($id, @msg)
-}
-
 =item $player->ext_msg ($type, @msg)
 
 Sends an ext event to the client.
@@ -2635,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
@@ -3185,6 +3202,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,
 );
@@ -3237,26 +3260,7 @@
 sub cf::client::ext_msg($$@) {
    my ($self, $type, @msg) = @_;
 
-   if ($self->extcmd == 2) {
-      $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
-   } elsif ($self->extcmd == 1) { # TODO: remove
-      push @msg, msgtype => "event_$type";
-      $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
-   }
-}
-
-=item $client->ext_reply ($msgid, @msg)
-
-Sends an ext reply to the client.
-
-=cut
-
-sub cf::client::ext_reply($$@) {
-   my ($self, $id, @msg) = @_;
-
-   return unless $self->extcmd == 2;
-
-   $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
+   $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
 }
 
 =item $success = $client->query ($flags, "text", \&cb)
@@ -3323,15 +3327,25 @@
       if (ref $msg) {
          my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
 
-         my @reply;
-
-         if (my $cb = $EXTICMD{$type}) {
-            @reply = $cb->($ns, @payload);
-         }
+         if (my $cb = $EXTIACMD{$type}) {
+            $cb->(
+               $ns,
+               sub {
+                  $ns->ext_msg ("reply-$reply", @_)
+                     if $reply;
+               },
+               @payload
+            );
+         } else {
+            my @reply;
 
-         $ns->ext_reply ($reply, @reply)
-            if $reply;
+            if (my $cb = $EXTICMD{$type}) {
+               @reply = $cb->($ns, @payload);
+            }
 
+            $ns->ext_msg ("reply-$reply", @reply)
+               if $reply;
+         }
       } else {
          error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
       }
@@ -3509,32 +3523,103 @@
 #############################################################################
 # the server's init and main functions
 
-our %FACEHASH; # hash => idx, #d# HACK for http server
+{
+   package cf::face;
+
+   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;
+
+      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.";
+      }
+   }
+
+   # rather ineffient
+   sub cf::face::get_data($;$) {
+      my ($idx, $set) = @_;
+
+      _get_data $idx, $set, Coro::rouse_cb;
+      Coro::rouse_wait
+   }
+
+   sub cf::face::ix {
+      my ($ns, $set, $idx, $pri) = @_;
+
+      _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.";
 
-   # patch in the exptable
-   my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
-   $facedata->{resource}{"res/exp_table"} = {
-      type => FT_RSRC,
-      data => $exp_table,
-      hash => (cf::face::mangle_chksum Digest::MD5::md5 $exp_table),
-   };
-   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};
@@ -3545,12 +3630,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) {
@@ -3565,8 +3649,6 @@
          } else {
             error "smooth face '$info->{smooth}' not found for face '$face'";
          }
-
-         cf::cede_to_tick;
       }
    }
 
@@ -3575,7 +3657,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
@@ -3589,20 +3670,32 @@
             # TODO: different hash - must free and use new index, or cache ixface data queue
             my $idx = (cf::face::find $name) || cf::face::alloc $name;
 
-            cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
             cf::face::set_type $idx, $type;
-            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
 }
 
@@ -3624,6 +3717,20 @@
    $status
 }
 
+sub reload_exp_table {
+   _reload_exp_table;
+
+   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 {
+   _reload_materials;
+}
+
 sub reload_regions {
    # HACK to clear player env face cache, we need some signal framework
    # for this (global event?)
@@ -3639,13 +3746,25 @@
 }
 
 sub reload_facedata {
-   load_facedata "$DATADIR/facedata"
+   load_facedata $DATADIR
       or die "unable to load facedata\n";
 }
 
 sub reload_archetypes {
    load_resource_file "$DATADIR/archetypes"
       or die "unable to load archetypes\n";
+
+   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 {
@@ -3676,9 +3795,9 @@
 sub reload_resources {
    trace "reloading resource files...\n";
 
-   reload_exp_table;
    reload_materials;
    reload_facedata;
+   reload_exp_table;
    reload_sound;
    reload_archetypes;
    reload_regions;
@@ -3760,6 +3879,8 @@
    cf::sync_job {
       cf::incloader::init ();
 
+      db_init;
+
       cf::init_anim;
       cf::init_attackmess;
       cf::init_dynamic;
@@ -3768,7 +3889,6 @@
 
       reload_resources;
       reload_config;
-      db_init;
 
       cf::init_uuid;
       cf::init_signals;
@@ -4203,6 +4323,7 @@
 
 {
    # configure BDB
+   info "initialising database";
 
    BDB::min_parallel 16;
    BDB::max_poll_reqs $TICK * 0.1;
@@ -4241,14 +4362,18 @@
    $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
       BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
    };
+
+   info "database initialised";
 }
 
 {
    # configure IO::AIO
 
+   info "initialising aio";
    IO::AIO::min_parallel 8;
    IO::AIO::max_poll_time $TICK * 0.1;
    undef $AnyEvent::AIO::WATCHER;
+   info "aio initialised";
 }
 
 our $_log_backtrace;