--- deliantra/server/lib/cf.pm	2006/09/10 00:51:24	1.64
+++ deliantra/server/lib/cf.pm	2006/09/12 22:18:55	1.65
@@ -645,85 +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->("load extensions");
-      cf::load_extensions;
-
-      $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]);
-      };
-   }
-};
-
 #############################################################################
 # extcmd framework, basically convert ext <msg>
 # into pkg::->on_extcmd_arg1 (...) while shortcutting a few
@@ -897,9 +818,107 @@
 }
 
 #############################################################################
+
+=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::datadir . "/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;
 }
@@ -907,6 +926,93 @@
 #############################################################################
 # 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;