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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.548 by root, Mon May 10 21:40:22 2010 UTC vs.
Revision 1.596 by root, Fri Nov 9 20:37:57 2012 UTC

 #
 # This file is part of Deliantra, the Roguelike Realtime MMORPG.
 #
-# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
+# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
 #
 # Deliantra is free software: you can redistribute it and/or modify it under
 # the terms of the Affero GNU General Public License as published by the
 # Free Software Foundation, either version 3 of the License, or (at your
 # option) any later version.
 #
 # This program is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
 # GNU General Public License for more details.
 #
 # You should have received a copy of the Affero GNU General Public License
 # and the GNU General Public License along with this program. If not, see
 # <http://www.gnu.org/licenses/>.
 #
 # The authors can be reached via e-mail to <support@deliantra.net>
 #
 package cf;
 use Safe;
 use Safe::Hole;
 use Storable ();
 use Carp ();
-use Guard ();
+use AnyEvent ();
+use AnyEvent::IO ();
+use AnyEvent::DNS ();
 use Coro ();
 use Coro::State;
 use Coro::Handle;
 use Coro::EV;
 use Coro::AnyEvent;
 use Coro::AIO;
 use Coro::BDB 1.6;
 use Coro::Storable;
 use Coro::Util ();
+use Guard ();
 use JSON::XS 2.01 ();
 use BDB ();
 use Data::Dumper;
 use Fcntl;
 use YAML::XS ();
 our %COMMAND      = ();
 our %COMMAND_TIME = ();
 our @EXTS         = (); # list of extension package names
 our %EXTCMD       = ();
+our %EXTACMD      = ();
 our %EXTICMD      = ();
+our %EXTIACMD     = ();
 our %EXT_CORO     = (); # coroutines bound to extensions
 our %EXT_MAP      = (); # pluggable maps
 our $RELOAD; # number of reloads so far, non-zero while in reload
 our @EVENT;
 our @REFLECT; # set by XS
 our %REFLECT; # set by us
 our $CONFDIR     = confdir;
 our $DATADIR     = datadir;
 our $LIBDIR      = "$DATADIR/ext";
 our $PODDIR      = "$DATADIR/pod";
 our $MAPDIR      = "$DATADIR/" . mapdir;
 our $LOCALDIR    = localdir;
 our $TMPDIR      = "$LOCALDIR/" . tmpdir;
 our $UNIQUEDIR   = "$LOCALDIR/" . uniquedir;
 our $PLAYERDIR   = "$LOCALDIR/" . playerdir;
 our $RANDOMDIR   = "$LOCALDIR/random";
 our $BDBDIR      = "$LOCALDIR/db";
 our $PIDFILE     = "$LOCALDIR/pid";
 our $RUNTIMEFILE = "$LOCALDIR/runtime";
-our %RESOURCE; # unused
+#our %RESOURCE; # unused
 our $OUTPUT_RATE_MIN =    3000;
 our $OUTPUT_RATE_MAX = 1000000;
 our $MAX_LINKS       = 32; # how many chained exits to follow
 our $DB_ENV;
 our @EXTRA_MODULES = qw(pod match mapscript incloader);
 our %CFG;
+our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
 our $UPTIME; $UPTIME ||= time;
-our $RUNTIME;
+our $RUNTIME     = 0;
+our $SERVER_TICK = 0;
 our $NOW;
 our (%PLAYER, %PLAYER_LOADING); # all users
 our (%MAP,    %MAP_LOADING   ); # all maps
 our $LINK_MAP; # the special {link} map, which is always available
 our @POST_INIT;
 our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
 our $REALLY_UNLOOP;      # never set to true, please :)
+our $WAIT_FOR_TICK = new Coro::Signal;
+our @WAIT_FOR_TICK_BEGIN;
 binmode STDOUT;
 binmode STDERR;
 # read virtual server time, if available
 =over 4
 =item $cf::UPTIME
-The timestamp of the server start (so not actually an uptime).
+The timestamp of the server start (so not actually an "uptime").
+=item $cf::SERVER_TICK
+An unsigned integer that starts at zero when the server is started and is
+incremented on every tick.
+=item $cf::NOW
+The (real) time of the last (current) server tick - updated before and
+after tick processing, so this is useful only as a rough "what time is it
+now" estimate.
+=item $cf::TICK
+The interval between each server tick, in seconds.
 =item $cf::RUNTIME
 The time this server has run, starts at 0 and is increased by $cf::TICK on
 every server tick.
 =item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR  $cf::PODDIR
 $cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
 $cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
 Various directories - "/etc", read-only install directory, perl-library
 directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
 unique-items directory, player file directory, random maps directory and
 database environment.
-=item $cf::NOW
-The time of the last (current) server tick.
-=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::wait_for_tick, cf::wait_for_tick_begin
 These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
 returns directly I<after> the tick processing (and consequently, can only wake one thread
 per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
+Note that cf::Wait_for_tick will immediately return when the server is not
+ticking, making it suitable for small pauses in threads that need to run
+when the server is paused. If that is not applicable (i.e. you I<really>
+want to wait, use C<$cf::WAIT_FOR_TICK>).
+=item $cf::WAIT_FOR_TICK
+Note that C<cf::wait_for_tick> is probably the correct thing to use. This
+variable contains a L<Coro::Signal> that is broadcats after every server
+tick. Calling C<< ->wait >> on it will suspend the caller until after the
+next server tick.
 =cut
 sub wait_for_tick();
 sub wait_for_tick_begin();
 )) {
    @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
 }
 $EV::DIED = sub {
-   Carp::cluck "error in event callback: @_";
+   warn "error in event callback: $@";
 };
+#############################################################################
+sub fork_call(&@);
+sub get_slot($;$$);
 #############################################################################
 =head2 UTILITY FUNCTIONS
       $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
       $d
    } || "[unable to dump $_[0]: '$@']";
 }
+=item $scalar = cf::load_file $path
+Loads the given file from path and returns its contents. Croaks on error
+and can block.
+=cut
+sub load_file($) {
+   0 <= aio_load $_[0], my $data
+      or Carp::croak "$_[0]: $!";
+   $data
+}
+=item $success = cf::replace_file $path, $data, $sync
+Atomically replaces the file at the given $path with new $data, and
+optionally $sync the data to disk before replacing the file.
+=cut
+sub replace_file($$;$) {
+   my ($path, $data, $sync) = @_;
+   my $lock = cf::lock_acquire ("replace_file:$path");
+   my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
+      or return;
+   $data = $data->() if ref $data;
+   length $data == aio_write $fh, 0, (length $data), $data, 0
+      or return;
+   !$sync
+      or !aio_fsync $fh
+      or return;
+   aio_close $fh
+      and return;
+   aio_rename "$path~", $path
+      and return;
+   if ($sync) {
+      $path =~ s%/[^/]*$%%;
+      aio_pathsync $path;
+   }
+   1
+}
 =item $ref = cf::decode_json $json
 Converts a JSON string into the corresponding perl data structure.
 =item $json = cf::encode_json $ref
 our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
 sub encode_json($) { $json_coder->encode ($_[0]) }
 sub decode_json($) { $json_coder->decode ($_[0]) }
+=item $ref = cf::decode_storable $scalar
+Same as Coro::Storable::thaw, so blocks.
+=cut
+BEGIN { *decode_storable = \&Coro::Storable::thaw }
-=item $ref = cf::yaml_load $scalar
+=item $ref = cf::decode_yaml $scalar
 Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
 =cut
-sub fork_call(&@);
+sub decode_yaml($) {
-sub yaml_load($) {
    fork_call { YAML::XS::Load $_[0] } @_
+}
+=item $scalar = cf::unlzf $scalar
+Same as Compress::LZF::compress, but takes server ticks into account, so
+blocks.
+=cut
+sub unlzf($) {
+   # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
+   cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
+   Compress::LZF::decompress $_[0]
 }
 =item cf::post_init { BLOCK }
 Execute the given codeblock, I<after> all extensions have been (re-)loaded,
 =cut
 sub post_init(&) {
    push @POST_INIT, shift;
+}
+sub _post_init {
+   trace "running post_init jobs";
+   # run them in parallel...
+   my @join;
+   while () {
+      push @join, map &Coro::async ($_, 0), @POST_INIT;
+      @POST_INIT = ();
+      @join or last;
+      (pop @join)->join;
+   }
 }
 =item cf::lock_wait $string
 Wait until the given lock is available. See cf::lock_acquire.
    EV::periodic $start, $interval, 0, $cb
 }
 =item cf::get_slot $time[, $priority[, $name]]
-Allocate $time seconds of blocking CPU time at priority C<$priority>:
+Allocate $time seconds of blocking CPU time at priority C<$priority>
-This call blocks and returns only when you have at least C<$time> seconds
+(default: 0):  This call blocks and returns only when you have at least
-of cpu time till the next tick. The slot is only valid till the next cede.
+C<$time> seconds of cpu time till the next tick. The slot is only valid
+till the next cede.
+Background jobs should use a priority les than zero, interactive jobs
+should use 100 or more.
 The optional C<$name> can be used to identify the job to run. It might be
 used for statistical purposes and should identify the same time-class.
 Useful for short background jobs.
          }
       }
       if (@SLOT_QUEUE) {
          # we do not use wait_for_tick() as it returns immediately when tick is inactive
-         push @cf::WAIT_FOR_TICK, $signal;
+         $WAIT_FOR_TICK->wait;
-         $signal->wait;
       } else {
          $busy = 0;
          Coro::schedule;
       }
    }
       my @data;
       my $md5;
       for (0 .. $#$src) {
-         0 <= aio_load $src->[$_], $data[$_]
+         $data[$_] = load_file $src->[$_];
-            or Carp::croak "$src->[$_]: $!";
       }
       # if processing is expensive, check
       # checksum first
       if (1) {
 =cut
 #############################################################################
 # command handling &c
-=item cf::register_command $name => \&callback($ob,$args);
+=item cf::register_command $name => \&callback($ob,$args)
 Register a callback for execution when the client sends the user command
 $name.
 =cut
    #warn "registering command '$name/$time' to '$caller'";
    push @{ $COMMAND{$name} }, [$caller, $cb];
 }
-=item cf::register_extcmd $name => \&callback($pl,$packet);
+=item cf::register_extcmd $name => \&callback($pl,@args)
 Register a callback for execution when the client sends an (synchronous)
 extcmd packet. Ext commands will be processed in the order they are
 received by the server, like other user commands. The first argument is
 the logged-in player. Ext commands can only be processed after a player
 has logged in successfully.
-If the callback returns something, it is sent back as if reply was being
+The values will be sent back to the client.
-called.
+=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
+Same as C<cf::register_extcmd>, but instead of returning values, the
+callback needs to clal the C<$reply> function.
-=item cf::register_exticmd $name => \&callback($ns,$packet);
+=item cf::register_exticmd $name => \&callback($ns,@args)
 Register a callback for execution when the client sends an (asynchronous)
 exticmd packet. Exti commands are processed by the server as soon as they
 are received, i.e. out of order w.r.t. other commands. The first argument
 is a client socket. Exti commands can be received anytime, even before
 log-in.
-If the callback returns something, it is sent back as if reply was being
+The values will be sent back to the client.
-called.
-=cut
+=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
+Same as C<cf::register_extcmd>, but instead of returning values, the
+callback needs to clal the C<$reply> function.
+=cut
-sub register_extcmd {
+sub register_extcmd($$) {
    my ($name, $cb) = @_;
    $EXTCMD{$name} = $cb;
 }
-sub register_exticmd {
+sub register_async_extcmd($$) {
    my ($name, $cb) = @_;
+   $EXTACMD{$name} = $cb;
+}
+sub register_exticmd($$) {
+   my ($name, $cb) = @_;
    $EXTICMD{$name} = $cb;
+}
+sub register_async_exticmd($$) {
+   my ($name, $cb) = @_;
+   $EXTIACMD{$name} = $cb;
 }
 use File::Glob ();
 cf::player->attach (
       my ($pl, $buf) = @_;
       my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
       if (ref $msg) {
-         my ($type, $reply, @payload) =
+         my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
-            "ARRAY" eq ref $msg
-               ? @$msg
-               : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
-         my @reply;
-         if (my $cb = $EXTCMD{$type}) {
+         if (my $cb = $EXTACMD{$type}) {
+            $cb->(
+               $pl,
+               sub {
+                  $pl->ext_msg ("reply-$reply", @_)
+                     if $reply;
+               },
+               @payload
+            );
+         } else {
+            my @reply;
+            if (my $cb = $EXTCMD{$type}) {
-            @reply = $cb->($pl, @payload);
+               @reply = $cb->($pl, @payload);
+            }
+            $pl->ext_msg ("reply-$reply", @reply)
+               if $reply;
          }
-         $pl->ext_reply ($reply, @reply)
-            if $reply;
       } else {
          error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
       }
    };
    $grp
 }
+sub _ext_cfg_reg($$$$) {
+   my ($rvar, $varname, $cfgname, $default) = @_;
+   $cfgname = lc $varname
+      unless length $cfgname;
+   $EXT_CFG{$cfgname} = [$rvar, $default];
+   $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
+}
 sub load_extensions {
    info "loading extensions...";
+   %EXT_CFG = ();
    cf::sync_job {
       my %todo;
       for my $path (<$LIBDIR/*.ext>) {
                   unless exists $done{$_};
             }
             trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
+            my $source = $v->{source};
+            # support "CONF varname :confname = default" pseudo-statements
+            $source =~ s{
+               ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
+            }{
+               "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
+            }gmxe;
-            my $active = eval $v->{source};
+            my $active = eval $source;
             if (length $@) {
                error "$v->{path}: $@\n";
                cf::cleanup "mandatory extension '$k' failed to load, exiting."
             while (my ($k, $v) = each %todo) {
                cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
                   if exists $v->{meta}{mandatory};
             }
+            last;
          }
       }
    };
 }
    my $name = $pl->ob->name;
    $pl->{deny_save} = 1;
    $pl->password ("*"); # this should lock out the player until we have nuked the dir
-   $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
+   $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
    $pl->deactivate;
    my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
+   $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
    ext::highscore::check ($pl->ob);
-   $pl->invoke (cf::EVENT_PLAYER_QUIT);
    $pl->ns->destroy if $pl->ns;
    my $path = playerdir $pl;
    my $temp = "$path~$cf::RUNTIME~deleting~";
    aio_rename $path, $temp;
 =item $protocol_xml = $player->expand_cfpod ($cfpod)
 Expand deliantra pod fragments into protocol xml.
-=item $player->ext_reply ($msgid, @msg)
-Sends an ext reply to the player.
-=cut
-sub ext_reply($$@) {
-   my ($self, $id, @msg) = @_;
-   $self->ns->ext_reply ($id, @msg)
-}
 =item $player->ext_msg ($type, @msg)
 Sends an ext event to the client.
 =cut
 sub generate_random_map {
    my ($self, $rmp) = @_;
    my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
-   # mit "rum" bekleckern, nicht
-   $self->_create_random_map (
+   $self->_create_random_map ($rmp);
-      $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
-      $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
-      $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
-      $rmp->{exit_on_final_map},
-      $rmp->{xsize}, $rmp->{ysize},
-      $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
-      $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
-      $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
-      $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
-      $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
-      (cf::region::find $rmp->{region}), $rmp->{custom}
-   )
 }
 =item cf::map->register ($regex, $prio)
 Register a handler for the map path matching the given regex at the
       $base =~ s{[^/]+/?$}{};
       $path = "$base/$path";
    }
    for ($path) {
-      redo if s{//}{/};
       redo if s{/\.?/}{/};
       redo if s{/[^/]+/\.\./}{/};
    }
    $path
    Carp::cluck "unable to resolve path '$path' (base '$base')";
    ()
 }
+# may re-bless or do other evil things
 sub init {
    my ($self) = @_;
    $self
 }
    $self->{load_path} = $path;
    1
 }
+# used to laod the header of an original map
 sub load_header_orig {
    my ($self) = @_;
    $self->load_header_from ($self->load_path)
 }
+# used to laod the header of an instantiated map
 sub load_header_temp {
    my ($self) = @_;
    $self->load_header_from ($self->save_path)
 }
+# called after loading the header from an instantiated map
 sub prepare_temp {
    my ($self) = @_;
    $self->last_access ((delete $self->{last_access})
                        || $cf::RUNTIME); #d#
    # safety
    $self->{instantiate_time} = $cf::RUNTIME
       if $self->{instantiate_time} > $cf::RUNTIME;
 }
+# called after loading the header from an original map
 sub prepare_orig {
    my ($self) = @_;
    $self->{load_original} = 1;
    $self->{instantiate_time} = $cf::RUNTIME;
 sub find {
    my ($path, $origin) = @_;
    cf::cede_to_tick;
-   $path = normalise $path, $origin && $origin->path;
+   $path = normalise $path, $origin;
    my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
    my $guard2 = cf::lock_acquire "map_find:$path";
    $cf::MAP{$path} || do {
    {
       my $guard = cf::lock_acquire "map_data:$path";
       return unless $self->valid;
-      return unless $self->in_memory == cf::MAP_SWAPPED;
+      return unless $self->state == cf::MAP_SWAPPED;
-      $self->in_memory (cf::MAP_LOADING);
       $self->alloc;
       $self->pre_load;
       cf::cede_to_tick;
+      if (exists $self->{load_path}) {
-      my $f = new_from_file cf::object::thawer $self->{load_path};
+         my $f = new_from_file cf::object::thawer $self->{load_path};
-      $f->skip_block;
+         $f->skip_block;
-      $self->_load_objects ($f)
+         $self->_load_objects ($f)
-         or return;
+            or return;
-      $self->post_load_original
+         $self->post_load_original
-         if delete $self->{load_original};
+            if delete $self->{load_original};
-      if (my $uniq = $self->uniq_path) {
+         if (my $uniq = $self->uniq_path) {
-         utf8::encode $uniq;
+            utf8::encode $uniq;
-         unless (aio_stat $uniq) {
+            unless (aio_stat $uniq) {
-            if (my $f = new_from_file cf::object::thawer $uniq) {
+               if (my $f = new_from_file cf::object::thawer $uniq) {
-               $self->clear_unique_items;
+                  $self->clear_unique_items;
-               $self->_load_objects ($f);
+                  $self->_load_objects ($f);
-               $f->resolve_delayed_derefs;
+                  $f->resolve_delayed_derefs;
+               }
             }
          }
-      }
-      $f->resolve_delayed_derefs;
+         $f->resolve_delayed_derefs;
+      } else {
+         $self->post_load_original
+            if delete $self->{load_original};
+      }
+      $self->state (cf::MAP_INACTIVE);
       cf::cede_to_tick;
       # now do the right thing for maps
       $self->link_multipart_objects;
       $self->difficulty ($self->estimate_difficulty)
       unless ($self->{deny_activate}) {
          $self->decay_objects;
          $self->fix_auto_apply;
          $self->update_buttons;
          cf::cede_to_tick;
-         $self->activate;
+         #$self->activate; # no longer activate maps automatically
       }
       $self->{last_save} = $cf::RUNTIME;
       $self->last_access ($cf::RUNTIME);
-      $self->in_memory (cf::MAP_ACTIVE);
    }
    $self->post_load;
+   1
 }
 # customize the map for a given player, i.e.
 # return the _real_ map. used by e.g. per-player
 # maps to change the path to ~playername/mappath
 #      if $self->per_party;
    $self
 }
-# find and load all maps in the 3x3 area around a map
-sub load_neighbours {
-   my ($map) = @_;
-   my @neigh; # diagonal neighbours
-   for (0 .. 3) {
-      my $neigh = $map->tile_path ($_)
-         or next;
-      $neigh = find $neigh, $map
-         or next;
-      $neigh->load;
-      # now find the diagonal neighbours
-      push @neigh,
-         [$neigh->tile_path (($_ + 3) % 4), $neigh],
-         [$neigh->tile_path (($_ + 1) % 4), $neigh];
-   }
-   for (grep defined $_->[0], @neigh) {
-      my ($path, $origin) = @$_;
-      my $neigh = find $path, $origin
-         or next;
-      $neigh->load;
-   }
-}
 sub find_sync {
    my ($path, $origin) = @_;
+   # it's a bug to call this from the main context
    return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
       if $Coro::current == $Coro::main;
    find $path, $origin
 }
 sub do_load_sync {
    my ($map) = @_;
+   # it's a bug to call this from the main context
    return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
       if $Coro::current == $Coro::main;
    $map->load;
 }
 our $MAP_PREFETCHER = undef;
 sub find_async {
    my ($path, $origin, $load) = @_;
-   $path = normalise $path, $origin && $origin->{path};
+   $path = normalise $path, $origin;
    if (my $map = $cf::MAP{$path}) {
-      return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
+      return $map if !$load || $map->linkable;
    }
    $MAP_PREFETCH{$path} |= $load;
    $MAP_PREFETCHER ||= cf::async {
 sub swap_out {
    my ($self) = @_;
    my $lock = cf::lock_acquire "map_data:$self->{path}";
-   return if $self->in_memory != cf::MAP_ACTIVE;
+   return if !$self->linkable;
    return if $self->{deny_save};
    return if $self->players;
    # first deactivate the map and "unlink" it from the core
    $self->deactivate;
    $_->clear_links_to ($self) for values %cf::MAP;
-   $self->in_memory (cf::MAP_SWAPPED);
+   $self->state (cf::MAP_SWAPPED);
    # then atomically save
    $self->_save;
    # then free the map
    return if $self->players;
    cf::trace "resetting map ", $self->path, "\n";
-   $self->in_memory (cf::MAP_SWAPPED);
+   $self->state (cf::MAP_SWAPPED);
    # need to save uniques path
    unless ($self->{deny_save}) {
       my $uniq = $self->uniq_path; utf8::encode $uniq;
    # 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_neighbours;
    return unless $self->contr->active;
    local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
    if ($self->enter_map ($map, $x, $y)) {
             ($path, $x, $y) = (undef, undef, undef);
          }
       }
       my $map = eval {
-         my $map = defined $path ? cf::map::find $path : undef;
+         my $map = defined $path ? cf::map::find $path, $self->map : undef;
          if ($map) {
             $map = $map->customise_for ($self);
             $map = $check->($map, $x, $y, $self) if $check && $map;
          } else {
       $Coro::current->{desc} = "enter_exit";
       unless (eval {
          $self->deactivate_recursive; # just to be sure
-         # random map handling
-         {
-            my $guard = cf::lock_acquire "exit_prepare:$exit";
-            prepare_random_map $exit
-               if $exit->slaying eq "/!";
-         }
-         my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
+         my $map = cf::map::normalise $exit->slaying, $exit->map;
          my $x   = $exit->stats->hp;
          my $y   = $exit->stats->sp;
+         # special map handling
+         my $slaying = $exit->slaying;
+         # special map handling
+         if ($slaying eq "/!") {
+            my $guard = cf::lock_acquire "exit_prepare:$exit";
+            prepare_random_map $exit
+               if $exit->slaying eq "/!"; # need to re-check after getting the lock
+            $map = $exit->slaying;
+         } elsif ($slaying eq '!up') {
+            $map = $exit->map->tile_path (cf::TILE_UP);
+            $x = $exit->x;
+            $y = $exit->y;
+         } elsif ($slaying eq '!down') {
+            $map = $exit->map->tile_path (cf::TILE_DOWN);
+            $x = $exit->x;
+            $y = $exit->y;
+         }
          $self->goto ($map, $x, $y);
          # if exit is damned, update players death & WoR home-position
          $self->contr->savebed ($map, $x, $y)
 =cut
 sub cf::client::ext_msg($$@) {
    my ($self, $type, @msg) = @_;
-   if ($self->extcmd == 2) {
-      $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
+   $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
-   } elsif ($self->extcmd == 1) { # TODO: remove
-      push @msg, msgtype => "event_$type";
-      $self->send_big_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_big_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_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
-   }
 }
 =item $success = $client->query ($flags, "text", \&cb)
 Queues a query to the client, calling the given callback with
       my ($ns, $buf) = @_;
       my $msg = eval { $ns->{json_coder}->decode ($buf) };
       if (ref $msg) {
-         my ($type, $reply, @payload) =
+         my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
-            "ARRAY" eq ref $msg
-               ? @$msg
-               : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
-         my @reply;
-         if (my $cb = $EXTICMD{$type}) {
+         if (my $cb = $EXTIACMD{$type}) {
+            $cb->(
+               $ns,
+               sub {
+                  $ns->ext_msg ("reply-$reply", @_)
+                     if $reply;
+               },
+               @payload
+            );
+         } else {
+            my @reply;
+            if (my $cb = $EXTICMD{$type}) {
-            @reply = $cb->($ns, @payload);
+               @reply = $cb->($ns, @payload);
+            }
+            $ns->ext_msg ("reply-$reply", @reply)
+               if $reply;
          }
-         $ns->ext_reply ($reply, @reply)
-            if $reply;
       } else {
          error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
       }
       cf::override;
 =cut
 #############################################################################
 # the server's init and main functions
+our %FACEHASH; # hash => idx, #d# HACK for http server
+# internal api, not fianlised
+sub set_face {
+   my ($name, $type, $data) = @_;
+   my $idx = cf::face::find $name;
+   if ($idx) {
+      delete $FACEHASH{cf::face::get_chksum $idx};
+   } else {
+      $idx = cf::face::alloc $name;
+   }
+   my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
+   cf::face::set_type $idx, $type;
+   cf::face::set_data $idx, 0, $data, $hash;
+   cf::face::set_meta $idx, $type & 1 ? undef : undef;
+   $FACEHASH{$hash} = $idx;#d#
+   $idx
+}
 sub load_facedata($) {
    my ($path) = @_;
    # HACK to clear player env face cache, we need some signal framework
    # for this (global event?)
    my $enc = JSON::XS->new->utf8->canonical->relaxed;
    trace "loading facedata from $path\n";
-   0 < aio_load $path, my $facedata
+   my $facedata = decode_storable load_file $path;
-      or die "$path: $!";
-   $facedata = Coro::Storable::thaw $facedata;
    $facedata->{version} == 2
       or cf::cleanup "$path: version mismatch, cannot proceed.";
-   # patch in the exptable
-   my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
-   $facedata->{resource}{"res/exp_table"} = {
-      type => FT_RSRC,
-      data => $exp_table,
-      hash => (Digest::MD5::md5 $exp_table),
-   };
    cf::cede_to_tick;
    {
       my $faces = $facedata->{faceinfo};
-      while (my ($face, $info) = each %$faces) {
+      for my $face (sort keys %$faces) {
+         my $info = $faces->{$face};
          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->{hash32};
          cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
+         cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
+         $FACEHASH{$info->{hash64}} = $idx;#d#
          cf::cede_to_tick;
       }
       while (my ($face, $info) = each %$faces) {
    {
       my $res = $facedata->{resource};
       while (my ($name, $info) = each %$res) {
-         if (defined $info->{type}) {
+         if (defined (my $type = $info->{type})) {
+            # TODO: different hash - must free and use new index, or cache ixface data queue
             my $idx = (cf::face::find $name) || cf::face::alloc $name;
+            cf::face::set_type $idx, $type;
             cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
-            cf::face::set_type $idx, $info->{type};
+            cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
+            $FACEHASH{$info->{hash}} = $idx;#d#
          } else {
-            $RESOURCE{$name} = $info; # unused
+#            $RESOURCE{$name} = $info; # unused
          }
          cf::cede_to_tick;
       }
    }
    my $status = load_resource_file_ $_[0];
    get_slot 0.1, 100;
    cf::arch::commit_load;
    $status
+}
+sub reload_exp_table {
+   _reload_exp_table;
+   set_face "res/exp_table" => FT_RSRC,
+            JSON::XS->new->utf8->canonical->encode (
+               [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
+            );
+}
+sub reload_materials {
+   _reload_materials;
 }
 sub reload_regions {
    # HACK to clear player env face cache, we need some signal framework
    # for this (global event?)
 }
 sub reload_archetypes {
    load_resource_file "$DATADIR/archetypes"
       or die "unable to load archetypes\n";
+   set_face "res/skill_info" => FT_RSRC,
+            JSON::XS->new->utf8->canonical->encode (
+               [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
+            );
+   set_face "res/spell_paths" => FT_RSRC,
+            JSON::XS->new->utf8->canonical->encode (
+               [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
+            );
 }
 sub reload_treasures {
    load_resource_file "$DATADIR/treasures"
       or die "unable to load treasurelists\n";
 }
 sub reload_sound {
    trace "loading sound config from $DATADIR/sound\n";
-   0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
-      or die "$DATADIR/sound $!";
-   my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
+   my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
    for (0 .. SOUND_CAST_SPELL_0 - 1) {
       my $sound = $soundconf->{compat}[$_]
          or next;
 }
 sub reload_resources {
    trace "reloading resource files...\n";
-   reload_exp_table;
    reload_materials;
    reload_facedata;
+   reload_exp_table;
    reload_sound;
    reload_archetypes;
    reload_regions;
    reload_treasures;
 }
 sub reload_config {
    trace "reloading config file...\n";
-   0 < aio_load "$CONFDIR/config", my $config
+   my $config = load_file "$CONFDIR/config";
-      or die "$CONFDIR/config: $!";
    utf8::decode $config;
-   *CFG = yaml_load $config;
+   *CFG = decode_yaml $config;
    $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
    $cf::map::MAX_RESET     = $CFG{map_max_reset}     if exists $CFG{map_max_reset};
    $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
 sub main {
    cf::init_globals; # initialise logging
    LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
-   LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
+   LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
    LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
    LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
    $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
    # we must not ever block the main coroutine
-   local $Coro::idle = sub {
+   $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";
          EV::loop EV::LOOP_ONESHOT;
       })->prio (Coro::PRIO_MAX);
    evthread_start IO::AIO::poll_fileno;
    cf::sync_job {
       cf::incloader::init ();
+      db_init;
       cf::init_anim;
       cf::init_attackmess;
       cf::init_dynamic;
       cf::load_settings;
       reload_resources;
       reload_config;
-      db_init;
       cf::init_uuid;
       cf::init_signals;
       cf::init_skills;
       # no (long-running) fork's whatsoever before this point(!)
       use POSIX ();
       POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
-      (pop @POST_INIT)->(0) while @POST_INIT;
+      cf::_post_init 0;
    };
    cf::object::thawer::errors_are_fatal 0;
    info "parse errors in files are no longer fatal from this point on.\n";
-   my $free_main; $free_main = EV::idle sub {
+   AE::postpone {
-      undef $free_main;
       undef &main; # free gobs of memory :)
    };
    goto &main_loop;
 }
       cf::write_runtime_sync; # external watchdog should not bark
       trace "emergency_perl_save: flushing outstanding aio requests";
       while (IO::AIO::nreqs || BDB::nreqs) {
-         Coro::EV::timer_once 0.01; # let the sync_job do it's thing
+         Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
       }
       cf::write_runtime_sync; # external watchdog should not bark
    };
    my $t1 = AE::time;
    while ($RELOAD) {
       cf::get_slot 0.1, -1, "reload_perl";
-      info "reloading...";
+      info "perl_reload: reloading...";
-      trace "entering sync_job";
+      trace "perl_reload: entering sync_job";
       cf::sync_job {
          #cf::emergency_save;
-         trace "cancelling all extension coros";
+         trace "perl_reload: cancelling all extension coros";
          $_->cancel for values %EXT_CORO;
          %EXT_CORO = ();
-         trace "removing commands";
+         trace "perl_reload: removing commands";
          %COMMAND = ();
-         trace "removing ext/exti commands";
+         trace "perl_reload: removing ext/exti commands";
          %EXTCMD  = ();
          %EXTICMD = ();
-         trace "unloading/nuking all extensions";
+         trace "perl_reload: unloading/nuking all extensions";
          for my $pkg (@EXTS) {
             trace "... unloading $pkg";
             if (my $cb = $pkg->can ("unload")) {
                eval {
             trace "... clearing $pkg";
             clear_package $pkg;
          }
-         trace "unloading all perl modules loaded from $LIBDIR";
+         trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
          while (my ($k, $v) = each %INC) {
             next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
             trace "... unloading $k";
             delete $INC{$k};
             }
             clear_package $k;
          }
-         trace "getting rid of safe::, as good as possible";
+         trace "perl_reload: getting rid of safe::, as good as possible";
          clear_package "safe::$_"
             for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
-         trace "unloading cf.pm \"a bit\"";
+         trace "perl_reload: unloading cf.pm \"a bit\"";
          delete $INC{"cf.pm"};
          delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
          # don't, removes xs symbols, too,
          # and global variables created in xs
          #clear_package __PACKAGE__;
-         info "unload completed, starting to reload now";
+         info "perl_reload: unload completed, starting to reload now";
-         trace "reloading cf.pm";
+         trace "perl_reload: reloading cf.pm";
          require cf;
          cf::_connect_to_perl_1;
-         trace "loading config and database again";
+         trace "perl_reload: loading config and database again";
          cf::reload_config;
-         trace "loading extensions";
+         trace "perl_reload: loading extensions";
          cf::load_extensions;
          if ($REATTACH_ON_RELOAD) {
-            trace "reattaching attachments to objects/players";
+            trace "perl_reload: reattaching attachments to objects/players";
             _global_reattach; # objects, sockets
-            trace "reattaching attachments to maps";
+            trace "perl_reload: reattaching attachments to maps";
             reattach $_ for values %MAP;
-            trace "reattaching attachments to players";
+            trace "perl_reload: reattaching attachments to players";
             reattach $_ for values %PLAYER;
          }
-         trace "running post_init jobs";
+         cf::_post_init 1;
-         (pop @POST_INIT)->(1) while @POST_INIT;
-         trace "leaving sync_job";
+         trace "perl_reload: leaving sync_job";
          1
       } or do {
          error $@;
-         cf::cleanup "error while reloading, exiting.";
+         cf::cleanup "perl_reload: error, exiting.";
       };
-      info "reloaded";
       --$RELOAD;
    }
    $t1 = AE::time - $t1;
-   info "reload completed in ${t1}s\n";
+   info "perl_reload: completed in ${t1}s\n";
 };
 our $RELOAD_WATCHER; # used only during reload
 sub reload_perl() {
 #############################################################################
 my $bug_warning = 0;
-our @WAIT_FOR_TICK;
-our @WAIT_FOR_TICK_BEGIN;
 sub wait_for_tick() {
-   return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
+   return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
-   my $signal = new Coro::Signal;
+   $WAIT_FOR_TICK->wait;
-   push @WAIT_FOR_TICK, $signal;
-   $signal->wait;
 }
 sub wait_for_tick_begin() {
-   return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
+   return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
    my $signal = new Coro::Signal;
    push @WAIT_FOR_TICK_BEGIN, $signal;
    $signal->wait;
 }
       Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
          unless ++$bug_warning > 10;
       return;
    }
-   cf::server_tick; # one server iteration
+   cf::one_tick; # one server iteration
    #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
    if ($NOW >= $NEXT_RUNTIME_WRITE) {
       $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
    }
    if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
       $sig->send;
    }
-   while (my $sig = shift @WAIT_FOR_TICK) {
+   $WAIT_FOR_TICK->broadcast;
-      $sig->send;
-   }
    $LOAD = ($NOW - $TICK_START) / $TICK;
    $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
    if (0) {
    }
 }
 {
    # configure BDB
+   info "initialising database";
    BDB::min_parallel 16;
    BDB::max_poll_reqs $TICK * 0.1;
-   $AnyEvent::BDB::WATCHER->priority (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);
       $DB_ENV->set_flags      (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
       BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
    };
    $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
       BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
    };
+   info "database initialised";
 }
 {
    # configure IO::AIO
+   info "initialising aio";
    IO::AIO::min_parallel 8;
    IO::AIO::max_poll_time $TICK * 0.1;
    undef $AnyEvent::AIO::WATCHER;
+   info "aio initialised";
 }
-my $_log_backtrace;
+our $_log_backtrace;
+our $_log_backtrace_last;
 sub _log_backtrace {
    my ($msg, @addr) = @_;
-   $msg =~ s/\n//;
+   $msg =~ s/\n$//;
+   if ($_log_backtrace_last eq $msg) {
+      LOG llevInfo, "[ABT] $msg\n";
+      LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
    # limit the # of concurrent backtraces
-   if ($_log_backtrace < 2) {
+   } elsif ($_log_backtrace < 2) {
+      $_log_backtrace_last = $msg;
       ++$_log_backtrace;
       my $perl_bt = Carp::longmess $msg;
       async {
          $Coro::current->{desc} = "abt $msg";
          LOG llevInfo, "[ABT] $_\n" for @bt;
          --$_log_backtrace;
       };
    } else {
       LOG llevInfo, "[ABT] $msg\n";
-      LOG llevInfo, "[ABT] [suppressed]\n";
+      LOG llevInfo, "[ABT] [overload, suppressed]\n";
    }
 }
 # load additional modules
 require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.548 by root, Mon May 10 21:40:22 2010 UTC vs. Revision 1.596 by root, Fri Nov 9 20:37:57 2012 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.548 by root, Mon May 10 21:40:22 2010 UTC vs.
Revision 1.596 by root, Fri Nov 9 20:37:57 2012 UTC