--- deliantra/server/lib/cf.pm	2006/07/30 17:42:14	1.28
+++ deliantra/server/lib/cf.pm	2006/08/24 14:05:22	1.37
@@ -7,6 +7,7 @@
 use Safe;
 use Safe::Hole;
 
+use Time::HiRes;
 use Event;
 $Event::Eval = 1; # no idea why this is required, but it is
 
@@ -18,6 +19,10 @@
 our %PROP_IDX;
 our $LIBDIR = maps_directory "perl";
 
+our $TICK = MAX_TIME * 1e-6;
+our $TICK_WATCHER;
+our $NEXT_TICK;
+
 BEGIN {
    @EVENT = map lc, @EVENT;
 
@@ -72,7 +77,7 @@
 
 # we bless all objects into derived classes to force a method lookup
 # within the Safe compartment.
-for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region)) {
+for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
    no strict 'refs';
    @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
 }
@@ -183,10 +188,6 @@
 
    warn "removing extension $pkg\n";
 
-   if (my $cb = $pkg->can ("on_unload")) {
-      $cb->($pkg);
-   }
-
    # remove hooks
    for my $idx (0 .. $#EVENT) {
       delete $hook[$idx]{$pkg};
@@ -210,6 +211,13 @@
       delete $extcmd{$name};
    }
 
+   if (my $cb = $pkg->can ("on_unload")) {
+      eval {
+         $cb->($pkg);
+         1
+      } or warn "$pkg unloaded, but with errors: $@";
+   }
+
    Symbol::delete_package $pkg;
 }
 
@@ -225,64 +233,75 @@
    }
 }
 
-register_command "perl-reload", 0, sub {
-   my ($who, $arg) = @_;
+sub _perl_reload(&) {
+   my ($msg) = @_;
 
-   if ($who->flag (FLAG_WIZ)) {
-      $who->message ("reloading...");
+   $msg->("reloading...");
 
-      warn "reloading...\n";
-      eval {
-         # 1. cancel all watchers
-         $_->cancel for Event::all_watchers;
+   eval {
+      # 1. cancel all watchers
+      $_->cancel for Event::all_watchers;
+
+      # 2. unload all extensions
+      for (@exts) {
+         $msg->("unloading <$_>");
+         unload_extension $_;
+      }
 
-         # 2. unload all extensions
-         for (@exts) {
-            $who->message ("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->();
          }
 
-         # 3. unload all modules loaded from $LIBDIR
-         while (my ($k, $v) = each %INC) {
-            next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
+         Symbol::delete_package $k;
+      }
 
-            $who->message ("removing <$k>");
-            delete $INC{$k};
+      # 4. get rid of ext::, as good as possible
+      Symbol::delete_package "ext::$_"
+         for qw(cf::object cf::object::map 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
+      #Symbol::delete_package __PACKAGE__;
+
+      # 7. reload cf.pm
+      $msg->("reloading cf.pm");
+      require cf;
+   };
+   $msg->($@) if $@;
 
-            $k =~ s/\.pm$//;
-            $k =~ s/\//::/g;
+   $msg->("reloaded");
+};
 
-            if (my $cb = $k->can ("unload_module")) {
-               $cb->();
-            }
+sub perl_reload() {
+   _perl_reload {
+      warn $_[0];
+      print "$_[0]\n";
+   };
+}
 
-            Symbol::delete_package $k;
-         }
+register_command "perl-reload", 0, sub {
+   my ($who, $arg) = @_;
 
-         # 4. get rid of ext::, as good as possible
-         Symbol::delete_package "ext::$_"
-            for qw(cf::object cf::object::map 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
-         #Symbol::delete_package __PACKAGE__;
-
-         # 7. reload cf.pm
-         $who->message ("reloading cf.pm");
-         require cf;
+   if ($who->flag (FLAG_WIZ)) {
+      _perl_reload {
+         warn $_[0];
+         $who->message ($_[0]);
       };
-      warn $@ if $@;
-      $who->message ($@) if $@;
-      warn "reloaded\n";
-
-      $who->message ("reloaded");
-   } else {
-      $who->message ("Intruder Alert!");
    }
 };
 
@@ -291,13 +310,13 @@
 
 use JSON::Syck (); # TODO# replace by JSON::PC once working
 
-$JSON::Syck::ImplicitUnicode = 1;
-
 sub from_json($) {
+   $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
    JSON::Syck::Load $_[0]
 }
 
 sub to_json($) {
+   $JSON::Syck::ImplicitUnicode = 0;  # work around JSON::Syck bugs
    JSON::Syck::Dump $_[0]
 }
 
@@ -383,10 +402,14 @@
 #############################################################################
 # load/save perl data associated with player->ob objects
 
+sub all_objects(@) {
+   @_, map all_objects ($_->inv), @_
+}
+
 *on_player_load = sub {
    my ($ob, $path) = @_;
 
-   for my $o ($ob, $ob->inv) {
+   for my $o (all_objects $ob) {
       if (my $value = $o->get_ob_key_value ("_perl_data")) {
          $o->set_ob_key_value ("_perl_data");
 
@@ -399,7 +422,7 @@
    my ($ob, $path) = @_;
 
    $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
-      for grep %$_, $ob, $ob->inv;
+      for grep %$_, all_objects $ob;
 };
 
 #############################################################################
@@ -509,6 +532,13 @@
 }
 
 #############################################################################
+# the server's main()
+
+sub run {
+   Event::loop;
+}
+
+#############################################################################
 # initialisation
 
 register "<global>", __PACKAGE__;
@@ -517,5 +547,22 @@
 
 load_extensions;
 
+$TICK_WATCHER = Event->timer (
+   prio => 1,
+   at   => $NEXT_TICK || 1,
+   cb   => sub {
+      cf::server_tick; # one server iteration
+
+      my $NOW = Event::time;
+      $NEXT_TICK += $TICK;
+
+      # if we are delayed by four ticks, skip them all
+      $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
+
+      $TICK_WATCHER->at ($NEXT_TICK);
+      $TICK_WATCHER->start;
+   },
+);
+
 1