--- deliantra/server/lib/cf.pm	2007/04/16 10:14:25	1.240
+++ deliantra/server/lib/cf.pm	2007/04/18 14:24:10	1.250
@@ -5,14 +5,16 @@
 
 use Symbol;
 use List::Util;
+use Socket;
 use Storable;
 use Event;
 use Opcode;
 use Safe;
 use Safe::Hole;
 
-use Coro 3.52 ();
+use Coro 3.61 ();
 use Coro::State;
+use Coro::Handle;
 use Coro::Event;
 use Coro::Timer;
 use Coro::Signal;
@@ -56,7 +58,7 @@
 our @EVENT;
 our $LIBDIR = datadir . "/ext";
 
-our $TICK = MAX_TIME * 1e-6;
+our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
 our $TICK_WATCHER;
 our $AIO_POLL_WATCHER;
 our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
@@ -148,11 +150,13 @@
 BEGIN {
    *CORE::GLOBAL::warn = sub {
       my $msg = join "", @_;
-      utf8::encode $msg;
 
       $msg .= "\n"
          unless $msg =~ /\n$/;
 
+      $msg =~ s/([\x00-\x09\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
+
+      utf8::encode $msg;
       LOG llevError, $msg;
    };
 }
@@ -2264,8 +2268,8 @@
 =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.
+currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
+convert to/from binary).
 
 The parameter C<$family> should best start with the name of the extension
 using it, it should be unique.
@@ -2298,20 +2302,6 @@
          };
          cf::cleanup "db_open(db): $@" if $@;
       };
-
-      my $path = cf::localdir . "/database.pst";
-      if (stat $path) {
-         cf::sync_job {
-            my $pst = Storable::retrieve $path;
-
-            cf::db_put (board => data      => $pst->{board});
-            cf::db_put (guildrules => data => $pst->{guildrules});
-            cf::db_put (rent => balance    => $pst->{rent}{balance});
-            BDB::db_env_txn_checkpoint $DB_ENV;
-
-            unlink $path;
-         };
-      }
    }
 }
 
@@ -2322,20 +2312,130 @@
       BDB::db_get $DB, undef, $key, my $data;
 
       $! ? ()
-         : Compress::LZF::sthaw $data
+         : $data
    }
 }
 
 sub db_put($$$) {
    BDB::dbreq_pri 4;
-   BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
+   BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
+}
+
+=item cf::cache $id => [$paths...], $processversion => $process
+
+Generic caching function that returns the value of the resource $id,
+caching and regenerating as required.
+
+This function can block.
+
+=cut
+
+sub cache {
+   my ($id, $src, $processversion, $process) = @_;
+
+   my $meta =
+      join "\x00",
+         $processversion,
+         map {
+            aio_stat $_
+               and Carp::croak "$_: $!";
+
+            ($_, (stat _)[7,9])
+         } @$src;
+
+   my $dbmeta = db_get cache => "$id/meta";
+   if ($dbmeta ne $meta) {
+      # changed, we may need to process
+
+      my @data;
+      my $md5;
+
+      for (0 .. $#$src) {
+         0 <= aio_load $src->[$_], $data[$_]
+            or Carp::croak "$src->[$_]: $!";
+      }
+
+      # if processing is expensive, check
+      # checksum first
+      if (1) {
+         $md5 =
+            join "\x00",
+               $processversion,
+               map {
+                  Coro::cede;
+                  ($src->[$_], Digest::MD5::md5_hex $data[$_])
+               } 0.. $#$src;
+           
+
+         my $dbmd5 = db_get cache => "$id/md5";
+         if ($dbmd5 eq $md5) {
+            db_put cache => "$id/meta", $meta;
+
+            return db_get cache => "$id/data";
+         }
+      }
+
+      my $data = $process->(\@data);
+
+      db_put cache => "$id/data", $data;
+      db_put cache => "$id/md5" , $md5;
+      db_put cache => "$id/meta", $meta;
+
+      return $data;
+   }
+
+   db_get cache => "$id/data"
+}
+
+=item fork_call { }, $args
+
+Executes the given code block with the given arguments in a seperate
+process, returning the results. Everything must be serialisable with
+Coro::Storable. May, of course, block. Note that the executed sub may
+never block itself or use any form of Event handling.
+
+=cut
+
+sub fork_call(&@) {
+   my ($cb, @args) = @_;
+
+#   socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
+#      or die "socketpair: $!";
+   pipe my $fh1, my $fh2
+      or die "pipe: $!";
+
+   if (my $pid = fork) {
+      close $fh2;
+
+      my $res = (Coro::Handle::unblock $fh1)->readline (undef);
+      $res = Coro::Storable::thaw $res;
+
+      waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
+
+      die $$res unless "ARRAY" eq ref $res;
+
+      return wantarray ? @$res : $res->[-1];
+   } else {
+      eval {
+         local $SIG{__DIE__};
+         local $SIG{__WARN__};
+         close $fh1;
+
+         my @res = eval { $cb->(@args) };
+         syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
+      };
+
+      _exit 0;
+   }
 }
 
+
+
 #############################################################################
 # the server's init and main functions
 
-sub load_facedata {
-   my $path = sprintf "%s/facedata", cf::datadir;
+sub load_facedata($) {
+   my ($path) = @_;
 
    warn "loading facedata from $path\n";
 
@@ -2386,11 +2486,35 @@
    1
 }
 
-sub reload_resources {
+sub reload_facedata {
+   load_facedata sprintf "%s/facedata", cf::datadir
+      or die "unable to load facedata\n";
+}
+
+sub reload_regions {
    load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir
-      or die "unable to load regions file\n";#d#
-   load_facedata
-      or die "unable to load facedata\n";#d#
+      or die "unable to load regions file\n";
+}
+
+sub reload_archetypes {
+   load_resource_file sprintf "%s/archetypes", cf::datadir
+      or die "unable to load archetypes\n";
+}
+
+sub reload_treasures {
+   load_resource_file sprintf "%s/treasures", cf::datadir
+      or die "unable to load treasurelists\n";
+}
+
+sub reload_resources {
+   warn "reloading resource files...\n";
+
+   reload_regions;
+   reload_facedata;
+   reload_archetypes;
+   reload_treasures;
+
+   warn "finished reloading resource files\n";
 }
 
 sub init {
@@ -2493,7 +2617,7 @@
       if $make_core;
 }
 
-sub reload() {
+sub do_reload_perl() {
    # can/must only be called in main
    if ($Coro::current != $Coro::main) {
       warn "can only reload from main coroutine";
@@ -2602,9 +2726,6 @@
       warn "reattaching attachments to players";
       reattach $_ for values %PLAYER;
 
-      warn "loading reloadable resources";
-      reload_resources;
-
       warn "leaving sync_job";
 
       1
@@ -2619,24 +2740,27 @@
 
 our $RELOAD_WATCHER; # used only during reload
 
+sub reload_perl() {
+   # doing reload synchronously and two reloads happen back-to-back,
+   # coro crashes during coro_state_free->destroy here.
+
+   $RELOAD_WATCHER ||= Event->timer (
+      reentrant => 0,
+      after     => 0,
+      data      => WF_AUTOCANCEL,
+      cb => sub {
+         do_reload_perl;
+         undef $RELOAD_WATCHER;
+      },
+   );
+}
+
 register_command "reload" => sub {
    my ($who, $arg) = @_;
 
    if ($who->flag (FLAG_WIZ)) {
       $who->message ("reloading server.");
-
-      # doing reload synchronously and two reloads happen back-to-back,
-      # coro crashes during coro_state_free->destroy here.
-
-      $RELOAD_WATCHER ||= Event->timer (
-         reentrant => 0,
-         after     => 0,
-         data      => WF_AUTOCANCEL,
-         cb => sub {
-            reload;
-            undef $RELOAD_WATCHER;
-         },
-      );
+      async { reload_perl };
    }
 };
 
@@ -2649,6 +2773,8 @@
 
 sub wait_for_tick {
    return unless $TICK_WATCHER->is_active;
+   return if $Coro::current == $Coro::main;
+
    my $signal = new Coro::Signal;
    push @WAIT_FOR_TICK, $signal;
    $signal->wait;
@@ -2656,6 +2782,8 @@
 
 sub wait_for_tick_begin {
    return unless $TICK_WATCHER->is_active;
+   return if $Coro::current == $Coro::main;
+
    my $signal = new Coro::Signal;
    push @WAIT_FOR_TICK_BEGIN, $signal;
    $signal->wait;
@@ -2677,6 +2805,7 @@
       $NOW = Event::time;
 
       cf::server_tick; # one server iteration
+
       $RUNTIME   += $TICK;
       $NEXT_TICK += $TICK;
 
@@ -2688,13 +2817,6 @@
          };
       }
 
-      if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
-         $sig->send;
-      }
-      while (my $sig = shift @WAIT_FOR_TICK) {
-         $sig->send;
-      }
-
 #      my $AFTER = Event::time;
 #      warn $AFTER - $NOW;#d#
 
@@ -2703,6 +2825,15 @@
 
       $TICK_WATCHER->at ($NEXT_TICK);
       $TICK_WATCHER->start;
+
+      if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
+         $sig->send;
+      }
+      while (my $sig = shift @WAIT_FOR_TICK) {
+         $sig->send;
+      }
+
+      _post_tick;
    },
 );
 
@@ -2771,6 +2902,9 @@
    );
 }
 
+# load additional modules
+use cf::pod;
+
 END { cf::emergency_save }
 
 1