--- deliantra/server/lib/cf.pm	2006/12/21 22:41:35	1.93
+++ deliantra/server/lib/cf.pm	2006/12/30 16:56:16	1.104
@@ -1,5 +1,8 @@
 package cf;
 
+use utf8;
+use strict;
+
 use Symbol;
 use List::Util;
 use Storable;
@@ -7,16 +10,22 @@
 use Safe;
 use Safe::Hole;
 
-use IO::AIO ();
+use Coro 3.3;
+use Coro::Event;
+use Coro::Timer;
+use Coro::Signal;
+use Coro::Semaphore;
+
+use IO::AIO 2.3;
 use YAML::Syck ();
 use Time::HiRes;
-use Event;
-$Event::Eval = 1; # no idea why this is required, but it is
+
+use Event; $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 (2); # run main coroutine ("the server") with very high priority
 
 sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
 
@@ -24,18 +33,39 @@
 our %COMMAND_TIME = ();
 our %EXTCMD       = ();
 
-_init_vars;
-
 our @EVENT;
 our $LIBDIR = datadir . "/ext";
 
 our $TICK = MAX_TIME * 1e-6;
 our $TICK_WATCHER;
 our $NEXT_TICK;
+our $NOW;
 
 our %CFG;
 
 our $UPTIME; $UPTIME ||= time;
+our $RUNTIME;
+
+our %MAP; # all maps
+our $LINK_MAP; # the special {link} map
+our $FREEZE;
+
+binmode STDOUT;
+binmode STDERR;
+
+# read virtual server time, if available
+unless ($RUNTIME || !-e cf::localdir . "/runtime") {
+   open my $fh, "<", cf::localdir . "/runtime"
+      or die "unable to read runtime file: $!";
+   $RUNTIME = <$fh> + 0.;
+}
+
+mkdir cf::localdir;
+mkdir cf::localdir . "/" . cf::playerdir;
+mkdir cf::localdir . "/" . cf::tmpdir;
+mkdir cf::localdir . "/" . cf::uniquedir;
+
+our %EXT_CORO;
 
 #############################################################################
 
@@ -47,11 +77,20 @@
 
 The timestamp of the server start (so not actually an uptime).
 
+=item $cf::RUNTIME
+
+The time this server has run, starts at 0 and is increased by $cf::TICK on
+every server tick.
+
 =item $cf::LIBDIR
 
 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.
@@ -68,10 +107,11 @@
 BEGIN {
    *CORE::GLOBAL::warn = sub {
       my $msg = join "", @_;
+      utf8::encode $msg;
+
       $msg .= "\n"
          unless $msg =~ /\n$/;
 
-      print STDERR "cfperl: $msg";
       LOG llevError, "cfperl: $msg";
    };
 }
@@ -86,7 +126,7 @@
 # we bless all objects into (empty) derived classes to force a method lookup
 # within the Safe compartment.
 for my $pkg (qw(
-   cf::global
+   cf::global cf::attachable
    cf::object cf::object::player
    cf::client cf::player
    cf::arch cf::living
@@ -134,6 +174,31 @@
    JSON::Syck::Dump $_[0]
 }
 
+=item $coro = cf::coro { BLOCK }
+
+Creates and returns a new coro. This coro is automcatially being canceled
+when the extension calling this is being unloaded.
+
+=cut
+
+sub coro(&) {
+   my $cb = shift;
+
+   my $coro; $coro = async {
+      eval {
+         $cb->();
+      };
+      warn $@ if $@;
+   };
+
+   $coro->on_destroy (sub {
+      delete $EXT_CORO{$coro+0};
+   });
+   $EXT_CORO{$coro+0} = $coro;
+
+   $coro
+}
+
 =back
 
 =cut
@@ -142,34 +207,70 @@
 
 =head2 ATTACHABLE OBJECTS
 
-You can define and attach attachments to each "attachable" object in
-crossfire+ (objects, players, clients, maps and the special "global"
-class). In the following description, CLASS can be any of C<global>,
-C<object> C<player>, C<client> or C<map>.
+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+).
 
 =over 4
 
-=item cf::CLASS::attachment $name, ...
+=item $attachable->attach ($attachment, key => $value...)
+
+=item $attachable->detach ($attachment)
 
-Register an attachment by name through which attachable objects can refer
-to this attachment.
+Attach/detach a pre-registered attachment to a specific object and give it
+the specified key/value pairs as arguments.
+
+Example, attach a minesweeper attachment to the given object, making it a
+10x10 minesweeper game:
+
+   $obj->attach (minesweeper => width => 10, height => 10);
 
 =item $bool = $attachable->attached ($name)
 
 Checks wether the named attachment is currently attached to the object.
 
-=item $attachable->attach ($attachment, key => $value...)
+=item cf::CLASS->attach ...
 
-=item $attachable->detach ($attachment)
+=item cf::CLASS->detach ...
 
-Attach/detach a pre-registered attachment either to a specific object
-(C<$attachable>) or all objects of the given class (if C<$attachable> is a
-class in a static method call).
+Define an anonymous attachment and attach it to all objects of the given
+CLASS. See the next function for an explanation of its arguments.
 
 You can attach to global events by using the C<cf::global> class.
 
-These method calls expect any number of the following handler/hook
-descriptions:
+Example, log all player logins:
+
+   cf::player->attach (
+      on_login => sub {
+         my ($pl) = @_;
+         ...
+      },
+   );
+
+Example, attach to the jeweler skill:
+
+   cf::object->attach (
+      type         => cf::SKILL,
+      subtype      => cf::SK_JEWELER,
+      on_use_skill => sub {
+         my ($sk, $ob, $part, $dir, $msg) = @_;
+         ...
+      },
+   );
+
+=item cf::CLASS::attachment $name, ...
+
+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
 
@@ -205,15 +306,34 @@
 
 =back
 
+Example, define an attachment called "sockpuppet" that calls the given
+event handler when a monster attacks:
+
+   cf::object::attachment sockpuppet =>
+      on_skill_attack => sub {
+         my ($self, $victim) = @_;
+         ...
+      }
+   }
+
+=item $attachable->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.
+
 =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_CLIENT = ();
-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;
 
@@ -229,6 +349,9 @@
                            @{$registry->[$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).
@@ -239,6 +362,11 @@
    my $prio = 0;
    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;
 
@@ -323,7 +451,7 @@
    exists $obj->{_attachment}{$name}
 }
 
-for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {
+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)
@@ -369,19 +497,13 @@
    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 = $client->invoke (EVENT_CLIENT_XXX, ...)
+Generate an object-specific event with the given arguments.
 
-=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
-
-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).
 
@@ -390,43 +512,12 @@
 =cut
 
 #############################################################################
-
-=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
-
-Attachable objects includes objects, players, clients and maps.
-
-=over 4
-
-=item $object->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
-
-#############################################################################
 # object support
 
-sub instantiate {
-   my ($obj, $data) = @_;
-
-   $data = from_json $data;
-
-   for (@$data) {
-      my ($name, $args) = @$_;
-
-      $obj->attach ($name, %{$args || {} });
-   }
-}
-
-# basically do the same as instantiate, without calling instantiate
 sub reattach {
+   # basically do the same as instantiate, without calling instantiate
    my ($obj) = @_;
+
    my $registry = $obj->registry;
 
    @$registry = ();
@@ -445,6 +536,32 @@
    }
 }
 
+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) = @_;
 
@@ -503,20 +620,6 @@
    ()
 }
 
-cf::object->attach (
-   prio     => -1000000,
-   on_clone => sub {
-      my ($src, $dst) = @_;
-
-      @{$dst->registry} = @{$src->registry};
-
-      %$dst = %$src;
-
-      %{$dst->{_attachment}} = %{$src->{_attachment}}
-         if exists $src->{_attachment};
-   },
-);
-
 #############################################################################
 # command handling &c
 
@@ -714,6 +817,8 @@
 
 Functions and methods that extend core crossfire objects.
 
+=head3 cf::player
+
 =over 4
 
 =item cf::player::exists $login
@@ -727,6 +832,26 @@
       or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
 }
 
+=item $player->ext_reply ($msgid, $msgtype, %msg)
+
+Sends an ext reply to the player.
+
+=cut
+
+sub cf::player::ext_reply($$$%) {
+   my ($self, $id, %msg) = @_;
+
+   $msg{msgid} = $id;
+
+   $self->send ("ext " . to_json \%msg);
+}
+
+=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>
@@ -737,6 +862,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) = @_;
 
@@ -750,20 +876,6 @@
    }
 }
 
-=item $player->ext_reply ($msgid, $msgtype, %msg)
-
-Sends an ext reply to the player.
-
-=cut
-
-sub cf::player::ext_reply($$$%) {
-   my ($self, $id, %msg) = @_;
-
-   $msg{msgid} = $id;
-
-   $self->send ("ext " . to_json \%msg);
-}
-
 =item $player_object->may ("access")
 
 Returns wether the given player is authorized to access resource "access"
@@ -780,9 +892,111 @@
          : $cf::CFG{"may_$access"})
 }
 
+=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, $text);
+}
+
+
+=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;
+}
+
+cf::client->attach (
+   on_reply => sub {
+      my ($ns, $msg) = @_;
+
+      # this weird shuffling is so that direct followup queries
+      # get handled first
+      my $queue = delete $ns->{query_queue};
+
+      (shift @$queue)->[1]->($msg);
+
+      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;
+         }
+      }
+   },
+);
+
+=item $client->coro (\&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::coro {
+   my ($self, $cb) = @_;
+
+   my $coro; $coro = async {
+      eval {
+         $cb->();
+      };
+      warn $@ if $@;
+   };
+
+   $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
 
@@ -1021,20 +1235,26 @@
 #############################################################################
 # initialisation
 
-sub _perl_reload(&) {
-   my ($msg) = @_;
-
-   $msg->("reloading...");
+sub _perl_reload() {
+   warn "reloading...";
 
    eval {
+      local $FREEZE = 1;
+
+      cf::emergency_save;
+
       # cancel all watchers
       for (Event::all_watchers) {
          $_->cancel if $_->data & WF_AUTOCANCEL;
       }
 
+      # cancel all extension coros
+      $_->cancel for values %EXT_CORO;
+      %EXT_CORO = ();
+
       # unload all extensions
       for (@exts) {
-         $msg->("unloading <$_>");
+         warn "unloading <$_>";
          unload_extension $_;
       }
 
@@ -1042,7 +1262,7 @@
       while (my ($k, $v) = each %INC) {
          next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
 
-         $msg->("removing <$k>");
+         warn "removing <$k>";
          delete $INC{$k};
 
          $k =~ s/\.pm$//;
@@ -1057,10 +1277,11 @@
 
       # sync database to disk
       cf::db_sync;
+      IO::AIO::flush;
 
       # get 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
@@ -1073,31 +1294,29 @@
       #Symbol::delete_package __PACKAGE__;
 
       # reload cf.pm
-      $msg->("reloading cf.pm");
+      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;
 
       # load extensions
-      $msg->("load extensions");
+      warn "load extensions";
       cf::load_extensions;
 
       # reattach attachments to objects
-      $msg->("reattach");
+      warn "reattach";
       _global_reattach;
    };
-   $msg->($@) if $@;
+   warn $@ if $@;
 
-   $msg->("reloaded");
+   warn "reloaded";
 };
 
 sub perl_reload() {
-   _perl_reload {
-      warn $_[0];
-      print "$_[0]\n";
-   };
+   _perl_reload;
 }
 
 register "<global>", __PACKAGE__;
@@ -1106,27 +1325,28 @@
    my ($who, $arg) = @_;
 
    if ($who->flag (FLAG_WIZ)) {
-      _perl_reload {
-         warn $_[0];
-         $who->message ($_[0]);
-      };
+      $who->message ("reloading...");
+      _perl_reload;
    }
 };
 
 unshift @INC, $LIBDIR;
 
 $TICK_WATCHER = Event->timer (
-   prio  => 0,
-   at    => $NEXT_TICK || 1,
-   data  => WF_AUTOCANCEL,
-   cb    => sub {
-      cf::server_tick; # one server iteration
+   reentrant => 0,
+   prio      => 0,
+   at        => $NEXT_TICK || $TICK,
+   data      => WF_AUTOCANCEL,
+   cb        => sub {
+      unless ($FREEZE) {
+         cf::server_tick; # one server iteration
+         $RUNTIME += $TICK;
+      }
 
-      my $NOW = Event::time;
       $NEXT_TICK += $TICK;
 
       # if we are delayed by four ticks or more, skip them all
-      $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
+      $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
 
       $TICK_WATCHER->at ($NEXT_TICK);
       $TICK_WATCHER->start;
@@ -1141,5 +1361,14 @@
            data => WF_AUTOCANCEL,
            cb   => \&IO::AIO::poll_cb);
 
+# we must not ever block the main coroutine
+$Coro::idle = sub {
+   #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
+   warn "FATAL: Coro::idle was called, major BUG\n";
+   (Coro::unblock_sub {
+      Event::one_event;
+   })->();
+};
+
 1