--- deliantra/server/lib/cf.pm	2006/08/30 08:28:33	1.56
+++ deliantra/server/lib/cf.pm	2006/09/12 22:43:31	1.66
@@ -13,12 +13,10 @@
 
 use strict;
 
-_reload_1;
+_init_vars;
 
 our %COMMAND = ();
 our @EVENT;
-our %PROP_TYPE;
-our %PROP_IDX;
 our $LIBDIR = maps_directory "perl";
 
 our $TICK = MAX_TIME * 1e-6;
@@ -36,40 +34,6 @@
    };
 }
 
-my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
-
-# generate property mutators
-sub prop_gen {
-   my ($prefix, $class) = @_;
-
-   no strict 'refs';
-
-   for my $prop (keys %PROP_TYPE) {
-      $prop =~ /^\Q$prefix\E_(.*$)/ or next;
-      my $sub = lc $1;
-
-      my $type = $PROP_TYPE{$prop};
-      my $idx  = $PROP_IDX {$prop};
-
-      *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
-         $_[0]->get_property ($type, $idx)
-      };
-
-      *{"$class\::set_$sub"} = sub {
-         $_[0]->set_property ($type, $idx, $_[1]);
-      } unless $ignore_set{$prop};
-   }
-}
-
-# auto-generate most of the API
-
-prop_gen OBJECT_PROP => "cf::object";
-# CFAPI_OBJECT_ANIMATION?
-prop_gen PLAYER_PROP => "cf::object::player";
-
-prop_gen MAP_PROP    => "cf::map";
-prop_gen ARCH_PROP   => "cf::arch";
-
 @safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
 
 # we bless all objects into (empty) derived classes to force a method lookup
@@ -391,7 +355,7 @@
 
       if ($@) {
          warn "$@";
-         warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";
+         warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
          override;
       }
 
@@ -478,29 +442,53 @@
 }
 
 sub object_freezer_save {
-   my ($filename, $objs) = @_;
+   my ($filename, $rdata, $objs) = @_;
 
-   if (@$objs) {
-      open my $fh, ">:raw", "$filename.pst~";
-      syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
-      close $fh;
-      chmod SAVE_MODE, "$filename.pst~";
-      rename "$filename.pst~", "$filename.pst";
+   if (length $$rdata) {
+      warn sprintf "saving %s (%d,%d)\n",
+         $filename, length $$rdata, scalar @$objs;
+
+      if (open my $fh, ">:raw", "$filename~") {
+         chmod SAVE_MODE, $fh;
+         syswrite $fh, $$rdata;
+         close $fh;
+
+         if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
+            chmod SAVE_MODE, $fh;
+            syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
+            close $fh;
+            rename "$filename.pst~", "$filename.pst";
+         } else {
+            unlink "$filename.pst";
+         }
+
+         rename "$filename~", $filename;
+      } else {
+         warn "FATAL: $filename~: $!\n";
+      }
    } else {
+      unlink $filename;
       unlink "$filename.pst";
    }
-
-   chmod SAVE_MODE, "$filename~";
-   rename "$filename~", $filename;
 }
 
 sub object_thawer_load {
    my ($filename) = @_;
 
-   open my $fh, "<:raw:perlio", "$filename.pst"
-      or return;
+   local $/;
+
+   my $av;
 
-   eval { local $/; (Storable::thaw <$fh>)->{objs} }
+   #TODO: use sysread etc.
+   if (open my $data, "<:raw:perlio", $filename) {
+      $data = <$data>;
+      if (open my $pst, "<:raw:perlio", "$filename.pst") {
+         $av = eval { (Storable::thaw <$pst>)->{objs} };
+      }
+      return ($data, $av);
+   }
+
+   ()
 }
 
 attach_to_objects
@@ -657,79 +645,6 @@
    }
 }
 
-sub _perl_reload(&) {
-   my ($msg) = @_;
-
-   $msg->("reloading...");
-
-   eval {
-      # 1. cancel all watchers
-      $_->cancel for Event::all_watchers;
-
-      # 2. unload all extensions
-      for (@exts) {
-         $msg->("unloading <$_>");
-         unload_extension $_;
-      }
-
-      # 3. unload all modules loaded from $LIBDIR
-      while (my ($k, $v) = each %INC) {
-         next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
-
-         $msg->("removing <$k>");
-         delete $INC{$k};
-
-         $k =~ s/\.pm$//;
-         $k =~ s/\//::/g;
-
-         if (my $cb = $k->can ("unload_module")) {
-            $cb->();
-         }
-
-         Symbol::delete_package $k;
-      }
-
-      # 4. get rid of safe::, as good as possible
-      Symbol::delete_package "safe::$_"
-         for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
-
-      # 5. remove register_script_function callbacks
-      # TODO
-      
-      # 6. unload cf.pm "a bit"
-      delete $INC{"cf.pm"};
-
-      # don't, removes xs symbols, too,
-      # and global variables created in xs
-      #Symbol::delete_package __PACKAGE__;
-
-      # 7. reload cf.pm
-      $msg->("reloading cf.pm");
-      require cf;
-   };
-   $msg->($@) if $@;
-
-   $msg->("reloaded");
-};
-
-sub perl_reload() {
-   _perl_reload {
-      warn $_[0];
-      print "$_[0]\n";
-   };
-}
-
-register_command "perl-reload", 0, sub {
-   my ($who, $arg) = @_;
-
-   if ($who->flag (FLAG_WIZ)) {
-      _perl_reload {
-         warn $_[0];
-         $who->message ($_[0]);
-      };
-   }
-};
-
 #############################################################################
 # extcmd framework, basically convert ext <msg>
 # into pkg::->on_extcmd_arg1 (...) while shortcutting a few
@@ -766,27 +681,6 @@
    unlink "$path.pst";
 };
 
-# old style persistent data, TODO: remove #d#
-*cf::mapsupport::on_swapin = sub {
-   my ($map) = @_;
-
-   my $path = $map->tmpname;
-   $path = $map->path unless defined $path;
-
-   warn "$path.cfperl\n";#d#
-
-   open my $fh, "<:raw", "$path.cfperl"
-      or return; # no perl data
-
-   my $data = Storable::thaw do { local $/; <$fh> };
-
-   $data->{version} <= 1
-      or return; # too new
-
-   $map->_set_obs ($data->{obs});
-   $map->invoke (EVENT_MAP_UPGRADE);
-};
-
 attach_to_maps prio => -10000, package => cf::mapsupport::;
 
 #############################################################################
@@ -796,6 +690,7 @@
    @_, map all_objects ($_->inv), @_
 }
 
+# TODO: compatibility cruft, remove when no longer needed
 attach_to_players
    on_load => sub {
       my ($pl, $path) = @_;
@@ -923,21 +818,205 @@
 }
 
 #############################################################################
+
+=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.
+
+The parameter C<$family> should best start with the name of the extension
+using it, it should be unique.
+
+=over 4
+
+=item $hashref = cf::db_get $family
+
+Return a hashref for use by the extension C<$family>, which can be
+modified. After modifications, you have to call C<cf::db_dirty> or
+C<cf::db_sync>.
+
+=item $value = cf::db_get $family => $key
+
+Returns a single value from the database
+
+=item cf::db_put $family => $hashref
+
+Stores the given family hashref into the database. Updates are delayed, if
+you want the data to be synced to disk immediately, use C<cf::db_sync>.
+
+=item cf::db_put $family => $key => $value
+
+Stores the given C<$value> in the family hash. Updates are delayed, if you
+want the data to be synced to disk immediately, use C<cf::db_sync>.
+
+=item cf::db_dirty
+
+Marks the database as dirty, to be updated at a later time.
+
+=item cf::db_sync
+
+Immediately write the database to disk I<if it is dirty>.
+
+=cut
+
+{
+   my $db;
+   my $path = cf::localdir . "/database.pst";
+
+   sub db_load() {
+      warn "loading database $path\n";#d# remove later
+      $db = stat $path ? Storable::retrieve $path : { };
+   }
+
+   my $pid;
+
+   sub db_save() {
+      warn "saving database $path\n";#d# remove later
+      waitpid $pid, 0 if $pid;
+      unless ($pid = fork) {
+         $db->{_meta}{version} = 1;
+         Storable::nstore $db, "$path~";
+         rename "$path~", $path;
+         cf::_exit 0 if defined $pid;
+      }
+   }
+
+   my $dirty;
+
+   sub db_sync() {
+      db_save if $dirty;
+      undef $dirty;
+   }
+
+   my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
+      db_sync;
+   });
+
+   sub db_dirty() {
+      $dirty = 1;
+      $idle->start;
+   }
+
+   sub db_get($;$) {
+      @_ >= 2
+         ? $db->{$_[0]}{$_[1]}
+         : ($db->{$_[0]} ||= { })
+   }
+
+   sub db_put($$;$) {
+      if (@_ >= 3) {
+         $db->{$_[0]}{$_[1]} = $_[2];
+      } else {
+         $db->{$_[0]} = $_[1];
+      }
+      db_dirty;
+   }
+}
+
+#############################################################################
 # the server's main()
 
 sub main {
+   db_load;
+   load_extensions;
    Event::loop;
 }
 
 #############################################################################
 # initialisation
 
+sub _perl_reload(&) {
+   my ($msg) = @_;
+
+   $msg->("reloading...");
+
+   eval {
+      # cancel all watchers
+      $_->cancel for Event::all_watchers;
+
+      # unload all extensions
+      for (@exts) {
+         $msg->("unloading <$_>");
+         unload_extension $_;
+      }
+
+      # unload all modules loaded from $LIBDIR
+      while (my ($k, $v) = each %INC) {
+         next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
+
+         $msg->("removing <$k>");
+         delete $INC{$k};
+
+         $k =~ s/\.pm$//;
+         $k =~ s/\//::/g;
+
+         if (my $cb = $k->can ("unload_module")) {
+            $cb->();
+         }
+
+         Symbol::delete_package $k;
+      }
+
+      # sync database to disk
+      cf::db_sync;
+
+      # get rid of safe::, as good as possible
+      Symbol::delete_package "safe::$_"
+         for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
+
+      # remove register_script_function callbacks
+      # TODO
+      
+      # unload cf.pm "a bit"
+      delete $INC{"cf.pm"};
+
+      # don't, removes xs symbols, too,
+      # and global variables created in xs
+      #Symbol::delete_package __PACKAGE__;
+
+      # reload cf.pm
+      $msg->("reloading cf.pm");
+      require cf;
+
+      # load database again
+      cf::db_load;
+
+      # load extensions
+      $msg->("load extensions");
+      cf::load_extensions;
+
+      # reattach attachments to objects
+      $msg->("reattach");
+      _global_reattach;
+   };
+   $msg->($@) if $@;
+
+   $msg->("reloaded");
+};
+
+sub perl_reload() {
+   _perl_reload {
+      warn $_[0];
+      print "$_[0]\n";
+   };
+}
+
+register_command "perl-reload", 0, sub {
+   my ($who, $arg) = @_;
+
+   if ($who->flag (FLAG_WIZ)) {
+      _perl_reload {
+         warn $_[0];
+         $who->message ($_[0]);
+      };
+   }
+};
+
 register "<global>", __PACKAGE__;
 
 unshift @INC, $LIBDIR;
 
-load_extensions;
-
 $TICK_WATCHER = Event->timer (
    prio => 1,
    at   => $NEXT_TICK || 1,
@@ -955,7 +1034,5 @@
    },
 );
 
-_reload_2;
-
 1