--- deliantra/server/lib/cf.pm	2009/10/11 05:31:54	1.482
+++ deliantra/server/lib/cf.pm	2010/04/07 18:35:56	1.511
@@ -1,23 +1,24 @@
-# 
+#
 # This file is part of Deliantra, the Roguelike Realtime MMORPG.
 # 
-# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
+# Copyright (©) 2006,2007,2008,2009,2010 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;
 
@@ -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;
@@ -229,7 +230,7 @@
 
 =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.
 
@@ -290,7 +291,7 @@
 }
 
 $EV::DIED = sub {
-   warn "error in event callback: @_";
+   Carp::cluck "error in event callback: @_";
 };
 
 #############################################################################
@@ -424,24 +425,29 @@
 
 our @SLOT_QUEUE;
 our $SLOT_QUEUE;
+our $SLOT_DECAY = 0.9;
 
 $SLOT_QUEUE->cancel if $SLOT_QUEUE;
 $SLOT_QUEUE = Coro::async {
    $Coro::current->desc ("timeslot manager");
 
    my $signal = new Coro::Signal;
+   my $busy;
 
    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;
-            }
+
+      for (0 .. $#SLOT_QUEUE) {
+         if ($SLOT_QUEUE[$_][0] <= $avail) {
+            $busy = 0;
+            my $job = splice @SLOT_QUEUE, $_, 1, ();
+            $job->[2]->send;
+            Coro::cede;
+            goto next_job;
+         } else {
+            $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
          }
       }
 
@@ -450,6 +456,7 @@
          push @cf::WAIT_FOR_TICK, $signal;
          $signal->wait;
       } else {
+         $busy = 0;
          Coro::schedule;
       }
    }
@@ -460,7 +467,8 @@
 
    my ($time, $pri, $name) = @_;
 
-   $time = $TICK * .6 if $time > $TICK * .6;
+   $time = clamp $time, 0.01, $TICK * .6;
+
    my $sig = new Coro::Signal;
 
    push @SLOT_QUEUE, [$time, $pri, $sig, $name];
@@ -1304,7 +1312,7 @@
 use File::Glob ();
 
 cf::player->attach (
-   on_command => sub {
+   on_unknown_command => sub {
       my ($pl, $name, $params) = @_;
 
       my $cb = $COMMAND{$name}
@@ -1393,38 +1401,47 @@
          $todo{$base} = \%ext;
       }
 
+      my $pass = 0;
       my %done;
       while (%todo) {
          my $progress;
 
+         ++$pass;
+
+         ext:
          while (my ($k, $v) = each %todo) {
             for (split /,\s*/, $v->{meta}{depends}) {
-               goto skip
+               next ext
                   unless exists $done{$_};
             }
 
-            warn "... loading '$k' into '$v->{pkg}'\n";
+            warn "... pass $pass, 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;
-                  cf::cleanup "mandatory extension failed to load, exiting.";
-               }
-               
-               warn $msg;
-            }
+            my $active = eval $v->{source};
 
-            $done{$k} = delete $todo{$k};
-            push @EXTS, $v->{pkg};
-            $progress = 1;
+            if (length $@) {
+               warn "$v->{path}: $@\n";
+
+               cf::cleanup "mandatory extension '$k' failed to load, exiting."
+                  if exists $v->{meta}{mandatory};
+            } else {
+               $done{$k} = delete $todo{$k};
+               push @EXTS, $v->{pkg};
+               $progress = 1;
+
+               warn "$v->{base}: extension inactive.\n"
+                  unless $active;
+            }
          }
 
-         skip:
-         die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
-            unless $progress;
+         unless ($progress) {
+            warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
+
+            while (my ($k, $v) = each %todo) {
+               cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
+                  if exists $v->{meta}{mandatory};
+            }
+         }
       }
    };
 }
@@ -1518,6 +1535,19 @@
    }
 }
 
+cf::player->attach (
+   on_load => sub {
+      my ($pl, $path) = @_;
+
+      # restore slots saved in save, below
+      my $slots = delete $pl->{_slots};
+
+      $pl->ob->current_weapon ($slots->[0]);
+      $pl->combat_ob          ($slots->[1]);
+      $pl->ranged_ob          ($slots->[2]);
+   },
+);
+
 sub save($) {
    my ($pl) = @_;
 
@@ -1533,6 +1563,9 @@
 
    cf::get_slot 0.01;
 
+   # save slots, to be restored later
+   local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
+
    $pl->save_pl ($path);
    cf::cede_to_tick;
 }
@@ -1754,7 +1787,7 @@
    # 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->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
       $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
       $rmp->{exit_on_final_map},
       $rmp->{xsize}, $rmp->{ysize},
@@ -2010,8 +2043,8 @@
    }
 }
 
-sub pre_load  { }
-sub post_load { }
+sub pre_load { }
+#sub post_load { } # XS
 
 sub load {
    my ($self) = @_;
@@ -2078,6 +2111,9 @@
    $self->post_load;
 }
 
+# customize the map for a given player, i.e.
+# return the _real_ map. used by e.g. per-player
+# maps to change the path to ~playername/mappath
 sub customise_for {
    my ($self, $ob) = @_;
 
@@ -2342,6 +2378,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
@@ -2546,7 +2614,7 @@
 
    # 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;
@@ -2755,6 +2823,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
@@ -2766,6 +2859,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",
@@ -2778,6 +2877,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",
@@ -2902,17 +3007,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)
@@ -2925,10 +3020,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}));
    }
 }
 
@@ -2942,11 +3037,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}));
    }
 }
 
@@ -3057,7 +3152,7 @@
 }
 
 cf::client->attach (
-   on_destroy => sub {
+   on_client_destroy => sub {
       my ($ns) = @_;
 
       $_->cancel for values %{ (delete $ns->{_coro}) || {} };
@@ -3083,7 +3178,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
 ));
@@ -3145,8 +3240,8 @@
 
    %vars = (_dummy => 0) unless %vars;
 
+   my @res;
    local $_;
-   local @safe::cf::_safe_eval_args = values %vars;
 
    my $eval =
       "do {\n"
@@ -3156,9 +3251,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 "$@";
@@ -3187,8 +3288,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
@@ -3219,9 +3320,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;
 
@@ -3233,8 +3336,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;
       }
@@ -3268,29 +3371,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;
@@ -3384,11 +3471,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];
 
@@ -3402,6 +3491,8 @@
       };
       warn $@ if $@;
    }
+
+   warn "finished reloading resource files\n";
 }
 
 sub pidfile() {
@@ -3459,15 +3550,15 @@
    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;
       cf::init_skills;
 
       cf::init_beforeplay;
@@ -3502,6 +3593,8 @@
 }
 
 sub write_runtime_sync {
+   my $t0 = EV::time;
+
    # first touch the runtime file to show we are still running:
    # the fsync below can take a very very long time.
 
@@ -3509,7 +3602,7 @@
 
    my $guard = cf::lock_acquire "write_runtime";
 
-   my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
+   my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
       or return;
 
    my $value = $cf::RUNTIME + 90 + 10;
@@ -3532,7 +3625,7 @@
    aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
       and return;
 
-   warn "runtime file written.\n";
+   warn sprintf "runtime file written (%gs).\n", EV::time - $t0;
 
    1
 }
@@ -3761,7 +3854,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;
@@ -3833,7 +3926,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;
@@ -3841,7 +3934,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;
@@ -3857,6 +3950,8 @@
 
    cf::server_tick; # one server iteration
 
+   #for(1..3e6){} EV::now_update; $NOW=EV::now; # generate load #d#
+
    if ($NOW >= $NEXT_RUNTIME_WRITE) {
       $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
       Coro::async_pool {
@@ -3888,7 +3983,7 @@
 {
    # configure BDB
 
-   BDB::min_parallel 8;
+   BDB::min_parallel 16;
    BDB::max_poll_reqs $TICK * 0.1;
    $AnyEvent::BDB::WATCHER->priority (1);
 
@@ -3979,6 +4074,7 @@
 
 # load additional modules
 require "cf/$_.pm" for @EXTRA_MODULES;
+cf::_connect_to_perl_2;
 
 END { cf::emergency_save }