--- deliantra/server/lib/cf.pm	2006/12/11 02:54:57	1.84
+++ deliantra/server/lib/cf.pm	2007/10/04 11:36:38	1.377
@@ -1,36 +1,124 @@
 package cf;
 
+use utf8;
+use strict;
+
 use Symbol;
 use List::Util;
+use Socket;
 use Storable;
+use Event;
 use Opcode;
 use Safe;
 use Safe::Hole;
 
-use IO::AIO ();
+use Coro 3.64 ();
+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 ();
+use BDB ();
+use Data::Dumper;
+use Digest::MD5;
+use Fcntl;
 use YAML::Syck ();
+use IO::AIO 2.32 ();
 use Time::HiRes;
-use Event;
+use Compress::LZF;
+use Digest::MD5 ();
+
+# configure various modules to our taste
+#
+$Storable::canonical = 1; # reduce rsync transfers
+Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
+Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
+
 $Event::Eval = 1; # no idea why this is required, but it is
 
 # work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
 $YAML::Syck::ImplicitUnicode = 1;
 
-use strict;
+$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
+
+sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
+
+our %COMMAND      = ();
+our %COMMAND_TIME = ();
 
-_init_vars;
+our @EXTS         = (); # list of extension package names
+our %EXTCMD       = ();
+our %EXTICMD      = ();
+our %EXT_CORO     = (); # coroutines bound to extensions
+our %EXT_MAP      = (); # pluggable maps
 
-our %COMMAND = ();
+our $RELOAD; # number of reloads so far
 our @EVENT;
-our $LIBDIR = maps_directory "perl";
 
-our $TICK = MAX_TIME * 1e-6;
+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 $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
 our $TICK_WATCHER;
+our $AIO_POLL_WATCHER;
+our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
 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, %PLAYER_LOADING); # all users
+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
+
+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") {
+   open my $fh, "<", "$LOCALDIR/runtime"
+      or die "unable to read runtime file: $!";
+   $RUNTIME = <$fh> + 0.;
+}
+
+mkdir $_
+   for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
+
+our $EMERGENCY_POSITION;
+
+sub cf::map::normalise;
 
 #############################################################################
 
@@ -42,20 +130,55 @@
 
 The timestamp of the server start (so not actually an uptime).
 
-=item $cf::LIBDIR
+=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.
 
-The perl library directory, where extensions and cf-specific modules can
-be found. It will be added to C<@INC> automatically.
+=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::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.
 
+=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 process
+per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
+
+=item @cf::INVOKE_RESULTS
+
+This array contains the results of the last C<invoke ()> call.  When
+C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
+that call.
+
 =back
 
 =cut
@@ -63,19 +186,33 @@
 BEGIN {
    *CORE::GLOBAL::warn = sub {
       my $msg = join "", @_;
+
       $msg .= "\n"
          unless $msg =~ /\n$/;
 
-      print STDERR "cfperl: $msg";
-      LOG llevError, "cfperl: $msg";
+      $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
+
+      LOG llevError, $msg;
    };
 }
 
-@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
+@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'; # 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::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
+for my $pkg (qw(
+   cf::global cf::attachable
+   cf::object cf::object::player
+   cf::client cf::player
+   cf::arch cf::living
+   cf::map cf::party cf::region
+)) {
    no strict 'refs';
    @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
 }
@@ -84,40 +221,427 @@
    warn "error in event callback: @_";
 };
 
-my %ext_pkg;
-my @exts;
-my @hook;
-my %command;
-my %extcmd;
+#############################################################################
 
 =head2 UTILITY FUNCTIONS
 
 =over 4
 
+=item dumpval $ref
+
 =cut
 
-use JSON::Syck (); # TODO# replace by JSON::PC once working
+sub dumpval {
+   eval {
+      local $SIG{__DIE__};
+      my $d;
+      if (1) {
+         $d = new Data::Dumper([$_[0]], ["*var"]);
+         $d->Terse(1);
+         $d->Indent(2);
+         $d->Quotekeys(0);
+         $d->Useqq(1);
+         #$d->Bless(...);
+         $d->Seen($_[1]) if @_ > 1;
+         $d = $d->Dump();
+      }
+      $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
+      $d
+   } || "[unable to dump $_[0]: '$@']";
+}
 
 =item $ref = cf::from_json $json
 
 Converts a JSON string into the corresponding perl data structure.
 
+=item $json = cf::to_json $ref
+
+Converts a perl data structure into its JSON representation.
+
 =cut
 
-sub from_json($) {
-   $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
-   JSON::Syck::Load $_[0]
+our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
+
+sub to_json   ($) { $json_coder->encode ($_[0]) }
+sub from_json ($) { $json_coder->decode ($_[0]) }
+
+=item cf::lock_wait $string
+
+Wait until the given lock is available. See cf::lock_acquire. 
+
+=item my $lock = cf::lock_acquire $string
+
+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;
+   }
 }
 
-=item $json = cf::to_json $ref
+sub lock_acquire($) {
+   my ($key) = @_;
 
-Converts a perl data structure into its JSON representation.
+   # 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 lock_active($) {
+   my ($key) = @_;
+
+   ! ! $LOCK{$key}
+}
+
+sub freeze_mainloop {
+   return unless $TICK_WATCHER->is_active;
+
+   my $guard = Coro::guard {
+      $TICK_WATCHER->start;
+   };
+   $TICK_WATCHER->stop;
+   $guard
+}
+
+=item cf::get_slot $time[, $priority[, $name]]
+
+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
+of cpu time till the next tick. The slot is only valid till the next cede.
+
+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.
+
+=cut
+
+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 ($avail > 0.01) {
+         for (0 .. $#SLOT_QUEUE) {
+            if ($SLOT_QUEUE[$_][0] < $avail) {
+               my $job = splice @SLOT_QUEUE, $_, 1, ();
+               $job->[2]->send;
+               Coro::cede;
+               goto next_job;
+            }
+         }
+      }
+
+      if (@SLOT_QUEUE) {
+         # 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;
+      }
+   }
+};
+
+sub get_slot($;$$) {
+   my ($time, $pri, $name) = @_;
+
+   $time = $TICK * .6 if $time > $TICK * .6;
+   my $sig = new Coro::Signal;
+
+   push @SLOT_QUEUE, [$time, $pri, $sig, $name];
+   @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
+   $SLOT_QUEUE->ready;
+   $sig->wait;
+}
+
+=item cf::async { BLOCK }
+
+Currently the same as Coro::async_pool, meaning you cannot use
+C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
+thing you are allowed to do is call C<prio> on it.
+
+=cut
+
+BEGIN { *async = \&Coro::async_pool }
+
+=item cf::sync_job { BLOCK }
+
+The design of Crossfire TRT requires that the main coroutine ($Coro::main)
+is always able to handle events or runnable, as Crossfire TRT is only
+partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
+acceptable.
+
+If it must be done, put the blocking parts into C<sync_job>. This will run
+the given BLOCK in another coroutine while waiting for the result. The
+server will be frozen during this time, so the block should either finish
+fast or be very important.
+
+=cut
+
+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)
+      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);
+
+      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->()
+   }
+}
+
+=item $coro = cf::async_ext { BLOCK }
+
+Like async, but this coro is automatically being canceled when the
+extension calling this is being unloaded.
+
+=cut
+
+sub async_ext(&) {
+   my $cb = shift;
+
+   my $coro = &Coro::async ($cb);
+
+   $coro->on_destroy (sub {
+      delete $EXT_CORO{$coro+0};
+   });
+   $EXT_CORO{$coro+0} = $coro;
+
+   $coro
+}
+
+=item fork_call { }, $args
+
+Executes the given code block with the given arguments in a seperate
+process, returning the results. Everything must be serialisable with
+Coro::Storable. May, of course, block. Note that the executed sub may
+never block itself or use any form of Event handling.
+
+=cut
+
+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 (likely this will be rather laborious)
+
+   my @res = Coro::Util::fork_eval {
+      reset_signals;
+      &$cb
+   }, @args;
+
+   wantarray ? @res : $res[-1]
+}
+
+=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 to_json($) {
-   $JSON::Syck::ImplicitUnicode = 0;  # work around JSON::Syck bugs
-   JSON::Syck::Dump $_[0]
+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 {
+   cf::sync_job {
+      $DB ||= db_table "db";
+   };
+}
+
+sub db_get($$) {
+   my $key = "$_[0]/$_[1]";
+
+   cf::sync_job {
+      BDB::db_get $DB, undef, $key, my $data;
+
+      $! ? ()
+         : $data
+   }
+}
+
+sub db_put($$$) {
+   BDB::dbreq_pri 4;
+   BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
+}
+
+=item cf::cache $id => [$paths...], $processversion => $process
+
+Generic caching function that returns the value of the resource $id,
+caching and regenerating as required.
+
+This function can block.
+
+=cut
+
+sub cache {
+   my ($id, $src, $processversion, $process) = @_;
+
+   my $meta =
+      join "\x00",
+         $processversion,
+         map {
+            aio_stat $_
+               and Carp::croak "$_: $!";
+
+            ($_, (stat _)[7,9])
+         } @$src;
+
+   my $dbmeta = db_get cache => "$id/meta";
+   if ($dbmeta ne $meta) {
+      # changed, we may need to process
+
+      my @data;
+      my $md5;
+
+      for (0 .. $#$src) {
+         0 <= aio_load $src->[$_], $data[$_]
+            or Carp::croak "$src->[$_]: $!";
+      }
+
+      # if processing is expensive, check
+      # checksum first
+      if (1) {
+         $md5 =
+            join "\x00",
+               $processversion,
+               map {
+                  cf::cede_to_tick;
+                  ($src->[$_], Digest::MD5::md5_hex $data[$_])
+               } 0.. $#$src;
+           
+
+         my $dbmd5 = db_get cache => "$id/md5";
+         if ($dbmd5 eq $md5) {
+            db_put cache => "$id/meta", $meta;
+
+            return db_get cache => "$id/data";
+         }
+      }
+
+      my $t1 = Time::HiRes::time;
+      my $data = $process->(\@data);
+      my $t2 = Time::HiRes::time;
+
+      warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
+
+      db_put cache => "$id/data", $data;
+      db_put cache => "$id/md5" , $md5;
+      db_put cache => "$id/meta", $meta;
+
+      return $data;
+   }
+
+   db_get cache => "$id/data"
+}
+
+=item cf::datalog type => key => value, ...
+
+Log a datalog packet of the given type with the given key-value pairs.
+
+=cut
+
+sub datalog($@) {
+  my ($type, %kv) = @_;
+  warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
 }
 
 =back
@@ -126,42 +650,72 @@
 
 #############################################################################
 
-=head2 EVENTS AND OBJECT ATTACHMENTS
+=head2 ATTACHABLE OBJECTS
+
+Many objects in crossfire are so-called attachable objects. That means you can
+attach callbacks/event handlers (a collection of which is called an "attachment")
+to it. All such attachable objects support the following methods.
+
+In the following description, CLASS can be any of C<global>, C<object>
+C<player>, C<client> or C<map> (i.e. the attachable objects in
+Crossfire TRT).
 
 =over 4
 
-=item $object->attach ($attachment, key => $value...)
+=item $attachable->attach ($attachment, key => $value...)
 
-=item $object->detach ($attachment)
+=item $attachable->detach ($attachment)
 
-Attach/detach a pre-registered attachment to an object.
+Attach/detach a pre-registered attachment to a specific object and give it
+the specified key/value pairs as arguments.
 
-=item $player->attach ($attachment, key => $value...)
+Example, attach a minesweeper attachment to the given object, making it a
+10x10 minesweeper game:
 
-=item $player->detach ($attachment)
+   $obj->attach (minesweeper => width => 10, height => 10);
 
-Attach/detach a pre-registered attachment to a player.
+=item $bool = $attachable->attached ($name)
 
-=item $map->attach ($attachment, key => $value...)
+Checks wether the named attachment is currently attached to the object.
 
-=item $map->detach ($attachment)
+=item cf::CLASS->attach ...
 
-Attach/detach a pre-registered attachment to a map.
+=item cf::CLASS->detach ...
 
-=item $bool = $object->attached ($name)
+Define an anonymous attachment and attach it to all objects of the given
+CLASS. See the next function for an explanation of its arguments.
 
-=item $bool = $player->attached ($name)
+You can attach to global events by using the C<cf::global> class.
 
-=item $bool = $map->attached ($name)
+Example, log all player logins:
 
-Checks wether the named attachment is currently attached to the object.
+   cf::player->attach (
+      on_login => sub {
+         my ($pl) = @_;
+         ...
+      },
+   );
+
+Example, attach to the jeweler skill:
 
-=item cf::attach_global ...
+   cf::object->attach (
+      type         => cf::SKILL,
+      subtype      => cf::SK_JEWELER,
+      on_use_skill => sub {
+         my ($sk, $ob, $part, $dir, $msg) = @_;
+         ...
+      },
+   );
 
-Attach handlers for global events.
+=item cf::CLASS::attachment $name, ...
 
-This and all following C<attach_*>-functions expect any number of the
-following handler/hook descriptions:
+Register an attachment by C<$name> through which attachable objects of the
+given CLASS can refer to this attachment.
+
+Some classes such as crossfire maps and objects can specify attachments
+that are attached at load/instantiate time, thus the need for a name.
+
+These calls expect any number of the following handler/hook descriptions:
 
 =over 4
 
@@ -173,6 +727,12 @@
 registered at priority C<-1000>, so lower priorities should not be used
 unless you know what you are doing.
 
+=item type => $type
+
+(Only for C<< cf::object->attach >> calls), limits the attachment to the
+given type of objects only (the additional parameter C<subtype> can be
+used to further limit to the given subtype).
+
 =item on_I<event> => \&cb
 
 Call the given code reference whenever the named event happens (event is
@@ -191,54 +751,45 @@
 
 =back
 
-=item cf::attach_to_type $object_type, $subtype, ...
+Example, define an attachment called "sockpuppet" that calls the given
+event handler when a monster attacks:
 
-Attach handlers for a specific object type (e.g. TRANSPORT) and
-subtype. If C<$subtype> is zero or undef, matches all objects of the given
-type.
-
-=item cf::attach_to_objects ...
-
-Attach handlers to all objects. Do not use this except for debugging or
-very rare events, as handlers are (obviously) called for I<all> objects in
-the game.
-
-=item cf::attach_to_players ...
-
-Attach handlers to all players.
-
-=item cf::attach_to_maps ...
-
-Attach handlers to all maps.
-
-=item cf:register_attachment $name, ...
-
-Register an attachment by name through which objects can refer to this
-attachment.
-
-=item cf:register_player_attachment $name, ...
-
-Register an attachment by name through which players can refer to this
-attachment.
+   cf::object::attachment sockpuppet =>
+      on_skill_attack => sub {
+         my ($self, $victim) = @_;
+         ...
+      }
+   }
 
-=item cf:register_map_attachment $name, ...
+=item $attachable->valid
 
-Register an attachment by name through which maps can refer to this
-attachment.
+Just because you have a perl object does not mean that the corresponding
+C-level object still exists. If you try to access an object that has no
+valid C counterpart anymore you get an exception at runtime. This method
+can be used to test for existence of the C object part without causing an
+exception.
 
 =cut
 
 # the following variables are defined in .xs and must not be re-created
-our @CB_GLOBAL = (); # registry for all global events
-our @CB_OBJECT = (); # all objects (should not be used except in emergency)
-our @CB_PLAYER = ();
-our @CB_TYPE   = (); # registry for type (cf-object class) based events
-our @CB_MAP    = ();
+our @CB_GLOBAL     = (); # registry for all global events
+our @CB_ATTACHABLE = (); # registry for all attachables
+our @CB_OBJECT     = (); # all objects (should not be used except in emergency)
+our @CB_PLAYER     = ();
+our @CB_CLIENT     = ();
+our @CB_TYPE       = (); # registry for type (cf-object class) based events
+our @CB_MAP        = ();
 
 my %attachment;
 
-sub _attach_cb($\%$$$) {
-   my ($registry, $undo, $event, $prio, $cb) = @_;
+sub cf::attachable::thawer_merge {
+   # simply override everything except _meta
+   local $_[0]{_meta};
+   %{$_[0]} = %{$_[1]};
+}
+
+sub _attach_cb($$$$) {
+   my ($registry, $event, $prio, $cb) = @_;
 
    use sort 'stable';
 
@@ -247,42 +798,52 @@
    @{$registry->[$event]} = sort
                            { $a->[0] cmp $b->[0] }
                            @{$registry->[$event] || []}, $cb;
-
-   push @{$undo->{cb}}, [$event, $cb];
 }
 
+# hack
+my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
+
 # attach handles attaching event callbacks
 # the only thing the caller has to do is pass the correct
 # registry (== where the callback attaches to).
-sub _attach(\@$@) {
+sub _attach {
    my ($registry, $klass, @arg) = @_;
 
+   my $object_type;
    my $prio = 0;
-
-   my %undo = (
-      registry => $registry,
-      cb       => [],
-   );
-
    my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
 
+   #TODO: get rid of this hack
+   if ($attachable_klass{$klass}) {
+      %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
+   }
+
    while (@arg) {
       my $type = shift @arg;
 
       if ($type eq "prio") {
          $prio = shift @arg;
 
+      } elsif ($type eq "type") {
+         $object_type = shift @arg;
+         $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_TYPES] ||= [];
+
       } elsif ($type eq "package") {
          my $pkg = shift @arg;
 
          while (my ($name, $id) = each %cb_id) {
             if (my $cb = $pkg->can ($name)) {
-               _attach_cb $registry, %undo, $id, $prio, $cb;
+               _attach_cb $registry, $id, $prio, $cb;
             }
          }
 
       } elsif (exists $cb_id{$type}) {
-         _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
+         _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
 
       } elsif (ref $type) {
          warn "attaching objects not supported, ignoring.\n";
@@ -292,116 +853,85 @@
          warn "attach argument '$type' not supported, ignoring.\n";
       }
    }
-
-   \%undo
 }
 
-sub _attach_attachment {
+sub _object_attach {
    my ($obj, $name, %arg) = @_;
 
    return if exists $obj->{_attachment}{$name};
 
-   my $res;
-
    if (my $attach = $attachment{$name}) {
       my $registry = $obj->registry;
 
       for (@$attach) {
          my ($klass, @attach) = @$_;
-         $res = _attach @$registry, $klass, @attach;
+         _attach $registry, $klass, @attach;
       }
 
       $obj->{$name} = \%arg;
    } else {
-      warn "object uses attachment '$name' that is not available, postponing.\n";
+      warn "object uses attachment '$name' which is not available, postponing.\n";
    }
 
    $obj->{_attachment}{$name} = undef;
-
-   $res->{attachment} = $name;
-   $res
 }
 
-*cf::object::attach =
-*cf::player::attach =
-*cf::map::attach = sub {
-   my ($obj, $name, %arg) = @_;
-
-   _attach_attachment $obj, $name, %arg;
+sub cf::attachable::attach {
+   if (ref $_[0]) {
+      _object_attach @_;
+   } else {
+      _attach shift->_attach_registry, @_;
+   }
+   _recalc_want;
 };
 
 # all those should be optimised
-*cf::object::detach =
-*cf::player::detach =
-*cf::map::detach = sub {
+sub cf::attachable::detach {
    my ($obj, $name) = @_;
 
-   delete $obj->{_attachment}{$name};
-   reattach ($obj);
+   if (ref $obj) {
+      delete $obj->{_attachment}{$name};
+      reattach ($obj);
+   } else {
+      Carp::croak "cannot, currently, detach class attachments";
+   }
+   _recalc_want;
 };
 
-*cf::object::attached =
-*cf::player::attached =
-*cf::map::attached = sub {
+sub cf::attachable::attached {
    my ($obj, $name) = @_;
 
    exists $obj->{_attachment}{$name}
-};
-
-sub attach_global {
-   _attach @CB_GLOBAL, KLASS_GLOBAL, @_
 }
 
-sub attach_to_type {
-   my $type = shift;
-   my $subtype = shift;
-
-   _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
-}
-
-sub attach_to_objects {
-   _attach @CB_OBJECT, KLASS_OBJECT, @_
-}
-
-sub attach_to_players {
-   _attach @CB_PLAYER, KLASS_PLAYER, @_
-}
-
-sub attach_to_maps {
-   _attach @CB_MAP, KLASS_MAP, @_
-}
-
-sub register_attachment {
-   my $name = shift;
-
-   $attachment{$name} = [[KLASS_OBJECT, @_]];
-}
-
-sub register_player_attachment {
-   my $name = shift;
-
-   $attachment{$name} = [[KLASS_PLAYER, @_]];
-}
+for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
+   eval "#line " . __LINE__ . " 'cf.pm'
+      sub cf::\L$klass\E::_attach_registry {
+         (\\\@CB_$klass, KLASS_$klass)
+      }
 
-sub register_map_attachment {
-   my $name = shift;
+      sub cf::\L$klass\E::attachment {
+         my \$name = shift;
 
-   $attachment{$name} = [[KLASS_MAP, @_]];
+         \$attachment{\$name} = [[KLASS_$klass, \@_]];
+      }
+   ";
+   die if $@;
 }
 
 our $override;
-our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
+our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
 
 sub override {
    $override = 1;
-   @invoke_results = ();
+   @INVOKE_RESULTS = (@_);
 }
 
 sub do_invoke {
    my $event = shift;
    my $callbacks = shift;
 
-   @invoke_results = ();
+   @INVOKE_RESULTS = ();
 
    local $override;
 
@@ -420,64 +950,40 @@
    0
 }
 
-=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...
-
-=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
+=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
 
-=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
+=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
 
-=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
+Generate an object-specific event with the given arguments.
 
-Generate a global/object/player/map-specific event with the given arguments.
-
-This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
+This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
 removed in future versions), and there is no public API to access override
-results (if you must, access C<@cf::invoke_results> directly).
+results (if you must, access C<@cf::INVOKE_RESULTS> directly).
 
 =back
 
 =cut
 
 #############################################################################
-
-=head2 METHODS VALID FOR ALL CORE OBJECTS
-
-=over 4
-
-=item $object->valid, $player->valid, $map->valid
-
-Just because you have a perl object does not mean that the corresponding
-C-level object still exists. If you try to access an object that has no
-valid C counterpart anymore you get an exception at runtime. This method
-can be used to test for existence of the C object part without causing an
-exception.
-
-=back
-
-=cut
-
-*cf::object::valid =
-*cf::player::valid =
-*cf::map::valid = \&cf::_valid;
-
-#############################################################################
 # object support
+#
 
-sub instantiate {
-   my ($obj, $data) = @_;
+sub _can_merge {
+   my ($ob1, $ob2) = @_;
 
-   $data = from_json $data;
+   local $Storable::canonical = 1;
+   my $fob1 = Storable::freeze $ob1;
+   my $fob2 = Storable::freeze $ob2;
 
-   for (@$data) {
-      my ($name, $args) = @$_;
-
-      $obj->attach ($name, %{$args || {} });
-   }
+   $fob1 eq $fob2
 }
 
-# basically do the same as instantiate, without calling instantiate
 sub reattach {
+   # basically do the same as instantiate, without calling instantiate
    my ($obj) = @_;
+
+   bless $obj, ref $obj; # re-bless in case extensions have been reloaded
+
    my $registry = $obj->registry;
 
    @$registry = ();
@@ -488,7 +994,7 @@
       if (my $attach = $attachment{$name}) {
          for (@$attach) {
             my ($klass, @attach) = @$_;
-            _attach @$registry, $klass, @attach;
+            _attach $registry, $klass, @attach;
          }
       } else {
          warn "object uses attachment '$name' that is not available, postponing.\n";
@@ -496,35 +1002,69 @@
    }
 }
 
+cf::attachable->attach (
+   prio           => -1000000,
+   on_instantiate => sub {
+      my ($obj, $data) = @_;
+
+      $data = from_json $data;
+
+      for (@$data) {
+         my ($name, $args) = @$_;
+
+         $obj->attach ($name, %{$args || {} });
+      }
+   },
+   on_reattach => \&reattach,
+   on_clone => sub {
+      my ($src, $dst) = @_;
+
+      @{$dst->registry} = @{$src->registry};
+
+      %$dst = %$src;
+
+      %{$dst->{_attachment}} = %{$src->{_attachment}}
+         if exists $src->{_attachment};
+   },
+);
+
 sub object_freezer_save {
    my ($filename, $rdata, $objs) = @_;
 
-   if (length $$rdata) {
-      warn sprintf "saving %s (%d,%d)\n",
-         $filename, length $$rdata, scalar @$objs;
-
-      if (open my $fh, ">:raw", "$filename~") {
-         chmod SAVE_MODE, $fh;
-         syswrite $fh, $$rdata;
-         close $fh;
+   sync_job {
+      if (length $$rdata) {
+         utf8::decode (my $decname = $filename);
+         warn sprintf "saving %s (%d,%d)\n",
+            $decname, length $$rdata, scalar @$objs;
 
-         if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
+         if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
             chmod SAVE_MODE, $fh;
-            syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
+            aio_write $fh, 0, (length $$rdata), $$rdata, 0;
+            aio_fsync $fh if $cf::USE_FSYNC;
             close $fh;
-            rename "$filename.pst~", "$filename.pst";
+
+            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 };
+                  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.pst";
+            }
+
+            aio_rename "$filename~", $filename;
          } else {
-            unlink "$filename.pst";
+            warn "FATAL: $filename~: $!\n";
          }
-
-         rename "$filename~", $filename;
       } else {
-         warn "FATAL: $filename~: $!\n";
+         aio_unlink $filename;
+         aio_unlink "$filename.pst";
       }
-   } else {
-      unlink $filename;
-      unlink "$filename.pst";
-   }
+   };
 }
 
 sub object_freezer_as_string {
@@ -538,256 +1078,1228 @@
 sub object_thawer_load {
    my ($filename) = @_;
 
-   local $/;
+   my ($data, $av);
+
+   (aio_load $filename, $data) >= 0
+      or return;
 
-   my $av;
+   unless (aio_stat "$filename.pst") {
+      (aio_load "$filename.pst", $av) >= 0
+         or return;
 
-   #TODO: use sysread etc.
-   if (open my $data, "<:raw:perlio", $filename) {
-      $data = <$data>;
-      if (open my $pst, "<:raw:perlio", "$filename.pst") {
-         $av = eval { (Storable::thaw <$pst>)->{objs} };
-      }
-      return ($data, $av);
+      $av = eval { (Storable::thaw $av)->{objs} };
    }
 
-   ()
+   utf8::decode (my $decname = $filename);
+   warn sprintf "loading %s (%d,%d)\n",
+      $decname, length $data, scalar @{$av || []};
+
+   ($data, $av)
 }
 
-attach_to_objects
-   prio     => -1000000,
-   on_clone => sub {
-      my ($src, $dst) = @_;
+=head2 COMMAND CALLBACKS
 
-      @{$dst->registry} = @{$src->registry};
+=over 4
 
-      %$dst = %$src;
+=cut
 
-      %{$dst->{_attachment}} = %{$src->{_attachment}}
-         if exists $src->{_attachment};
+#############################################################################
+# command handling &c
+
+=item cf::register_command $name => \&callback($ob,$args);
+
+Register a callback for execution when the client sends the user command
+$name.
+
+=cut
+
+sub register_command {
+   my ($name, $cb) = @_;
+
+   my $caller = caller;
+   #warn "registering command '$name/$time' to '$caller'";
+
+   push @{ $COMMAND{$name} }, [$caller, $cb];
+}
+
+=item cf::register_extcmd $name => \&callback($pl,$packet);
+
+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
+called.
+
+=item cf::register_exticmd $name => \&callback($ns,$packet);
+
+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
+called.
+
+=cut
+
+sub register_extcmd {
+   my ($name, $cb) = @_;
+
+   $EXTCMD{$name} = $cb;
+}
+
+sub register_exticmd {
+   my ($name, $cb) = @_;
+
+   $EXTICMD{$name} = $cb;
+}
+
+cf::player->attach (
+   on_command => sub {
+      my ($pl, $name, $params) = @_;
+
+      my $cb = $COMMAND{$name}
+         or return;
+
+      for my $cmd (@$cb) {
+         $cmd->[1]->($pl->ob, $params);
+      }
+
+      cf::override;
    },
-;
+   on_extcmd => sub {
+      my ($pl, $buf) = @_;
+
+      my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
+
+      if (ref $msg) {
+         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}) {
+            @reply = $cb->($pl, @payload);
+         }
+
+         $pl->ext_reply ($reply, @reply)
+            if $reply;
+
+      } else {
+         warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
+      }
+
+      cf::override;
+   },
+);
+
+sub load_extensions {
+   cf::sync_job {
+      my %todo;
+
+      for my $path (<$LIBDIR/*.ext>) {
+         next unless -r $path;
+
+         $path =~ /([^\/\\]+)\.ext$/ or die "$path";
+         my $base = $1;
+         my $pkg = $1;
+         $pkg =~ s/[^[:word:]]/_/g;
+         $pkg = "ext::$pkg";
+
+         open my $fh, "<:utf8", $path
+            or die "$path: $!";
+
+         my $source = do { local $/; <$fh> };
+
+         my %ext = (
+            path => $path,
+            base => $base,
+            pkg  => $pkg,
+         );
+
+         $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
+            if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
+
+         $ext{source} =
+            "package $pkg; use strict; use utf8;\n"
+            . "#line 1 \"$path\"\n{\n"
+            . $source
+            . "\n};\n1";
+
+         $todo{$base} = \%ext;
+      }
+
+      my %done;
+      while (%todo) {
+         my $progress;
+
+         while (my ($k, $v) = each %todo) {
+            for (split /,\s*/, $v->{meta}{depends}) {
+               goto skip
+                  unless exists $done{$_};
+            }
+
+            warn "... loading '$k' into '$v->{pkg}'\n";
+
+            unless (eval $v->{source}) {
+               my $msg = $@ ? "$v->{path}: $@\n"
+                            : "$v->{base}: extension inactive.\n";
+
+               if (exists $v->{meta}{mandatory}) {
+                  warn $msg;
+                  warn "mandatory extension failed to load, exiting.\n";
+                  exit 1;
+               }
+               
+               warn $msg;
+            }
+
+            $done{$k} = delete $todo{$k};
+            push @EXTS, $v->{pkg};
+            $progress = 1;
+         }
+
+         skip:
+         die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
+            unless $progress;
+      }
+   };
+}
 
 #############################################################################
-# old plug-in events
 
-sub inject_event {
-   my $extension = shift;
-   my $event_code = shift;
+=back
 
-   my $cb = $hook[$event_code]{$extension}
-      or return;
+=head2 CORE EXTENSIONS
+
+Functions and methods that extend core crossfire objects.
+
+=cut
+
+package cf::player;
 
-   &$cb
+use Coro::AIO;
+
+=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
 }
 
-sub inject_global_event {
-   my $event = shift;
+=item cf::player::find $login
+
+Returns the given player object, loading it if necessary (might block).
+
+=cut
+
+sub playerdir($) {
+   "$PLAYERDIR/"
+     . (ref $_[0] ? $_[0]->ob->name : $_[0])
+}
+
+sub path($) {
+   my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
+
+   (playerdir $login) . "/playerdata"
+}
+
+sub find_active($) {
+   $cf::PLAYER{$_[0]}
+      and $cf::PLAYER{$_[0]}->active
+      and $cf::PLAYER{$_[0]}
+}
+
+sub exists($) {
+   my ($login) = @_;
+
+   $cf::PLAYER{$login}
+      or cf::sync_job { !aio_stat path $login }
+}
+
+sub find($) {
+   return $cf::PLAYER{$_[0]} || do {
+      my $login = $_[0];
+
+      my $guard = cf::lock_acquire "user_find:$login";
+
+      $cf::PLAYER{$_[0]} || do {
+         # rename old playerfiles to new ones
+         #TODO: remove when no longer required
+         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 $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
+      }
+   }
+}
+
+sub save($) {
+   my ($pl) = @_;
+
+   return if $pl->{deny_save};
+
+   my $path = path $pl;
+   my $guard = cf::lock_acquire "user_save:$path";
+
+   return if $pl->{deny_save};
+
+   aio_mkdir playerdir $pl, 0770;
+   $pl->{last_save} = $cf::RUNTIME;
 
-   my $cb = $hook[$event]
+   $pl->save_pl ($path);
+   cf::cede_to_tick;
+}
+
+sub new($) {
+   my ($login) = @_;
+
+   my $self = create;
+
+   $self->ob->name ($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
+be destroyed. May block for a long time.
+
+=cut
+
+sub quit_character {
+   my ($pl) = @_;
+
+   my $name = $pl->ob->name;
 
-   List::Util::max map &$_, values %$cb
+   $pl->{deny_save} = 1;
+   $pl->password ("*"); # this should lock out the player until we nuked the dir
+
+   $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
+   $pl->deactivate;
+   $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;
+   delete $cf::PLAYER{$pl->ob->name};
+   $pl->destroy;
+
+   my $prefix = qr<^~\Q$name\E/>;
+
+   # nuke player maps
+   $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
+
+   IO::AIO::aio_rmtree $temp;
+}
+
+=item $pl->kick
+
+Kicks a player out of the game. This destroys the connection.
+
+=cut
+
+sub kick {
+   my ($pl, $kicker) = @_;
+
+   $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
+   $pl->killer ("kicked");
+   $pl->ns->destroy;
 }
 
-sub inject_command {
-   my ($name, $obj, $params) = @_;
+=item cf::player::list_logins
 
-   for my $cmd (@{ $command{$name} }) {
-      $cmd->[1]->($obj, $params);
+Returns am arrayref of all valid playernames in the system, can take a
+while and may block, so not sync_job-capable, ever.
+
+=cut
+
+sub list_logins {
+   my $dirs = aio_readdir $PLAYERDIR
+      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, Fcntl::O_RDONLY, 0 or next;
+         aio_read $fh, 0, 512, my $buf, 0            or next;
+         $buf !~ /^password -------------$/m         or next; # official not-valid tag
+      }
+
+      utf8::decode $login;
+      push @logins, $login;
    }
 
-   -1
+   \@logins
 }
 
-sub register_command {
-   my ($name, $time, $cb) = @_;
+=item $player->maps
 
-   my $caller = caller;
-   #warn "registering command '$name/$time' to '$caller'";
+Returns an arrayref of map paths that are private for this
+player. May block.
+
+=cut
+
+sub maps($) {
+   my ($pl) = @_;
+
+   $pl = ref $pl ? $pl->ob->name : $pl;
+
+   my $files = aio_readdir playerdir $pl
+      or return;
+
+   my @paths;
 
-   push @{ $command{$name} }, [$time, $cb, $caller];
-   $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
+   for (@$files) {
+      utf8::decode $_;
+      next if /\.(?:pl|pst)$/;
+      next unless /^$PATH_SEP/o;
+
+      push @paths, cf::map::normalise "~$pl/$_";
+   }
+
+   \@paths
 }
 
-sub register_extcmd {
-   my ($name, $cb) = @_;
+=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
 
-   my $caller = caller;
-   #warn "registering extcmd '$name' to '$caller'";
+Expand crossfire pod fragments into protocol xml.
+
+=cut
+
+sub expand_cfpod {
+   ((my $self), (local $_)) = @_;
 
-   $extcmd{$name} = [$cb, $caller];
+   # escape & and <
+   s/&/&amp;/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>
+      || s{H<([^\>]*)>}
+          {
+             ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
+              "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
+              "")
+                [$self->{hintmode}]
+          }ge;
+
+   # create single paragraphs (very hackish)
+   s/(?<=\S)\n(?=\w)/ /g;
+
+   # compress some whitespace
+   s/\s+\n/\n/g; # ws line-ends
+   s/\n\n+/\n/g; # double lines
+   s/^\n+//;     # beginning lines
+   s/\n+$//;     # ending lines
+
+   $_
+}
+
+sub hintmode {
+   $_[0]{hintmode} = $_[1] if @_ > 1;
+   $_[0]{hintmode}
 }
 
-sub register {
-   my ($base, $pkg) = @_;
+=item $player->ext_reply ($msgid, @msg)
+
+Sends an ext reply to the player.
+
+=cut
 
-   #TODO
+sub ext_reply($$@) {
+   my ($self, $id, @msg) = @_;
+
+   $self->ns->ext_reply ($id, @msg)
 }
 
-sub load_extension {
+=item $player->ext_msg ($type, @msg)
+
+Sends an ext event to the client.
+
+=cut
+
+sub ext_msg($$@) {
+   my ($self, $type, @msg) = @_;
+
+   $self->ns->ext_msg ($type, @msg);
+}
+
+=head3 cf::region
+
+=over 4
+
+=cut
+
+package cf::region;
+
+=item cf::region::find_by_path $path
+
+Tries to decuce the likely region for a map knowing only its path.
+
+=cut
+
+sub find_by_path($) {
    my ($path) = @_;
 
-   $path =~ /([^\/\\]+)\.ext$/ or die "$path";
-   my $base = $1;
-   my $pkg = $1;
-   $pkg =~ s/[^[:word:]]/_/g;
-   $pkg = "ext::$pkg";
+   my ($match, $specificity);
 
-   warn "loading '$path' into '$pkg'\n";
+   for my $region (list) {
+      if ($region->{match} && $path =~ $region->{match}) {
+         ($match, $specificity) = ($region, $region->specificity)
+            if $region->specificity > $specificity;
+      }
+   }
 
-   open my $fh, "<:utf8", $path
-      or die "$path: $!";
+   $match
+}
 
-   my $source =
-      "package $pkg; use strict; use utf8;\n"
-      . "#line 1 \"$path\"\n{\n"
-      . (do { local $/; <$fh> })
-      . "\n};\n1";
+=back
 
-   eval $source
-      or die $@ ? "$path: $@\n"
-                : "extension disabled.\n";
+=head3 cf::map
 
-   push @exts, $pkg;
-   $ext_pkg{$base} = $pkg;
+=over 4
+
+=cut
 
-#   no strict 'refs';
-#   @{"$pkg\::ISA"} = ext::;
+package cf::map;
+
+use Fcntl;
+use Coro::AIO;
+
+use overload
+   '""'     => \&as_string,
+   fallback => 1;
+
+our $MAX_RESET     = 3600;
+our $DEFAULT_RESET = 3000;
+
+sub generate_random_map {
+   my ($self, $rmp) = @_;
+   # mit "rum" bekleckern, nicht
+   $self->_create_random_map (
+      $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
+      $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
+      $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
+givne priority (higher is better, built-in handlers have priority 0, the
+default).
+
+=cut
 
-   register $base, $pkg;
+sub register {
+   my (undef, $regex, $prio) = @_;
+   my $pkg = caller;
+
+   no strict;
+   push @{"$pkg\::ISA"}, __PACKAGE__;
+
+   $EXT_MAP{$pkg} = [$prio, qr<$regex>];
 }
 
-sub unload_extension {
-   my ($pkg) = @_;
+# also paths starting with '/'
+$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
 
-   warn "removing extension $pkg\n";
+sub thawer_merge {
+   my ($self, $merge) = @_;
 
-   # remove hooks
-   #TODO
-#   for my $idx (0 .. $#PLUGIN_EVENT) {
-#      delete $hook[$idx]{$pkg};
-#   }
+   # we have to keep some variables in memory intact
+   local $self->{path};
+   local $self->{load_path};
 
-   # remove commands
-   for my $name (keys %command) {
-      my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
+   $self->SUPER::thawer_merge ($merge);
+}
 
-      if (@cb) {
-         $command{$name} = \@cb;
-         $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
-      } else {
-         delete $command{$name};
-         delete $COMMAND{"$name\000"};
-      }
+sub normalise {
+   my ($path, $base) = @_;
+
+   $path = "$path"; # make sure its a string
+
+   $path =~ s/\.map$//;
+
+   # map plan:
+   #
+   # /!          non-realised random map exit (special hack!)
+   # {...        are special paths that are not being touched
+   # ?xxx/...    are special absolute paths
+   # ?random/... random maps
+   # /...        normal maps
+   # ~user/...   per-player map of a specific user
+
+   $path =~ s/$PATH_SEP/\//go;
+
+   # treat it as relative path if it starts with
+   # something that looks reasonable
+   if ($path =~ m{^(?:\./|\.\./|\w)}) {
+      $base or Carp::carp "normalise called with relative path and no base: '$path'";
+
+      $base =~ s{[^/]+/?$}{};
+      $path = "$base/$path";
    }
 
-   # remove extcmds
-   for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
-      delete $extcmd{$name};
+   for ($path) {
+      redo if s{//}{/};
+      redo if s{/\.?/}{/};
+      redo if s{/[^/]+/\.\./}{/};
    }
 
-   if (my $cb = $pkg->can ("unload")) {
-      eval {
-         $cb->($pkg);
-         1
-      } or warn "$pkg unloaded, but with errors: $@";
+   $path
+}
+
+sub new_from_path {
+   my (undef, $path, $base) = @_;
+
+   return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
+
+   $path = normalise $path, $base;
+
+   for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
+      if ($path =~ $EXT_MAP{$pkg}[1]) {
+         my $self = bless cf::map::new, $pkg;
+         $self->{path} = $path; $self->path ($path);
+         $self->init; # pass $1 etc.
+         return $self;
+      }
    }
 
-   Symbol::delete_package $pkg;
+   Carp::cluck "unable to resolve path '$path' (base '$base').";
+   ()
 }
 
-sub load_extensions {
-   my $LIBDIR = maps_directory "perl";
+sub init {
+   my ($self) = @_;
 
-   for my $ext (<$LIBDIR/*.ext>) {
-      next unless -r $ext;
-      eval {
-         load_extension $ext;
-         1
-      } or warn "$ext not loaded: $@";
+   $self
+}
+
+sub as_string {
+   my ($self) = @_;
+
+   "$self->{path}"
+}
+
+# the displayed name, this is a one way mapping
+sub visible_name {
+   &as_string
+}
+
+# the original (read-only) location
+sub load_path {
+   my ($self) = @_;
+
+   "$MAPDIR/$self->{path}.map"
+}
+
+# the temporary/swap location
+sub save_path {
+   my ($self) = @_;
+
+   (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
+   "$TMPDIR/$path.map"
+}
+
+# the unique path, undef == no special unique path
+sub uniq_path {
+   my ($self) = @_;
+
+   (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
+   "$UNIQUEDIR/$path"
+}
+
+# and all this just because we cannot iterate over
+# all maps in C++...
+sub change_all_map_light {
+   my ($change) = @_;
+
+   $_->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;
+   IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
+}
+
+sub load_header_from($) {
+   my ($self, $path) = @_;
+
+   utf8::encode $path;
+   my $f = new_from_file cf::object::thawer $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 load_header_orig {
+   my ($self) = @_;
+
+   $self->load_header_from ($self->load_path)
+}
+
+sub load_header_temp {
+   my ($self) = @_;
+
+   $self->load_header_from ($self->save_path)
+}
+
+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;
+}
+
+sub prepare_orig {
+   my ($self) = @_;
+
+   $self->{load_original} = 1;
+   $self->{instantiate_time} = $cf::RUNTIME;
+   $self->last_access ($cf::RUNTIME);
+   $self->instantiate;
+}
+
+sub load_header {
+   my ($self) = @_;
+
+   if ($self->load_header_temp) {
+      $self->prepare_temp;
+   } else {
+      $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
 }
 
-#############################################################################
-# extcmd framework, basically convert ext <msg>
-# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
+sub find;
+sub find {
+   my ($path, $origin) = @_;
 
-attach_to_players
-   on_extcmd => sub {
-      my ($pl, $buf) = @_;
+   $path = normalise $path, $origin && $origin->path;
 
-      my $msg = eval { from_json $buf };
+   cf::lock_wait "map_data:$path";#d#remove
+   cf::lock_wait "map_find:$path";
 
-      if (ref $msg) {
-         if (my $cb = $extcmd{$msg->{msgtype}}) {
-            if (my %reply = $cb->[0]->($pl, $msg)) {
-               $pl->ext_reply ($msg->{msgid}, %reply);
+   $cf::MAP{$path} || do {
+      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;
+
+      $map->load_header
+         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;
+         return find $path;
+      }
+
+      $cf::MAP{$path} = $map
+   }
+}
+
+sub pre_load  { }
+sub post_load { }
+
+sub load {
+   my ($self) = @_;
+
+   local $self->{deny_reset} = 1; # loading can take a long time
+
+   my $path = $self->{path};
+
+   {
+      my $guard = cf::lock_acquire "map_data:$path";
+
+      return unless $self->valid;
+      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 ($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;
+         unless (aio_stat $uniq) {
+            if (my $f = new_from_file cf::object::thawer $uniq) {
+               $self->clear_unique_items;
+               $self->_load_objects ($f);
+               $f->resolve_delayed_derefs;
             }
          }
-      } else {
-         warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
       }
 
-      cf::override;
-   },
-;
+      $f->resolve_delayed_derefs;
 
-#############################################################################
-# load/save/clean perl data associated with a map
+      cf::cede_to_tick;
+      # now do the right thing for maps
+      $self->link_multipart_objects;
+      $self->difficulty ($self->estimate_difficulty)
+         unless $self->difficulty;
+      cf::cede_to_tick;
+
+      unless ($self->{deny_activate}) {
+         $self->decay_objects;
+         $self->fix_auto_apply;
+         $self->update_buttons;
+         cf::cede_to_tick;
+         $self->set_darkness_map;
+         cf::cede_to_tick;
+         $self->activate;
+      }
 
-*cf::mapsupport::on_clean = sub {
+      $self->{last_save} = $cf::RUNTIME;
+      $self->last_access ($cf::RUNTIME);
+
+      $self->in_memory (cf::MAP_IN_MEMORY);
+   }
+
+   $self->post_load;
+}
+
+sub customise_for {
+   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_neighbours {
    my ($map) = @_;
 
-   my $path = $map->tmpname;
-   defined $path or return;
+   my @neigh; # diagonal neighbours
 
-   unlink "$path.pst";
-};
+   for (0 .. 3) {
+      my $neigh = $map->tile_path ($_)
+         or next;
+      $neigh = find $neigh, $map
+         or next;
+      $neigh->load;
 
-attach_to_maps prio => -10000, package => cf::mapsupport::;
+      push @neigh,
+         [$neigh->tile_path (($_ + 3) % 4), $neigh],
+         [$neigh->tile_path (($_ + 1) % 4), $neigh];
+   }
 
-#############################################################################
-# load/save perl data associated with player->ob objects
+   for (grep defined $_->[0], @neigh) {
+      my ($path, $origin) = @$_;
+      my $neigh = find $path, $origin
+         or next;
+      $neigh->load;
+   }
+}
 
-sub all_objects(@) {
-   @_, map all_objects ($_->inv), @_
+sub find_sync {
+   my ($path, $origin) = @_;
+
+   cf::sync_job { find $path, $origin }
 }
 
-# TODO: compatibility cruft, remove when no longer needed
-attach_to_players
-   on_load => sub {
-      my ($pl, $path) = @_;
+sub do_load_sync {
+   my ($map) = @_;
+
+   cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
+      if $Coro::current == $Coro::main;
 
-      for my $o (all_objects $pl->ob) {
-         if (my $value = $o->get_ob_key_value ("_perl_data")) {
-            $o->set_ob_key_value ("_perl_data");
+   cf::sync_job { $map->load };
+}
 
-            %$o = %{ Storable::thaw pack "H*", $value };
+our %MAP_PREFETCH;
+our $MAP_PREFETCHER = undef;
+
+sub find_async {
+   my ($path, $origin, $load) = @_;
+
+   $path = normalise $path, $origin && $origin->{path};
+
+   if (my $map = $cf::MAP{$path}) {
+      return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
+   }
+
+   $MAP_PREFETCH{$path} |= $load;
+
+   $MAP_PREFETCHER ||= cf::async {
+      $Coro::current->{desc} = "map prefetcher";
+
+      while (%MAP_PREFETCH) {
+         while (my ($k, $v) = each %MAP_PREFETCH) {
+            if (my $map = find $k) {
+               $map->load if $v;
+            }
+
+            delete $MAP_PREFETCH{$k};
          }
       }
-   },
-;
+      undef $MAP_PREFETCHER;
+   };
+   $MAP_PREFETCHER->prio (6);
 
-#############################################################################
+   ()
+}
 
-=head2 CORE EXTENSIONS
+sub save {
+   my ($self) = @_;
 
-Functions and methods that extend core crossfire objects.
+   my $lock = cf::lock_acquire "map_data:$self->{path}";
+
+   $self->{last_save} = $cf::RUNTIME;
+
+   return unless $self->dirty;
+
+   my $save = $self->save_path; utf8::encode $save;
+   my $uniq = $self->uniq_path; utf8::encode $uniq;
+
+   $self->{load_path} = $save;
+
+   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);
+      $self->_save_objects ($uniq, cf::IO_UNIQUES);
+   } else {
+      $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
+   }
+}
+
+sub swap_out {
+   my ($self) = @_;
+
+   # save first because save cedes
+   $self->save;
+
+   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;
+}
+
+sub reset_at {
+   my ($self) = @_;
+
+   # TODO: safety, remove and allow resettable per-player maps
+   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;
+
+   $time + $to
+}
+
+sub should_reset {
+   my ($self) = @_;
+
+   $self->reset_at <= $cf::RUNTIME
+}
+
+sub reset {
+   my ($self) = @_;
+
+   my $lock = cf::lock_acquire "map_data:$self->{path}";
+
+   return if $self->players;
+
+   warn "resetting map ", $self->path;
+
+   $self->in_memory (cf::MAP_SWAPPED);
+
+   # need to save uniques path
+   unless ($self->{deny_save}) {
+      my $uniq = $self->uniq_path; utf8::encode $uniq;
+
+      $self->_save_objects ($uniq, cf::IO_UNIQUES)
+         if $uniq;
+   }
+
+   delete $cf::MAP{$self->path};
+
+   $self->deactivate;
+   $_->clear_links_to ($self) for values %cf::MAP;
+   $self->clear;
+
+   $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};
+
+      $self->unlink_save;
+
+      bless $self, "cf::map";
+      delete $self->{deny_reset};
+      $self->{deny_save} = 1;
+      $self->reset_timeout (1);
+      $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
+
+      $cf::MAP{$self->path} = $self;
+   }
+
+   $self->reset; # polite request, might not happen
+}
+
+=item $maps = cf::map::tmp_maps
+
+Returns an arrayref with all map paths of currently instantiated and saved
+maps. May block.
+
+=cut
+
+sub tmp_maps() {
+   [
+      map {
+         utf8::decode $_;
+         /\.map$/
+            ? normalise $_
+            : ()
+      } @{ aio_readdir $TMPDIR or [] }
+   ]
+}
+
+=item $maps = cf::map::random_maps
+
+Returns an arrayref with all map paths of currently instantiated and saved
+random maps. May block.
+
+=cut
+
+sub random_maps() {
+   [
+      map {
+         utf8::decode $_;
+         /\.map$/
+            ? normalise "?random/$_"
+            : ()
+      } @{ aio_readdir $RANDOMDIR or [] }
+   ]
+}
+
+=item cf::map::unique_maps
+
+Returns an arrayref of paths of all shared maps that have
+instantiated unique items. May block.
+
+=cut
+
+sub unique_maps() {
+   [
+      map {
+         utf8::decode $_;
+         /\.map$/
+            ? normalise $_
+            : ()
+      } @{ aio_readdir $UNIQUEDIR or [] }
+   ]
+}
+
+package cf;
+
+=back
+
+=head3 cf::object
+
+=cut
+
+package cf::object;
 
 =over 4
 
-=item cf::player::exists $login
+=item $ob->inv_recursive
+
+Returns the inventory of the object _and_ their inventories, recursively.
+
+=cut
+
+sub inv_recursive_;
+sub inv_recursive_ {
+   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.
 
-Returns true when the given account exists.
+=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 cf::player::exists($) {
-   cf::player::find $_[0]
-      or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
+sub deref {
+   my ($ref) = @_;
+
+   # temporary compatibility#TODO#remove
+   $ref =~ s{^<}{player/<};
+
+   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
+
+=over 4
+
 =item $player_object->reply ($npc, $msg[, $flags])
 
 Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
@@ -798,6 +2310,7 @@
 
 # rough implementation of a future "reply" method that works
 # with dialog boxes.
+#TODO: the first argument must go, split into a $npc->reply_to ( method
 sub cf::object::player::reply($$$;$) {
    my ($self, $npc, $msg, $flags) = @_;
 
@@ -805,24 +2318,29 @@
 
    if ($self->{record_replies}) {
       push @{ $self->{record_replies} }, [$npc, $msg, $flags];
+
    } else {
-      $msg = $npc->name . " says: $msg" if $npc;
-      $self->message ($msg, $flags);
+      my $pl = $self->contr;
+
+      if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
+         my $dialog = $pl->{npc_dialog};
+         $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
+
+      } else {
+         $msg = $npc->name . " says: $msg" if $npc;
+         $self->message ($msg, $flags);
+      }
    }
 }
 
-=item $player->ext_reply ($msgid, $msgtype, %msg)
-
-Sends an ext reply to the player.
+=item $object->send_msg ($channel, $msg, $color, [extra...])
 
 =cut
 
-sub cf::player::ext_reply($$$%) {
-   my ($self, $id, %msg) = @_;
-
-   $msg{msgid} = $id;
-
-   $self->send ("ext " . to_json \%msg);
+sub cf::object::send_msg {
+   my $pl = shift->contr
+      or return;
+   $pl->send_msg (@_);
 }
 
 =item $player_object->may ("access")
@@ -841,9 +2359,515 @@
          : $cf::CFG{"may_$access"})
 }
 
+=item $player_object->enter_link
+
+Freezes the player and moves him/her to a special map (C<{link}>).
+
+The player should be reasonably safe there for short amounts of time. You
+I<MUST> call C<leave_link> as soon as possible, though.
+
+Will never block.
+
+=item $player_object->leave_link ($map, $x, $y)
+
+Moves the player out of the special C<{link}> map onto the specified
+map. If the map is not valid (or omitted), the player will be moved back
+to the location he/she was before the call to C<enter_link>, or, if that
+fails, to the emergency map position.
+
+Might block.
+
 =cut
 
-#############################################################################
+sub link_map {
+   unless ($LINK_MAP) {
+      $LINK_MAP = cf::map::find "{link}"
+         or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
+      $LINK_MAP->load;
+   }
+
+   $LINK_MAP
+}
+
+sub cf::object::player::enter_link {
+   my ($self) = @_;
+
+   $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 && $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
+      ($map, $x, $y) = @{ $link_pos || [] };
+      $map = cf::map::find $map;
+
+      unless ($map) {
+         ($map, $x, $y) = @$EMERGENCY_POSITION;
+         $map = cf::map::find $map
+            or die "FATAL: cannot load emergency map\n";
+      }
+   }
+
+   ($x, $y) = (-1, -1)
+      unless (defined $x) && (defined $y);
+
+   # 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;
+   $self->activate_recursive;
+
+   local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
+   $self->enter_map ($map, $x, $y);
+}
+
+=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
+
+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. In either case, $done will
+be called at the end of this process.
+
+=cut
+
+our $GOTOGEN;
+
+sub cf::object::player::goto {
+   my ($self, $path, $x, $y, $check, $done) = @_;
+
+   # do generation counting so two concurrent goto's will be executed in-order
+   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 = 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);
+         }
+
+         $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 $@;
+      }
+
+      if ($gen == $self->{_goto_generation}) {
+         delete $self->{_goto_generation};
+         $self->leave_link ($map, $x, $y);
+      }
+
+      $done->() if $done;
+   })->prio (1);
+}
+
+=item $player_object->enter_exit ($exit_object)
+
+=cut
+
+sub parse_random_map_params {
+   my ($spec) = @_;
+
+   my $rmp = { # defaults
+      xsize    => (cf::rndm 15, 40),
+      ysize    => (cf::rndm 15, 40),
+      symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
+      #layout   => string,
+   };
+
+   for (split /\n/, $spec) {
+      my ($k, $v) = split /\s+/, $_, 2;
+
+      $rmp->{lc $k} = $v if (length $k) && (length $v);
+   }
+
+   $rmp
+}
+
+sub prepare_random_map {
+   my ($exit) = @_;
+
+   my $guard = cf::lock_acquire "exit_prepare:$exit";
+
+   # all this does is basically replace the /! path by
+   # a new random map path (?random/...) with a seed
+   # that depends on the exit object
+
+   my $rmp = parse_random_map_params $exit->msg;
+
+   if ($exit->map) {
+      $rmp->{region}     = $exit->region->name;
+      $rmp->{origin_map} = $exit->map->path;
+      $rmp->{origin_x}   = $exit->x;
+      $rmp->{origin_y}   = $exit->y;
+   }
+
+   $rmp->{random_seed} ||= $exit->random_seed;
+
+   my $data = cf::to_json $rmp;
+   my $md5 = Digest::MD5::md5_hex $data;
+   my $meta = "$RANDOMDIR/$md5.meta";
+
+   if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
+      aio_write $fh, 0, (length $data), $data, 0;
+      undef $fh;
+      aio_rename "$meta~", $meta;
+
+      $exit->slaying ("?random/$md5");
+      $exit->msg (undef);
+   }
+}
+
+sub cf::object::player::enter_exit {
+   my ($self, $exit) = @_;
+
+   return unless $self->type == cf::PLAYER;
+
+   if ($exit->slaying eq "/!") {
+      #TODO: this should de-fi-ni-te-ly not be a sync-job
+      # the problem is that $exit might not survive long enough
+      # so it needs to be done right now, right here
+      cf::sync_job { prepare_random_map $exit };
+   }
+
+   my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
+   my $hp      = $exit->stats->hp;
+   my $sp      = $exit->stats->sp;
+
+   $self->enter_link;
+
+   # 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;
+      }) {
+         $self->message ("Something went wrong deep within the crossfire server. "
+                       . "I'll try to bring you back to the map you were before. "
+                       . "Please report this to the dungeon master!",
+                         cf::NDI_UNIQUE | cf::NDI_RED);
+
+         warn "ERROR in enter_exit: $@";
+         $self->leave_link;
+      }
+   })->prio (1);
+}
+
+=head3 cf::client
+
+=over 4
+
+=item $client->send_drawinfo ($text, $flags)
+
+Sends a drawinfo packet to the client. Circumvents output buffering so
+should not be used under normal circumstances.
+
+=cut
+
+sub cf::client::send_drawinfo {
+   my ($self, $text, $flags) = @_;
+
+   utf8::encode $text;
+   $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
+}
+
+=item $client->send_msg ($channel, $msg, $color, [extra...])
+
+Send a drawinfo or msg packet to the client, formatting the msg for the
+client if neccessary. C<$type> should be a string identifying the type of
+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};
+
+   } elsif (ref $channel) {
+      # send meta info to client, if not yet sent
+      unless (exists $self->{channel}{$channel->{id}}) {
+         $self->{channel}{$channel->{id}} = $channel;
+         $self->ext_msg (channel_info => $channel)
+            if $self->can_msg;
+      }
+
+      $channel = $channel->{id};
+   }
+
+   return unless @extra || length $msg;
+
+   if ($self->can_msg) {
+      # default colour, mask it out
+      $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
+         if $color & cf::NDI_DEF;
+
+      $self->send_packet ("msg " . $self->{json_coder}->encode (
+         [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
+   } else {
+      if ($color >= 0) {
+         # replace some tags by gcfclient-compatible ones
+         for ($msg) {
+            1 while
+               s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
+               || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
+               || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
+               || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
+               || 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 10 8 $msg")
+         } else {
+            $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
+            $self->send_packet ("drawinfo $color $msg")
+         }
+      }
+   }
+}
+
+=item $client->ext_msg ($type, @msg)
+
+Sends an ext event to the client.
+
+=cut
+
+sub cf::client::ext_msg($$@) {
+   my ($self, $type, @msg) = @_;
+
+   if ($self->extcmd == 2) {
+      $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
+   } 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)
+
+Queues a query to the client, calling the given callback with
+the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
+C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
+
+Queries can fail, so check the return code. Or don't, as queries will
+become reliable at some point in the future.
+
+=cut
+
+sub cf::client::query {
+   my ($self, $flags, $text, $cb) = @_;
+
+   return unless $self->state == ST_PLAYING
+              || $self->state == ST_SETUP
+              || $self->state == ST_CUSTOM;
+
+   $self->state (ST_CUSTOM);
+
+   utf8::encode $text;
+   push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
+
+   $self->send_packet ($self->{query_queue}[0][0])
+      if @{ $self->{query_queue} } == 1;
+
+   1
+}
+
+cf::client->attach (
+   on_connect => sub {
+      my ($ns) = @_;
+
+      $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
+   },
+   on_reply => sub {
+      my ($ns, $msg) = @_;
+
+      # this weird shuffling is so that direct followup queries
+      # get handled first
+      my $queue = delete $ns->{query_queue}
+         or return; # be conservative, not sure how that can happen, but we saw a crash here
+
+      (shift @$queue)->[1]->($msg);
+      return unless $ns->valid; # temporary(?) workaround for callback destroying socket
+
+      push @{ $ns->{query_queue} }, @$queue;
+
+      if (@{ $ns->{query_queue} } == @$queue) {
+         if (@$queue) {
+            $ns->send_packet ($ns->{query_queue}[0][0]);
+         } else {
+            $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
+         }
+      }
+   },
+   on_exticmd => sub {
+      my ($ns, $buf) = @_;
+
+      my $msg = eval { $ns->{json_coder}->decode ($buf) };
+
+      if (ref $msg) {
+         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}) {
+            @reply = $cb->($ns, @payload);
+         }
+
+         $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;
+   },
+);
+
+=item $client->async (\&cb)
+
+Create a new coroutine, running the specified callback. The coroutine will
+be automatically cancelled when the client gets destroyed (e.g. on logout,
+or loss of connection).
+
+=cut
+
+sub cf::client::async {
+   my ($self, $cb) = @_;
+
+   my $coro = &Coro::async ($cb);
+
+   $coro->on_destroy (sub {
+      delete $self->{_coro}{$coro+0};
+   });
+
+   $self->{_coro}{$coro+0} = $coro;
+
+   $coro
+}
+
+cf::client->attach (
+   on_destroy => sub {
+      my ($ns) = @_;
+
+      $_->cancel for values %{ (delete $ns->{_coro}) || {} };
+   },
+);
+
+=back
+
 
 =head2 SAFE SCRIPTING
 
@@ -860,24 +2884,40 @@
 
 $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 fucntions and emthods are available within a safe environment:
+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
+     insert remove name archname title slaying race decrease_ob_nr
+
+  cf::object::player
+     player
+
+  cf::player
+     peaceful
 
-  cf::object contr pay_amount pay_player
-  cf::object::player player
-  cf::player peaceful
+  cf::map
+     trigger
 
 =cut
 
 for (
-   ["cf::object"         => qw(contr pay_amount pay_player)],
+   ["cf::object"         => qw(contr pay_amount pay_player map force_find force_add x y
+                               insert remove inv name archname title slaying race
+                               decrease_ob_nr)],
    ["cf::object::player" => qw(player)],
    ["cf::player"         => qw(peaceful)],
+   ["cf::map"            => qw(trigger)],
 ) {
    no strict 'refs';
    my ($pkg, @funs) = @$_;
@@ -955,151 +2995,387 @@
 =cut
 
 #############################################################################
+# the server's init and main functions
 
-=head2 EXTENSION DATABASE SUPPORT
+sub load_facedata($) {
+   my ($path) = @_;
 
-Crossfire maintains a very simple database for extension use. It can
-currently store anything that can be serialised using Storable, which
-excludes objects.
+   # HACK to clear player env face cache, we need some signal framework
+   # for this (global event?)
+   %ext::player_env::MUSIC_FACE_CACHE = ();
 
-The parameter C<$family> should best start with the name of the extension
-using it, it should be unique.
+   my $enc = JSON::XS->new->utf8->canonical->relaxed;
 
-=over 4
+   warn "loading facedata from $path\n";
 
-=item $hashref = cf::db_get $family
+   my $facedata;
+   0 < aio_load $path, $facedata
+      or die "$path: $!";
 
-Return a hashref for use by the extension C<$family>, which can be
-modified. After modifications, you have to call C<cf::db_dirty> or
-C<cf::db_sync>.
+   $facedata = Coro::Storable::thaw $facedata;
 
-=item $value = cf::db_get $family => $key
+   $facedata->{version} == 2
+      or cf::cleanup "$path: version mismatch, cannot proceed.";
 
-Returns a single value from the database
+   # 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;
 
-=item cf::db_put $family => $hashref
+   {
+      my $faces = $facedata->{faceinfo};
 
-Stores the given family hashref into the database. Updates are delayed, if
-you want the data to be synced to disk immediately, use C<cf::db_sync>.
+      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}, Digest::MD5::md5 $info->{data32};
+         cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
 
-=item cf::db_put $family => $key => $value
+         cf::cede_to_tick;
+      }
 
-Stores the given C<$value> in the family hash. Updates are delayed, if you
-want the data to be synced to disk immediately, use C<cf::db_sync>.
+      while (my ($face, $info) = each %$faces) {
+         next unless $info->{smooth};
+         my $idx = cf::face::find $face
+            or next;
+         if (my $smooth = cf::face::find $info->{smooth}) {
+            cf::face::set_smooth      $idx, $smooth;
+            cf::face::set_smoothlevel $idx, $info->{smoothlevel};
+         } else {
+            warn "smooth face '$info->{smooth}' not found for face '$face'";
+         }
 
-=item cf::db_dirty
+         cf::cede_to_tick;
+      }
+   }
 
-Marks the database as dirty, to be updated at a later time.
+   {
+      my $anims = $facedata->{animinfo};
 
-=item cf::db_sync
+      while (my ($anim, $info) = each %$anims) {
+         cf::anim::set $anim, $info->{frames}, $info->{facings};
+         cf::cede_to_tick;
+      }
 
-Immediately write the database to disk I<if it is dirty>.
+      cf::anim::invalidate_all; # d'oh
+   }
 
-=cut
+   {
+      # TODO: for gcfclient pleasure, we should give resources
+      # that gcfclient doesn't grok a >10000 face index.
+      my $res = $facedata->{resource};
 
-our $DB;
+      my $soundconf = delete $res->{"res/sound.conf"};
 
-{
-   my $path = cf::localdir . "/database.pst";
+      while (my ($name, $info) = each %$res) {
+         my $idx = (cf::face::find $name) || cf::face::alloc $name;
+         my $data;
 
-   sub db_load() {
-      warn "loading database $path\n";#d# remove later
-      $DB = stat $path ? Storable::retrieve $path : { };
-   }
+         if ($info->{type} & 1) {
+            # prepend meta info
+
+            my $meta = $enc->encode ({
+               name => $name,
+               %{ $info->{meta} || {} },
+            });
+
+            $data = pack "(w/a*)*", $meta, $info->{data};
+         } else {
+            $data = $info->{data};
+         }
 
-   my $pid;
+         cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
+         cf::face::set_type $idx, $info->{type};
 
-   sub db_save() {
-      warn "saving database $path\n";#d# remove later
-      waitpid $pid, 0 if $pid;
-      if (0 == ($pid = fork)) {
-         $DB->{_meta}{version} = 1;
-         Storable::nstore $DB, "$path~";
-         rename "$path~", $path;
-         cf::_exit 0 if defined $pid;
+         cf::cede_to_tick;
       }
-   }
 
-   my $dirty;
+      if ($soundconf) {
+         $soundconf = $enc->decode (delete $soundconf->{data});
+
+         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
+         }
 
-   sub db_sync() {
-      db_save if $dirty;
-      undef $dirty;
+         while (my ($k, $v) = each %{$soundconf->{event}}) {
+            my $face = cf::face::find "sound/$v";
+            cf::sound::set $k => $face;
+         }
+      }
    }
 
-   my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
-      db_sync;
-   });
+   1
+}
 
-   sub db_dirty() {
-      $dirty = 1;
-      $idle->start;
-   }
+register_exticmd fx_want => sub {
+   my ($ns, $want) = @_;
 
-   sub db_get($;$) {
-      @_ >= 2
-         ? $DB->{$_[0]}{$_[1]}
-         : ($DB->{$_[0]} ||= { })
+   while (my ($k, $v) = each %$want) {
+      $ns->fx_want ($k, $v);
    }
+};
 
-   sub db_put($$;$) {
-      if (@_ >= 3) {
-         $DB->{$_[0]}{$_[1]} = $_[2];
-      } else {
-         $DB->{$_[0]} = $_[1];
-      }
-      db_dirty;
+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}/
+         if exists $_->{match};
    }
+}
 
-   attach_global
-      prio => 10000,
-      on_cleanup => sub {
-         db_sync;
-      },
-   ;
+sub reload_facedata {
+   load_facedata "$DATADIR/facedata"
+      or die "unable to load facedata\n";
 }
 
-#############################################################################
-# the server's main()
+sub reload_archetypes {
+   load_resource_file "$DATADIR/archetypes"
+      or die "unable to load archetypes\n";
+   #d# NEED to laod twice to resolve forward references
+   # this really needs to be done in an extra post-pass
+   # (which needs to be synchronous, so solve it differently)
+   load_resource_file "$DATADIR/archetypes"
+      or die "unable to load archetypes\n";
+}
 
-sub cfg_load {
-   open my $fh, "<:utf8", cf::confdir . "/config"
+sub reload_treasures {
+   load_resource_file "$DATADIR/treasures"
+      or die "unable to load treasurelists\n";
+}
+
+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";
+}
+
+sub init {
+   reload_resources;
+}
+
+sub reload_config {
+   open my $fh, "<:utf8", "$CONFDIR/config"
       or return;
 
    local $/;
    *CFG = YAML::Syck::Load <$fh>;
+
+   $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
+
+   $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};
+
+   if (exists $CFG{mlockall}) {
+      eval {
+         $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
+            and die "WARNING: m(un)lockall failed: $!\n";
+      };
+      warn $@ if $@;
+   }
 }
 
 sub main {
-   cfg_load;
-   db_load;
+   # we must not ever block the main coroutine
+   local $Coro::idle = sub {
+      Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
+      (async {
+         $Coro::current->{desc} = "IDLE BUG HANDLER";
+         Event::one_event;
+      })->prio (Coro::PRIO_MAX);
+   };
+
+   reload_config;
+   db_init;
    load_extensions;
+
+   $TICK_WATCHER->start;
    Event::loop;
 }
 
 #############################################################################
-# initialisation
+# initialisation and cleanup
 
-sub _perl_reload(&) {
-   my ($msg) = @_;
+# install some emergency cleanup handlers
+BEGIN {
+   for my $signal (qw(INT HUP TERM)) {
+      Event->signal (
+         reentrant => 0,
+         data      => WF_AUTOCANCEL,
+         signal    => $signal,
+         prio      => 0,
+         cb        => sub {
+            cf::cleanup "SIG$signal";
+         },
+      );
+   }
+}
 
-   $msg->("reloading...");
+sub write_runtime {
+   my $runtime = "$LOCALDIR/runtime";
 
-   eval {
-      # cancel all watchers
-      $_->cancel for Event::all_watchers;
+   # 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 $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
+      or return;
+
+   my $value = $cf::RUNTIME + 90 + 10;
+   # 10 is the runtime save interval, for a monotonic clock
+   # 60 allows for the watchdog to kill the server.
+
+   (aio_write $fh, 0, (length $value), $value, 0) <= 0
+      and return;
+
+   # 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
+}
+
+sub emergency_save() {
+   my $freeze_guard = cf::freeze_mainloop;
 
-      # unload all extensions
-      for (@exts) {
-         $msg->("unloading <$_>");
-         unload_extension $_;
+   warn "enter emergency perl save\n";
+
+   cf::sync_job {
+      # use a peculiar iteration method to avoid tripping on perl
+      # refcount bugs in for. also avoids problems with players
+      # 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;
+         $pl->save;
+      }
+      warn "end emergency player save\n";
+
+      warn "begin emergency map save\n";
+      for my $path (keys %cf::MAP) {
+         my $map = $cf::MAP{$path} or next;
+         $map->valid or next;
+         $map->save;
       }
+      warn "end emergency map save\n";
+
+      warn "begin emergency database checkpoint\n";
+      BDB::db_env_txn_checkpoint $DB_ENV;
+      warn "end emergency database checkpoint\n";
+   };
+
+   warn "leave emergency perl save\n";
+}
+
+sub post_cleanup {
+   my ($make_core) = @_;
+
+   warn Carp::longmess "post_cleanup backtrace"
+      if $make_core;
+}
+
+sub do_reload_perl() {
+   # can/must only be called in main
+   if ($Coro::current != $Coro::main) {
+      warn "can only reload from main coroutine";
+      return;
+   }
+
+   warn "reloading...";
+
+   warn "entering sync_job";
+
+   cf::sync_job {
+      cf::write_runtime; # external watchdog should not bark
+      cf::emergency_save;
+      cf::write_runtime; # external watchdog should not bark
+
+      warn "syncing database to disk";
+      BDB::db_env_txn_checkpoint $DB_ENV;
+
+      # if anything goes wrong in here, we should simply crash as we already saved
 
-      # unload all modules loaded from $LIBDIR
+      warn "cancelling all WF_AUTOCANCEL watchers";
+      for (Event::all_watchers) {
+         $_->cancel if $_->data & WF_AUTOCANCEL;
+      }
+
+      warn "flushing outstanding aio requests";
+      for (;;) {
+         BDB::flush;
+         IO::AIO::flush;
+         Coro::cede;
+         last unless IO::AIO::nreqs || BDB::nreqs;
+         warn "iterate...";
+      }
+
+      ++$RELOAD;
+
+      warn "cancelling all extension coros";
+      $_->cancel for values %EXT_CORO;
+      %EXT_CORO = ();
+
+      warn "removing commands";
+      %COMMAND = ();
+
+      warn "removing ext/exti commands";
+      %EXTCMD  = ();
+      %EXTICMD = ();
+
+      warn "unloading/nuking all extensions";
+      for my $pkg (@EXTS) {
+         warn "... unloading $pkg";
+
+         if (my $cb = $pkg->can ("unload")) {
+            eval {
+               $cb->($pkg);
+               1
+            } or warn "$pkg unloaded, but with errors: $@";
+         }
+
+         warn "... nuking $pkg";
+         Symbol::delete_package $pkg;
+      }
+
+      warn "unloading all perl modules loaded from $LIBDIR";
       while (my ($k, $v) = each %INC) {
          next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
 
-         $msg->("removing <$k>");
+         warn "... unloading $k";
          delete $INC{$k};
 
          $k =~ s/\.pm$//;
@@ -1112,90 +3388,295 @@
          Symbol::delete_package $k;
       }
 
-      # sync database to disk
-      cf::db_sync;
-
-      # get rid of safe::, as good as possible
+      warn "getting rid of safe::, as good as possible";
       Symbol::delete_package "safe::$_"
-         for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
+         for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
 
-      # remove register_script_function callbacks
-      # TODO
-      
-      # unload cf.pm "a bit"
+      warn "unloading cf.pm \"a bit\"";
       delete $INC{"cf.pm"};
+      delete $INC{"cf/pod.pm"};
 
       # don't, removes xs symbols, too,
       # and global variables created in xs
       #Symbol::delete_package __PACKAGE__;
 
-      # reload cf.pm
-      $msg->("reloading cf.pm");
+      warn "unload completed, starting to reload now";
+
+      warn "reloading cf.pm";
       require cf;
+      cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
 
-      # load config and database again
-      cf::cfg_load;
-      cf::db_load;
+      warn "loading config and database again";
+      cf::reload_config;
 
-      # load extensions
-      $msg->("load extensions");
+      warn "loading extensions";
       cf::load_extensions;
 
-      # reattach attachments to objects
-      $msg->("reattach");
-      _global_reattach;
+      warn "reattaching attachments to objects/players";
+      _global_reattach; # objects, sockets
+      warn "reattaching attachments to maps";
+      reattach $_ for values %MAP;
+      warn "reattaching attachments to players";
+      reattach $_ for values %PLAYER;
+
+      warn "leaving sync_job";
+
+      1
+   } or do {
+      warn $@;
+      warn "error while reloading, exiting.";
+      exit 1;
    };
-   $msg->($@) if $@;
 
-   $msg->("reloaded");
+   warn "reloaded";
 };
 
-sub perl_reload() {
-   _perl_reload {
-      warn $_[0];
-      print "$_[0]\n";
-   };
+our $RELOAD_WATCHER; # used only during reload
+
+sub reload_perl() {
+   # doing reload synchronously and two reloads happen back-to-back,
+   # coro crashes during coro_state_free->destroy here.
+
+   $RELOAD_WATCHER ||= Event->timer (
+      reentrant => 0,
+      after     => 0,
+      data      => WF_AUTOCANCEL,
+      cb => sub {
+         do_reload_perl;
+         undef $RELOAD_WATCHER;
+      },
+   );
 }
 
-register_command "perl-reload", 0, sub {
+register_command "reload" => sub {
    my ($who, $arg) = @_;
 
    if ($who->flag (FLAG_WIZ)) {
-      _perl_reload {
-         warn $_[0];
-         $who->message ($_[0]);
+      $who->message ("reloading server.");
+      async {
+         $Coro::current->{desc} = "perl_reload";
+         reload_perl;
       };
    }
 };
 
-register "<global>", __PACKAGE__;
-
 unshift @INC, $LIBDIR;
 
+my $bug_warning = 0;
+
+our @WAIT_FOR_TICK;
+our @WAIT_FOR_TICK_BEGIN;
+
+sub wait_for_tick {
+   return unless $TICK_WATCHER->is_active;
+   return if $Coro::current == $Coro::main;
+
+   my $signal = new Coro::Signal;
+   push @WAIT_FOR_TICK, $signal;
+   $signal->wait;
+}
+
+sub wait_for_tick_begin {
+   return unless $TICK_WATCHER->is_active;
+   return if $Coro::current == $Coro::main;
+
+   my $signal = new Coro::Signal;
+   push @WAIT_FOR_TICK_BEGIN, $signal;
+   $signal->wait;
+}
+
 $TICK_WATCHER = Event->timer (
-   prio  => 1,
-   async => 1,
-   at    => $NEXT_TICK || 1,
-   cb    => sub {
+   reentrant => 0,
+   parked    => 1,
+   prio      => 0,
+   at        => $NEXT_TICK || $TICK,
+   data      => WF_AUTOCANCEL,
+   cb        => sub {
+      if ($Coro::current != $Coro::main) {
+         Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
+            unless ++$bug_warning > 10;
+         return;
+      }
+
+      $NOW = $tick_start = Event::time;
+
       cf::server_tick; # one server iteration
 
-      my $NOW = Event::time;
+      $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: $!";
+         };
+      }
+
+      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 = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
 
       $TICK_WATCHER->at ($NEXT_TICK);
       $TICK_WATCHER->start;
+
+      $LOAD = ($NOW - $tick_start) / $TICK;
+      $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
+
+      _post_tick;
    },
 );
 
-IO::AIO::max_poll_time $TICK * 0.2;
+{
+   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::set_sync_prepare {
+      my $status;
+      my $current = $Coro::current;
+      (
+         sub {
+            $status = $!;
+            $current->ready; undef $current;
+         },
+         sub {
+            Coro::schedule while defined $current;
+            $! = $status;
+         },
+      )
+   };
+
+   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,
+               $BDBDIR,
+               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 $!;
+         };
+
+         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;
+
+   undef $Coro::AIO::WATCHER;
+   IO::AIO::max_poll_time $TICK * 0.1;
+   $AIO_POLL_WATCHER = Event->io (
+      reentrant => 0,
+      data      => WF_AUTOCANCEL,
+      fd        => IO::AIO::poll_fileno,
+      poll      => 'r',
+      prio      => 0,
+      cb        => \&IO::AIO::poll_cb,
+   );
+}
+
+my $_log_backtrace;
+
+sub _log_backtrace {
+   my ($msg, @addr) = @_;
+
+   $msg =~ s/\n//;
+
+   # 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: $!";
+
+            my @funcs;
+            my @res = <$fh>;
+            chomp for @res;
+            while (@res) {
+               my ($func, $line) = splice @res, 0, 2, ();
+               push @funcs, "[$func] $line";
+            }
+
+            @funcs
+         };
+
+         LOG llevInfo, "[ABT] $msg\n";
+         LOG llevInfo, "[ABT] $_\n" for @bt;
+         --$_log_backtrace;
+      };
+   } else {
+      LOG llevInfo, "[ABT] $msg\n";
+      LOG llevInfo, "[ABT] [suppressed]\n";
+   }
+}
+
+# load additional modules
+use cf::pod;
 
-Event->io (fd   => IO::AIO::poll_fileno,
-           poll => 'r',
-           prio => 5,
-           cb   => \&IO::AIO::poll_cb);
+END { cf::emergency_save }
 
 1