--- deliantra/server/lib/cf.pm	2007/04/18 12:43:54	1.249
+++ deliantra/server/lib/cf.pm	2007/04/18 14:24:10	1.250
@@ -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,54 +2312,125 @@
       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 => ...
+=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.
 
-   source    => filename returning the data (must be a scalar)
-   expensive => true == try to cache harder
-   filter    => sub that processes the data into a scalar
-
 =cut
 
 sub cache {
-   my ($id, %arg) = @_;
+   my ($id, $src, $processversion, $process) = @_;
 
-   aio_stat $arg{source}
-      and Carp::croak "$arg{source}: $!";
+   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 $meta = join ":", (stat _)[7,9];
-   my $md5;
+      my $data = $process->(\@data);
 
-   if ($arg{expensive}) {
-      0 <= aio_load $arg{source}, my $buf
-         or Carp::croak "$arg{source}: $!";
+      db_put cache => "$id/data", $data;
+      db_put cache => "$id/md5" , $md5;
+      db_put cache => "$id/meta", $meta;
 
-      $md5 = Digest::MD5::md5_hex $buf;
+      return $data;
    }
 
-   my $dbmeta = db_get "$id/meta";
-   if ($dbmeta ne $meta) {
-      # changed, we need to process
+   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 {
-      # just fetch
-   }
+      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