[ViewVC] Diff of: cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.134 by root, Thu Jan 4 17:28:49 2007 UTC vs.
Revision 1.154 by root, Tue Jan 9 15:36:19 2007 UTC

 use Coro::Timer;
 use Coro::Signal;
 use Coro::Semaphore;
 use Coro::AIO;
+use Data::Dumper;
 use Digest::MD5;
 use Fcntl;
-use IO::AIO 2.31 ();
+use IO::AIO 2.32 ();
 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;
-$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
+$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 = ();
 our %CFG;
 our $UPTIME; $UPTIME ||= time;
 our $RUNTIME;
+our %PLAYER; # all users
-our %MAP; # all maps
+our %MAP;    # all maps
 our $LINK_MAP; # the special {link} map
 our $RANDOM_MAPS = cf::localdir . "/random";
-our %EXT_CORO;
+our %EXT_CORO; # coroutines bound to extensions
 binmode STDOUT;
 binmode STDERR;
 # read virtual server time, if available
       utf8::encode $msg;
       $msg .= "\n"
          unless $msg =~ /\n$/;
-      LOG llevError, "cfperl: $msg";
+      LOG llevError, $msg;
    };
 }
 @safe::cf::global::ISA         = @cf::global::ISA         = 'cf::attachable';
 @safe::cf::object::ISA         = @cf::object::ISA         = 'cf::attachable';
 =head2 UTILITY FUNCTIONS
 =over 4
+=item dumpval $ref
 =cut
+sub dumpval {
+   eval {
+      local $SIG{__DIE__};
+      my $d;
+      if (1) {
+         $d = new Data::Dumper([$_[0]], ["*var"]);
+         $d->Terse(1);
+         $d->Indent(2);
+         $d->Quotekeys(0);
+         $d->Useqq(1);
+         #$d->Bless(...);
+         $d->Seen($_[1]) if @_ > 1;
+         $d = $d->Dump();
+      }
+      $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
+      $d
+   } || "[unable to dump $_[0]: '$@']";
+}
 use JSON::Syck (); # TODO# replace by JSON::PC once working
 =item $ref = cf::from_json $json
 sub to_json($) {
    $JSON::Syck::ImplicitUnicode = 0;  # work around JSON::Syck bugs
    JSON::Syck::Dump $_[0]
 }
-=item my $guard = cf::guard { BLOCK }
-Run the given callback when the guard object gets destroyed (useful for
-coroutine cancellations).
-You can call C<< ->cancel >> on the guard object to stop the block from
-being executed.
-=cut
-sub guard(&) {
-   bless \(my $cb = $_[0]), cf::guard::;
-}
-sub cf::guard::cancel {
-   ${$_[0]} = sub { };
-}
-sub cf::guard::DESTROY {
-   ${$_[0]}->();
-}
 =item cf::lock_wait $string
 Wait until the given lock is available. See cf::lock_acquire.
 =item my $lock = cf::lock_acquire $string
 Wait until the given lock is available and then acquires it and returns
-a guard object. If the guard object gets destroyed (goes out of scope,
+a Coro::guard object. If the guard object gets destroyed (goes out of scope,
 for example when the coroutine gets canceled), the lock is automatically
 returned.
 Lock names should begin with a unique identifier (for example, cf::map::find
 uses map_find and cf::map::load uses map_load).
    # wait, to be sure we are not locked
    lock_wait $key;
    $LOCK{$key} = [];
-   cf::guard {
+   Coro::guard {
       # wake up all waiters, to be on the safe side
       $_->ready for @{ delete $LOCK{$key} };
    }
 }
-=item cf::async { BLOCK }
-Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the
-error instead of exiting the server in case of a problem.
-=cut
-sub async(&) {
-   my ($cb) = @_;
-   Coro::async {
-      eval { $cb->() };
-      warn $@ if $@;
-   }
-}
 sub freeze_mainloop {
    return unless $TICK_WATCHER->is_active;
-   my $guard = guard { $TICK_WATCHER->start };
+   my $guard = Coro::guard { $TICK_WATCHER->start };
    $TICK_WATCHER->stop;
    $guard
 }
+=item cf::async { BLOCK }
+Currently the same as Coro::async_pool, meaning you cannot use
+C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
+thing you are allowed to do is call C<prio> on it.
+=cut
+BEGIN { *async = \&Coro::async_pool }
 =item cf::sync_job { BLOCK }
 The design of crossfire+ requires that the main coro ($Coro::main) is
 always able to handle events or runnable, as crossfire+ is only partly
       my $freeze_guard = freeze_mainloop;
       my $busy = 1;
       my @res;
-      (Coro::async {
+      (async {
          @res = eval { $job->() };
          warn $@ if $@;
          undef $busy;
       })->prio (Coro::PRIO_MAX);
       while ($busy) {
-         Coro::cede_notself;
+         Coro::cede or Event::one_event;
-         Event::one_event unless Coro::nready;
       }
       wantarray ? @res : $res[0]
    } else {
       # we are in another coroutine, how wonderful, everything just works
       $job->()
    }
 }
-=item $coro = cf::coro { BLOCK }
+=item $coro = cf::async_ext { BLOCK }
-Creates and returns a new coro. This coro is automcatially being canceled
+Like async, but this coro is automcatially being canceled when the
-when the extension calling this is being unloaded.
+extension calling this is being unloaded.
 =cut
-sub coro(&) {
+sub async_ext(&) {
    my $cb = shift;
-   my $coro = &cf::async ($cb);
+   my $coro = &Coro::async ($cb);
    $coro->on_destroy (sub {
       delete $EXT_CORO{$coro+0};
    });
    $EXT_CORO{$coro+0} = $coro;
 =cut
 #############################################################################
 package cf::path;
+# used to convert map paths into valid unix filenames by repalcing / by ∕
+our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
 sub new {
    my ($class, $path, $base) = @_;
    $path = $path->as_string if ref $path;
 #   }
 }
 # escape the /'s in the path
 sub _escaped_path  {
-   # ∕ is U+2215
-   (my $path = $_[0]{path}) =~ s/\//∕/g;
+   (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
    $path
 }
 # the original (read-only) location
 sub load_path {
 =head2 CORE EXTENSIONS
 Functions and methods that extend core crossfire objects.
+=cut
+package cf::player;
+use Coro::AIO;
 =head3 cf::player
 =over 4
-=item cf::player::exists $login
+=item cf::player::find $login
-Returns true when the given account exists.
+Returns the given player object, loading it if necessary (might block).
 =cut
-sub cf::player::exists($) {
+sub playerdir($) {
-   cf::player::find $_[0]
+   cf::localdir
-      or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
+     . "/"
+     . cf::playerdir
+     . "/"
+     . (ref $_[0] ? $_[0]->ob->name : $_[0])
+}
+sub path($) {
+   my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
+   (playerdir $login) . "/$login.pl"
+}
+sub find_active($) {
+   $cf::PLAYER{$_[0]}
+      and $cf::PLAYER{$_[0]}->active
+      and $cf::PLAYER{$_[0]}
+}
+sub exists($) {
+   my ($login) = @_;
+   $cf::PLAYER{$login}
+      or cf::sync_job { !aio_stat $login }
+}
+sub find($) {
+   return $cf::PLAYER{$_[0]} || do {
+      my $login = $_[0];
+      my $guard = cf::lock_acquire "user_find:$login";
+      $cf::PLAYER{$_[0]} || do {
+         my $pl = load_pl path $login
+            or return;
+         $cf::PLAYER{$login} = $pl
+      }
+   }
+}
+sub save($) {
+   my ($pl) = @_;
+   return if $pl->{deny_save};
+   my $path = path $pl;
+   my $guard = cf::lock_acquire "user_save:$path";
+   return if $pl->{deny_save};
+   aio_mkdir playerdir $pl, 0770;
+   $pl->{last_save} = $cf::RUNTIME;
+   $pl->save_pl ($path);
+   Coro::cede;
+}
+sub new($) {
+   my ($login) = @_;
+   my $self = create;
+   $self->ob->name ($login);
+   $self->{deny_save} = 1;
+   $cf::PLAYER{$login} = $self;
+   $self
+}
+=item $pl->quit_character
+Nukes the player without looking back. If logged in, the connection will
+be destroyed. May block for a long time.
+=cut
+sub quit_character {
+   my ($pl) = @_;
+   $pl->{deny_save} = 1;
+   $pl->password ("*"); # this should lock out the player until we nuked the dir
+   $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
+   $pl->deactivate;
+   $pl->invoke (cf::EVENT_PLAYER_QUIT);
+   $pl->ns->destroy if $pl->ns;
+   my $path = playerdir $pl;
+   my $temp = "$path~$cf::RUNTIME~deleting~";
+   aio_rename $path, $temp;
+   delete $cf::PLAYER{$pl->ob->name};
+   $pl->destroy;
+   IO::AIO::aio_rmtree $temp;
+}
+=item cf::player::list_logins
+Returns am arrayref of all valid playernames in the system, can take a
+while and may block, so not sync_job-capable, ever.
+=cut
+sub list_logins {
+   my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
+      or return [];
+   my @logins;
+   for my $login (@$dirs) {
+      my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
+      aio_read $fh, 0, 512, my $buf, 0                  or next;
+      $buf !~ /^password -------------$/                or next; # official not-valid tag
+      utf8::decode $login;
+      push @logins, $login;
+   }
+   \@logins
+}
+=item $player->maps
+Returns an arrayref of cf::path's of all maps that are private for this
+player. May block.
+=cut
+sub maps($) {
+   my ($pl) = @_;
+   my $files = aio_readdir playerdir $pl
+      or return;
+   my @paths;
+   for (@$files) {
+      utf8::decode $_;
+      next if /\.(?:pl|pst)$/;
+      next unless /^$PATH_SEP/;
+      s/$PATH_SEP/\//g;
+      push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
+   }
+   \@paths
 }
 =item $player->ext_reply ($msgid, $msgtype, %msg)
 Sends an ext reply to the player.
 =cut
-sub cf::player::ext_reply($$$%) {
+sub ext_reply($$$%) {
    my ($self, $id, %msg) = @_;
    $msg{msgid} = $id;
-   $self->send ("ext " . to_json \%msg);
+   $self->send ("ext " . cf::to_json \%msg);
 }
+package cf;
 =back
 =head3 cf::map
       or return;
    my $map = cf::map::new
       or return;
+   # for better error messages only, will be overwritten
+   $map->path ($path);
    $map->load_header ($path)
      or return;
    $map->{load_path} = $path;
 }
 sub save {
    my ($self) = @_;
+   my $lock = cf::lock_acquire "map_data:" . $self->path;
    $self->{last_save} = $cf::RUNTIME;
    return unless $self->dirty;
    my $save = $self->{path}->save_path; utf8::encode $save;
    $self->{load_path} = $save;
    return if $self->{deny_save};
    local $self->{last_access} = $self->last_access;#d#
+   cf::async {
+      $_->contr->save for $self->players;
+   };
    if ($uniq) {
       $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
       $self->save_objects ($uniq, cf::IO_UNIQUES);
    } else {
    my ($self) = @_;
    # save first because save cedes
    $self->save;
+   my $lock = cf::lock_acquire "map_data:" . $self->path;
    return if $self->players;
    return if $self->in_memory != cf::MAP_IN_MEMORY;
    return if $self->{deny_save};
    $self->clear;
 }
 sub reset {
    my ($self) = @_;
+   my $lock = cf::lock_acquire "map_data:" . $self->path;
    return if $self->players;
    return if $self->{path}{user_rel};#d#
    warn "resetting map ", $self->path;#d#
 }
 sub emergency_save {
    my $freeze_guard = cf::freeze_mainloop;
-   warn "enter emergency map save\n";
+   warn "enter emergency perl save\n";
    cf::sync_job {
+      warn "begin emergency player save\n";
+      $_->save for values %cf::PLAYER;
+      warn "end emergency player save\n";
       warn "begin emergency map save\n";
       $_->save for values %cf::MAP;
+      warn "end emergency map save\n";
    };
-   warn "end emergency map save\n";
+   warn "leave emergency perl save\n";
 }
 package cf;
 =back
    ($x, $y) = ($map->enter_x, $map->enter_y)
       if $x <=0 && $y <= 0;
    $map->load;
+   return unless $self->contr->active;
    $self->activate_recursive;
    $self->enter_map ($map, $x, $y);
 }
 cf::player->attach (
       # try to abort aborted map switching on player login :)
       # should happen only on crashes
       if ($pl->ob->{_link_pos}) {
          $pl->ob->enter_link;
-         cf::async {
+         (async {
             # we need this sleep as the login has a concurrent enter_exit running
             # and this sleep increases chances of the player not ending up in scorn
+            $pl->ob->reply (undef,
+                            "There was an internal problem at your last logout, "
+                          . "the server will try to bring you to your intended destination in a second.",
+                            cf::NDI_RED);
             Coro::Timer::sleep 1;
             $pl->ob->leave_link;
-         };
+         })->prio (2);
       }
    },
 );
-=item $player_object->goto_map ($path, $x, $y)
+=item $player_object->goto ($path, $x, $y)
 =cut
-sub cf::object::player::goto_map {
+sub cf::object::player::goto {
    my ($self, $path, $x, $y) = @_;
+   $path = new cf::path $path;
+   $path ne "/" or Carp::cluck ("oy");#d#
    $self->enter_link;
-   (cf::async {
+   (async {
-      $path = new cf::path $path;
       my $map = cf::map::find $path->as_string;
       $map = $map->customise_for ($self) if $map;
 #      warn "entering ", $map->path, " at ($x, $y)\n"
 #         if $map;
-      $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
+      $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
       $self->leave_link ($map, $x, $y);
    })->prio (1);
 }
    return unless $self->type == cf::PLAYER;
    $self->enter_link;
-   (cf::async {
+   (async {
       $self->deactivate_recursive; # just to be sure
       unless (eval {
          prepare_random_map $exit
             if $exit->slaying eq "/!";
          my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
-         $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
+         $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
          1;
       }) {
          $self->message ("Something went wrong deep within the crossfire server. "
                      . "I'll try to bring you back to the map you were before. "
          }
       }
    },
 );
-=item $client->coro (\&cb)
+=item $client->async (\&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 {
+sub cf::client::async {
    my ($self, $cb) = @_;
-   my $coro = &cf::async ($cb);
+   my $coro = &Coro::async ($cb);
    $coro->on_destroy (sub {
       delete $self->{_coro}{$coro+0};
    });
    local $/;
    *CFG = YAML::Syck::Load <$fh>;
    $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
+   $cf::map::MAX_RESET     = $CFG{map_max_reset}     if exists $CFG{map_max_reset};
+   $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
    if (exists $CFG{mlockall}) {
       eval {
-         $CFG{mlockall} ? &mlockall : &munlockall
+         $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
             and die "WARNING: m(un)lockall failed: $!\n";
       };
       warn $@ if $@;
    }
 }
 sub main {
    # we must not ever block the main coroutine
    local $Coro::idle = sub {
       Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
-      (Coro::unblock_sub {
-         Event::one_event;
+      async { Event::one_event };
-      })->();
    };
    cfg_load;
    db_load;
    load_extensions;
       cf::load_extensions;
       # reattach attachments to objects
       warn "reattach";
       _global_reattach;
+      reattach $_ for values %MAP;
    };
    if ($@) {
       warn $@;
       warn "error while reloading, exiting.";
    $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
    $LINK_MAP->in_memory (MAP_IN_MEMORY);
    # dirty hack because... archetypes are not yet loaded
    Event->timer (
-      after => 2,
+      after => 10,
       cb    => sub {
          $_[0]->w->cancel;
          # provide some exits "home"
          my $exit = cf::object::new "exit";

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.134 by root, Thu Jan 4 17:28:49 2007 UTC vs. Revision 1.154 by root, Tue Jan 9 15:36:19 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.134 by root, Thu Jan 4 17:28:49 2007 UTC vs.
Revision 1.154 by root, Tue Jan 9 15:36:19 2007 UTC