--- deliantra/server/lib/cf.pm	2008/12/28 06:59:27	1.463
+++ deliantra/server/lib/cf.pm	2010/01/16 23:27:21	1.501
@@ -1,29 +1,30 @@
-# 
+#
 # This file is part of Deliantra, the Roguelike Realtime MMORPG.
 # 
 # Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
 # 
-# Deliantra is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
+# Deliantra is free software: you can redistribute it and/or modify it under
+# the terms of the Affero GNU General Public License as published by the
+# Free Software Foundation, either version 3 of the License, or (at your
+# option) any later version.
 # 
 # This program is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
 # GNU General Public License for more details.
 # 
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see <http://www.gnu.org/licenses/>.
+# You should have received a copy of the Affero GNU General Public License
+# and the GNU General Public License along with this program. If not, see
+# <http://www.gnu.org/licenses/>.
 # 
 # The authors can be reached via e-mail to <support@deliantra.net>
-# 
+#
 
 package cf;
 
 use 5.10.0;
 use utf8;
-use strict "vars", "subs";
+use strict qw(vars subs);
 
 use Symbol;
 use List::Util;
@@ -33,6 +34,7 @@
 use Safe;
 use Safe::Hole;
 use Storable ();
+use Carp ();
 
 use Guard ();
 use Coro ();
@@ -53,9 +55,8 @@
 use JSON::XS 2.01 ();
 use BDB ();
 use Data::Dumper;
-use Digest::MD5;
 use Fcntl;
-use YAML ();
+use YAML::XS ();
 use IO::AIO ();
 use Time::HiRes;
 use Compress::LZF;
@@ -74,6 +75,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      = ();
@@ -87,6 +91,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;
@@ -107,13 +113,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;
@@ -134,7 +142,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;
@@ -146,6 +155,8 @@
    $RUNTIME = <$fh> + 0.;
 }
 
+eval "sub TICK() { $TICK } 1" or die;
+
 mkdir $_
    for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
 
@@ -155,6 +166,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
@@ -208,42 +230,45 @@
 
 =item @cf::INVOKE_RESULTS
 
-This array contains the results of the last C<invoke ()> call.  When
+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.
 
+=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';
@@ -266,7 +291,7 @@
 }
 
 $EV::DIED = sub {
-   warn "error in event callback: @_";
+   Carp::cluck "error in event callback: @_";
 };
 
 #############################################################################
@@ -1149,7 +1174,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) {
@@ -1157,7 +1185,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";
                }
@@ -1318,7 +1349,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;
       }
@@ -1980,8 +2011,8 @@
    }
 }
 
-sub pre_load  { }
-sub post_load { }
+sub pre_load { }
+#sub post_load { } # XS
 
 sub load {
    my ($self) = @_;
@@ -2211,7 +2242,7 @@
 
    return if $self->players;
 
-   warn "resetting map ", $self->path;
+   warn "resetting map ", $self->path, "\n";
 
    $self->in_memory (cf::MAP_SWAPPED);
 
@@ -2312,6 +2343,38 @@
    ]
 }
 
+=item cf::map::static_maps
+
+Returns an arrayref if paths of all static maps (all preinstalled F<.map>
+file in the shared directory excluding F</styles> and F</editor>). May
+block.
+
+=cut
+
+sub static_maps() {
+   my @dirs = "";
+   my @maps;
+
+   while (@dirs) {
+      my $dir = shift @dirs;
+
+      next if $dir eq "/styles" || $dir eq "/editor";
+
+      my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
+         or return;
+
+      for (@$files) {
+         s/\.map$// or next;
+         utf8::decode $_;
+         push @maps, "$dir/$_";
+      }
+
+      push @dirs, map "$dir/$_", @$dirs;
+   }
+
+   \@maps
+}
+
 =back
 
 =head3 cf::object
@@ -2386,7 +2449,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 = {
@@ -2516,17 +2579,18 @@
 
    # use -1 or undef as default coordinates, not 0, 0
    ($x, $y) = ($map->enter_x, $map->enter_y)
-      if $x <=0 && $y <= 0;
+      if $x <= 0 && $y <= 0;
 
    $map->load;
    $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->()]])
@@ -2724,6 +2788,31 @@
    $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
 }
 
+=item $client->send_big_packet ($pkt)
+
+Like C<send_packet>, but tries to compress large packets, and fragments
+them as required.
+
+=cut
+
+our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
+
+sub cf::client::send_big_packet {
+   my ($self, $pkt) = @_;
+
+   # try lzf for large packets
+   $pkt = "lzf " . Compress::LZF::compress $pkt
+      if 1024 <= length $pkt and $self->{can_lzf};
+
+   # split very large packets
+   if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
+      $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
+      $pkt = "frag";
+   }
+
+   $self->send_packet ($pkt);
+}
+
 =item $client->send_msg ($channel, $msg, $color, [extra...])
 
 Send a drawinfo or msg packet to the client, formatting the msg for the
@@ -2735,6 +2824,12 @@
 
 # non-persistent channels (usually the info channel)
 our %CHANNEL = (
+   "c/motd" => {
+      id      => "infobox",
+      title   => "MOTD",
+      reply   => undef,
+      tooltip => "The message of the day",
+   },
    "c/identify" => {
       id      => "infobox",
       title   => "Identify",
@@ -2747,6 +2842,12 @@
       reply   => undef,
       tooltip => "Signs and other items you examined",
    },
+   "c/shopinfo" => {
+      id      => "infobox",
+      title   => "Shop Info",
+      reply   => undef,
+      tooltip => "What your bargaining skill tells you about the shop",
+   },
    "c/book" => {
       id      => "infobox",
       title   => "Book",
@@ -2771,12 +2872,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",
@@ -2795,6 +2926,12 @@
       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,
 );
@@ -2835,17 +2972,7 @@
                 [$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);
+   $self->send_big_packet ($pkt);
 }
 
 =item $client->ext_msg ($type, @msg)
@@ -2858,10 +2985,10 @@
    my ($self, $type, @msg) = @_;
 
    if ($self->extcmd == 2) {
-      $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
+      $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
    } elsif ($self->extcmd == 1) { # TODO: remove
       push @msg, msgtype => "event_$type";
-      $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
+      $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
    }
 }
 
@@ -2875,11 +3002,11 @@
    my ($self, $id, @msg) = @_;
 
    if ($self->extcmd == 2) {
-      $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
+      $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
    } elsif ($self->extcmd == 1) {
       #TODO: version 1, remove
       unshift @msg, msgtype => "reply", msgid => $id;
-      $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
+      $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
    }
 }
 
@@ -3016,7 +3143,7 @@
 $SIG{FPE} = 'IGNORE';
 
 $safe->permit_only (Opcode::opset qw(
-   :base_core :base_mem :base_orig :base_math
+   :base_core :base_mem :base_orig :base_math :base_loop
    grepstart grepwhile mapstart mapwhile
    sort time
 ));
@@ -3030,6 +3157,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
@@ -3045,9 +3173,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';
@@ -3075,8 +3203,10 @@
    $qcode =~ s/"/‟/g; # not allowed in #line filenames
    $qcode =~ s/\n/\\n/g;
 
+   %vars = (_dummy => 0) unless %vars;
+
+   my @res;
    local $_;
-   local @safe::cf::_safe_eval_args = values %vars;
 
    my $eval =
       "do {\n"
@@ -3086,9 +3216,15 @@
       . "\n}"
    ;
 
-   sub_generation_inc;
-   my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
-   sub_generation_inc;
+   if ($CFG{safe_eval}) {
+      sub_generation_inc;
+      local @safe::cf::_safe_eval_args = values %vars;
+      @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
+      sub_generation_inc;
+   } else {
+      local @cf::_safe_eval_args = values %vars;
+      @res = wantarray ? eval eval : scalar eval $eval;
+   }
 
    if ($@) {
       warn "$@";
@@ -3117,8 +3253,8 @@
 sub register_script_function {
    my ($fun, $cb) = @_;
 
-   no strict 'refs';
-   *{"safe::$fun"} = $safe_hole->wrap ($cb);
+   $fun = "safe::$fun" if $CFG{safe_eval};
+   *$fun = $safe_hole->wrap ($cb);
 }
 
 =back
@@ -3149,9 +3285,11 @@
       or cf::cleanup "$path: version mismatch, cannot proceed.";
 
    # patch in the exptable
+   my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
    $facedata->{resource}{"res/exp_table"} = {
       type => FT_RSRC,
-      data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
+      data => $exp_table,
+      hash => (Digest::MD5::md5 $exp_table),
    };
    cf::cede_to_tick;
 
@@ -3163,8 +3301,8 @@
 
          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};
+         cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
+         cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
 
          cf::cede_to_tick;
       }
@@ -3198,29 +3336,13 @@
    }
 
    {
-      # TODO: for gcfclient pleasure, we should give resources
-      # that gcfclient doesn't grok a >10000 face index.
       my $res = $facedata->{resource};
 
       while (my ($name, $info) = each %$res) {
          if (defined $info->{type}) {
             my $idx = (cf::face::find $name) || cf::face::alloc $name;
-            my $data;
-
-            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};
-            }
 
-            cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
+            cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
             cf::face::set_type $idx, $info->{type};
          } else {
             $RESOURCE{$name} = $info;
@@ -3314,11 +3436,13 @@
 }
 
 sub reload_config {
+   warn "reloading config file...\n";
+
    open my $fh, "<:utf8", "$CONFDIR/config"
       or return;
 
    local $/;
-   *CFG = YAML::Load <$fh>;
+   *CFG = YAML::XS::Load scalar <$fh>;
 
    $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
 
@@ -3332,6 +3456,8 @@
       };
       warn $@ if $@;
    }
+
+   warn "finished reloading resource files\n";
 }
 
 sub pidfile() {
@@ -3353,6 +3479,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
 
@@ -3380,12 +3515,13 @@
    evthread_start IO::AIO::poll_fileno;
 
    cf::sync_job {
+      cf::load_settings;
+      cf::load_materials;
+
       reload_resources;
       reload_config;
       db_init;
 
-      cf::load_settings;
-      cf::load_materials;
       cf::init_uuid;
       cf::init_signals;
       cf::init_commands;
@@ -3400,12 +3536,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;
 }
 
 #############################################################################
@@ -3671,7 +3808,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
@@ -3681,7 +3818,7 @@
 
          warn "reloading cf.pm";
          require cf;
-         cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
+         cf::_connect_to_perl_1;
 
          warn "loading config and database again";
          cf::reload_config;
@@ -3753,7 +3890,7 @@
 our @WAIT_FOR_TICK_BEGIN;
 
 sub wait_for_tick {
-   return if tick_inhibit || $Coro::current == $Coro::main;
+   return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
 
    my $signal = new Coro::Signal;
    push @WAIT_FOR_TICK, $signal;
@@ -3761,7 +3898,7 @@
 }
 
 sub wait_for_tick_begin {
-   return if tick_inhibit || $Coro::current == $Coro::main;
+   return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
 
    my $signal = new Coro::Signal;
    push @WAIT_FOR_TICK_BEGIN, $signal;
@@ -3898,7 +4035,8 @@
 }
 
 # load additional modules
-use cf::pod;
+require "cf/$_.pm" for @EXTRA_MODULES;
+cf::_connect_to_perl_2;
 
 END { cf::emergency_save }