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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.324 by root, Sat Jul 28 14:23:17 2007 UTC vs.
Revision 1.385 by root, Fri Oct 12 19:13:26 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.61 ();
+use Coro 4.1 ();
 use Coro::State;
 use Coro::Handle;
 use Coro::Event;
 use Coro::Timer;
 use Coro::Signal;
 use Coro::Semaphore;
 use Coro::AIO;
 use Coro::Storable;
+use Coro::Util ();
-use JSON::XS 1.4 ();
+use JSON::XS ();
 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 $NEXT_TICK;
 our $NOW;
 our $USE_FSYNC = 1; # use fsync to write maps - default off
 our $BDB_POLL_WATCHER;
+our $BDB_DEADLOCK_WATCHER;
+our $BDB_CHECKPOINT_WATCHER;
+our $BDB_TRICKLE_WATCHER;
 our $DB_ENV;
 our %CFG;
 our $UPTIME; $UPTIME ||= time;
 our $RUNTIME;
-our %PLAYER; # all users
+our (%PLAYER, %PLAYER_LOADING); # all users
-our %MAP;    # all maps
+our (%MAP,    %MAP_LOADING   ); # all maps
 our $LINK_MAP; # the special {link} map, which is always available
 # used to convert map paths into valid unix filenames by replacing / by ∕
 our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
       $msg .= "\n"
          unless $msg =~ /\n$/;
       $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
-      utf8::encode $msg;
       LOG llevError, $msg;
    };
 }
 @safe::cf::global::ISA         = @cf::global::ISA         = 'cf::attachable';
 Wait until the given lock is available and then acquires it and returns
 a Coro::guard object. If the guard object gets destroyed (goes out of scope,
 for example when the coroutine gets canceled), the lock is automatically
 returned.
+Locks are *not* recursive, locking from the same coro twice results in a
+deadlocked coro.
 Lock names should begin with a unique identifier (for example, cf::map::find
 uses map_find and cf::map::load uses map_load).
 =item $locked = cf::lock_active $string
 Return true if the lock is currently active, i.e. somebody has locked it.
 =cut
 our %LOCK;
+our %LOCKER;#d#
 sub lock_wait($) {
    my ($key) = @_;
+   if ($LOCKER{$key} == $Coro::current) {#d#
+      Carp::cluck "lock_wait($key) for already-acquired lock";#d#
+      return;#d#
+   }#d#
    # wait for lock, if any
    while ($LOCK{$key}) {
       push @{ $LOCK{$key} }, $Coro::current;
       Coro::schedule;
    # wait, to be sure we are not locked
    lock_wait $key;
    $LOCK{$key} = [];
+   $LOCKER{$key} = $Coro::current;#d#
    Coro::guard {
+      delete $LOCKER{$key};#d#
       # wake up all waiters, to be on the safe side
       $_->ready for @{ delete $LOCK{$key} };
    }
 }
 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);
 Coro::Storable. May, of course, block. Note that the executed sub may
 never block itself or use any form of Event handling.
 =cut
-sub _store_scalar {
-   open my $fh, ">", \my $buf
-         or die "fork_call: cannot open fh-to-buf in child : $!";
-      Storable::store_fd $_[0], $fh;
-   close $fh;
-   $buf
-}
 sub fork_call(&@) {
    my ($cb, @args) = @_;
-#   socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
+   # we seemingly have to make a local copy of the whole thing,
-#      or die "socketpair: $!";
+   # otherwise perl prematurely frees the stuff :/
-   pipe my $fh1, my $fh2
+   # TODO: investigate and fix (likely this will be rather laborious)
-      or die "pipe: $!";
-   if (my $pid = fork) {
+   my @res = Coro::Util::fork_eval {
-      close $fh2;
-      my $res = (Coro::Handle::unblock $fh1)->readline (undef);
-      warn "pst<$res>" unless $res =~ /^pst/;
-      $res = Coro::Storable::thaw $res;
-      waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
-      Carp::confess $$res unless "ARRAY" eq ref $res;
-      return wantarray ? @$res : $res->[-1];
-   } else {
       reset_signals;
-      local $SIG{__WARN__};
+      &$cb
-      local $SIG{__DIE__};
+   }, @args;
-      # just in case, this hack effectively disables event
-      # in the child. cleaner and slower would be canceling all watchers,
-      # but this works for the time being.
-      local $Coro::idle;
-      $Coro::current->prio (Coro::PRIO_MAX);
-      eval {
+   wantarray ? @res : $res[-1]
-         close $fh1;
-         my @res = eval { $cb->(@args) };
-         syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
-         close $fh2;
-      };
-      warn $@ if $@;
-      _exit 0;
-   }
 }
 =item $value = cf::db_get $family => $key
 Returns a single value from the environment database.
 =item cf::db_put $family => $key => $value
 Stores the given C<$value> in the family. It can currently store binary
 data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
+=item $db = cf::db_table "name"
+Create and/or open a new database table. The string must not be "db" and must be unique
+within each server.
 =cut
+sub db_table($) {
+   my ($name) = @_;
+   my $db = BDB::db_create $DB_ENV;
+   eval {
+      $db->set_flags (BDB::CHKSUM);
+      utf8::encode $name;
+      BDB::db_open $db, undef, $name, undef, BDB::BTREE,
+                   BDB::CREATE | BDB::AUTO_COMMIT, 0666;
+      cf::cleanup "db_open(db): $!" if $!;
+   };
+   cf::cleanup "db_open(db): $@" if $@;
+   $db
+}
 our $DB;
 sub db_init {
-   unless ($DB) {
-      $DB = BDB::db_create $DB_ENV;
-      cf::sync_job {
+   cf::sync_job {
-         eval {
+      $DB ||= db_table "db";
-            $DB->set_flags (BDB::CHKSUM);
-            BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
-                         BDB::CREATE | BDB::AUTO_COMMIT, 0666;
-            cf::cleanup "db_open(db): $!" if $!;
-         };
-         cf::cleanup "db_open(db): $@" if $@;
-      };
-   }
+   };
 }
 sub db_get($$) {
    my $key = "$_[0]/$_[1]";
       if (1) {
          $md5 =
             join "\x00",
                $processversion,
                map {
-                  Coro::cede;
+                  cf::cede_to_tick;
                   ($src->[$_], Digest::MD5::md5_hex $data[$_])
                } 0.. $#$src;
          my $dbmd5 = db_get cache => "$id/md5";
 #
 sub _can_merge {
    my ($ob1, $ob2) = @_;
+   return 1;#d#
+   #todo#d# kill yourself and do some recursive checking manually without storable
+   sync_job {
+      my $guard = Coro::Storable::guard;
-   local $Storable::canonical = 1;
+      local $Storable::canonical = 1;
-   my $fob1 = Storable::freeze $ob1;
+      my $fob1 = Storable::freeze $ob1;
-   my $fob2 = Storable::freeze $ob2;
+      my $fob2 = Storable::freeze $ob2;
-   $fob1 eq $fob2
+      $fob1 eq $fob2
+   }
 }
 sub reattach {
    # basically do the same as instantiate, without calling instantiate
    my ($obj) = @_;
 sub object_freezer_save {
    my ($filename, $rdata, $objs) = @_;
    sync_job {
       if (length $$rdata) {
+         utf8::decode (my $decname = $filename);
          warn sprintf "saving %s (%d,%d)\n",
-            $filename, length $$rdata, scalar @$objs;
+            $decname, length $$rdata, scalar @$objs;
          if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
             chmod SAVE_MODE, $fh;
             aio_write $fh, 0, (length $$rdata), $$rdata, 0;
             aio_fsync $fh if $cf::USE_FSYNC;
             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";
                }
          }
       } else {
          aio_unlink $filename;
          aio_unlink "$filename.pst";
       }
-   }
+   };
 }
 sub object_freezer_as_string {
    my ($rdata, $objs) = @_;
       or return;
    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)\n",
+   warn sprintf "loading %s (%d,%d)\n",
-      $filename, length $data, scalar @{$av || []};
+      $decname, length $data, scalar @{$av || []};
-   return ($data, $av);
+   ($data, $av)
 }
 =head2 COMMAND CALLBACKS
 =over 4
          my ($type, $reply, @payload) =
             "ARRAY" eq ref $msg
                ? @$msg
                : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
+         my @reply;
          if (my $cb = $EXTCMD{$type}) {
-            my @reply = $cb->($pl, @payload);
+            @reply = $cb->($pl, @payload);
-            $pl->ext_reply ($reply, @reply)
-               if $reply;
          }
+         $pl->ext_reply ($reply, @reply)
+            if $reply;
       } else {
          warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
       }
       cf::override;
 =head3 cf::player
 =over 4
+=item cf::player::num_playing
+Returns the official number of playing players, as per the Crossfire metaserver rules.
+=cut
+sub num_playing {
+   scalar grep
+      $_->ob->map
+      && !$_->hidden
+      && !$_->ob->flag (cf::FLAG_WIZ),
+      cf::player::list
+}
 =item cf::player::find $login
 Returns the given player object, loading it if necessary (might block).
 =cut
          aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
          aio_link +(playerdir $login) . "/$login.pl"    , (playerdir $login) . "/playerdata";
          aio_unlink +(playerdir $login) . "/$login.pl.pst";
          aio_unlink +(playerdir $login) . "/$login.pl";
-         my $pl = load_pl path $login
+         my $f = new_from_file cf::object::thawer path $login
             or return;
+         my $pl = cf::player::load_pl $f
+            or return;
+         local $cf::PLAYER_LOADING{$login} = $pl;
+         $f->resolve_delayed_derefs;
          $cf::PLAYER{$login} = $pl
       }
    }
 }
    aio_mkdir playerdir $pl, 0770;
    $pl->{last_save} = $cf::RUNTIME;
    $pl->save_pl ($path);
-   Coro::cede;
+   cf::cede_to_tick;
 }
 sub new($) {
    my ($login) = @_;
    $self->{deny_save} = 1;
    $cf::PLAYER{$login} = $self;
    $self
+}
+=item $player->send_msg ($channel, $msg, $color, [extra...])
+=cut
+sub send_msg {
+   my $ns = shift->ns
+      or return;
+   $ns->send_msg (@_);
 }
 =item $pl->quit_character
 Nukes the player without looking back. If logged in, the connection will
       or return [];
    my @logins;
    for my $login (@$dirs) {
+      my $path = path $login;
+      # a .pst is a dead give-away for a valid player
+      unless (-e "$path.pst") {
-      my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
+         my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
-      aio_read $fh, 0, 512, my $buf, 0                  or next;
+         aio_read $fh, 0, 512, my $buf, 0            or next;
-      $buf !~ /^password -------------$/m               or next; # official not-valid tag
+         $buf !~ /^password -------------$/m         or next; # official not-valid tag
+      }
       utf8::decode $login;
       push @logins, $login;
    }
 sub expand_cfpod {
    ((my $self), (local $_)) = @_;
    # escape & and <
    s/&/&amp;/g;
-   s/(?<![BIUGH])</&lt;/g;
+   s/(?<![BIUGHT])</&lt;/g;
    # this is buggy, it needs to properly take care of nested <'s
    1 while
       # replace B<>, I<>, U<> etc.
       s/B<([^\>]*)>/<b>$1<\/b>/
       || s/I<([^\>]*)>/<i>$1<\/i>/
       || s/U<([^\>]*)>/<u>$1<\/u>/
+      || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
       # replace G<male|female> tags
       || s{G<([^>|]*)\|([^>]*)>}{
          $self->gender ? $2 : $1
       }ge
       # replace H<hint text>
 =cut
 sub ext_reply($$@) {
    my ($self, $id, @msg) = @_;
-   if ($self->ns->extcmd == 2) {
+   $self->ns->ext_reply ($id, @msg)
-      $self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
-   } elsif ($self->ns->extcmd == 1) {
-      #TODO: version 1, remove
-      unshift @msg, msgtype => "reply", msgid => $id;
-      $self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
-   }
 }
 =item $player->ext_msg ($type, @msg)
 Sends an ext event to the client.
 sub load_header_from($) {
    my ($self, $path) = @_;
    utf8::encode $path;
-   #aio_open $path, O_RDONLY, 0
+   my $f = new_from_file cf::object::thawer $path
-   #   or return;
-   $self->_load_header ($path)
       or return;
+   $self->_load_header ($f)
+      or return;
+   local $MAP_LOADING{$self->{path}} = $self;
+   $f->resolve_delayed_derefs;
    $self->{load_path} = $path;
    1
 }
 sub find {
    my ($path, $origin) = @_;
    $path = normalise $path, $origin && $origin->path;
+   cf::lock_wait "map_data:$path";#d#remove
    cf::lock_wait "map_find:$path";
    $cf::MAP{$path} || do {
-      my $guard = cf::lock_acquire "map_find:$path";
+      my $guard1 = cf::lock_acquire "map_find:$path";
+      my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
       my $map = new_from_path cf::map $path
          or return;
       $map->{last_save} = $cf::RUNTIME;
          or return;
       if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
          # doing this can freeze the server in a sync job, obviously
          #$cf::WAIT_FOR_TICK->wait;
+         undef $guard1;
+         undef $guard2;
          $map->reset;
-         undef $guard;
          return find $path;
       }
       $cf::MAP{$path} = $map
    }
    local $self->{deny_reset} = 1; # loading can take a long time
    my $path = $self->{path};
    {
-      my $guard = cf::lock_acquire "map_load:$path";
+      my $guard = cf::lock_acquire "map_data:$path";
+      return unless $self->valid;
-      return if $self->in_memory != cf::MAP_SWAPPED;
+      return unless $self->in_memory == cf::MAP_SWAPPED;
       $self->in_memory (cf::MAP_LOADING);
       $self->alloc;
       $self->pre_load;
-      Coro::cede;
+      cf::cede_to_tick;
+      my $f = new_from_file cf::object::thawer $self->{load_path};
+      $f->skip_block;
-      $self->_load_objects ($self->{load_path}, 1)
+      $self->_load_objects ($f)
          or return;
       $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
          if delete $self->{load_original};
       if (my $uniq = $self->uniq_path) {
          utf8::encode $uniq;
-         if (aio_open $uniq, O_RDONLY, 0) {
+         unless (aio_stat $uniq) {
+            if (my $f = new_from_file cf::object::thawer $uniq) {
-            $self->clear_unique_items;
+               $self->clear_unique_items;
-            $self->_load_objects ($uniq, 0);
+               $self->_load_objects ($f);
+               $f->resolve_delayed_derefs;
+            }
          }
       }
-      Coro::cede;
+      $f->resolve_delayed_derefs;
+      cf::cede_to_tick;
       # now do the right thing for maps
       $self->link_multipart_objects;
       $self->difficulty ($self->estimate_difficulty)
          unless $self->difficulty;
-      Coro::cede;
+      cf::cede_to_tick;
       unless ($self->{deny_activate}) {
          $self->decay_objects;
          $self->fix_auto_apply;
          $self->update_buttons;
-         Coro::cede;
+         cf::cede_to_tick;
          $self->set_darkness_map;
-         Coro::cede;
+         cf::cede_to_tick;
          $self->activate;
       }
-      $map->{last_save} = $cf::RUNTIME;
+      $self->{last_save} = $cf::RUNTIME;
-      $map->last_access ($cf::RUNTIME);
+      $self->last_access ($cf::RUNTIME);
       $self->in_memory (cf::MAP_IN_MEMORY);
    }
    $self->post_load;
    $self
 }
 # find and load all maps in the 3x3 area around a map
-sub load_diag {
+sub load_neighbours {
    my ($map) = @_;
-   my @diag; # diagonal neighbours
+   my @neigh; # diagonal neighbours
    for (0 .. 3) {
       my $neigh = $map->tile_path ($_)
          or next;
       $neigh = find $neigh, $map
          or next;
       $neigh->load;
+      push @neigh,
-      push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
+         [$neigh->tile_path (($_ + 3) % 4), $neigh],
-                  [$neigh->tile_path (($_ + 1) % 4), $neigh];
+         [$neigh->tile_path (($_ + 1) % 4), $neigh];
    }
-   for (@diag) {
+   for (grep defined $_->[0], @neigh) {
+      my ($path, $origin) = @$_;
-      my $neigh = find @$_
+      my $neigh = find $path, $origin
          or next;
       $neigh->load;
    }
 }
 }
 sub do_load_sync {
    my ($map) = @_;
+   cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
+      if $Coro::current == $Coro::main;
    cf::sync_job { $map->load };
 }
 our %MAP_PREFETCH;
 our $MAP_PREFETCHER = undef;
 sub find_async {
-   my ($path, $origin) = @_;
+   my ($path, $origin, $load) = @_;
    $path = normalise $path, $origin && $origin->{path};
    if (my $map = $cf::MAP{$path}) {
-      return $map if $map->in_memory == cf::MAP_IN_MEMORY;
+      return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
    }
-   undef $MAP_PREFETCH{$path};
+   $MAP_PREFETCH{$path} |= $load;
    $MAP_PREFETCHER ||= cf::async {
+      $Coro::current->{desc} = "map prefetcher";
       while (%MAP_PREFETCH) {
-         for my $path (keys %MAP_PREFETCH) {
+         while (my ($k, $v) = each %MAP_PREFETCH) {
-            if (my $map = find $path) {
+            if (my $map = find $k) {
-               $map->load;
+               $map->load if $v;
             }
-            delete $MAP_PREFETCH{$path};
+            delete $MAP_PREFETCH{$k};
          }
       }
       undef $MAP_PREFETCHER;
    };
    $MAP_PREFETCHER->prio (6);
 }
 sub save {
    my ($self) = @_;
-   my $lock = cf::lock_acquire "map_data:" . $self->path;
+   my $lock = cf::lock_acquire "map_data:$self->{path}";
    $self->{last_save} = $cf::RUNTIME;
    return unless $self->dirty;
    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);
    my ($self) = @_;
    # save first because save cedes
    $self->save;
-   my $lock = cf::lock_acquire "map_data:" . $self->path;
+   my $lock = cf::lock_acquire "map_data:$self->{path}";
    return if $self->players;
    return if $self->in_memory != cf::MAP_IN_MEMORY;
    return if $self->{deny_save};
+   $self->in_memory (cf::MAP_SWAPPED);
+   $self->deactivate;
+   $_->clear_links_to ($self) for values %cf::MAP;
    $self->clear;
-   $self->in_memory (cf::MAP_SWAPPED);
 }
 sub reset_at {
    my ($self) = @_;
          if $uniq;
    }
    delete $cf::MAP{$self->path};
+   $self->deactivate;
+   $_->clear_links_to ($self) for values %cf::MAP;
    $self->clear;
-   $_->clear_links_to ($self) for values %cf::MAP;
    $self->unlink_save;
    $self->destroy;
 }
 my $nuke_counter = "aaaa";
 sub nuke {
    my ($self) = @_;
+   {
+      my $lock = cf::lock_acquire "map_data:$self->{path}";
-   delete $cf::MAP{$self->path};
+      delete $cf::MAP{$self->path};
-   $self->unlink_save;
+      $self->unlink_save;
-   bless $self, "cf::map";
+      bless $self, "cf::map";
-   delete $self->{deny_reset};
+      delete $self->{deny_reset};
-   $self->{deny_save} = 1;
+      $self->{deny_save} = 1;
-   $self->reset_timeout (1);
+      $self->reset_timeout (1);
-   $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
+      $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
-   $cf::MAP{$self->path} = $self;
+      $cf::MAP{$self->path} = $self;
+   }
    $self->reset; # polite request, might not happen
 }
 =item $maps = cf::map::tmp_maps
 sub inv_recursive {
    inv_recursive_ inv $_[0]
 }
+=item $ref = $ob->ref
+creates and returns a persistent reference to an objetc that can be stored as a string.
+=item $ob = cf::object::deref ($refstring)
+returns the objetc referenced by refstring. may return undef when it cnanot find the object,
+even if the object actually exists. May block.
+=cut
+sub deref {
+   my ($ref) = @_;
+   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;
+      $pl->ob
+   } else {
+      warn "$ref: cannot resolve object reference\n";
+      undef
+   }
+}
 package cf;
 =back
 =head3 cf::object::player
          $self->message ($msg, $flags);
       }
    }
 }
+=item $object->send_msg ($channel, $msg, $color, [extra...])
+=cut
+sub cf::object::send_msg {
+   my $pl = shift->contr
+      or return;
+   $pl->send_msg (@_);
+}
 =item $player_object->may ("access")
 Returns wether the given player is authorized to access resource "access"
 (e.g. "command_wizcast").
    # use -1 or undef as default coordinates, not 0, 0
    ($x, $y) = ($map->enter_x, $map->enter_y)
       if $x <=0 && $y <= 0;
    $map->load;
-   $map->load_diag;
+   $map->load_neighbours;
    return unless $self->contr->active;
    $self->activate_recursive;
    local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
    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];
+            # see if we actually can go there
+            if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
+               $ob = $obs[rand @obs];
+            } else {
+               $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
+            }
+            # else put us there anyways for now #d#
+            ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
+         } else {
+            ($path, $x, $y) = (undef, undef, undef);
+         }
+      }
       my $map = eval {
-         my $map = cf::map::find $path;
+         my $map = defined $path ? cf::map::find $path : undef;
          if ($map) {
             $map = $map->customise_for ($self);
             $map = $check->($map) if $check && $map;
          } else {
-            $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
+            $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
          }
          $map
       };
    # 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;
 the message, with C<log> being the default. If C<$color> is negative, suppress
 the message unless the client supports the msg packet.
 =cut
+our %CHANNEL = (
+   "c/identify" => {
+      id      => "infobox",
+      title   => "Identify",
+      reply   => undef,
+      tooltip => "Items recently identified",
+   },
+   "c/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
+   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);
+         $self->ext_msg (channel_info => $channel)
+            if $self->can_msg;
       }
       $channel = $channel->{id};
    }
                || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
          }
          $color &= cf::NDI_COLOR_MASK;
+         utf8::encode $msg;
          if (0 && $msg =~ /\[/) {
+            # COMMAND/INFO
-            $self->send_packet ("drawextinfo $color 4 0 $msg")
+            $self->send_packet ("drawextinfo $color 10 8 $msg")
          } else {
             $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
             $self->send_packet ("drawinfo $color $msg")
          }
       }
 =cut
 sub cf::client::ext_msg($$@) {
    my ($self, $type, @msg) = @_;
-   my $extcmd = $self->extcmd;
-   if ($extcmd == 2) {
+   if ($self->extcmd == 2) {
       $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
-   } elsif ($extcmd == 1) { # TODO: remove
+   } elsif ($self->extcmd == 1) { # TODO: remove
       push @msg, msgtype => "event_$type";
+      $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
+   }
+}
+=item $client->ext_reply ($msgid, @msg)
+Sends an ext reply to the client.
+=cut
+sub cf::client::ext_reply($$@) {
+   my ($self, $id, @msg) = @_;
+   if ($self->extcmd == 2) {
+      $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
+   } elsif ($self->extcmd == 1) {
+      #TODO: version 1, remove
+      unshift @msg, msgtype => "reply", msgid => $id;
       $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
    }
 }
 =item $success = $client->query ($flags, "text", \&cb)
          my ($type, $reply, @payload) =
             "ARRAY" eq ref $msg
                ? @$msg
                : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
+         my @reply;
          if (my $cb = $EXTICMD{$type}) {
-            my @reply = $cb->($ns, @payload);
+            @reply = $cb->($ns, @payload);
-            $ns->ext_reply ($reply, @reply)
-               if $reply;
          }
+         $ns->ext_reply ($reply, @reply)
+            if $reply;
       } else {
          warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
       }
       cf::override;
 our $safe = new Safe "safe";
 our $safe_hole = new Safe::Hole;
 $SIG{FPE} = 'IGNORE';
-$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
+$safe->permit_only (Opcode::opset qw(
+   :base_core :base_mem :base_orig :base_math
+   grepstart grepwhile mapstart mapwhile
+   sort time
+));
 # here we export the classes and methods available to script code
 =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
+     insert remove name archname title slaying race decrease_ob_nr
   cf::object::player
      player
   cf::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
-                               insert remove)],
+                               decrease_ob_nr destroy)],
    ["cf::object::player" => qw(player)],
    ["cf::player"         => qw(peaceful)],
    ["cf::map"            => qw(trigger)],
 ) {
    no strict 'refs';
 # the server's init and main functions
 sub load_facedata($) {
    my ($path) = @_;
+   # HACK to clear player env face cache, we need some signal framework
+   # for this (global event?)
+   %ext::player_env::MUSIC_FACE_CACHE = ();
+   my $enc = JSON::XS->new->utf8->canonical->relaxed;
    warn "loading facedata from $path\n";
    my $facedata;
    0 < aio_load $path, $facedata
       or die "$path: $!";
    $facedata = Coro::Storable::thaw $facedata;
    $facedata->{version} == 2
       or cf::cleanup "$path: version mismatch, cannot proceed.";
+   # patch in the exptable
+   $facedata->{resource}{"res/exp_table"} = {
+      type => FT_RSRC,
+      data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
+   };
+   cf::cede_to_tick;
    {
       my $faces = $facedata->{faceinfo};
       while (my ($face, $info) = each %$faces) {
          my $idx = (cf::face::find $face) || cf::face::alloc $face;
          cf::face::set_visibility $idx, $info->{visibility};
          cf::face::set_magicmap   $idx, $info->{magicmap};
-         cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
+         cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
-         cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
+         cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
          cf::cede_to_tick;
       }
       while (my ($face, $info) = each %$faces) {
    {
       # TODO: for gcfclient pleasure, we should give resources
       # that gcfclient doesn't grok a >10000 face index.
       my $res = $facedata->{resource};
-      my $enc = JSON::XS->new->utf8->canonical;
       my $soundconf = delete $res->{"res/sound.conf"};
       while (my ($name, $info) = each %$res) {
-         my $meta = $enc->encode ({
-            name => $name,
-            %{ $info->{meta} || {} },
-         });
          my $idx = (cf::face::find $name) || cf::face::alloc $name;
+         my $data;
          if ($info->{type} & 1) {
             # prepend meta info
+            my $meta = $enc->encode ({
+               name => $name,
+               %{ $info->{meta} || {} },
+            });
-            my $data = pack "(w/a*)*", $meta, $info->{data};
+            $data = pack "(w/a*)*", $meta, $info->{data};
-            my $chk  = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
-            cf::face::set_data $idx, 0, $data, $chk;
          } else {
-            cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
+            $data = $info->{data};
          }
+         cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
          cf::face::set_type $idx, $info->{type};
          cf::cede_to_tick;
       }
          for (0 .. SOUND_CAST_SPELL_0 - 1) {
             my $sound = $soundconf->{compat}[$_]
                or next;
             my $face = cf::face::find "sound/$sound->[1]";
             cf::sound::set $sound->[0] => $face;
             cf::sound::old_sound_index $_, $face; # gcfclient-compat
          }
+         while (my ($k, $v) = each %{$soundconf->{event}}) {
+            my $face = cf::face::find "sound/$v";
+            cf::sound::set $k => $face;
-         #TODO
+         }
       }
    }
    1
 }
       $ns->fx_want ($k, $v);
    }
 };
 sub reload_regions {
+   # HACK to clear player env face cache, we need some signal framework
+   # for this (global event?)
+   %ext::player_env::MUSIC_FACE_CACHE = ();
    load_resource_file "$MAPDIR/regions"
       or die "unable to load regions file\n";
    for (cf::region::list) {
       $_->{match} = qr/$_->{match}/
 sub init {
    reload_resources;
 }
-sub cfg_load {
+sub reload_config {
    open my $fh, "<:utf8", "$CONFDIR/config"
       or return;
    local $/;
    *CFG = YAML::Syck::Load <$fh>;
 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);
    };
-   cfg_load;
+   reload_config;
    db_init;
    load_extensions;
    $TICK_WATCHER->start;
    Event::loop;
       # 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";
       warn "reloading cf.pm";
       require cf;
       cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
       warn "loading config and database again";
-      cf::cfg_load;
+      cf::reload_config;
       warn "loading extensions";
       cf::load_extensions;
       warn "reattaching attachments to objects/players";
 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;
    my $signal = new Coro::Signal;
    push @WAIT_FOR_TICK_BEGIN, $signal;
    $signal->wait;
 }
-      my $min = 1e6;#d#
-      my $avg = 10;
 $TICK_WATCHER = Event->timer (
    reentrant => 0,
    parked    => 1,
    prio      => 0,
    at        => $NEXT_TICK || $TICK,
       $NOW = $tick_start = Event::time;
       cf::server_tick; # one server iteration
-      0 && sync_job {#d#
-         for(1..10)  {
-            my $t = Event::time;
-            my $map = my $map = new_from_path cf::map "/tmp/x.map"
-                     or die;
-            $map->width (50);
-            $map->height (50);
-            $map->alloc;
-            $map->_load_objects ("/tmp/x.map", 1);
-            my $t = Event::time - $t;
-            #next unless $t < 0.0013;#d#
-            if ($t < $min) {
-               $min = $t;
-            }
-            $avg = $avg * 0.99 + $t * 0.01;
-         }
-         warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
-         exit 0;
-         # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
-      };
       $RUNTIME   += $TICK;
       $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: $!";
          };
       }
-#      my $AFTER = Event::time;
-#      warn $AFTER - $NOW;#d#
       if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
          $sig->send;
       }
       while (my $sig = shift @WAIT_FOR_TICK) {
          $sig->send;
       $LOAD = ($NOW - $tick_start) / $TICK;
       $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
       _post_tick;
    },
 );
 {
+   BDB::min_parallel 8;
    BDB::max_poll_time $TICK * 0.1;
    $BDB_POLL_WATCHER = Event->io (
       reentrant => 0,
       fd        => BDB::poll_fileno,
       poll      => 'r',
       prio      => 0,
       data      => WF_AUTOCANCEL,
       cb        => \&BDB::poll_cb,
    );
-   BDB::min_parallel 8;
    BDB::set_sync_prepare {
       my $status;
       my $current = $Coro::current;
       (
       )
    };
    unless ($DB_ENV) {
       $DB_ENV = BDB::db_env_create;
+      $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
+                          | BDB::LOG_AUTOREMOVE, 1);
+      $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
+      $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
       cf::sync_job {
          eval {
             BDB::db_env_open
                $DB_ENV,
                BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
                | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
                0666;
             cf::cleanup "db_env_open($BDBDIR): $!" if $!;
-            $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
-            $DB_ENV->set_lk_detect;
          };
          cf::cleanup "db_env_open(db): $@" if $@;
       };
    }
+   $BDB_DEADLOCK_WATCHER = Event->timer (
+      after     => 3,
+      interval  => 1,
+      hard      => 1,
+      prio      => 0,
+      data      => WF_AUTOCANCEL,
+      cb        => sub {
+         BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
+      },
+   );
+   $BDB_CHECKPOINT_WATCHER = Event->timer (
+      after     => 11,
+      interval  => 60,
+      hard      => 1,
+      prio      => 0,
+      data      => WF_AUTOCANCEL,
+      cb        => sub {
+         BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
+      },
+   );
+   $BDB_TRICKLE_WATCHER = Event->timer (
+      after     => 5,
+      interval  => 10,
+      hard      => 1,
+      prio      => 0,
+      data      => WF_AUTOCANCEL,
+      cb        => sub {
+         BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
+      },
+   );
 }
 {
    IO::AIO::min_parallel 8;
    $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.324 by root, Sat Jul 28 14:23:17 2007 UTC vs. Revision 1.385 by root, Fri Oct 12 19:13:26 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.324 by root, Sat Jul 28 14:23:17 2007 UTC vs.
Revision 1.385 by root, Fri Oct 12 19:13:26 2007 UTC