--- deliantra/server/lib/cf.pm	2007/01/01 11:21:55	1.110
+++ deliantra/server/lib/cf.pm	2007/01/02 19:18:33	1.123
@@ -183,6 +183,70 @@
    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,
+for example when the coroutine gets canceled), the lock is automatically
+returned.
+
+Lock names should begin with a unique identifier (for example, find_map
+uses map_find and load_map uses map_load).
+
+=cut
+
+our %LOCK;
+
+sub lock_wait($) {
+   my ($key) = @_;
+
+   # wait for lock, if any
+   while ($LOCK{$key}) {
+      push @{ $LOCK{$key} }, $Coro::current;
+      Coro::schedule;
+   }
+}
+
+sub lock_acquire($) {
+   my ($key) = @_;
+
+   # wait, to be sure we are not locked
+   lock_wait $key;
+
+   $LOCK{$key} = [];
+
+   cf::guard {
+      # wake up all waiters, to be on the safe side
+      $_->ready for @{ delete $LOCK{$key} };
+   }
+}
+
 =item cf::sync_job { BLOCK }
 
 The design of crossfire+ requires that the main coro ($Coro::main) is
@@ -199,28 +263,34 @@
 sub sync_job(&) {
    my ($job) = @_;
 
-   my $busy = 1;
-   my @res;
-
-   my $coro = Coro::async {
-      @res = eval { $job->() };
-      warn $@ if $@;
-      undef $busy;
-   };
-
    if ($Coro::current == $Coro::main) {
+      # this is the main coro, too bad, we have to block
+      # till the operation succeeds, freezing the server :/
+      
       # TODO: use suspend/resume instead
+      # (but this is cancel-safe)
       local $FREEZE = 1;
-      $coro->prio (Coro::PRIO_MAX);
+
+      my $busy = 1;
+      my @res;
+
+      (Coro::async {
+         @res = eval { $job->() };
+         warn $@ if $@;
+         undef $busy;
+      })->prio (Coro::PRIO_MAX);
+
       while ($busy) {
          Coro::cede_notself;
          Event::one_event unless Coro::nready;
       }
+
+      wantarray ? @res : $res[0]
    } else {
-      $coro->join;
+      # we are in another coroutine, how wonderful, everything just works
+ 
+      $job->()
    }
-
-   wantarray ? @res : $res[0]
 }
 
 =item $coro = cf::coro { BLOCK }
@@ -254,7 +324,7 @@
    my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
       or return;
 
-   my $value = $cf::RUNTIME;
+   my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
    (aio_write $fh, 0, (length $value), $value, 0) <= 0
       and return;
 
@@ -285,7 +355,17 @@
 
    my $self = bless { }, $class;
 
-   if ($path =~ s{^\?random/}{}) {
+   # {...        are special paths that are not touched
+   # ?xxx/...    are special absolute paths
+   # ?random/... random maps
+   # /!          non-realised random map exit
+   # /...        normal maps
+   # ~/...       per-player maps without a specific player (DO NOT USE)
+   # ~user/...   per-player map of a specific user
+
+   if ($path =~ /^{/) {
+      # fine as it is
+   } elsif ($path =~ s{^\?random/}{}) {
       Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
       $self->{random} = cf::from_json $data;
    } else {
@@ -800,9 +880,11 @@
    unless (aio_stat "$filename.pst") {
       (aio_load "$filename.pst", $av) >= 0
          or return;
-      $av = eval { (Storable::thaw <$av>)->{objs} };
+      $av = eval { (Storable::thaw $av)->{objs} };
    }
 
+   warn sprintf "loading %s (%d)\n",
+      $filename, length $data, scalar @{$av || []};#d#
    return ($data, $av);
 }
 
@@ -1048,8 +1130,6 @@
 
 our $MAX_RESET     = 7200;
 our $DEFAULT_RESET = 3600;
-$MAX_RESET     = 10;#d#
-$DEFAULT_RESET = 10;#d#
 
 sub generate_random_map {
    my ($path, $rmp) = @_;
@@ -1075,7 +1155,8 @@
 sub change_all_map_light {
    my ($change) = @_;
 
-   $_->change_map_light ($change) for values %cf::MAP;
+   $_->change_map_light ($change)
+      for grep $_->outdoor, values %cf::MAP;
 }
 
 sub try_load_header($) {
@@ -1092,7 +1173,6 @@
      or return;
 
    $map->{load_path} = $path;
-   use Data::Dumper; warn Dumper $map;#d#
 
    $map
 }
@@ -1102,10 +1182,14 @@
 
    #warn "find_map<$path,$origin>\n";#d#
 
-   $path = ref $path ? $path : new cf::path $path, $origin && $origin->path;
+   $path = new cf::path $path, $origin && $origin->path;
    my $key = $path->as_string;
 
+   cf::lock_wait "map_find:$key";
+
    $cf::MAP{$key} || do {
+      my $guard = cf::lock_acquire "map_find:$key";
+
       # do it the slow way
       my $map = try_load_header $path->save_path;
 
@@ -1122,6 +1206,7 @@
 
          $map or return;
 
+         $map->{load_original} = 1;
          $map->{instantiate_time} = $cf::RUNTIME;
          $map->instantiate;
 
@@ -1131,9 +1216,14 @@
 
       $map->path ($key);
       $map->{path} = $path;
+      $map->{last_save} = $cf::RUNTIME;
       $map->last_access ($cf::RUNTIME);
 
-      $map->reset if $map->should_reset;
+      if ($map->should_reset) {
+         $map->reset;
+         undef $guard;
+         $map = find_map $path;
+      }
 
       $cf::MAP{$key} = $map
    }
@@ -1142,16 +1232,20 @@
 sub load {
    my ($self) = @_;
 
+   my $path = $self->{path};
+   my $guard = cf::lock_acquire "map_load:" . $path->as_string;
+
    return if $self->in_memory != cf::MAP_SWAPPED;
 
    $self->in_memory (cf::MAP_LOADING);
 
-   my $path = $self->{path};
-
    $self->alloc;
    $self->load_objects ($self->{load_path}, 1)
       or return;
 
+   $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
+      if delete $self->{load_original};
+
    if (my $uniq = $path->uniq_path) {
       utf8::encode $uniq;
       if (aio_open $uniq, O_RDONLY, 0) {
@@ -1195,19 +1289,17 @@
 sub save {
    my ($self) = @_;
 
-   my $save = $self->{path}->save_path; utf8::encode $save;
-   my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
-
    $self->{last_save} = $cf::RUNTIME;
 
    return unless $self->dirty;
 
+   my $save = $self->{path}->save_path; utf8::encode $save;
+   my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
+
    $self->{load_path} = $save;
 
    return if $self->{deny_save};
 
-   warn "saving map ", $self->path;
-
    if ($uniq) {
       $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
       $self->save_objects ($uniq, cf::IO_UNIQUES);
@@ -1228,17 +1320,44 @@
    $self->in_memory (cf::MAP_SWAPPED);
 }
 
-sub should_reset {
-   my ($map) = @_;
+sub reset_at {
+   my ($self) = @_;
 
    # TODO: safety, remove and allow resettable per-player maps
-   return if $map->{path}{user_rel};#d#
-   return if $map->{deny_reset};
-   #return unless $map->reset_timeout;
+   return 1e99 if $self->{path}{user_rel};
+   return 1e99 if $self->{deny_reset};
+
+   my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
+   my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
+
+   $time + $to
+}
 
-   my $time = $map->fixed_resettime ? $map->{instantiate_time} : $map->last_access;
+sub should_reset {
+   my ($self) = @_;
 
-   $time + ($map->reset_timeout || $DEFAULT_RESET) < $cf::RUNTIME
+   $self->reset_at <= $cf::RUNTIME
+}
+
+sub unlink_save {
+   my ($self) = @_;
+
+   utf8::encode (my $save = $self->{path}->save_path);
+   aioreq_pri 3; IO::AIO::aio_unlink $save;
+   aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
+}
+
+sub rename {
+   my ($self, $new_path) = @_;
+
+   $self->unlink_save;
+
+   delete $cf::MAP{$self->path};
+   $self->{path} = new cf::path $new_path;
+   $self->path ($self->{path}->as_string);
+   $cf::MAP{$self->path} = $self;
+
+   $self->save;
 }
 
 sub reset {
@@ -1249,15 +1368,23 @@
 
    warn "resetting map ", $self->path;#d#
 
-   utf8::encode (my $save = $self->{path}->save_path);
-   aioreq_pri 3; IO::AIO::aio_unlink $save;
-   aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
+   delete $cf::MAP{$self->path};
 
    $_->clear_links_to ($self) for values %cf::MAP;
 
-   $self->clear;
-   $self->in_memory (cf::MAP_SWAPPED);
-   utf8::encode ($self->{load_path} = $self->{path}->load_path);
+   $self->unlink_save;
+   $self->destroy;
+}
+
+my $nuke_counter = "aaaa";
+
+sub nuke {
+   my ($self) = @_;
+
+   $self->{deny_save} = 1;
+   $self->reset_timeout (1);
+   $self->rename ("{nuke}/" . ($nuke_counter++));
+   $self->reset; # polite request, might not happen
 }
 
 sub customise_for {
@@ -1332,16 +1459,35 @@
          : $cf::CFG{"may_$access"})
 }
 
+=item $player_object->enter_link
+
+Freezes the player and moves him/her to a special map (C<{link}>).
+
+The player should be reaosnably safe there for short amounts of time. You
+I<MUST> call C<leave_link> as soon as possible, though.
+
+=item $player_object->leave_link ($map, $x, $y)
+
+Moves the player out of the specila link map onto the given map. If the
+map is not valid (or omitted), the player will be moved back to the
+location he/she was before the call to C<enter_link>, or, if that fails,
+to the emergency map position.
+
+Might block.
+
+=cut
+
 sub cf::object::player::enter_link {
    my ($self) = @_;
 
+   $self->deactivate_recursive;
+
    return if $self->map == $LINK_MAP;
 
-   $self->{_link_pos} = [$self->map->{path}, $self->x, $self->y]
+   $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
       if $self->map;
 
    $self->enter_map ($LINK_MAP, 20, 20);
-   $self->deactivate_recursive;
 }
 
 sub cf::object::player::leave_link {
@@ -1350,8 +1496,6 @@
    my $link_pos = delete $self->{_link_pos};
 
    unless ($map) {
-      $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
-
       # restore original map position
       ($map, $x, $y) = @{ $link_pos || [] };
       $map = cf::map::find_map $map;
@@ -1376,7 +1520,35 @@
    $self->enter_map ($map, $x, $y);
 }
 
-=item $player_object->goto_map ($map, $x, $y)
+cf::player->attach (
+   on_logout => sub {
+      my ($pl) = @_;
+
+      # abort map switching before logout
+      if ($pl->ob->{_link_pos}) {
+         cf::sync_job {
+            $pl->ob->leave_link
+         };
+      }
+   },
+   on_login => sub {
+      my ($pl) = @_;
+
+      # try to abort aborted map switching on player login :)
+      # should happen only on crashes
+      if ($pl->ob->{_link_pos}) {
+         $pl->ob->enter_link;
+         Coro::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
+            Coro::Timer::sleep 1;
+            $pl->ob->leave_link;
+         };
+      }
+   },
+);
+
+=item $player_object->goto_map ($path, $x, $y)
 
 =cut
 
@@ -1391,8 +1563,10 @@
       my $map = cf::map::find_map $path->as_string;
       $map = $map->customise_for ($self) if $map;
 
-      warn "entering ", $map->path, " at ($x, $y)\n"
-         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);
 
       $self->leave_link ($map, $x, $y);
    })->prio (1);
@@ -1743,14 +1917,12 @@
    my $path = cf::localdir . "/database.pst";
 
    sub db_load() {
-      warn "loading database $path\n";#d# remove later
       $DB = stat $path ? Storable::retrieve $path : { };
    }
 
    my $pid;
 
    sub db_save() {
-      warn "saving database $path\n";#d# remove later
       waitpid $pid, 0 if $pid;
       if (0 == ($pid = fork)) {
          $DB->{_meta}{version} = 1;
@@ -1813,7 +1985,7 @@
 sub main {
    # we must not ever block the main coroutine
    local $Coro::idle = sub {
-      Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
+      Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
       (Coro::unblock_sub {
          Event::one_event;
       })->();
@@ -1828,7 +2000,7 @@
 #############################################################################
 # initialisation
 
-sub perl_reload() {
+sub reload() {
    # can/must only be called in main
    if ($Coro::current != $Coro::main) {
       warn "can only reload from main coroutine\n";
@@ -1965,12 +2137,12 @@
 
 register "<global>", __PACKAGE__;
 
-register_command "perl-reload" => sub {
+register_command "reload" => sub {
    my ($who, $arg) = @_;
 
    if ($who->flag (FLAG_WIZ)) {
       $who->message ("start of reload.");
-      perl_reload;
+      reload;
       $who->message ("end of reload.");
    }
 };