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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.373 by root, Sat Sep 15 15:58:06 2007 UTC vs.
Revision 1.386 by root, Mon Oct 15 17:50:27 2007 UTC

 use strict;
 use Symbol;
 use List::Util;
 use Socket;
-use Storable;
 use Event;
 use Opcode;
 use Safe;
 use Safe::Hole;
+use Storable ();
-use Coro 3.64 ();
+use Coro 4.1 ();
 use Coro::State;
 use Coro::Handle;
 use Coro::Event;
 use Coro::Timer;
 use Coro::Signal;
 use BDB ();
 use Data::Dumper;
 use Digest::MD5;
 use Fcntl;
 use YAML::Syck ();
-use IO::AIO 2.32 ();
+use IO::AIO 2.51 ();
 use Time::HiRes;
 use Compress::LZF;
 use Digest::MD5 ();
 # configure various modules to our taste
 our @SLOT_QUEUE;
 our $SLOT_QUEUE;
 $SLOT_QUEUE->cancel if $SLOT_QUEUE;
 $SLOT_QUEUE = Coro::async {
+   $Coro::current->desc ("timeslot manager");
    my $signal = new Coro::Signal;
    while () {
       next_job:
       my $avail = cf::till_tick;
             }
          }
       }
       if (@SLOT_QUEUE) {
-         # we do not use wait_For_tick() as it returns immediately when tick is inactive
+         # we do not use wait_for_tick() as it returns immediately when tick is inactive
          push @cf::WAIT_FOR_TICK, $signal;
          $signal->wait;
       } else {
          Coro::schedule;
       }
       my $time = Event::time;
       # this is the main coro, too bad, we have to block
       # till the operation succeeds, freezing the server :/
+      LOG llevError, Carp::longmess "sync job";#d#
       # TODO: use suspend/resume instead
       # (but this is cancel-safe)
       my $freeze_guard = freeze_mainloop;
       my $busy = 1;
       my @res;
       (async {
+         $Coro::current->desc ("sync job coro");
          @res = eval { $job->() };
          warn $@ if $@;
          undef $busy;
       })->prio (Coro::PRIO_MAX);
 =cut
 #############################################################################
 # object support
-#
+sub _object_equal($$);
+sub _object_equal($$) {
+   my ($a, $b) = @_;
+   return 0 unless (ref $a) eq (ref $b);
+   if ("HASH" eq ref $a) {
+      my @ka = keys %$a;
+      my @kb = keys %$b;
+      return 0 if @ka != @kb;
+      for (0 .. $#ka) {
+         return 0 unless $ka[$_] eq $kb[$_];
+         return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
+      }
+   } elsif ("ARRAY" eq ref $a) {
+      return 0 if @$a != @$b;
+      for (0 .. $#$a) {
+         return 0 unless _object_equal $a->[$_], $b->[$_];
+      }
+   } elsif ($a ne $b) {
+      return 0;
+   }
+   1
+}
+our $SLOW_MERGES;#d#
 sub _can_merge {
    my ($ob1, $ob2) = @_;
-   local $Storable::canonical = 1;
+   ++$SLOW_MERGES;#d#
-   my $fob1 = Storable::freeze $ob1;
-   my $fob2 = Storable::freeze $ob2;
-   $fob1 eq $fob2
+   # we do the slow way here
+   return _object_equal $ob1, $ob2
 }
 sub reattach {
    # basically do the same as instantiate, without calling instantiate
    my ($obj) = @_;
             close $fh;
             if (@$objs) {
                if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
                   chmod SAVE_MODE, $fh;
-                  my $data = Storable::nfreeze { version => 1, objs => $objs };
+                  my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };
                   aio_write $fh, 0, (length $data), $data, 0;
                   aio_fsync $fh if $cf::USE_FSYNC;
                   close $fh;
                   aio_rename "$filename.pst~", "$filename.pst";
                }
    unless (aio_stat "$filename.pst") {
       (aio_load "$filename.pst", $av) >= 0
          or return;
-      $av = eval { (Storable::thaw $av)->{objs} };
+      my $st = eval { Coro::Storable::thaw $av }
+            || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
+      $av = $st->{objs};
    }
    utf8::decode (my $decname = $filename);
    warn sprintf "loading %s (%d,%d)\n",
       $decname, length $data, scalar @{$av || []};
    }
    $MAP_PREFETCH{$path} |= $load;
    $MAP_PREFETCHER ||= cf::async {
+      $Coro::current->{desc} = "map prefetcher";
       while (%MAP_PREFETCH) {
          while (my ($k, $v) = each %MAP_PREFETCH) {
             if (my $map = find $k) {
                $map->load if $v;
             }
    return if $self->{deny_save};
    local $self->{last_access} = $self->last_access;#d#
    cf::async {
+      $Coro::current->{desc} = "map player save";
       $_->contr->save for $self->players;
    };
    if ($uniq) {
       $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
 =cut
 sub deref {
    my ($ref) = @_;
-   # temporary compatibility#TODO#remove
-   $ref =~ s{^<}{player/<};
-   if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
+   if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
       my ($uuid, $name) = ($1, $2);
       my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
          or return;
       $pl->ob->uuid eq $uuid
          or return;
    my $gen = $self->{_goto_generation} = ++$GOTOGEN;
    $self->enter_link;
    (async {
+      $Coro::current->{desc} = "player::goto $path $x $y";
       # *tag paths override both path and x|y
       if ($path =~ /^\*(.*)$/) {
          if (my @obs = grep $_->map, ext::map_tags::find $1) {
             my $ob = $obs[rand @obs];
    # if exit is damned, update players death & WoR home-position
    $self->contr->savebed ($slaying, $hp, $sp)
       if $exit->flag (FLAG_DAMNED);
    (async {
+      $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
       $self->deactivate_recursive; # just to be sure
       unless (eval {
          $self->goto ($slaying, $hp, $sp);
          1;
 =cut
 our %CHANNEL = (
    "c/identify" => {
-      id      => "identify",
+      id      => "infobox",
       title   => "Identify",
       reply   => undef,
       tooltip => "Items recently identified",
    },
    "c/examine" => {
-      id      => "examine",
+      id      => "infobox",
       title   => "Examine",
       reply   => undef,
       tooltip => "Signs and other items you examined",
    },
+   "c/lookat" => {
+      id      => "infobox",
+      title   => "Look",
+      reply   => undef,
+      tooltip => "What you saw there",
+   },
 );
 sub cf::client::send_msg {
    my ($self, $channel, $msg, $color, @extra) = @_;
    $msg = $self->pl->expand_cfpod ($msg);
    $color &= cf::NDI_CLIENT_MASK; # just in case...
    # check predefined channels, for the benefit of C
-   $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
+   if ($CHANNEL{$channel}) {
+      $channel = $CHANNEL{$channel};
+      $self->ext_msg (channel_info => $channel)
+         if $self->can_msg;
+      $channel = $channel->{id};
-   if (ref $channel) {
+   } elsif (ref $channel) {
       # send meta info to client, if not yet sent
       unless (exists $self->{channel}{$channel->{id}}) {
          $self->{channel}{$channel->{id}} = $channel;
          $self->ext_msg (channel_info => $channel)
             if $self->can_msg;
 =pod
 The following functions and methods are available within a safe environment:
   cf::object
-     contr pay_amount pay_player map x y force_find force_add
+     contr pay_amount pay_player map x y force_find force_add destroy
      insert remove name archname title slaying race decrease_ob_nr
   cf::object::player
      player
 =cut
 for (
    ["cf::object"         => qw(contr pay_amount pay_player map force_find force_add x y
                                insert remove inv name archname title slaying race
-                               decrease_ob_nr)],
+                               decrease_ob_nr destroy)],
    ["cf::object::player" => qw(player)],
    ["cf::player"         => qw(peaceful)],
    ["cf::map"            => qw(trigger)],
 ) {
    no strict 'refs';
 sub main {
    # we must not ever block the main coroutine
    local $Coro::idle = sub {
       Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
       (async {
+         $Coro::current->{desc} = "IDLE BUG HANDLER";
          Event::one_event;
       })->prio (Coro::PRIO_MAX);
    };
    reload_config;
       # and maps saved/destroyed asynchronously.
       warn "begin emergency player save\n";
       for my $login (keys %cf::PLAYER) {
          my $pl = $cf::PLAYER{$login} or next;
          $pl->valid or next;
+         delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
          $pl->save;
       }
       warn "end emergency player save\n";
       warn "begin emergency map save\n";
 register_command "reload" => sub {
    my ($who, $arg) = @_;
    if ($who->flag (FLAG_WIZ)) {
       $who->message ("reloading server.");
+      async {
+         $Coro::current->{desc} = "perl_reload";
-      async { reload_perl };
+         reload_perl;
+      };
    }
 };
 unshift @INC, $LIBDIR;
       $NEXT_TICK += $TICK;
       if ($NOW >= $NEXT_RUNTIME_WRITE) {
          $NEXT_RUNTIME_WRITE = $NOW + 10;
          Coro::async_pool {
+            $Coro::current->{desc} = "runtime saver";
             write_runtime
                or warn "ERROR: unable to write runtime file: $!";
          };
       }
    $AIO_POLL_WATCHER = Event->io (
       reentrant => 0,
       data      => WF_AUTOCANCEL,
       fd        => IO::AIO::poll_fileno,
       poll      => 'r',
-      prio      => 6,
+      prio      => 0,
       cb        => \&IO::AIO::poll_cb,
    );
 }
 my $_log_backtrace;
    # limit the # of concurrent backtraces
    if ($_log_backtrace < 2) {
       ++$_log_backtrace;
       async {
+         $Coro::current->{desc} = "abt $msg";
          my @bt = fork_call {
             @addr = map { sprintf "%x", $_ } @addr;
             my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
             open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
                or die "addr2line: $!";

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.373 by root, Sat Sep 15 15:58:06 2007 UTC vs. Revision 1.386 by root, Mon Oct 15 17:50:27 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.373 by root, Sat Sep 15 15:58:06 2007 UTC vs.
Revision 1.386 by root, Mon Oct 15 17:50:27 2007 UTC