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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.262 by root, Sat Apr 28 05:55:55 2007 UTC vs.
Revision 1.275 by root, Thu Jun 7 19:12:22 2007 UTC

 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
+our $LOAD;       # a number between 0 (idle) and 1 (too many objects)
+our $LOADAVG;    # same thing, but with alpha-smoothing
+our $tick_start; # for load detecting purposes
 binmode STDOUT;
 binmode STDERR;
 # read virtual server time, if available
 unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
 =item $cf::TICK
 The interval between server ticks, in seconds.
+=item $cf::LOADAVG
+The current CPU load on the server (alpha-smoothed), as a value between 0
+(none) and 1 (overloaded), indicating how much time is spent on processing
+objects per tick. Healthy values are < 0.5.
+=item $cf::LOAD
+The raw value load value from the last tick.
 =item %cf::CFG
 Configuration for the server, loaded from C</etc/crossfire/config>, or
 from wherever your confdir points to.
 @safe::cf::global::ISA         = @cf::global::ISA         = 'cf::attachable';
 @safe::cf::object::ISA         = @cf::object::ISA         = 'cf::attachable';
 @safe::cf::player::ISA         = @cf::player::ISA         = 'cf::attachable';
 @safe::cf::client::ISA         = @cf::client::ISA         = 'cf::attachable';
 @safe::cf::map::ISA            = @cf::map::ISA            = 'cf::attachable';
+@safe::cf::arch::ISA           = @cf::arch::ISA           = 'cf::object';
-@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
+@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
 # we bless all objects into (empty) derived classes to force a method lookup
 # within the Safe compartment.
 for my $pkg (qw(
    cf::global cf::attachable
 sub sync_job(&) {
    my ($job) = @_;
    if ($Coro::current == $Coro::main) {
+      my $time = Event::time;
       # this is the main coro, too bad, we have to block
       # till the operation succeeds, freezing the server :/
       # TODO: use suspend/resume instead
       # (but this is cancel-safe)
       while ($busy) {
          Coro::cede or Event::one_event;
       }
+      $time = Event::time - $time;
+      LOG llevError | logBacktrace, Carp::longmess "long sync job"
+         if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
+      $tick_start += $time; # do not account sync jobs to server load
       wantarray ? @res : $res[0]
    } else {
       # we are in another coroutine, how wonderful, everything just works
       $job->()
    $coro
 }
 sub write_runtime {
+   my $runtime = "$LOCALDIR/runtime";
+   # first touch the runtime file to show we are still running:
+   # the fsync below can take a very very long time.
+   IO::AIO::aio_utime $runtime, undef, undef;
    my $guard = cf::lock_acquire "write_runtime";
-   my $runtime = "$LOCALDIR/runtime";
    my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
       or return;
    my $value = $cf::RUNTIME + 90 + 10;
    # always fsync - this file is important
    aio_fsync $fh
       and return;
+   # touch it again to show we are up-to-date
+   aio_utime $fh, undef, undef;
    close $fh
       or return;
    aio_rename "$runtime~", $runtime
       and return;
+   warn "runtime file written.\n";
    1
 }
 =item cf::datalog type => key => value, ...
          $registry = $CB_TYPE[$object_type] ||= [];
       } elsif ($type eq "subtype") {
          defined $object_type or Carp::croak "subtype specified without type";
          my $object_subtype = shift @arg;
-         $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
+         $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
       } elsif ($type eq "package") {
          my $pkg = shift @arg;
          while (my ($name, $id) = each %cb_id) {
    if (ref $_[0]) {
       _object_attach @_;
    } else {
       _attach shift->_attach_registry, @_;
    }
+   _recalc_want;
 };
 # all those should be optimised
 sub cf::attachable::detach {
    my ($obj, $name) = @_;
       delete $obj->{_attachment}{$name};
       reattach ($obj);
    } else {
       Carp::croak "cannot, currently, detach class attachments";
    }
+   _recalc_want;
 };
 sub cf::attachable::attached {
    my ($obj, $name) = @_;
          or return;
       $av = eval { (Storable::thaw $av)->{objs} };
    }
    warn sprintf "loading %s (%d)\n",
-      $filename, length $data, scalar @{$av || []};#d#
+      $filename, length $data, scalar @{$av || []};
    return ($data, $av);
 }
 #############################################################################
 # command handling &c
    my ($self, $merge) = @_;
    # we have to keep some variables in memory intact
    local $self->{path};
    local $self->{load_path};
-   local $self->{deny_save};
-   local $self->{deny_reset};
    $self->SUPER::thawer_merge ($merge);
 }
 sub normalise {
    $_->change_map_light ($change)
       for grep $_->outdoor, values %cf::MAP;
 }
+sub decay_objects {
+   my ($self) = @_;
+   return if $self->{deny_reset};
+   $self->do_decay_objects;
+}
 sub unlink_save {
    my ($self) = @_;
    utf8::encode (my $save = $self->save_path);
    IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
       $self->load_header_orig
          or return;
       $self->prepare_orig;
    }
+   $self->{deny_reset} = 1
+      if $self->no_reset;
    $self->default_region (cf::region::find_by_path $self->{path})
       unless $self->default_region;
    1
 }
       $map->{last_save} = $cf::RUNTIME;
       $map->load_header
          or return;
-      if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)
+      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;
          $map->reset;
          undef $guard;
          return find $path;
    my ($self, $ob) = @_;
    return find "~" . $ob->name . "/" . $self->{path}
       if $self->per_player;
+#   return find "?party/" . $ob->name . "/" . $self->{path}
+#      if $self->per_party;
    $self
 }
 # find and load all maps in the 3x3 area around a map
 sub load_diag {
 sub reset_at {
    my ($self) = @_;
    # TODO: safety, remove and allow resettable per-player maps
-   return 1e99 if $self->isa ("ext::map_per_player");#d#
    return 1e99 if $self->{deny_reset};
    my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
    my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
    my ($self) = @_;
    my $lock = cf::lock_acquire "map_data:$self->{path}";
    return if $self->players;
-   return if $self->isa ("ext::map_per_player");#d#
-   warn "resetting map ", $self->path;#d#
+   warn "resetting map ", $self->path;
    $self->in_memory (cf::MAP_SWAPPED);
    # need to save uniques path
    unless ($self->{deny_save}) {
    $self->deactivate_recursive;
    return if UNIVERSAL::isa $self->map, "ext::map_link";
    $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
-      if $self->map;
+      if $self->map && $self->map->{path} ne "{link}";
    $self->enter_map ($LINK_MAP || link_map, 10, 10);
 }
 sub cf::object::player::leave_link {
    my ($self, $map, $x, $y) = @_;
+   return unless $self->contr->active;
    my $link_pos = delete $self->{_link_pos};
    unless ($map) {
       # restore original map position
    local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
    $self->enter_map ($map, $x, $y);
 }
-cf::player->attach (
-   on_logout => sub {
-      my ($pl) = @_;
-      # abort map switching before logout
-      if ($pl->ob->{_link_pos}) {
-         cf::sync_job {
-            $pl->ob->leave_link
-         };
-      }
-   },
-   on_login => sub {
-      my ($pl) = @_;
-      # try to abort aborted map switching on player login :)
-      # should happen only on crashes
-      if ($pl->ob->{_link_pos}) {
-         $pl->ob->enter_link;
-         (async {
-            $pl->ob->reply (undef,
-                            "There was an internal problem at your last logout, "
-                          . "the server will try to bring you to your intended destination in a second.",
-                            cf::NDI_RED);
-            # we need this sleep as the login has a concurrent enter_exit running
-            # and this sleep increases chances of the player not ending up in scorn
-            Coro::Timer::sleep 1;
-            $pl->ob->leave_link;
-         })->prio (2);
-      }
-   },
-);
-=item $player_object->goto ($path, $x, $y)
+=item $player_object->goto ($path, $x, $y[, $check->($map)])
+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.
 =cut
+our $GOTOGEN;
 sub cf::object::player::goto {
-   my ($self, $path, $x, $y) = @_;
+   my ($self, $path, $x, $y, $check) = @_;
+   # do generation counting so two concurrent goto's will be executed in-order
+   my $gen = $self->{_goto_generation} = ++$GOTOGEN;
    $self->enter_link;
    (async {
       my $map = eval {
          my $map = cf::map::find $path;
+         if ($map) {
-         $map = $map->customise_for ($self) 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);
+         }
          $map
+      };
+      if ($@) {
+         $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
+         LOG llevError | logBacktrace, Carp::longmess $@;
-      } or
+      }
-         $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
+      if ($gen == $self->{_goto_generation}) {
+         delete $self->{_goto_generation};
-      $self->leave_link ($map, $x, $y);
+         $self->leave_link ($map, $x, $y);
+      }
    })->prio (1);
 }
 =item $player_object->enter_exit ($exit_object)
       warn $@ if $@;
       _exit 0;
    }
 }
 #############################################################################
 # the server's init and main functions
 sub load_facedata($) {
    my ($path) = @_;
 sub reload_resources {
    warn "reloading resource files...\n";
    reload_regions;
    reload_facedata;
+   #reload_archetypes;#d#
    reload_archetypes;
    reload_treasures;
    warn "finished reloading resource files\n";
 }
    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,
          Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
             unless ++$bug_warning > 10;
          return;
       }
-      $NOW = Event::time;
+      $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) {
       }
 #      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;
+      }
+      $NOW = Event::time;
       # if we are delayed by four ticks or more, skip them all
-      $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
+      $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
       $TICK_WATCHER->at ($NEXT_TICK);
       $TICK_WATCHER->start;
-      if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
+      $LOAD = ($NOW - $tick_start) / $TICK;
-         $sig->send;
+      $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
-      }
-      while (my $sig = shift @WAIT_FOR_TICK) {
-         $sig->send;
-      }
       _post_tick;
    },
 );
 {
    BDB::max_poll_time $TICK * 0.1;

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.262 by root, Sat Apr 28 05:55:55 2007 UTC vs. Revision 1.275 by root, Thu Jun 7 19:12:22 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.262 by root, Sat Apr 28 05:55:55 2007 UTC vs.
Revision 1.275 by root, Thu Jun 7 19:12:22 2007 UTC