--- deliantra/server/lib/cf.pm	2008/08/11 23:23:41	1.440
+++ deliantra/server/lib/cf.pm	2008/08/30 05:19:03	1.441
@@ -21,8 +21,9 @@
 
 package cf;
 
+use 5.10.0;
 use utf8;
-use strict;
+use strict "vars", "subs";
 
 use Symbol;
 use List::Util;
@@ -36,6 +37,7 @@
 use Coro ();
 use Coro::State;
 use Coro::Handle;
+use Coro::EV;
 use Coro::AnyEvent;
 use Coro::Timer;
 use Coro::Signal;
@@ -248,7 +250,6 @@
    cf::map cf::mapspace
    cf::party cf::region
 )) {
-   no strict 'refs';
    @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
 }
 
@@ -1089,7 +1090,8 @@
    # basically do the same as instantiate, without calling instantiate
    my ($obj) = @_;
 
-   bless $obj, ref $obj; # re-bless in case extensions have been reloaded
+   # no longer needed after getting rid of delete_package?
+   #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
 
    my $registry = $obj->registry;
 
@@ -1335,7 +1337,7 @@
             if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
 
          $ext{source} =
-            "package $pkg; use strict; use utf8;\n"
+            "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
             . "#line 1 \"$path\"\n{\n"
             . $source
             . "\n};\n1";
@@ -3589,6 +3591,34 @@
       if $make_core;
 }
 
+# a safer delete_package, copied from Symbol
+sub clear_package($) {
+   my $pkg = shift;
+
+   # expand to full symbol table name if needed
+   unless ($pkg =~ /^main::.*::$/) {
+      $pkg = "main$pkg"       if      $pkg =~ /^::/;
+      $pkg = "main::$pkg"     unless  $pkg =~ /^main::/;
+      $pkg .= '::'            unless  $pkg =~ /::$/;
+   }
+
+   my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+   my $stem_symtab = *{$stem}{HASH};
+
+   defined $stem_symtab and exists $stem_symtab->{$leaf}
+      or return;
+
+   # clear all symbols
+   my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
+   for my $name (keys %$leaf_symtab) {
+      _gv_clear *{"$pkg$name"};
+#      use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
+   }
+   warn "cleared package #$pkg\n";#d#
+}
+
+our $RELOAD; # how many times to reload
+
 sub do_reload_perl() {
    # can/must only be called in main
    if ($Coro::current != $Coro::main) {
@@ -3596,114 +3626,113 @@
       return;
    }
 
-   warn "reloading...";
+   return if $RELOAD++;
 
-   warn "entering sync_job";
+   while ($RELOAD) {
+      warn "reloading...";
 
-   cf::sync_job {
-      cf::write_runtime_sync; # external watchdog should not bark
-      cf::emergency_save;
-      cf::write_runtime_sync; # external watchdog should not bark
+      warn "entering sync_job";
 
-      warn "syncing database to disk";
-      BDB::db_env_txn_checkpoint $DB_ENV;
+      cf::sync_job {
+         cf::write_runtime_sync; # external watchdog should not bark
+         cf::emergency_save;
+         cf::write_runtime_sync; # external watchdog should not bark
 
-      # if anything goes wrong in here, we should simply crash as we already saved
+         warn "syncing database to disk";
+         BDB::db_env_txn_checkpoint $DB_ENV;
 
-      warn "flushing outstanding aio requests";
-      for (;;) {
-         BDB::flush;
-         IO::AIO::flush;
-         Coro::cede_notself;
-         last unless IO::AIO::nreqs || BDB::nreqs;
-         warn "iterate...";
-      }
+         # if anything goes wrong in here, we should simply crash as we already saved
+
+         warn "flushing outstanding aio requests";
+         while (IO::AIO::nreqs || BDB::nreqs) {
+            Coro::EV::timer_once 0.01; # let the sync_job do it's thing
+         }
 
-      ++$RELOAD;
+         warn "cancelling all extension coros";
+         $_->cancel for values %EXT_CORO;
+         %EXT_CORO = ();
 
-      warn "cancelling all extension coros";
-      $_->cancel for values %EXT_CORO;
-      %EXT_CORO = ();
+         warn "removing commands";
+         %COMMAND = ();
 
-      warn "removing commands";
-      %COMMAND = ();
+         warn "removing ext/exti commands";
+         %EXTCMD  = ();
+         %EXTICMD = ();
 
-      warn "removing ext/exti commands";
-      %EXTCMD  = ();
-      %EXTICMD = ();
+         warn "unloading/nuking all extensions";
+         for my $pkg (@EXTS) {
+            warn "... unloading $pkg";
 
-      warn "unloading/nuking all extensions";
-      for my $pkg (@EXTS) {
-         warn "... unloading $pkg";
+            if (my $cb = $pkg->can ("unload")) {
+               eval {
+                  $cb->($pkg);
+                  1
+               } or warn "$pkg unloaded, but with errors: $@";
+            }
 
-         if (my $cb = $pkg->can ("unload")) {
-            eval {
-               $cb->($pkg);
-               1
-            } or warn "$pkg unloaded, but with errors: $@";
+            warn "... clearing $pkg";
+            clear_package $pkg;
          }
 
-         warn "... nuking $pkg";
-         Symbol::delete_package $pkg;
-      }
+         warn "unloading all perl modules loaded from $LIBDIR";
+         while (my ($k, $v) = each %INC) {
+            next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
 
-      warn "unloading all perl modules loaded from $LIBDIR";
-      while (my ($k, $v) = each %INC) {
-         next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
+            warn "... unloading $k";
+            delete $INC{$k};
 
-         warn "... unloading $k";
-         delete $INC{$k};
+            $k =~ s/\.pm$//;
+            $k =~ s/\//::/g;
 
-         $k =~ s/\.pm$//;
-         $k =~ s/\//::/g;
+            if (my $cb = $k->can ("unload_module")) {
+               $cb->();
+            }
 
-         if (my $cb = $k->can ("unload_module")) {
-            $cb->();
+            clear_package $k;
          }
 
-         Symbol::delete_package $k;
-      }
-
-      warn "getting rid of safe::, as good as possible";
-      Symbol::delete_package "safe::$_"
-         for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
+         warn "getting rid of safe::, as good as possible";
+         clear_package "safe::$_"
+            for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
 
-      warn "unloading cf.pm \"a bit\"";
-      delete $INC{"cf.pm"};
-      delete $INC{"cf/pod.pm"};
+         warn "unloading cf.pm \"a bit\"";
+         delete $INC{"cf.pm"};
+         delete $INC{"cf/pod.pm"};
 
-      # don't, removes xs symbols, too,
-      # and global variables created in xs
-      #Symbol::delete_package __PACKAGE__;
+         # don't, removes xs symbols, too,
+         # and global variables created in xs
+         #clear_package __PACKAGE__;
 
-      warn "unload completed, starting to reload now";
+         warn "unload completed, starting to reload now";
 
-      warn "reloading cf.pm";
-      require cf;
-      cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
+         warn "reloading cf.pm";
+         require cf;
+         cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
 
-      warn "loading config and database again";
-      cf::reload_config;
+         warn "loading config and database again";
+         cf::reload_config;
 
-      warn "loading extensions";
-      cf::load_extensions;
+         warn "loading extensions";
+         cf::load_extensions;
 
-      warn "reattaching attachments to objects/players";
-      _global_reattach; # objects, sockets
-      warn "reattaching attachments to maps";
-      reattach $_ for values %MAP;
-      warn "reattaching attachments to players";
-      reattach $_ for values %PLAYER;
+         warn "reattaching attachments to objects/players";
+         _global_reattach; # objects, sockets
+         warn "reattaching attachments to maps";
+         reattach $_ for values %MAP;
+         warn "reattaching attachments to players";
+         reattach $_ for values %PLAYER;
 
-      warn "leaving sync_job";
+         warn "leaving sync_job";
 
-      1
-   } or do {
-      warn $@;
-      cf::cleanup "error while reloading, exiting.";
-   };
+         1
+      } or do {
+         warn $@;
+         cf::cleanup "error while reloading, exiting.";
+      };
 
-   warn "reloaded";
+      warn "reloaded";
+      --$RELOAD;
+   }
 };
 
 our $RELOAD_WATCHER; # used only during reload