--- deliantra/server/lib/cf.pm	2008/10/01 05:50:19	1.457
+++ deliantra/server/lib/cf.pm	2009/10/11 00:24:35	1.481
@@ -23,7 +23,7 @@
 
 use 5.10.0;
 use utf8;
-use strict "vars", "subs";
+use strict qw(vars subs);
 
 use Symbol;
 use List::Util;
@@ -34,6 +34,7 @@
 use Safe::Hole;
 use Storable ();
 
+use Guard ();
 use Coro ();
 use Coro::State;
 use Coro::Handle;
@@ -42,6 +43,7 @@
 use Coro::Timer;
 use Coro::Signal;
 use Coro::Semaphore;
+use Coro::SemaphoreSet;
 use Coro::AnyEvent;
 use Coro::AIO;
 use Coro::BDB 1.6;
@@ -72,6 +74,9 @@
 Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
 Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
 
+# strictly for debugging
+$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
+
 sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
 
 our %COMMAND      = ();
@@ -85,6 +90,8 @@
 
 our $RELOAD; # number of reloads so far, non-zero while in reload
 our @EVENT;
+our @REFLECT; # set by XS
+our %REFLECT; # set by us
 
 our $CONFDIR     = confdir;
 our $DATADIR     = datadir;
@@ -105,13 +112,15 @@
 our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
 our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
 our $NEXT_TICK;
-our $USE_FSYNC = 1; # use fsync to write maps - default off
+our $USE_FSYNC = 1; # use fsync to write maps - default on
 
 our $BDB_DEADLOCK_WATCHER;
 our $BDB_CHECKPOINT_WATCHER;
 our $BDB_TRICKLE_WATCHER;
 our $DB_ENV;
 
+our @EXTRA_MODULES = qw(pod match mapscript);
+
 our %CFG;
 
 our $UPTIME; $UPTIME ||= time;
@@ -132,7 +141,8 @@
 
 our @POST_INIT;
 
-our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow)
+our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
+our $REALLY_UNLOOP;      # never set to true, please :)
 
 binmode STDOUT;
 binmode STDERR;
@@ -144,6 +154,8 @@
    $RUNTIME = <$fh> + 0.;
 }
 
+eval "sub TICK() { $TICK } 1" or die;
+
 mkdir $_
    for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
 
@@ -153,6 +165,17 @@
 
 #############################################################################
 
+%REFLECT = ();
+for (@REFLECT) {
+   my $reflect = JSON::XS::decode_json $_;
+   $REFLECT{$reflect->{class}} = $reflect;
+}
+
+# this is decidedly evil
+$REFLECT{object}{flags} = { map $_ => undef, grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
+
+#############################################################################
+
 =head2 GLOBAL VARIABLES
 
 =over 4
@@ -210,38 +233,41 @@
 C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
 that call.
 
+=item %cf::REFLECT
+
+Contains, for each (C++) class name, a hash reference with information
+about object members (methods, scalars, arrays and flags) and other
+metadata, which is useful for introspection.
+
 =back
 
 =cut
 
-BEGIN {
-   *CORE::GLOBAL::warn = sub {
-      my $msg = join "", @_;
+$Coro::State::WARNHOOK = sub {
+   my $msg = join "", @_;
 
-      $msg .= "\n"
-         unless $msg =~ /\n$/;
+   $msg .= "\n"
+      unless $msg =~ /\n$/;
 
-      $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
+   $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
 
-      LOG llevError, $msg;
-   };
-}
+   LOG llevError, $msg;
+};
 
 $Coro::State::DIEHOOK = sub {
    return unless $^S eq 0; # "eq", not "=="
 
+   warn Carp::longmess $_[0];
+
    if ($Coro::current == $Coro::main) {#d#
       warn "DIEHOOK called in main context, Coro bug?\n";#d#
       return;#d#
    }#d#
 
    # kill coroutine otherwise
-   warn Carp::longmess $_[0];
    Coro::terminate
 };
 
-$SIG{__DIE__} = sub { }; #d#?
-
 @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';
@@ -332,7 +358,7 @@
 =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,
+a L<Guard> object. If the guard object gets destroyed (goes out of scope,
 for example when the coroutine gets canceled), the lock is automatically
 returned.
 
@@ -348,51 +374,24 @@
 
 =cut
 
-our %LOCK;
-our %LOCKER;#d#
+our $LOCKS = new Coro::SemaphoreSet;
 
 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}) {
-      #local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
-      push @{ $LOCK{$key} }, $Coro::current;
-      Coro::schedule;
-   }
+   $LOCKS->wait ($_[0]);
 }
 
 sub lock_acquire($) {
-   my ($key) = @_;
-
-   # 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} };
-   }
+   $LOCKS->guard ($_[0])
 }
 
 sub lock_active($) {
-   my ($key) = @_;
-
-   ! ! $LOCK{$key}
+   $LOCKS->count ($_[0]) < 1
 }
 
 sub freeze_mainloop {
    tick_inhibit_inc;
 
-   Coro::guard \&tick_inhibit_dec;
+   &Guard::guard (\&tick_inhibit_dec);
 }
 
 =item cf::periodic $interval, $cb
@@ -1174,7 +1173,10 @@
          if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
             aio_chmod $fh, SAVE_MODE;
             aio_write $fh, 0, (length $$rdata), $$rdata, 0;
-            aio_fsync $fh if $cf::USE_FSYNC;
+            if ($cf::USE_FSYNC) {
+               aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
+               aio_fsync $fh;
+            }
             aio_close $fh;
 
             if (@$objs) {
@@ -1182,7 +1184,10 @@
                   aio_chmod $fh, SAVE_MODE;
                   my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
                   aio_write $fh, 0, (length $data), $data, 0;
-                  aio_fsync $fh if $cf::USE_FSYNC;
+                  if ($cf::USE_FSYNC) {
+                     aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
+                     aio_fsync $fh;
+                  }
                   aio_close $fh;
                   aio_rename "$filename.pst~", "$filename.pst";
                }
@@ -1195,7 +1200,7 @@
             $filename =~ s%/[^/]+$%%;
             aio_pathsync $filename if $cf::USE_FSYNC;
          } else {
-            warn "FATAL: $filename~: $!\n";
+            warn "unable to save objects: $filename~: $!\n";
          }
       } else {
          aio_unlink $filename;
@@ -1343,7 +1348,7 @@
 sub cache_extensions {
    my $grp = IO::AIO::aio_group;
 
-   add $grp IO::AIO::aio_readdir $LIBDIR, sub {
+   add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
       for (grep /\.ext$/, @{$_[0]}) {
          add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
       }
@@ -1889,15 +1894,6 @@
    "$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) = @_;
 
@@ -1989,13 +1985,10 @@
 
    $path = normalise $path, $origin && $origin->path;
 
-   cf::lock_wait "map_data:$path";#d#remove
-   cf::lock_wait "map_find:$path";
+   my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
+   my $guard2 = cf::lock_acquire "map_find:$path";
 
    $cf::MAP{$path} || do {
-      my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
-      my $guard2 = cf::lock_acquire "map_find:$path";
-
       my $map = new_from_path cf::map $path
          or return;
 
@@ -2073,8 +2066,6 @@
          $self->fix_auto_apply;
          $self->update_buttons;
          cf::cede_to_tick;
-         $self->set_darkness_map;
-         cf::cede_to_tick;
          $self->activate;
       }
 
@@ -2250,7 +2241,7 @@
 
    return if $self->players;
 
-   warn "resetting map ", $self->path;
+   warn "resetting map ", $self->path, "\n";
 
    $self->in_memory (cf::MAP_SWAPPED);
 
@@ -2425,7 +2416,7 @@
    id      => "say",
    title   => "Map",
    reply   => "say ",
-   tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
+   tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
 };
 
 our $CHAT_CHANNEL = {
@@ -2561,11 +2552,12 @@
    $map->load_neighbours;
 
    return unless $self->contr->active;
-   $self->flag (cf::FLAG_DEBUG, 0);#d# temp
-   $self->activate_recursive;
 
    local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
    $self->enter_map ($map, $x, $y);
+
+   # only activate afterwards, to support waiting in hooks
+   $self->activate_recursive;
 }
 
 =item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
@@ -2810,12 +2802,42 @@
       reply   => undef,
       tooltip => "Shows which body parts you posess and are available",
    },
+   "c/statistics" => {
+      id      => "infobox",
+      title   => "Statistics",
+      reply   => undef,
+      tooltip => "Shows your primary statistics",
+   },
    "c/skills" => {
       id      => "infobox",
       title   => "Skills",
       reply   => undef,
       tooltip => "Shows your experience per skill and item power",
    },
+   "c/shopitems" => {
+      id      => "infobox",
+      title   => "Shop Items",
+      reply   => undef,
+      tooltip => "Shows the items currently for sale in this shop",
+   },
+   "c/resistances" => {
+      id      => "infobox",
+      title   => "Resistances",
+      reply   => undef,
+      tooltip => "Shows your resistances",
+   },
+   "c/pets" => {
+      id      => "infobox",
+      title   => "Pets",
+      reply   => undef,
+      tooltip => "Shows information abotu your pets/a specific pet",
+   },
+   "c/perceiveself" => {
+      id      => "infobox",
+      title   => "Perceive Self",
+      reply   => undef,
+      tooltip => "You gained detailed knowledge about yourself",
+   },
    "c/uptime" => {
       id      => "infobox",
       title   => "Uptime",
@@ -2834,6 +2856,14 @@
       reply   => "gsay ",
       tooltip => "Messages and chat related to your party",
    },
+   "c/death" => {
+      id      => "death",
+      title   => "Death",
+      reply   => undef,
+      tooltip => "Reason for and more info about your most recent death",
+   },
+   "c/say"     => $SAY_CHANNEL,
+   "c/chat"    => $CHAT_CHANNEL,
 );
 
 sub cf::client::send_msg {
@@ -2848,17 +2878,14 @@
    if ($CHANNEL{$channel}) {
       $channel = $CHANNEL{$channel};
 
-      $self->ext_msg (channel_info => $channel)
-         if $self->can_msg;
-
+      $self->ext_msg (channel_info => $channel);
       $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;
+         $self->ext_msg (channel_info => $channel);
       }
 
       $channel = $channel->{id};
@@ -2866,52 +2893,26 @@
 
    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;
-
-      my $pkt = "msg "
-                . $self->{json_coder}->encode (
-                   [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
-                );
-
-      # try lzf for large packets
-      $pkt = "lzf " . Compress::LZF::compress $pkt
-         if 1024 <= length $pkt and $self->{can_lzf};
-
-      # split very large packets
-      if (8192 < length $pkt and $self->{can_lzf}) {
-         $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
-         $pkt = "frag";
-      }
-
-      $self->send_packet ($pkt);
-   } 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")
-         }
-      }
+   # default colour, mask it out
+   $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
+      if $color & cf::NDI_DEF;
+
+   my $pkt = "msg "
+             . $self->{json_coder}->encode (
+                [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
+             );
+
+   # try lzf for large packets
+   $pkt = "lzf " . Compress::LZF::compress $pkt
+      if 1024 <= length $pkt and $self->{can_lzf};
+
+   # split very large packets
+   if (8192 < length $pkt and $self->{can_lzf}) {
+      $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
+      $pkt = "frag";
    }
+
+   $self->send_packet ($pkt);
 }
 
 =item $client->ext_msg ($type, @msg)
@@ -3096,6 +3097,7 @@
   cf::object
      contr pay_amount pay_player map x y force_find force_add destroy
      insert remove name archname title slaying race decrease split
+     value
 
   cf::object::player
      player
@@ -3111,9 +3113,9 @@
 for (
    ["cf::object"         => qw(contr pay_amount pay_player map force_find force_add x y
                                insert remove inv nrof name archname title slaying race
-                               decrease split destroy change_exp)],
+                               decrease split destroy change_exp value msg lore send_msg)],
    ["cf::object::player" => qw(player)],
-   ["cf::player"         => qw(peaceful)],
+   ["cf::player"         => qw(peaceful send_msg)],
    ["cf::map"            => qw(trigger)],
 ) {
    no strict 'refs';
@@ -3141,6 +3143,8 @@
    $qcode =~ s/"/‟/g; # not allowed in #line filenames
    $qcode =~ s/\n/\\n/g;
 
+   %vars = (_dummy => 0) unless %vars;
+
    local $_;
    local @safe::cf::_safe_eval_args = values %vars;
 
@@ -3419,6 +3423,15 @@
    print $fh $$;
 }
 
+sub main_loop {
+   warn "EV::loop starting\n";
+   if (1) {
+      EV::loop;
+   }
+   warn "EV::loop returned\n";
+   goto &main_loop unless $REALLY_UNLOOP;
+}
+
 sub main {
    cf::init_globals; # initialise logging
 
@@ -3431,7 +3444,6 @@
    cf::init_anim;
    cf::init_attackmess;
    cf::init_dynamic;
-   cf::init_block;
 
    $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
 
@@ -3467,12 +3479,13 @@
       utime time, time, $RUNTIMEFILE;
 
       # no (long-running) fork's whatsoever before this point(!)
+      use POSIX ();
       POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
 
       (pop @POST_INIT)->(0) while @POST_INIT;
    };
 
-   EV::loop;
+   main_loop;
 }
 
 #############################################################################
@@ -3738,7 +3751,7 @@
 
          warn "unloading cf.pm \"a bit\"";
          delete $INC{"cf.pm"};
-         delete $INC{"cf/pod.pm"};
+         delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
 
          # don't, removes xs symbols, too,
          # and global variables created in xs
@@ -3965,7 +3978,7 @@
 }
 
 # load additional modules
-use cf::pod;
+require "cf/$_.pm" for @EXTRA_MODULES;
 
 END { cf::emergency_save }