--- deliantra/server/lib/cf.pm	2006/12/22 02:04:20	1.95
+++ deliantra/server/lib/cf.pm	2006/12/25 11:25:49	1.100
@@ -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";
 
@@ -86,7 +93,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
@@ -251,15 +258,24 @@
       }
    }
 
+=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;
 
@@ -275,6 +291,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).
@@ -285,6 +304,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;
 
@@ -369,7 +393,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)
@@ -415,19 +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 = $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).
 
@@ -436,60 +454,52 @@
 =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) = @_;
+cf::attachable->attach (
+   prio           => -1000000,
+   on_instantiate => sub {
+      my ($obj, $data) = @_;
 
-   $data = from_json $data;
+      $data = from_json $data;
 
-   for (@$data) {
-      my ($name, $args) = @$_;
-
-      $obj->attach ($name, %{$args || {} });
-   }
-}
+      for (@$data) {
+         my ($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) = @_;
@@ -549,20 +559,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
 
@@ -897,12 +893,42 @@
          if (@$queue) {
             $ns->send_packet ($ns->{query_queue}[0][0]);
          } else {
-            $ns->state (ST_PLAYING);
+            $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
 
 
@@ -1197,6 +1223,8 @@
       # 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;