--- deliantra/server/lib/cf.pm 2007/05/19 00:08:11 1.267 +++ deliantra/server/lib/cf.pm 2007/06/16 14:35:41 1.280 @@ -189,7 +189,8 @@ @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'; +@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object'; +@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet) # we bless all objects into (empty) derived classes to force a method lookup # within the Safe compartment. @@ -397,9 +398,7 @@ # first touch the runtime file to show we are still running: # the fsync below can take a very very long time. - if (my $fh = aio_open $runtime, O_WRONLY, 0) { - utime undef, undef, $fh; - } + IO::AIO::aio_utime $runtime, undef, undef; my $guard = cf::lock_acquire "write_runtime"; @@ -418,7 +417,7 @@ and return; # touch it again to show we are up-to-date - utime undef, undef, $fh; + aio_utime $fh, undef, undef; close $fh or return; @@ -426,7 +425,7 @@ aio_rename "$runtime~", $runtime and return; - warn "runtime file written.\n";#d# + warn "runtime file written.\n"; 1 } @@ -668,7 +667,7 @@ $obj->{$name} = \%arg; } else { - warn "object uses attachment '$name' that is not available, postponing.\n"; + warn "object uses attachment '$name' which is not available, postponing.\n"; } $obj->{_attachment}{$name} = undef; @@ -876,7 +875,7 @@ } warn sprintf "loading %s (%d)\n", - $filename, length $data, scalar @{$av || []};#d# + $filename, length $data, scalar @{$av || []}; return ($data, $av); } @@ -946,48 +945,77 @@ }, ); -sub load_extension { - my ($path) = @_; +sub load_extensions { + cf::sync_job { + my %todo; - $path =~ /([^\/\\]+)\.ext$/ or die "$path"; - my $base = $1; - my $pkg = $1; - $pkg =~ s/[^[:word:]]/_/g; - $pkg = "ext::$pkg"; + for my $path (<$LIBDIR/*.ext>) { + next unless -r $path; - warn "... loading '$path' into '$pkg'\n"; + $path =~ /([^\/\\]+)\.ext$/ or die "$path"; + my $base = $1; + my $pkg = $1; + $pkg =~ s/[^[:word:]]/_/g; + $pkg = "ext::$pkg"; - open my $fh, "<:utf8", $path - or die "$path: $!"; + open my $fh, "<:utf8", $path + or die "$path: $!"; + + my $source = do { local $/; <$fh> }; - my $source = - "package $pkg; use strict; use utf8;\n" - . "#line 1 \"$path\"\n{\n" - . (do { local $/; <$fh> }) - . "\n};\n1"; - - unless (eval $source) { - my $msg = $@ ? "$path: $@\n" - : "extension disabled.\n"; - if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match - warn $@; - warn "mandatory extension failed to load, exiting.\n"; - exit 1; + my %ext = ( + path => $path, + base => $base, + pkg => $pkg, + ); + + $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } + if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; + + $ext{source} = + "package $pkg; use strict; use utf8;\n" + . "#line 1 \"$path\"\n{\n" + . $source + . "\n};\n1"; + + $todo{$base} = \%ext; } - die $@; - } - push @EXTS, $pkg; -} + my %done; + while (%todo) { + my $progress; -sub load_extensions { - for my $ext (<$LIBDIR/*.ext>) { - next unless -r $ext; - eval { - load_extension $ext; - 1 - } or warn "$ext not loaded: $@"; - } + while (my ($k, $v) = each %todo) { + for (split /,\s*/, $v->{meta}{depends}) { + goto skip + unless exists $done{$_}; + } + + warn "... loading '$k' into '$v->{pkg}'\n"; + + unless (eval $v->{source}) { + my $msg = $@ ? "$v->{path}: $@\n" + : "$v->{base}: extension inactive.\n"; + + if (exists $v->{meta}{mandatory}) { + warn $msg; + warn "mandatory extension failed to load, exiting.\n"; + exit 1; + } + + warn $msg; + } + + $done{$k} = delete $todo{$k}; + push @EXTS, $v->{pkg}; + $progress = 1; + } + + skip: + die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" + unless $progress; + } + }; } ############################################################################# @@ -1308,8 +1336,6 @@ # we have to keep some variables in memory intact local $self->{path}; local $self->{load_path}; - local $self->{deny_save}; - local $self->{deny_reset}; $self->SUPER::thawer_merge ($merge); } @@ -1419,6 +1445,14 @@ for grep $_->outdoor, values %cf::MAP; } +sub decay_objects { + my ($self) = @_; + + return if $self->{deny_reset}; + + $self->do_decay_objects; +} + sub unlink_save { my ($self) = @_; @@ -1484,6 +1518,9 @@ $self->prepare_orig; } + $self->{deny_reset} = 1 + if $self->no_reset; + $self->default_region (cf::region::find_by_path $self->{path}) unless $self->default_region; @@ -1508,7 +1545,7 @@ $map->load_header or return; - if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) + if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) # doing this can freeze the server in a sync job, obviously #$cf::WAIT_FOR_TICK->wait; $map->reset; @@ -1585,6 +1622,9 @@ return find "~" . $ob->name . "/" . $self->{path} if $self->per_player; +# return find "?party/" . $ob->name . "/" . $self->{path} +# if $self->per_party; + $self } @@ -1704,7 +1744,6 @@ my ($self) = @_; # TODO: safety, remove and allow resettable per-player maps - return 1e99 if $self->isa ("ext::map_per_player");#d# return 1e99 if $self->{deny_reset}; my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; @@ -1725,9 +1764,8 @@ my $lock = cf::lock_acquire "map_data:$self->{path}"; return if $self->players; - return if $self->isa ("ext::map_per_player");#d# - warn "resetting map ", $self->path;#d# + warn "resetting map ", $self->path; $self->in_memory (cf::MAP_SWAPPED); @@ -1769,28 +1807,58 @@ $self->reset; # polite request, might not happen } -=item cf::map::unique_maps +=item $maps = cf::map::tmp_maps -Returns an arrayref of paths of all shared maps that have -instantiated unique items. May block. +Returns an arrayref with all map paths of currently instantiated and saved +maps. May block. =cut -sub unique_maps() { - my $files = aio_readdir $UNIQUEDIR - or return; +sub tmp_maps() { + [ + map { + utf8::decode $_; + /\.map$/ + ? normalise $_ + : () + } @{ aio_readdir $TMPDIR or [] } + ] +} - my @paths; +=item $maps = cf::map::random_maps - for (@$files) { - utf8::decode $_; - next if /\.pst$/; - next unless /^$PATH_SEP/o; +Returns an arrayref with all map paths of currently instantiated and saved +random maps. May block. - push @paths, cf::map::normalise $_; - } +=cut - \@paths +sub random_maps() { + [ + map { + utf8::decode $_; + /\.map$/ + ? normalise "?random/$_" + : () + } @{ aio_readdir $RANDOMDIR or [] } + ] +} + +=item cf::map::unique_maps + +Returns an arrayref of paths of all shared maps that have +instantiated unique items. May block. + +=cut + +sub unique_maps() { + [ + map { + utf8::decode $_; + /\.map$/ + ? normalise $_ + : () + } @{ aio_readdir $UNIQUEDIR or [] } + ] } package cf; @@ -1906,7 +1974,7 @@ return if UNIVERSAL::isa $self->map, "ext::map_link"; $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] - if $self->map; + if $self->map && $self->map->{path} ne "{link}"; $self->enter_map ($LINK_MAP || link_map, 10, 10); } @@ -1914,6 +1982,8 @@ sub cf::object::player::leave_link { my ($self, $map, $x, $y) = @_; + return unless $self->contr->active; + my $link_pos = delete $self->{_link_pos}; unless ($map) { @@ -1945,56 +2015,48 @@ $self->enter_map ($map, $x, $y); } -cf::player->attach ( - on_logout => sub { - my ($pl) = @_; +=item $player_object->goto ($path, $x, $y[, $check->($map)]) - # 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; - (async { - $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); - # 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; - })->prio (2); - } - }, -); - -=item $player_object->goto ($path, $x, $y) +Moves the player to the given map-path and coordinates by first freezing +her, loading and preparing them map, calling the provided $check callback +that has to return the map if sucecssful, and then unfreezes the player on +the new (success) or old (failed) map position. =cut +our $GOTOGEN; + sub cf::object::player::goto { - my ($self, $path, $x, $y) = @_; + my ($self, $path, $x, $y, $check) = @_; + + # do generation counting so two concurrent goto's will be executed in-order + my $gen = $self->{_goto_generation} = ++$GOTOGEN; $self->enter_link; (async { my $map = eval { my $map = cf::map::find $path; - $map = $map->customise_for ($self) if $map; + + if ($map) { + $map = $map->customise_for ($self); + $map = $check->($map) if $check && $map; + } else { + $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); + } + $map - } or - $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); + }; - $self->leave_link ($map, $x, $y); + if ($@) { + $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED); + LOG llevError | logBacktrace, Carp::longmess $@; + } + + if ($gen == $self->{_goto_generation}) { + delete $self->{_goto_generation}; + $self->leave_link ($map, $x, $y); + } })->prio (1); } @@ -2489,8 +2551,6 @@ } } - - ############################################################################# # the server's init and main functions @@ -2571,6 +2631,7 @@ reload_regions; reload_facedata; + #reload_archetypes;#d# reload_archetypes; reload_treasures; @@ -2850,6 +2911,8 @@ $signal->wait; } + my $min = 1e6;#d# + my $avg = 10; $TICK_WATCHER = Event->timer ( reentrant => 0, parked => 1, @@ -2867,6 +2930,29 @@ cf::server_tick; # one server iteration + 0 && sync_job {#d# + for(1..10) { + my $t = Event::time; + my $map = my $map = new_from_path cf::map "/tmp/x.map" + or die; + + $map->width (50); + $map->height (50); + $map->alloc; + $map->_load_objects ("/tmp/x.map", 1); + my $t = Event::time - $t; + + #next unless $t < 0.0013;#d# + if ($t < $min) { + $min = $t; + } + $avg = $avg * 0.99 + $t * 0.01; + } + warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d# + exit 0; + # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477 + }; + $RUNTIME += $TICK; $NEXT_TICK += $TICK;