--- deliantra/server/lib/cf.pm	2006/12/17 22:03:44	1.91
+++ deliantra/server/lib/cf.pm	2006/12/25 14:43:23	1.101
@@ -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;
+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 (Coro::PRIO_MIN);
 
 sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
 
@@ -24,8 +33,6 @@
 our %COMMAND_TIME = ();
 our %EXTCMD       = ();
 
-_init_vars;
-
 our @EVENT;
 our $LIBDIR = datadir . "/ext";
 
@@ -76,11 +83,17 @@
    };
 }
 
+@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';
+@safe::cf::client::ISA         = @cf::client::ISA         = 'cf::attachable';
+@safe::cf::map::ISA            = @cf::map::ISA            = 'cf::attachable';
 @safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
 
 # we bless all objects into (empty) derived classes to force a method lookup
 # within the Safe compartment.
 for my $pkg (qw(
+   cf::global cf::attachable
    cf::object cf::object::player
    cf::client cf::player
    cf::arch cf::living
@@ -134,42 +147,72 @@
 
 #############################################################################
 
-=head2 EVENTS AND OBJECT ATTACHMENTS
+=head2 ATTACHABLE OBJECTS
+
+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 $object->attach ($attachment, key => $value...)
+=item $attachable->attach ($attachment, key => $value...)
 
-=item $object->detach ($attachment)
+=item $attachable->detach ($attachment)
 
-Attach/detach a pre-registered attachment to an object.
+Attach/detach a pre-registered attachment to a specific object and give it
+the specified key/value pairs as arguments.
 
-=item $player->attach ($attachment, key => $value...)
+Example, attach a minesweeper attachment to the given object, making it a
+10x10 minesweeper game:
 
-=item $player->detach ($attachment)
+   $obj->attach (minesweeper => width => 10, height => 10);
 
-Attach/detach a pre-registered attachment to a player.
+=item $bool = $attachable->attached ($name)
 
-=item $map->attach ($attachment, key => $value...)
+Checks wether the named attachment is currently attached to the object.
 
-=item $map->detach ($attachment)
+=item cf::CLASS->attach ...
 
-Attach/detach a pre-registered attachment to a map.
+=item cf::CLASS->detach ...
 
-=item $bool = $object->attached ($name)
+Define an anonymous attachment and attach it to all objects of the given
+CLASS. See the next function for an explanation of its arguments.
 
-=item $bool = $player->attached ($name)
+You can attach to global events by using the C<cf::global> class.
 
-=item $bool = $map->attached ($name)
+Example, log all player logins:
 
-Checks wether the named attachment is currently attached to the object.
+   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::attach_global ...
+=item cf::CLASS::attachment $name, ...
 
-Attach handlers for global events.
+Register an attachment by C<$name> through which attachable objects of the
+given CLASS can refer to this attachment.
 
-This and all following C<attach_*>-functions expect any number of the
-following handler/hook descriptions:
+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
 
@@ -181,6 +224,12 @@
 registered at priority C<-1000>, so lower priorities should not be used
 unless you know what you are doing.
 
+=item type => $type
+
+(Only for C<< cf::object->attach >> calls), limits the attachment to the
+given type of objects only (the additional parameter C<subtype> can be
+used to further limit to the given subtype).
+
 =item on_I<event> => \&cb
 
 Call the given code reference whenever the named event happens (event is
@@ -199,54 +248,39 @@
 
 =back
 
-=item cf::attach_to_type $object_type, $subtype, ...
-
-Attach handlers for a specific object type (e.g. TRANSPORT) and
-subtype. If C<$subtype> is zero or undef, matches all objects of the given
-type.
-
-=item cf::attach_to_objects ...
-
-Attach handlers to all objects. Do not use this except for debugging or
-very rare events, as handlers are (obviously) called for I<all> objects in
-the game.
-
-=item cf::attach_to_players ...
-
-Attach handlers to all players.
-
-=item cf::attach_to_maps ...
-
-Attach handlers to all maps.
-
-=item cf:register_attachment $name, ...
+Example, define an attachment called "sockpuppet" that calls the given
+event handler when a monster attacks:
 
-Register an attachment by name through which objects can refer to this
-attachment.
-
-=item cf:register_player_attachment $name, ...
-
-Register an attachment by name through which players can refer to this
-attachment.
+   cf::object::attachment sockpuppet =>
+      on_skill_attack => sub {
+         my ($self, $victim) = @_;
+         ...
+      }
+   }
 
-=item cf:register_map_attachment $name, ...
+=item $attachable->valid
 
-Register an attachment by name through which maps can refer to this
-attachment.
+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_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;
 
-sub _attach_cb($\%$$$) {
-   my ($registry, $undo, $event, $prio, $cb) = @_;
+sub _attach_cb($$$$) {
+   my ($registry, $event, $prio, $cb) = @_;
 
    use sort 'stable';
 
@@ -255,42 +289,52 @@
    @{$registry->[$event]} = sort
                            { $a->[0] cmp $b->[0] }
                            @{$registry->[$event] || []}, $cb;
-
-   push @{$undo->{cb}}, [$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).
-sub _attach(\@$@) {
+sub _attach {
    my ($registry, $klass, @arg) = @_;
 
+   my $object_type;
    my $prio = 0;
-
-   my %undo = (
-      registry => $registry,
-      cb       => [],
-   );
-
    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;
 
       if ($type eq "prio") {
          $prio = shift @arg;
 
+      } elsif ($type eq "type") {
+         $object_type = shift @arg;
+         $registry = $CB_TYPE[$object_type] ||= [];
+
+      } elsif ($type eq "subtype") {
+         defined $object_type or Carp::croak "subtype specified without type";
+         my $object_subtype = shift @arg;
+         $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
+
       } elsif ($type eq "package") {
          my $pkg = shift @arg;
 
          while (my ($name, $id) = each %cb_id) {
             if (my $cb = $pkg->can ($name)) {
-               _attach_cb $registry, %undo, $id, $prio, $cb;
+               _attach_cb $registry, $id, $prio, $cb;
             }
          }
 
       } elsif (exists $cb_id{$type}) {
-         _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
+         _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
 
       } elsif (ref $type) {
          warn "attaching objects not supported, ignoring.\n";
@@ -300,23 +344,19 @@
          warn "attach argument '$type' not supported, ignoring.\n";
       }
    }
-
-   \%undo
 }
 
-sub _attach_attachment {
+sub _object_attach {
    my ($obj, $name, %arg) = @_;
 
    return if exists $obj->{_attachment}{$name};
 
-   my $res;
-
    if (my $attach = $attachment{$name}) {
       my $registry = $obj->registry;
 
       for (@$attach) {
          my ($klass, @attach) = @$_;
-         $res = _attach @$registry, $klass, @attach;
+         _attach $registry, $klass, @attach;
       }
 
       $obj->{$name} = \%arg;
@@ -325,76 +365,47 @@
    }
 
    $obj->{_attachment}{$name} = undef;
-
-   $res->{attachment} = $name;
-   $res
 }
 
-*cf::object::attach =
-*cf::player::attach =
-*cf::map::attach = sub {
-   my ($obj, $name, %arg) = @_;
-
-   _attach_attachment $obj, $name, %arg;
+sub cf::attachable::attach {
+   if (ref $_[0]) {
+      _object_attach @_;
+   } else {
+      _attach shift->_attach_registry, @_;
+   }
 };
 
 # all those should be optimised
-*cf::object::detach =
-*cf::player::detach =
-*cf::map::detach = sub {
+sub cf::attachable::detach {
    my ($obj, $name) = @_;
 
-   delete $obj->{_attachment}{$name};
-   reattach ($obj);
+   if (ref $obj) {
+      delete $obj->{_attachment}{$name};
+      reattach ($obj);
+   } else {
+      Carp::croak "cannot, currently, detach class attachments";
+   }
 };
 
-*cf::object::attached =
-*cf::player::attached =
-*cf::map::attached = sub {
+sub cf::attachable::attached {
    my ($obj, $name) = @_;
 
    exists $obj->{_attachment}{$name}
-};
-
-sub attach_global {
-   _attach @CB_GLOBAL, KLASS_GLOBAL, @_
-}
-
-sub attach_to_type {
-   my $type = shift;
-   my $subtype = shift;
-
-   _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
-}
-
-sub attach_to_objects {
-   _attach @CB_OBJECT, KLASS_OBJECT, @_
-}
-
-sub attach_to_players {
-   _attach @CB_PLAYER, KLASS_PLAYER, @_
-}
-
-sub attach_to_maps {
-   _attach @CB_MAP, KLASS_MAP, @_
-}
-
-sub register_attachment {
-   my $name = shift;
-
-   $attachment{$name} = [[KLASS_OBJECT, @_]];
 }
 
-sub register_player_attachment {
-   my $name = shift;
-
-   $attachment{$name} = [[KLASS_PLAYER, @_]];
-}
+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)
+      }
 
-sub register_map_attachment {
-   my $name = shift;
+      sub cf::\L$klass\E::attachment {
+         my \$name = shift;
 
-   $attachment{$name} = [[KLASS_MAP, @_]];
+         \$attachment{\$name} = [[KLASS_$klass, \@_]];
+      }
+   ";
+   die if $@;
 }
 
 our $override;
@@ -428,17 +439,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 = $map->invoke (EVENT_MAP_XXX, ...)
+Generate an object-specific event with the given arguments.
 
-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).
 
@@ -447,62 +454,52 @@
 =cut
 
 #############################################################################
-
-=head2 METHODS VALID FOR ALL CORE OBJECTS
-
-=over 4
-
-=item $object->valid, $player->valid, $map->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
-
-*cf::object::valid =
-*cf::player::valid =
-*cf::map::valid = \&cf::_valid;
-
-#############################################################################
 # object support
 
-sub instantiate {
-   my ($obj, $data) = @_;
+cf::attachable->attach (
+   prio           => -1000000,
+   on_instantiate => sub {
+      my ($obj, $data) = @_;
 
-   $data = from_json $data;
+      $data = from_json $data;
 
-   for (@$data) {
-      my ($name, $args) = @$_;
+      for (@$data) {
+         my ($name, $args) = @$_;
 
-      $obj->attach ($name, %{$args || {} });
-   }
-}
-
-# basically do the same as instantiate, without calling instantiate
-sub reattach {
-   my ($obj) = @_;
-   my $registry = $obj->registry;
+         $obj->attach ($name, %{$args || {} });
+      }
+   },
+   on_reattach => sub {
+      # basically do the same as instantiate, without calling instantiate
+      my ($obj) = @_;
+      my $registry = $obj->registry;
 
-   @$registry = ();
+      @$registry = ();
 
-   delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
+      delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
 
-   for my $name (keys %{ $obj->{_attachment} || {} }) {
-      if (my $attach = $attachment{$name}) {
-         for (@$attach) {
-            my ($klass, @attach) = @$_;
-            _attach @$registry, $klass, @attach;
+      for my $name (keys %{ $obj->{_attachment} || {} }) {
+         if (my $attach = $attachment{$name}) {
+            for (@$attach) {
+               my ($klass, @attach) = @$_;
+               _attach $registry, $klass, @attach;
+            }
+         } else {
+            warn "object uses attachment '$name' that is not available, postponing.\n";
          }
-      } else {
-         warn "object uses attachment '$name' that is not available, postponing.\n";
       }
-   }
-}
+   },
+   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) = @_;
@@ -562,20 +559,6 @@
    ()
 }
 
-attach_to_objects
-   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
 
@@ -613,7 +596,7 @@
    $EXTCMD{$name} = [$cb, $caller];
 }
 
-attach_to_players
+cf::player->attach (
    on_command => sub {
       my ($pl, $name, $params) = @_;
 
@@ -643,7 +626,7 @@
 
       cf::override;
    },
-;
+);
 
 sub register {
    my ($base, $pkg) = @_;
@@ -743,7 +726,7 @@
    unlink "$path.pst";
 };
 
-attach_to_maps prio => -10000, package => cf::mapsupport::;
+cf::map->attach (prio => -10000, package => cf::mapsupport::);
 
 #############################################################################
 # load/save perl data associated with player->ob objects
@@ -753,7 +736,7 @@
 }
 
 # TODO: compatibility cruft, remove when no longer needed
-attach_to_players
+cf::player->attach (
    on_load => sub {
       my ($pl, $path) = @_;
 
@@ -765,7 +748,7 @@
          }
       }
    },
-;
+);
 
 #############################################################################
 
@@ -773,6 +756,8 @@
 
 Functions and methods that extend core crossfire objects.
 
+=head3 cf::player
+
 =over 4
 
 =item cf::player::exists $login
@@ -786,6 +771,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>
@@ -796,6 +801,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) = @_;
 
@@ -809,20 +815,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"
@@ -839,9 +831,106 @@
          : $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 $@;
+      delete $self->{_coro}{$coro+0};
+   };
+
+   $self->{_coro}{$coro+0} = $coro;
+}
+
+cf::client->attach (
+   on_destroy => sub {
+      my ($ns) = @_;
+
+      $_->cancel for values %{ (delete $ns->{_coro}) || {} };
+   },
+);
+
+=back
+
 
 =head2 SAFE SCRIPTING
 
@@ -1051,12 +1140,12 @@
       db_dirty;
    }
 
-   attach_global
-      prio => 10000,
+   cf::global->attach (
+      prio       => 10000,
       on_cleanup => sub {
          db_sync;
       },
-   ;
+   );
 }
 
 #############################################################################
@@ -1134,6 +1223,7 @@
       # reload cf.pm
       $msg->("reloading cf.pm");
       require cf;
+      cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
 
       # load config and database again
       cf::cfg_load;