--- deliantra/server/lib/cf.pm	2006/10/01 10:59:30	1.71
+++ deliantra/server/lib/cf.pm	2006/12/21 06:42:28	1.92
@@ -7,17 +7,27 @@
 use Safe;
 use Safe::Hole;
 
+use IO::AIO ();
+use YAML::Syck ();
 use Time::HiRes;
 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;
 
+sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
+
+our %COMMAND      = ();
+our %COMMAND_TIME = ();
+our %EXTCMD       = ();
+
 _init_vars;
 
-our %COMMAND = ();
 our @EVENT;
-our $LIBDIR = maps_directory "perl";
+our $LIBDIR = datadir . "/ext";
 
 our $TICK = MAX_TIME * 1e-6;
 our $TICK_WATCHER;
@@ -25,12 +35,18 @@
 
 our %CFG;
 
+our $UPTIME; $UPTIME ||= time;
+
 #############################################################################
 
 =head2 GLOBAL VARIABLES
 
 =over 4
 
+=item $cf::UPTIME
+
+The timestamp of the server start (so not actually an uptime).
+
 =item $cf::LIBDIR
 
 The perl library directory, where extensions and cf-specific modules can
@@ -64,7 +80,12 @@
 
 # we bless all objects into (empty) derived classes to force a method lookup
 # within the Safe compartment.
-for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
+for my $pkg (qw(
+   cf::object cf::object::player
+   cf::client cf::player
+   cf::arch cf::living
+   cf::map cf::party cf::region
+)) {
    no strict 'refs';
    @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
 }
@@ -76,8 +97,6 @@
 my %ext_pkg;
 my @exts;
 my @hook;
-my %command;
-my %extcmd;
 
 =head2 UTILITY FUNCTIONS
 
@@ -135,12 +154,20 @@
 
 =item $map->detach ($attachment)
 
+Attach/detach a pre-registered attachment to a client.
+
+=item $client->attach ($attachment, key => $value...)
+
+=item $client->detach ($attachment)
+
 Attach/detach a pre-registered attachment to a map.
 
 =item $bool = $object->attached ($name)
 
 =item $bool = $player->attached ($name)
 
+=item $bool = $client->attached ($name)
+
 =item $bool = $map->attached ($name)
 
 Checks wether the named attachment is currently attached to the object.
@@ -196,6 +223,10 @@
 
 Attach handlers to all players.
 
+=item cf::attach_to_clients ...
+
+Attach handlers to all players.
+
 =item cf::attach_to_maps ...
 
 Attach handlers to all maps.
@@ -221,6 +252,7 @@
 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    = ();
 
@@ -313,6 +345,7 @@
 
 *cf::object::attach =
 *cf::player::attach =
+*cf::client::attach =
 *cf::map::attach = sub {
    my ($obj, $name, %arg) = @_;
 
@@ -322,6 +355,7 @@
 # all those should be optimised
 *cf::object::detach =
 *cf::player::detach =
+*cf::client::detach =
 *cf::map::detach = sub {
    my ($obj, $name) = @_;
 
@@ -331,6 +365,7 @@
 
 *cf::object::attached =
 *cf::player::attached =
+*cf::client::attached =
 *cf::map::attached = sub {
    my ($obj, $name) = @_;
 
@@ -356,6 +391,10 @@
    _attach @CB_PLAYER, KLASS_PLAYER, @_
 }
 
+sub attach_to_clients {
+   _attach @CB_CLIENT, KLASS_CLIENT, @_
+}
+
 sub attach_to_maps {
    _attach @CB_MAP, KLASS_MAP, @_
 }
@@ -372,6 +411,12 @@
    $attachment{$name} = [[KLASS_PLAYER, @_]];
 }
 
+sub register_client_attachment {
+   my $name = shift;
+
+   $attachment{$name} = [[KLASS_CLIENT, @_]];
+}
+
 sub register_map_attachment {
    my $name = shift;
 
@@ -415,6 +460,8 @@
 
 =item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
 
+=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
+
 =item $bool = $map->invoke (EVENT_MAP_XXX, ...)
 
 Generate a global/object/player/map-specific event with the given arguments.
@@ -433,7 +480,7 @@
 
 =over 4
 
-=item $object->valid, $player->valid, $map->valid
+=item $object->valid, $player->valid, $client->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
@@ -447,6 +494,7 @@
 
 *cf::object::valid =
 *cf::player::valid =
+*cf::client::valid =
 *cf::map::valid = \&cf::_valid;
 
 #############################################################################
@@ -516,6 +564,14 @@
    }
 }
 
+sub object_freezer_as_string {
+   my ($rdata, $objs) = @_;
+
+   use Data::Dumper;
+
+   $$rdata . Dumper $objs
+}
+
 sub object_thawer_load {
    my ($filename) = @_;
 
@@ -550,46 +606,32 @@
 ;
 
 #############################################################################
-# old plug-in events
+# command handling &c
 
-sub inject_event {
-   my $extension = shift;
-   my $event_code = shift;
+=item cf::register_command $name => \&callback($ob,$args);
 
-   my $cb = $hook[$event_code]{$extension}
-      or return;
+Register a callback for execution when the client sends the user command
+$name.
 
-   &$cb
-}
+=cut
 
-sub inject_global_event {
-   my $event = shift;
+sub register_command {
+   my ($name, $cb) = @_;
 
-   my $cb = $hook[$event]
-      or return;
+   my $caller = caller;
+   #warn "registering command '$name/$time' to '$caller'";
 
-   List::Util::max map &$_, values %$cb
+   push @{ $COMMAND{$name} }, [$caller, $cb];
 }
 
-sub inject_command {
-   my ($name, $obj, $params) = @_;
-
-   for my $cmd (@{ $command{$name} }) {
-      $cmd->[1]->($obj, $params);
-   }
-
-   -1
-}
+=item cf::register_extcmd $name => \&callback($pl,$packet);
 
-sub register_command {
-   my ($name, $time, $cb) = @_;
+Register a callbackf ro execution when the client sends an extcmd packet.
 
-   my $caller = caller;
-   #warn "registering command '$name/$time' to '$caller'";
+If the callback returns something, it is sent back as if reply was being
+called.
 
-   push @{ $command{$name} }, [$time, $cb, $caller];
-   $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
-}
+=cut
 
 sub register_extcmd {
    my ($name, $cb) = @_;
@@ -597,9 +639,41 @@
    my $caller = caller;
    #warn "registering extcmd '$name' to '$caller'";
 
-   $extcmd{$name} = [$cb, $caller];
+   $EXTCMD{$name} = [$cb, $caller];
 }
 
+attach_to_players
+   on_command => sub {
+      my ($pl, $name, $params) = @_;
+
+      my $cb = $COMMAND{$name}
+         or return;
+
+      for my $cmd (@$cb) {
+         $cmd->[1]->($pl->ob, $params);
+      }
+
+      cf::override;
+   },
+   on_extcmd => sub {
+      my ($pl, $buf) = @_;
+
+      my $msg = eval { from_json $buf };
+
+      if (ref $msg) {
+         if (my $cb = $EXTCMD{$msg->{msgtype}}) {
+            if (my %reply = $cb->[0]->($pl, $msg)) {
+               $pl->ext_reply ($msg->{msgid}, %reply);
+            }
+         }
+      } else {
+         warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
+      }
+
+      cf::override;
+   },
+;
+
 sub register {
    my ($base, $pkg) = @_;
 
@@ -627,7 +701,8 @@
       . "\n};\n1";
 
    eval $source
-      or die "$path: $@";
+      or die $@ ? "$path: $@\n"
+                : "extension disabled.\n";
 
    push @exts, $pkg;
    $ext_pkg{$base} = $pkg;
@@ -650,21 +725,19 @@
 #   }
 
    # remove commands
-   for my $name (keys %command) {
-      my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
+   for my $name (keys %COMMAND) {
+      my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
 
       if (@cb) {
-         $command{$name} = \@cb;
-         $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
+         $COMMAND{$name} = \@cb;
       } else {
-         delete $command{$name};
-         delete $COMMAND{"$name\000"};
+         delete $COMMAND{$name};
       }
    }
 
    # remove extcmds
-   for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
-      delete $extcmd{$name};
+   for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
+      delete $EXTCMD{$name};
    }
 
    if (my $cb = $pkg->can ("unload")) {
@@ -678,8 +751,6 @@
 }
 
 sub load_extensions {
-   my $LIBDIR = maps_directory "perl";
-
    for my $ext (<$LIBDIR/*.ext>) {
       next unless -r $ext;
       eval {
@@ -690,30 +761,6 @@
 }
 
 #############################################################################
-# extcmd framework, basically convert ext <msg>
-# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
-
-attach_to_players
-   on_extcmd => sub {
-      my ($pl, $buf) = @_;
-
-      my $msg = eval { from_json $buf };
-
-      if (ref $msg) {
-         if (my $cb = $extcmd{$msg->{msgtype}}) {
-            if (my %reply = $cb->[0]->($pl, $msg)) {
-               $pl->ext_reply ($msg->{msgid}, %reply);
-            }
-         }
-      } else {
-         warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
-      }
-
-      cf::override;
-   },
-;
-
-#############################################################################
 # load/save/clean perl data associated with a map
 
 *cf::mapsupport::on_clean = sub {
@@ -768,7 +815,7 @@
       or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
 }
 
-=item $player->reply ($npc, $msg[, $flags])
+=item $player_object->reply ($npc, $msg[, $flags])
 
 Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
 can be C<undef>. Does the right thing when the player is currently in a
@@ -805,7 +852,21 @@
    $self->send ("ext " . to_json \%msg);
 }
 
-=back
+=item $player_object->may ("access")
+
+Returns wether the given player is authorized to access resource "access"
+(e.g. "command_wizcast").
+
+=cut
+
+sub cf::object::player::may {
+   my ($self, $access) = @_;
+
+   $self->flag (cf::FLAG_WIZ) || 
+      (ref $cf::CFG{"may_$access"}
+         ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
+         : $cf::CFG{"may_$access"})
+}
 
 =cut
 
@@ -817,7 +878,7 @@
 snippets of perl code without them endangering the safety of the server
 itself. Looping constructs, I/O operators and other built-in functionality
 is not available in the safe scripting environment, and the number of
-functions and methods that cna be called is greatly reduced.
+functions and methods that can be called is greatly reduced.
 
 =cut
 
@@ -834,16 +895,18 @@
 
 The following fucntions and emthods are available within a safe environment:
 
-  cf::object contr pay_amount pay_player
+  cf::object contr pay_amount pay_player map
   cf::object::player player
   cf::player peaceful
+  cf::map trigger
 
 =cut
 
 for (
-   ["cf::object"         => qw(contr pay_amount pay_player)],
+   ["cf::object"         => qw(contr pay_amount pay_player map)],
    ["cf::object::player" => qw(player)],
    ["cf::player"         => qw(peaceful)],
+   ["cf::map"            => qw(trigger)],
 ) {
    no strict 'refs';
    my ($pkg, @funs) = @$_;
@@ -963,13 +1026,14 @@
 
 =cut
 
+our $DB;
+
 {
-   my $db;
    my $path = cf::localdir . "/database.pst";
 
    sub db_load() {
       warn "loading database $path\n";#d# remove later
-      $db = stat $path ? Storable::retrieve $path : { };
+      $DB = stat $path ? Storable::retrieve $path : { };
    }
 
    my $pid;
@@ -978,8 +1042,8 @@
       warn "saving database $path\n";#d# remove later
       waitpid $pid, 0 if $pid;
       if (0 == ($pid = fork)) {
-         $db->{_meta}{version} = 1;
-         Storable::nstore $db, "$path~";
+         $DB->{_meta}{version} = 1;
+         Storable::nstore $DB, "$path~";
          rename "$path~", $path;
          cf::_exit 0 if defined $pid;
       }
@@ -992,7 +1056,7 @@
       undef $dirty;
    }
 
-   my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
+   my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
       db_sync;
    });
 
@@ -1003,15 +1067,15 @@
 
    sub db_get($;$) {
       @_ >= 2
-         ? $db->{$_[0]}{$_[1]}
-         : ($db->{$_[0]} ||= { })
+         ? $DB->{$_[0]}{$_[1]}
+         : ($DB->{$_[0]} ||= { })
    }
 
    sub db_put($$;$) {
       if (@_ >= 3) {
-         $db->{$_[0]}{$_[1]} = $_[2];
+         $DB->{$_[0]}{$_[1]} = $_[2];
       } else {
-         $db->{$_[0]} = $_[1];
+         $DB->{$_[0]} = $_[1];
       }
       db_dirty;
    }
@@ -1027,7 +1091,16 @@
 #############################################################################
 # the server's main()
 
+sub cfg_load {
+   open my $fh, "<:utf8", cf::confdir . "/config"
+      or return;
+
+   local $/;
+   *CFG = YAML::Syck::Load <$fh>;
+}
+
 sub main {
+   cfg_load;
    db_load;
    load_extensions;
    Event::loop;
@@ -1043,7 +1116,9 @@
 
    eval {
       # cancel all watchers
-      $_->cancel for Event::all_watchers;
+      for (Event::all_watchers) {
+         $_->cancel if $_->data & WF_AUTOCANCEL;
+      }
 
       # unload all extensions
       for (@exts) {
@@ -1089,7 +1164,8 @@
       $msg->("reloading cf.pm");
       require cf;
 
-      # load database again
+      # load config and database again
+      cf::cfg_load;
       cf::db_load;
 
       # load extensions
@@ -1112,7 +1188,9 @@
    };
 }
 
-register_command "perl-reload", 0, sub {
+register "<global>", __PACKAGE__;
+
+register_command "perl-reload" => sub {
    my ($who, $arg) = @_;
 
    if ($who->flag (FLAG_WIZ)) {
@@ -1123,20 +1201,19 @@
    }
 };
 
-register "<global>", __PACKAGE__;
-
 unshift @INC, $LIBDIR;
 
 $TICK_WATCHER = Event->timer (
-   prio => 1,
-   at   => $NEXT_TICK || 1,
-   cb   => sub {
+   prio  => 0,
+   at    => $NEXT_TICK || 1,
+   data  => WF_AUTOCANCEL,
+   cb    => sub {
       cf::server_tick; # one server iteration
 
       my $NOW = Event::time;
       $NEXT_TICK += $TICK;
 
-      # if we are delayed by four ticks, skip them all
+      # if we are delayed by four ticks or more, skip them all
       $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
 
       $TICK_WATCHER->at ($NEXT_TICK);
@@ -1144,5 +1221,13 @@
    },
 );
 
+IO::AIO::max_poll_time $TICK * 0.2;
+
+Event->io (fd   => IO::AIO::poll_fileno,
+           poll => 'r',
+           prio => 5,
+           data => WF_AUTOCANCEL,
+           cb   => \&IO::AIO::poll_cb);
+
 1