--- deliantra/server/lib/cf.pm	2007/03/14 04:12:29	1.226
+++ deliantra/server/lib/cf.pm	2007/04/17 10:38:28	1.246
@@ -11,34 +11,39 @@
 use Safe;
 use Safe::Hole;
 
-use Coro 3.52 ();
+use Coro 3.61 ();
 use Coro::State;
 use Coro::Event;
 use Coro::Timer;
 use Coro::Signal;
 use Coro::Semaphore;
 use Coro::AIO;
+use Coro::Storable;
 
 use BDB ();
 use Data::Dumper;
 use Digest::MD5;
 use Fcntl;
-use IO::AIO 2.32 ();
 use YAML::Syck ();
+use IO::AIO 2.32 ();
 use Time::HiRes;
 use Compress::LZF;
 
+# 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
 
-sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
+$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;
 
 $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 = ();
 
@@ -51,7 +56,7 @@
 our @EVENT;
 our $LIBDIR = datadir . "/ext";
 
-our $TICK = MAX_TIME * 1e-6;
+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
@@ -73,9 +78,6 @@
 our $RANDOM_MAPS = cf::localdir . "/random";
 our $BDB_ENV_DIR = cf::localdir . "/db";
 
-our $WAIT_FOR_TICK;     $WAIT_FOR_TICK     ||= new Coro::Signal;
-our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
-
 # used to convert map paths into valid unix filenames by replacing / by ∕
 our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
 
@@ -133,12 +135,11 @@
 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_ONE
+=item cf::wait_for_tick, cf::wait_for_tick_begin
 
-These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
-or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
-processing has been done. Call C<< ->wait >> on them to maximise the
-window of cpu time available, or simply to synchronise to the server tick.
+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.
 
 =back
 
@@ -207,30 +208,16 @@
    } || "[unable to dump $_[0]: '$@']";
 }
 
-use JSON::Syck (); # TODO# replace by JSON::PC once working
+use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
 
 =item $ref = cf::from_json $json
 
 Converts a JSON string into the corresponding perl data structure.
 
-=cut
-
-sub from_json($) {
-   $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
-   JSON::Syck::Load $_[0]
-}
-
 =item $json = cf::to_json $ref
 
 Converts a perl data structure into its JSON representation.
 
-=cut
-
-sub to_json($) {
-   $JSON::Syck::ImplicitUnicode = 0;  # work around JSON::Syck bugs
-   JSON::Syck::Dump $_[0]
-}
-
 =item cf::lock_wait $string
 
 Wait until the given lock is available. See cf::lock_acquire. 
@@ -386,6 +373,17 @@
    1
 }
 
+=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
 
 =cut
@@ -965,7 +963,7 @@
 sub path($) {
    my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
 
-   (playerdir $login) . "/$login.pl"
+   (playerdir $login) . "/playerdata"
 }
 
 sub find_active($) {
@@ -988,6 +986,13 @@
       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 $pl = load_pl path $login
             or return;
          $cf::PLAYER{$login} = $pl
@@ -1126,13 +1131,13 @@
    \@paths
 }
 
-=item $player->ext_reply ($msgid, $msgtype, %msg)
+=item $player->ext_reply ($msgid, %msg)
 
 Sends an ext reply to the player.
 
 =cut
 
-sub ext_reply($$$%) {
+sub ext_reply($$%) {
    my ($self, $id, %msg) = @_;
 
    $msg{msgid} = $id;
@@ -1140,10 +1145,48 @@
    $self->send ("ext " . cf::to_json \%msg);
 }
 
-package cf;
+=item $player->ext_event ($type, %msg)
 
-=back
+Sends an ext event to the client.
+
+=cut
+
+sub ext_event($$%) {
+   my ($self, $type, %msg) = @_;
+
+   $self->ns->ext_event ($type, %msg);
+}
 
+=head3 cf::region
+
+=over 4
+
+=cut
+
+package cf::region;
+
+=item cf::region::find_by_path $path
+
+Tries to decuce the probable region for a map knowing only its path.
+
+=cut
+
+sub find_by_path($) {
+   my ($path) = @_;
+
+   my ($match, $specificity);
+
+   for my $region (list) {
+      if ($region->match && $path =~ $region->match) {
+         ($match, $specificity) = ($region, $region->specificity)
+            if $region->specificity > $specificity;
+      }
+   }
+
+   $match
+}
+
+=back
 
 =head3 cf::map
 
@@ -1384,6 +1427,9 @@
       $self->prepare_orig;
    }
 
+   $self->default_region (cf::region::find_by_path $self->{path})
+      unless $self->default_region;
+
    1
 }
 
@@ -1435,6 +1481,7 @@
    $self->alloc;
 
    $self->pre_load;
+   Coro::cede;
 
    $self->_load_objects ($self->{load_path}, 1)
       or return;
@@ -1451,9 +1498,9 @@
    }
 
    Coro::cede;
-
    # now do the right thing for maps
    $self->link_multipart_objects;
+   Coro::cede;
 
    unless ($self->{deny_activate}) {
       $self->decay_objects;
@@ -1465,9 +1512,11 @@
          unless $self->difficulty;
       Coro::cede;
       $self->activate;
+      Coro::cede;
    }
 
    $self->post_load;
+   Coro::cede;
 
    $self->in_memory (cf::MAP_IN_MEMORY);
 }
@@ -1955,6 +2004,8 @@
 
    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 };
    }
 
@@ -1972,9 +2023,9 @@
          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);
+                       . "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;
@@ -2000,6 +2051,18 @@
    $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
 }
 
+=item $client->ext_event ($type, %msg)
+
+Sends an exti event to the client.
+
+=cut
+
+sub cf::client::ext_event($$%) {
+   my ($self, $type, %msg) = @_;
+
+   $msg{msgtype} = "event_$type";
+   $self->send_packet ("ext " . cf::to_json \%msg);
+}
 
 =item $success = $client->query ($flags, "text", \&cb)
 
@@ -2106,7 +2169,7 @@
 
 =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
   cf::object::player player
@@ -2271,50 +2334,87 @@
 #############################################################################
 # the server's init and main functions
 
-sub load_faces {
-   my $path = sprintf "%s/faces", cf::datadir;
+sub load_facedata($) {
+   my ($path) = @_;
 
-   warn "loading faces from $path\n";
+   warn "loading facedata from $path\n";
 
-   my $faces;
-   0 < aio_load $path, $faces
+   my $facedata;
+   0 < aio_load $path, $facedata
       or die "$path: $!";
 
-   Coro::cede;
-   $faces = Storable::thaw $faces;
-   Coro::cede;
+   $facedata = Coro::Storable::thaw $facedata;
 
-   my $meta = delete $faces->{""};
-   $meta->{version} == 1
+   $facedata->{version} == 2
       or cf::cleanup "$path: version mismatch, cannot proceed.";
 
-   while (my ($face, $info) = each %$faces) {
-      my $idx = (cf::face::find $face) || cf::face::alloc $face;
-      cf::face::set $idx, $info->{visibility}, $info->{magicmap};
-      cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
-      Coro::cede;
+   {
+      my $faces = $facedata->{faceinfo};
+
+      while (my ($face, $info) = each %$faces) {
+         my $idx = (cf::face::find $face) || cf::face::alloc $face;
+         cf::face::set $idx, $info->{visibility}, $info->{magicmap};
+         cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
+         cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
+         Coro::cede;
+      }
+
+      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, $info->{smoothlevel};
+         } else {
+            warn "smooth face '$info->{smooth}' not found for face '$face'";
+         }
+         Coro::cede;
+      }
    }
 
-   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;
-      } else {
-         warn "smooth face '$info->{smooth}' not found for face '$face'";
+   {
+      my $anims = $facedata->{animinfo};
+
+      while (my ($anim, $info) = each %$anims) {
+         cf::anim::set $anim, $info->{frames}, $info->{facings};
+         Coro::cede;
       }
-      Coro::cede;
+
+      cf::anim::invalidate_all; # d'oh
    }
 
    1
 }
 
-sub reload_resources {
+sub reload_facedata {
+   load_facedata sprintf "%s/facedata", cf::datadir
+      or die "unable to load facedata\n";
+}
+
+sub reload_regions {
    load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir
-      or die "unable to load regions file\n";#d#
-   load_faces
-      or die "unable to load faces\n";#d#
+      or die "unable to load regions file\n";
+}
+
+sub reload_archetypes {
+   load_archetype_file sprintf "%s/archetypes", cf::datadir
+      or die "unable to load archetypes\n";
+}
+
+sub reload_treasures {
+   load_treasure_file sprintf "%s/treasures", cf::datadir
+      or die "unable to load treasurelists\n";
+}
+
+sub reload_resources {
+   warn "reloading resource files...\n";
+
+   reload_regions;
+   reload_facedata;
+   reload_archetypes;
+   reload_treasures;
+
+   warn "finished reloading resource files\n";
 }
 
 sub init {
@@ -2417,7 +2517,7 @@
       if $make_core;
 }
 
-sub reload() {
+sub do_reload_perl() {
    # can/must only be called in main
    if ($Coro::current != $Coro::main) {
       warn "can only reload from main coroutine";
@@ -2526,9 +2626,6 @@
       warn "reattaching attachments to players";
       reattach $_ for values %PLAYER;
 
-      warn "loading reloadable resources";
-      reload_resources;
-
       warn "leaving sync_job";
 
       1
@@ -2543,24 +2640,27 @@
 
 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 "reload" => sub {
    my ($who, $arg) = @_;
 
    if ($who->flag (FLAG_WIZ)) {
       $who->message ("reloading server.");
-
-      # 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 {
-            reload;
-            undef $RELOAD_WATCHER;
-         },
-      );
+      async { reload_perl };
    }
 };
 
@@ -2568,6 +2668,27 @@
 
 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 (
    reentrant => 0,
    parked    => 1,
@@ -2584,6 +2705,7 @@
       $NOW = Event::time;
 
       cf::server_tick; # one server iteration
+
       $RUNTIME   += $TICK;
       $NEXT_TICK += $TICK;
 
@@ -2595,9 +2717,6 @@
          };
       }
 
-      $WAIT_FOR_TICK->broadcast;
-      $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
-
 #      my $AFTER = Event::time;
 #      warn $AFTER - $NOW;#d#
 
@@ -2606,6 +2725,15 @@
 
       $TICK_WATCHER->at ($NEXT_TICK);
       $TICK_WATCHER->start;
+
+      if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
+         $sig->send;
+      }
+      while (my $sig = shift @WAIT_FOR_TICK) {
+         $sig->send;
+      }
+
+      _post_tick;
    },
 );