[ViewVC] Diff of: cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.434 by root, Thu May 29 03:27:37 2008 UTC vs.
Revision 1.441 by root, Sat Aug 30 05:19:03 2008 UTC

 # The authors can be reached via e-mail to <support@deliantra.net>
 #
 package cf;
+use 5.10.0;
 use utf8;
-use strict;
+use strict "vars", "subs";
 use Symbol;
 use List::Util;
 use Socket;
 use EV;
 use Storable ();
 use Coro ();
 use Coro::State;
 use Coro::Handle;
+use Coro::EV;
 use Coro::AnyEvent;
 use Coro::Timer;
 use Coro::Signal;
 use Coro::Semaphore;
 use Coro::AnyEvent;
 use Coro::AIO;
-use Coro::BDB;
+use Coro::BDB 1.6;
 use Coro::Storable;
 use Coro::Util ();
 use JSON::XS 2.01 ();
 use BDB ();
 use Time::HiRes;
 use Compress::LZF;
 use Digest::MD5 ();
 AnyEvent::detect;
-IO::AIO::max_poll_reqs 1;#d#
 # configure various modules to our taste
 #
 $Storable::canonical = 1; # reduce rsync transfers
 Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
 for my $pkg (qw(
    cf::global cf::attachable
    cf::object cf::object::player
    cf::client cf::player
    cf::arch cf::living
+   cf::map cf::mapspace
-   cf::map cf::party cf::region
+   cf::party cf::region
 )) {
-   no strict 'refs';
    @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
 }
 $EV::DIED = sub {
    warn "error in event callback: @_";
 sub reattach {
    # basically do the same as instantiate, without calling instantiate
    my ($obj) = @_;
+   # no longer needed after getting rid of delete_package?
-   bless $obj, ref $obj; # re-bless in case extensions have been reloaded
+   #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
    my $registry = $obj->registry;
    @$registry = ();
          $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
             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";
          $todo{$base} = \%ext;
       my $f = new_from_file cf::object::thawer $self->{load_path};
       $f->skip_block;
       $self->_load_objects ($f)
          or return;
-      $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
+      $self->post_load_original
          if delete $self->{load_original};
       if (my $uniq = $self->uniq_path) {
          utf8::encode $uniq;
          unless (aio_stat $uniq) {
 Moves the player to the given map-path and coordinates by first freezing
 her, loading and preparing them map, calling the provided $check callback
 that has to return the map if sucecssful, and then unfreezes the player on
 the new (success) or old (failed) map position. In either case, $done will
 be called at the end of this process.
+Note that $check will be called with a potentially non-loaded map, so if
+it needs a loaded map it has to call C<< ->load >>.
 =cut
 our $GOTOGEN;
 =cut
 for (
    ["cf::object"         => qw(contr pay_amount pay_player map force_find force_add x y
                                insert remove inv nrof name archname title slaying race
-                               decrease split destroy)],
+                               decrease split destroy change_exp)],
    ["cf::object::player" => qw(player)],
    ["cf::player"         => qw(peaceful)],
    ["cf::map"            => qw(trigger)],
 ) {
    no strict 'refs';
    warn "finished reloading resource files\n";
 }
 sub init {
    my $guard = freeze_mainloop;
+   evthread_start IO::AIO::poll_fileno;
    reload_resources;
 }
 sub reload_config {
    warn Carp::longmess "post_cleanup backtrace"
       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) {
       warn "can only reload from main coroutine";
       return;
    }
+   return if $RELOAD++;
+   while ($RELOAD) {
-   warn "reloading...";
+      warn "reloading...";
-   warn "entering sync_job";
+      warn "entering sync_job";
-   cf::sync_job {
+      cf::sync_job {
-      cf::write_runtime_sync; # external watchdog should not bark
+         cf::write_runtime_sync; # external watchdog should not bark
-      cf::emergency_save;
+         cf::emergency_save;
-      cf::write_runtime_sync; # external watchdog should not bark
+         cf::write_runtime_sync; # external watchdog should not bark
-      warn "syncing database to disk";
+         warn "syncing database to disk";
-      BDB::db_env_txn_checkpoint $DB_ENV;
+         BDB::db_env_txn_checkpoint $DB_ENV;
-      # if anything goes wrong in here, we should simply crash as we already saved
+         # if anything goes wrong in here, we should simply crash as we already saved
-      warn "flushing outstanding aio requests";
+         warn "flushing outstanding aio requests";
-      for (;;) {
-         BDB::flush;
-         IO::AIO::flush;
-         Coro::cede_notself;
-         last unless IO::AIO::nreqs || BDB::nreqs;
+         while (IO::AIO::nreqs || BDB::nreqs) {
-         warn "iterate...";
+            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 "removing commands";
-      %COMMAND = ();
-      warn "removing ext/exti commands";
-      %EXTCMD  = ();
-      %EXTICMD = ();
-      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: $@";
          }
-         warn "... nuking $pkg";
+         warn "cancelling all extension coros";
-         Symbol::delete_package $pkg;
+         $_->cancel for values %EXT_CORO;
-      }
+         %EXT_CORO = ();
-      warn "unloading all perl modules loaded from $LIBDIR";
+         warn "removing commands";
-      while (my ($k, $v) = each %INC) {
+         %COMMAND = ();
-         next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
+         warn "removing ext/exti commands";
+         %EXTCMD  = ();
+         %EXTICMD = ();
+         warn "unloading/nuking all extensions";
+         for my $pkg (@EXTS) {
-         warn "... unloading $k";
+            warn "... unloading $pkg";
-         delete $INC{$k};
-         $k =~ s/\.pm$//;
-         $k =~ s/\//::/g;
-         if (my $cb = $k->can ("unload_module")) {
+            if (my $cb = $pkg->can ("unload")) {
+               eval {
-            $cb->();
+                  $cb->($pkg);
+                  1
+               } or warn "$pkg unloaded, but with errors: $@";
+            }
+            warn "... clearing $pkg";
+            clear_package $pkg;
          }
-         Symbol::delete_package $k;
+         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};
+            $k =~ s/\.pm$//;
+            $k =~ s/\//::/g;
+            if (my $cb = $k->can ("unload_module")) {
+               $cb->();
+            }
+            clear_package $k;
-      }
+         }
-      warn "getting rid of safe::, as good as possible";
+         warn "getting rid of safe::, as good as possible";
-      Symbol::delete_package "safe::$_"
+         clear_package "safe::$_"
-         for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
+            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\"";
+         warn "unloading cf.pm \"a bit\"";
-      delete $INC{"cf.pm"};
+         delete $INC{"cf.pm"};
-      delete $INC{"cf/pod.pm"};
+         delete $INC{"cf/pod.pm"};
-      # don't, removes xs symbols, too,
+         # don't, removes xs symbols, too,
-      # and global variables created in xs
+         # and global variables created in xs
-      #Symbol::delete_package __PACKAGE__;
+         #clear_package __PACKAGE__;
-      warn "unload completed, starting to reload now";
+         warn "unload completed, starting to reload now";
-      warn "reloading cf.pm";
+         warn "reloading cf.pm";
-      require cf;
+         require cf;
-      cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
+         cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
-      warn "loading config and database again";
+         warn "loading config and database again";
-      cf::reload_config;
+         cf::reload_config;
-      warn "loading extensions";
+         warn "loading extensions";
-      cf::load_extensions;
+         cf::load_extensions;
-      warn "reattaching attachments to objects/players";
+         warn "reattaching attachments to objects/players";
-      _global_reattach; # objects, sockets
+         _global_reattach; # objects, sockets
-      warn "reattaching attachments to maps";
+         warn "reattaching attachments to maps";
-      reattach $_ for values %MAP;
+         reattach $_ for values %MAP;
-      warn "reattaching attachments to players";
+         warn "reattaching attachments to players";
-      reattach $_ for values %PLAYER;
+         reattach $_ for values %PLAYER;
-      warn "leaving sync_job";
+         warn "leaving sync_job";
-      1
+         1
-   } or do {
+      } or do {
-      warn $@;
+         warn $@;
-      cf::cleanup "error while reloading, exiting.";
+         cf::cleanup "error while reloading, exiting.";
-   };
+      };
-   warn "reloaded";
+      warn "reloaded";
+      --$RELOAD;
+   }
 };
 our $RELOAD_WATCHER; # used only during reload
 sub reload_perl() {
    BDB::max_poll_reqs $TICK * 0.1;
    $AnyEvent::BDB::WATCHER->priority (1);
    unless ($DB_ENV) {
       $DB_ENV = BDB::db_env_create;
-      $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
+      $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
-                          | BDB::LOG_AUTOREMOVE, 1);
+      $DB_ENV->set_flags      (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
+      $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
       $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
       $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
       cf::sync_job {
          eval {
 {
    # configure IO::AIO
    IO::AIO::min_parallel 8;
    IO::AIO::max_poll_time $TICK * 0.1;
-   #undef $AnyEvent::AIO::WATCHER;
+   undef $AnyEvent::AIO::WATCHER;
 }
 my $_log_backtrace;
 sub _log_backtrace {
 # load additional modules
 use cf::pod;
 END { cf::emergency_save }
-evthread_start IO::AIO::poll_fileno;
 1

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.434 by root, Thu May 29 03:27:37 2008 UTC vs. Revision 1.441 by root, Sat Aug 30 05:19:03 2008 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.434 by root, Thu May 29 03:27:37 2008 UTC vs.
Revision 1.441 by root, Sat Aug 30 05:19:03 2008 UTC