--- deliantra/server/lib/cf.pm	2007/04/17 10:38:28	1.246
+++ deliantra/server/lib/cf.pm	2007/04/18 14:45:13	1.251
@@ -5,6 +5,7 @@
 
 use Symbol;
 use List::Util;
+use Socket;
 use Storable;
 use Event;
 use Opcode;
@@ -13,6 +14,7 @@
 
 use Coro 3.61 ();
 use Coro::State;
+use Coro::Handle;
 use Coro::Event;
 use Coro::Timer;
 use Coro::Signal;
@@ -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,15 +2312,126 @@
       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 {
+      local $SIG{__WARN__};
+      eval {
+         local $SIG{__DIE__};
+         close $fh1;
+
+         my @res = eval { $cb->(@args) };
+         syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
+      };
+
+      warn $@ if $@;
+      _exit 0;
+   }
+}
+
+
+
 #############################################################################
 # the server's init and main functions
 
@@ -2397,12 +2498,12 @@
 }
 
 sub reload_archetypes {
-   load_archetype_file sprintf "%s/archetypes", cf::datadir
+   load_resource_file sprintf "%s/archetypes", cf::datadir
       or die "unable to load archetypes\n";
 }
 
 sub reload_treasures {
-   load_treasure_file sprintf "%s/treasures", cf::datadir
+   load_resource_file sprintf "%s/treasures", cf::datadir
       or die "unable to load treasurelists\n";
 }
 
@@ -2802,6 +2903,9 @@
    );
 }
 
+# load additional modules
+use cf::pod;
+
 END { cf::emergency_save }
 
 1