--- deliantra/server/lib/cf.pm 2010/05/11 13:19:59 1.549 +++ deliantra/server/lib/cf.pm 2011/05/04 07:36:40 1.569 @@ -1,7 +1,7 @@ # # This file is part of Deliantra, the Roguelike Realtime MMORPG. # -# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team +# Copyright (©) 2006,2007,2008,2009,2010,2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team # # Deliantra is free software: you can redistribute it and/or modify it under # the terms of the Affero GNU General Public License as published by the @@ -95,10 +95,12 @@ our %REFLECT; # set by us our $CONFDIR = confdir; + our $DATADIR = datadir; our $LIBDIR = "$DATADIR/ext"; our $PODDIR = "$DATADIR/pod"; our $MAPDIR = "$DATADIR/" . mapdir; + our $LOCALDIR = localdir; our $TMPDIR = "$LOCALDIR/" . tmpdir; our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; @@ -317,6 +319,11 @@ ############################################################################# +sub fork_call(&@); +sub get_slot($;$$); + +############################################################################# + =head2 UTILITY FUNCTIONS =over 4 @@ -344,6 +351,20 @@ } || "[unable to dump $_[0]: '$@']"; } +=item $scalar = load_file $path + +Loads the given file from path and returns its contents. Croaks on error +and can block. + +=cut + +sub load_file($) { + 0 <= aio_load $_[0], my $data + or Carp::croak "$_[0]: $!"; + + $data +} + =item $ref = cf::decode_json $json Converts a JSON string into the corresponding perl data structure. @@ -359,18 +380,37 @@ sub encode_json($) { $json_coder->encode ($_[0]) } sub decode_json($) { $json_coder->decode ($_[0]) } -=item $ref = cf::yaml_load $scalar +=item $ref = cf::decode_storable $scalar -Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks). +Same as Coro::Storable::thaw, so blocks. =cut -sub fork_call(&@); +BEGIN { *decode_storable = \&Coro::Storable::thaw } + +=item $ref = cf::decode_yaml $scalar -sub yaml_load($) { +Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks). + +=cut + +sub decode_yaml($) { fork_call { YAML::XS::Load $_[0] } @_ } +=item $scalar = cf::unlzf $scalar + +Same as Compress::LZF::compress, but takes server ticks into account, so +blocks. + +=cut + +sub unlzf($) { + # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine) + cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf"; + Compress::LZF::decompress $_[0] +} + =item cf::post_init { BLOCK } Execute the given codeblock, I all extensions have been (re-)loaded, @@ -385,6 +425,23 @@ push @POST_INIT, shift; } +sub _post_init { + trace "running post_init jobs"; + + # run them in parallel... + + my @join; + + while () { + push @join, map &Coro::async ($_, 0), @POST_INIT; + @POST_INIT = (); + + @join or last; + + (pop @join)->join; + } +} + =item cf::lock_wait $string Wait until the given lock is available. See cf::lock_acquire. @@ -445,9 +502,13 @@ =item cf::get_slot $time[, $priority[, $name]] -Allocate $time seconds of blocking CPU time at priority C<$priority>: -This call blocks and returns only when you have at least C<$time> seconds -of cpu time till the next tick. The slot is only valid till the next cede. +Allocate $time seconds of blocking CPU time at priority C<$priority> +(default: 0): This call blocks and returns only when you have at least +C<$time> seconds of cpu time till the next tick. The slot is only valid +till the next cede. + +Background jobs should use a priority les than zero, interactive jobs +should use 100 or more. The optional C<$name> can be used to identify the job to run. It might be used for statistical purposes and should identify the same time-class. @@ -752,8 +813,7 @@ my $md5; for (0 .. $#$src) { - 0 <= aio_load $src->[$_], $data[$_] - or Carp::croak "$src->[$_]: $!"; + $data[$_] = load_file $src->[$_]; } # if processing is expensive, check @@ -1497,6 +1557,8 @@ cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting." if exists $v->{meta}{mandatory}; } + + last; } } }; @@ -1846,20 +1908,7 @@ my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM - # mit "rum" bekleckern, nicht - $self->_create_random_map ( - $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, - $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle}, - $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, - $rmp->{exit_on_final_map}, - $rmp->{xsize}, $rmp->{ysize}, - $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, - $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, - $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, - $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, - $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, - (cf::region::find $rmp->{region}), $rmp->{custom} - ) + $self->_create_random_map ($rmp); } =item cf::map->register ($regex, $prio) @@ -1920,7 +1969,6 @@ } for ($path) { - redo if s{//}{/}; redo if s{/\.?/}{/}; redo if s{/[^/]+/\.\./}{/}; } @@ -1948,6 +1996,7 @@ () } +# may re-bless or do other evil things sub init { my ($self) = @_; @@ -2022,18 +2071,21 @@ 1 } +# used to laod the header of an original map sub load_header_orig { my ($self) = @_; $self->load_header_from ($self->load_path) } +# used to laod the header of an instantiated map sub load_header_temp { my ($self) = @_; $self->load_header_from ($self->save_path) } +# called after loading the header from an instantiated map sub prepare_temp { my ($self) = @_; @@ -2044,6 +2096,7 @@ if $self->{instantiate_time} > $cf::RUNTIME; } +# called after loading the header from an original map sub prepare_orig { my ($self) = @_; @@ -2079,7 +2132,7 @@ cf::cede_to_tick; - $path = normalise $path, $origin && $origin->path; + $path = normalise $path, $origin; my $guard1 = cf::lock_acquire "map_data:$path";#d#remove my $guard2 = cf::lock_acquire "map_find:$path"; @@ -2122,33 +2175,38 @@ return unless $self->valid; return unless $self->in_memory == cf::MAP_SWAPPED; - $self->in_memory (cf::MAP_LOADING); - $self->alloc; $self->pre_load; cf::cede_to_tick; - my $f = new_from_file cf::object::thawer $self->{load_path}; - $f->skip_block; - $self->_load_objects ($f) - or return; + if (exists $self->{load_path}) { + my $f = new_from_file cf::object::thawer $self->{load_path}; + $f->skip_block; + $self->_load_objects ($f) + or return; - $self->post_load_original - if delete $self->{load_original}; + $self->post_load_original + if delete $self->{load_original}; - if (my $uniq = $self->uniq_path) { - utf8::encode $uniq; - unless (aio_stat $uniq) { - if (my $f = new_from_file cf::object::thawer $uniq) { - $self->clear_unique_items; - $self->_load_objects ($f); - $f->resolve_delayed_derefs; + if (my $uniq = $self->uniq_path) { + utf8::encode $uniq; + unless (aio_stat $uniq) { + if (my $f = new_from_file cf::object::thawer $uniq) { + $self->clear_unique_items; + $self->_load_objects ($f); + $f->resolve_delayed_derefs; + } } } + + $f->resolve_delayed_derefs; + } else { + $self->post_load_original + if delete $self->{load_original}; } - $f->resolve_delayed_derefs; + $self->in_memory (cf::MAP_INACTIVE); cf::cede_to_tick; # now do the right thing for maps @@ -2162,16 +2220,16 @@ $self->fix_auto_apply; $self->update_buttons; cf::cede_to_tick; - $self->activate; + #$self->activate; # no longer activate maps automatically } $self->{last_save} = $cf::RUNTIME; $self->last_access ($cf::RUNTIME); - - $self->in_memory (cf::MAP_ACTIVE); } $self->post_load; + + 1 } # customize the map for a given player, i.e. @@ -2219,6 +2277,7 @@ sub find_sync { my ($path, $origin) = @_; + # it's a bug to call this from the main context return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" if $Coro::current == $Coro::main; @@ -2228,6 +2287,7 @@ sub do_load_sync { my ($map) = @_; + # it's a bug to call this from the main context return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync" if $Coro::current == $Coro::main; @@ -2240,10 +2300,10 @@ sub find_async { my ($path, $origin, $load) = @_; - $path = normalise $path, $origin && $origin->{path}; - + $path = normalise $path, $origin; + if (my $map = $cf::MAP{$path}) { - return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; + return $map if !$load || $map->linkable; } $MAP_PREFETCH{$path} |= $load; @@ -2312,7 +2372,7 @@ my $lock = cf::lock_acquire "map_data:$self->{path}"; - return if $self->in_memory != cf::MAP_ACTIVE; + return if !$self->linkable; return if $self->{deny_save}; return if $self->players; @@ -2761,7 +2821,7 @@ } my $map = eval { - my $map = defined $path ? cf::map::find $path : undef; + my $map = defined $path ? cf::map::find $path, $self->map : undef; if ($map) { $map = $map->customise_for ($self); @@ -2861,17 +2921,32 @@ unless (eval { $self->deactivate_recursive; # just to be sure - # random map handling - { + my $map = cf::map::normalise $exit->slaying, $exit->map; + my $x = $exit->stats->hp; + my $y = $exit->stats->sp; + + # special map handling + my $slaying = $exit->slaying; + + # special map handling + if ($slaying eq "/!") { my $guard = cf::lock_acquire "exit_prepare:$exit"; prepare_random_map $exit - if $exit->slaying eq "/!"; - } + if $exit->slaying eq "/!"; # need to re-check after getting the lock - my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; - my $x = $exit->stats->hp; - my $y = $exit->stats->sp; + $map = $exit->slaying; + + } elsif ($slaying eq '!up') { + $map = $exit->map->tile_path (cf::TILE_UP); + $x = $exit->x; + $y = $exit->y; + + } elsif ($slaying eq '!down') { + $map = $exit->map->tile_path (cf::TILE_DOWN); + $x = $exit->x; + $y = $exit->y; + } $self->goto ($map, $x, $y); @@ -3396,10 +3471,7 @@ trace "loading facedata from $path\n"; - 0 < aio_load $path, my $facedata - or die "$path: $!"; - - $facedata = Coro::Storable::thaw $facedata; + my $facedata = decode_storable load_file $path; $facedata->{version} == 2 or cf::cleanup "$path: version mismatch, cannot proceed."; @@ -3423,6 +3495,7 @@ cf::face::set_magicmap $idx, $info->{magicmap}; cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; + cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; cf::cede_to_tick; } @@ -3527,10 +3600,7 @@ sub reload_sound { trace "loading sound config from $DATADIR/sound\n"; - 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data - or die "$DATADIR/sound $!"; - - my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data); + my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound"); for (0 .. SOUND_CAST_SPELL_0 - 1) { my $sound = $soundconf->{compat}[$_] @@ -3564,11 +3634,9 @@ sub reload_config { trace "reloading config file...\n"; - 0 < aio_load "$CONFDIR/config", my $config - or die "$CONFDIR/config: $!"; - + my $config = load_file "$CONFDIR/config"; utf8::decode $config; - *CFG = yaml_load $config; + *CFG = decode_yaml $config; $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38]; @@ -3616,7 +3684,7 @@ cf::init_globals; # initialise logging LOG llevInfo, "Welcome to Deliantra, v" . VERSION; - LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; + LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; @@ -3662,7 +3730,7 @@ use POSIX (); POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; - (pop @POST_INIT)->(0) while @POST_INIT; + cf::_post_init 0; }; cf::object::thawer::errors_are_fatal 0; @@ -3895,25 +3963,25 @@ while ($RELOAD) { cf::get_slot 0.1, -1, "reload_perl"; - info "reloading..."; + info "perl_reload: reloading..."; - trace "entering sync_job"; + trace "perl_reload: entering sync_job"; cf::sync_job { #cf::emergency_save; - trace "cancelling all extension coros"; + trace "perl_reload: cancelling all extension coros"; $_->cancel for values %EXT_CORO; %EXT_CORO = (); - trace "removing commands"; + trace "perl_reload: removing commands"; %COMMAND = (); - trace "removing ext/exti commands"; + trace "perl_reload: removing ext/exti commands"; %EXTCMD = (); %EXTICMD = (); - trace "unloading/nuking all extensions"; + trace "perl_reload: unloading/nuking all extensions"; for my $pkg (@EXTS) { trace "... unloading $pkg"; @@ -3928,7 +3996,7 @@ clear_package $pkg; } - trace "unloading all perl modules loaded from $LIBDIR"; + trace "perl_reload: unloading all perl modules loaded from $LIBDIR"; while (my ($k, $v) = each %INC) { next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; @@ -3945,11 +4013,11 @@ clear_package $k; } - trace "getting rid of safe::, as good as possible"; + trace "perl_reload: getting rid of safe::, as good as possible"; clear_package "safe::$_" for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); - trace "unloading cf.pm \"a bit\""; + trace "perl_reload: unloading cf.pm \"a bit\""; delete $INC{"cf.pm"}; delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; @@ -3957,44 +4025,42 @@ # and global variables created in xs #clear_package __PACKAGE__; - info "unload completed, starting to reload now"; + info "perl_reload: unload completed, starting to reload now"; - trace "reloading cf.pm"; + trace "perl_reload: reloading cf.pm"; require cf; cf::_connect_to_perl_1; - trace "loading config and database again"; + trace "perl_reload: loading config and database again"; cf::reload_config; - trace "loading extensions"; + trace "perl_reload: loading extensions"; cf::load_extensions; if ($REATTACH_ON_RELOAD) { - trace "reattaching attachments to objects/players"; + trace "perl_reload: reattaching attachments to objects/players"; _global_reattach; # objects, sockets - trace "reattaching attachments to maps"; + trace "perl_reload: reattaching attachments to maps"; reattach $_ for values %MAP; - trace "reattaching attachments to players"; + trace "perl_reload: reattaching attachments to players"; reattach $_ for values %PLAYER; } - trace "running post_init jobs"; - (pop @POST_INIT)->(1) while @POST_INIT; + cf::_post_init 1; - trace "leaving sync_job"; + trace "perl_reload: leaving sync_job"; 1 } or do { error $@; - cf::cleanup "error while reloading, exiting."; + cf::cleanup "perl_reload: error, exiting."; }; - info "reloaded"; --$RELOAD; } $t1 = AE::time - $t1; - info "reload completed in ${t1}s\n"; + info "perl_reload: completed in ${t1}s\n"; }; our $RELOAD_WATCHER; # used only during reload @@ -4137,15 +4203,20 @@ undef $AnyEvent::AIO::WATCHER; } -my $_log_backtrace; +our $_log_backtrace; +our $_log_backtrace_last; sub _log_backtrace { my ($msg, @addr) = @_; - $msg =~ s/\n//; + $msg =~ s/\n$//; + if ($_log_backtrace_last eq $msg) { + LOG llevInfo, "[ABT] $msg\n"; + LOG llevInfo, "[ABT] [duplicate, suppressed]\n"; # limit the # of concurrent backtraces - if ($_log_backtrace < 2) { + } elsif ($_log_backtrace < 2) { + $_log_backtrace_last = $msg; ++$_log_backtrace; my $perl_bt = Carp::longmess $msg; async { @@ -4175,7 +4246,7 @@ }; } else { LOG llevInfo, "[ABT] $msg\n"; - LOG llevInfo, "[ABT] [suppressed]\n"; + LOG llevInfo, "[ABT] [overload, suppressed]\n"; } }