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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.354 by root, Sun Sep 2 12:26:54 2007 UTC vs.
Revision 1.361 by root, Sun Sep 9 12:52:48 2007 UTC

 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
 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} };
    }
 }
 sub fork_call(&@) {
    my ($cb, @args) = @_;
    # we seemingly have to make a local copy of the whole thing,
    # otherwise perl prematurely frees the stuff :/
-   # TODO: investigate and fix (liekly this will be rather laborious)
+   # TODO: investigate and fix (likely this will be rather laborious)
    my @res = Coro::Util::fork_eval {
       reset_signals;
       &$cb
    }, @args;
    },
 );
 sub object_freezer_save {
    my ($filename, $rdata, $objs) = @_;
+   my $guard = cf::lock_acquire "io";
    sync_job {
       if (length $$rdata) {
          warn sprintf "saving %s (%d,%d)\n",
             $filename, length $$rdata, scalar @$objs;
          }
       } else {
          aio_unlink $filename;
          aio_unlink "$filename.pst";
       }
-   }
+   };
+   undef $guard;
 }
 sub object_freezer_as_string {
    my ($rdata, $objs) = @_;
 sub object_thawer_load {
    my ($filename) = @_;
    my ($data, $av);
+   my $guard = cf::lock_acquire "io";
    (aio_load $filename, $data) >= 0
       or return;
    unless (aio_stat "$filename.pst") {
       (aio_load "$filename.pst", $av) >= 0
          or return;
+      undef $guard;
       $av = eval { (Storable::thaw $av)->{objs} };
    }
    warn sprintf "loading %s (%d)\n",
       $filename, length $data, scalar @{$av || []};
-   return ($data, $av);
+   ($data, $av)
 }
 =head2 COMMAND CALLBACKS
 =over 4
 =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;
+         $f->next;
+         my $pl = cf::player::load_pl $f
+            or return;
+         local $cf::PLAYER_LOADING{$login} = $pl;
+         $f->resolve_delayed_derefs;
          $cf::PLAYER{$login} = $pl
       }
    }
 }
 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 $guard1 = cf::lock_acquire "map_data:$path";
+      my $guard = cf::lock_acquire "map_data:$path";
-      my $guard2 = cf::lock_acquire "map_load:$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;
       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;
+            }
          }
       }
+      $f->resolve_delayed_derefs;
       cf::cede_to_tick;
       # now do the right thing for maps
       $self->link_multipart_objects;
       $self->difficulty ($self->estimate_difficulty)
    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;
 }
    map { $_, inv_recursive_ $_->inv } @_
 }
 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) = @_;
+   # temporary compatibility#TODO#remove
+   $ref =~ s{^<}{player/<};
+   if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
+      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
                      or die;
             $map->width (50);
             $map->height (50);
             $map->alloc;
-            $map->_load_objects ("/tmp/x.map", 1);
+            $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
             my $t = Event::time - $t;
             #next unless $t < 0.0013;#d#
             if ($t < $min) {
                $min = $t;

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.354 by root, Sun Sep 2 12:26:54 2007 UTC vs. Revision 1.361 by root, Sun Sep 9 12:52:48 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.354 by root, Sun Sep 2 12:26:54 2007 UTC vs.
Revision 1.361 by root, Sun Sep 9 12:52:48 2007 UTC