--- deliantra/server/lib/cf.pm 2008/09/22 05:42:41 1.451 +++ deliantra/server/lib/cf.pm 2009/10/08 05:09:43 1.480 @@ -23,7 +23,7 @@ use 5.10.0; use utf8; -use strict "vars", "subs"; +use strict qw(vars subs); use Symbol; use List::Util; @@ -34,6 +34,7 @@ use Safe::Hole; use Storable (); +use Guard (); use Coro (); use Coro::State; use Coro::Handle; @@ -42,6 +43,7 @@ use Coro::Timer; use Coro::Signal; use Coro::Semaphore; +use Coro::SemaphoreSet; use Coro::AnyEvent; use Coro::AIO; use Coro::BDB 1.6; @@ -72,6 +74,9 @@ Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve"; Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later +# strictly for debugging +$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; + sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload our %COMMAND = (); @@ -85,6 +90,8 @@ our $RELOAD; # number of reloads so far, non-zero while in reload our @EVENT; +our @REFLECT; # set by XS +our %REFLECT; # set by us our $CONFDIR = confdir; our $DATADIR = datadir; @@ -105,13 +112,15 @@ our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) our $NEXT_RUNTIME_WRITE; # when should the runtime file be written our $NEXT_TICK; -our $USE_FSYNC = 1; # use fsync to write maps - default off +our $USE_FSYNC = 1; # use fsync to write maps - default on our $BDB_DEADLOCK_WATCHER; our $BDB_CHECKPOINT_WATCHER; our $BDB_TRICKLE_WATCHER; our $DB_ENV; +our @EXTRA_MODULES = qw(pod mapscript); + our %CFG; our $UPTIME; $UPTIME ||= time; @@ -130,6 +139,11 @@ our $JITTER; # average jitter our $TICK_START; # for load detecting purposes +our @POST_INIT; + +our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) +our $REALLY_UNLOOP; # never set to true, please :) + binmode STDOUT; binmode STDERR; @@ -140,6 +154,8 @@ $RUNTIME = <$fh> + 0.; } +eval "sub TICK() { $TICK } 1" or die; + mkdir $_ for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; @@ -149,6 +165,17 @@ ############################################################################# +%REFLECT = (); +for (@REFLECT) { + my $reflect = JSON::XS::decode_json $_; + $REFLECT{$reflect->{class}} = $reflect; +} + +# this is decidedly evil +$REFLECT{object}{flags} = [grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"}]; + +############################################################################# + =head2 GLOBAL VARIABLES =over 4 @@ -206,38 +233,41 @@ C is called C<@cf::INVOKE_RESULTS> is set to the parameters of that call. +=item %cf::REFLECT + +Contains, for each (C++) class name, a hash reference with information +about object members (methods, scalars, arrays and flags) and other +metadata, which is useful for introspection. + =back =cut -BEGIN { - *CORE::GLOBAL::warn = sub { - my $msg = join "", @_; +$Coro::State::WARNHOOK = sub { + my $msg = join "", @_; - $msg .= "\n" - unless $msg =~ /\n$/; + $msg .= "\n" + unless $msg =~ /\n$/; - $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; + $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; - LOG llevError, $msg; - }; -} + LOG llevError, $msg; +}; $Coro::State::DIEHOOK = sub { return unless $^S eq 0; # "eq", not "==" + warn Carp::longmess $_[0]; + if ($Coro::current == $Coro::main) {#d# warn "DIEHOOK called in main context, Coro bug?\n";#d# return;#d# }#d# # kill coroutine otherwise - warn Carp::longmess $_[0]; Coro::terminate }; -$SIG{__DIE__} = sub { }; #d#? - @safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; @safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; @safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; @@ -307,6 +337,20 @@ sub encode_json($) { $json_coder->encode ($_[0]) } sub decode_json($) { $json_coder->decode ($_[0]) } +=item cf::post_init { BLOCK } + +Execute the given codeblock, I all extensions have been (re-)loaded, +but I the server starts ticking again. + +The cdoeblock will have a single boolean argument to indicate whether this +is a reload or not. + +=cut + +sub post_init(&) { + push @POST_INIT, shift; +} + =item cf::lock_wait $string Wait until the given lock is available. See cf::lock_acquire. @@ -314,7 +358,7 @@ =item my $lock = cf::lock_acquire $string Wait until the given lock is available and then acquires it and returns -a Coro::guard object. If the guard object gets destroyed (goes out of scope, +a L object. If the guard object gets destroyed (goes out of scope, for example when the coroutine gets canceled), the lock is automatically returned. @@ -330,51 +374,24 @@ =cut -our %LOCK; -our %LOCKER;#d# +our $LOCKS = new Coro::SemaphoreSet; sub lock_wait($) { - my ($key) = @_; - - if ($LOCKER{$key} == $Coro::current) {#d# - Carp::cluck "lock_wait($key) for already-acquired lock";#d# - return;#d# - }#d# - - # wait for lock, if any - while ($LOCK{$key}) { - #local $Coro::current->{desc} = "$Coro::current->{desc} "; - push @{ $LOCK{$key} }, $Coro::current; - Coro::schedule; - } + $LOCKS->wait ($_[0]); } sub lock_acquire($) { - my ($key) = @_; - - # wait, to be sure we are not locked - lock_wait $key; - - $LOCK{$key} = []; - $LOCKER{$key} = $Coro::current;#d# - - Coro::guard { - delete $LOCKER{$key};#d# - # wake up all waiters, to be on the safe side - $_->ready for @{ delete $LOCK{$key} }; - } + $LOCKS->guard ($_[0]) } sub lock_active($) { - my ($key) = @_; - - ! ! $LOCK{$key} + $LOCKS->count ($_[0]) < 1 } sub freeze_mainloop { tick_inhibit_inc; - Coro::guard \&tick_inhibit_dec; + &Guard::guard (\&tick_inhibit_dec); } =item cf::periodic $interval, $cb @@ -1156,7 +1173,10 @@ if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { aio_chmod $fh, SAVE_MODE; aio_write $fh, 0, (length $$rdata), $$rdata, 0; - aio_fsync $fh if $cf::USE_FSYNC; + if ($cf::USE_FSYNC) { + aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER; + aio_fsync $fh; + } aio_close $fh; if (@$objs) { @@ -1164,7 +1184,10 @@ aio_chmod $fh, SAVE_MODE; my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; aio_write $fh, 0, (length $data), $data, 0; - aio_fsync $fh if $cf::USE_FSYNC; + if ($cf::USE_FSYNC) { + aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER; + aio_fsync $fh; + } aio_close $fh; aio_rename "$filename.pst~", "$filename.pst"; } @@ -1173,8 +1196,11 @@ } aio_rename "$filename~", $filename; + + $filename =~ s%/[^/]+$%%; + aio_pathsync $filename if $cf::USE_FSYNC; } else { - warn "FATAL: $filename~: $!\n"; + warn "unable to save objects: $filename~: $!\n"; } } else { aio_unlink $filename; @@ -1275,6 +1301,8 @@ $EXTICMD{$name} = $cb; } +use File::Glob (); + cf::player->attach ( on_command => sub { my ($pl, $name, $params) = @_; @@ -1316,6 +1344,19 @@ }, ); +# "readahead" all extensions +sub cache_extensions { + my $grp = IO::AIO::aio_group; + + add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub { + for (grep /\.ext$/, @{$_[0]}) { + add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; + } + }; + + $grp +} + sub load_extensions { cf::sync_job { my %todo; @@ -1447,7 +1488,7 @@ my ($login) = @_; $cf::PLAYER{$login} - or cf::sync_job { !aio_stat path $login } + or !aio_stat path $login } sub find($) { @@ -1853,15 +1894,6 @@ "$UNIQUEDIR/$path" } -# and all this just because we cannot iterate over -# all maps in C++... -sub change_all_map_light { - my ($change) = @_; - - $_->change_map_light ($change) - for grep $_->outdoor, values %cf::MAP; -} - sub decay_objects { my ($self) = @_; @@ -1953,13 +1985,10 @@ $path = normalise $path, $origin && $origin->path; - cf::lock_wait "map_data:$path";#d#remove - cf::lock_wait "map_find:$path"; + my $guard1 = cf::lock_acquire "map_data:$path";#d#remove + my $guard2 = cf::lock_acquire "map_find:$path"; $cf::MAP{$path} || do { - my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it - my $guard2 = cf::lock_acquire "map_find:$path"; - my $map = new_from_path cf::map $path or return; @@ -2037,8 +2066,6 @@ $self->fix_auto_apply; $self->update_buttons; cf::cede_to_tick; - $self->set_darkness_map; - cf::cede_to_tick; $self->activate; } @@ -2214,7 +2241,7 @@ return if $self->players; - warn "resetting map ", $self->path; + warn "resetting map ", $self->path, "\n"; $self->in_memory (cf::MAP_SWAPPED); @@ -2389,7 +2416,7 @@ id => "say", title => "Map", reply => "say ", - tooltip => "Things said to and replied from npcs near you and other players on the same map only.", + tooltip => "Things said to and replied from NPCs near you and other players on the same map only.", }; our $CHAT_CHANNEL = { @@ -2525,11 +2552,12 @@ $map->load_neighbours; return unless $self->contr->active; - $self->flag (cf::FLAG_DEBUG, 0);#d# temp - $self->activate_recursive; local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext $self->enter_map ($map, $x, $y); + + # only activate afterwards, to support waiting in hooks + $self->activate_recursive; } =item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) @@ -2774,12 +2802,42 @@ reply => undef, tooltip => "Shows which body parts you posess and are available", }, + "c/statistics" => { + id => "infobox", + title => "Statistics", + reply => undef, + tooltip => "Shows your primary statistics", + }, "c/skills" => { id => "infobox", title => "Skills", reply => undef, tooltip => "Shows your experience per skill and item power", }, + "c/shopitems" => { + id => "infobox", + title => "Shop Items", + reply => undef, + tooltip => "Shows the items currently for sale in this shop", + }, + "c/resistances" => { + id => "infobox", + title => "Resistances", + reply => undef, + tooltip => "Shows your resistances", + }, + "c/pets" => { + id => "infobox", + title => "Pets", + reply => undef, + tooltip => "Shows information abotu your pets/a specific pet", + }, + "c/perceiveself" => { + id => "infobox", + title => "Perceive Self", + reply => undef, + tooltip => "You gained detailed knowledge about yourself", + }, "c/uptime" => { id => "infobox", title => "Uptime", @@ -2798,6 +2856,14 @@ reply => "gsay ", tooltip => "Messages and chat related to your party", }, + "c/death" => { + id => "death", + title => "Death", + reply => undef, + tooltip => "Reason for and more info about your most recent death", + }, + "c/say" => $SAY_CHANNEL, + "c/chat" => $CHAT_CHANNEL, ); sub cf::client::send_msg { @@ -2812,17 +2878,14 @@ if ($CHANNEL{$channel}) { $channel = $CHANNEL{$channel}; - $self->ext_msg (channel_info => $channel) - if $self->can_msg; - + $self->ext_msg (channel_info => $channel); $channel = $channel->{id}; } elsif (ref $channel) { # send meta info to client, if not yet sent unless (exists $self->{channel}{$channel->{id}}) { $self->{channel}{$channel->{id}} = $channel; - $self->ext_msg (channel_info => $channel) - if $self->can_msg; + $self->ext_msg (channel_info => $channel); } $channel = $channel->{id}; @@ -2830,52 +2893,26 @@ return unless @extra || length $msg; - if ($self->can_msg) { - # default colour, mask it out - $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) - if $color & cf::NDI_DEF; - - my $pkt = "msg " - . $self->{json_coder}->encode ( - [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] - ); - - # try lzf for large packets - $pkt = "lzf " . Compress::LZF::compress $pkt - if 1024 <= length $pkt and $self->{can_lzf}; - - # split very large packets - if (8192 < length $pkt and $self->{can_lzf}) { - $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt; - $pkt = "frag"; - } - - $self->send_packet ($pkt); - } else { - if ($color >= 0) { - # replace some tags by gcfclient-compatible ones - for ($msg) { - 1 while - s/([^<]*)<\/b>/[b]${1}[\/b]/ - || s/([^<]*)<\/i>/[i]${1}[\/i]/ - || s/([^<]*)<\/u>/[ul]${1}[\/ul]/ - || s/([^<]*)<\/tt>/[fixed]${1}[\/fixed]/ - || s/([^<]*)<\/fg>/[color=$1]${2}[\/color]/; - } - - $color &= cf::NDI_COLOR_MASK; - - utf8::encode $msg; - - if (0 && $msg =~ /\[/) { - # COMMAND/INFO - $self->send_packet ("drawextinfo $color 10 8 $msg") - } else { - $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; - $self->send_packet ("drawinfo $color $msg") - } - } + # default colour, mask it out + $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) + if $color & cf::NDI_DEF; + + my $pkt = "msg " + . $self->{json_coder}->encode ( + [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] + ); + + # try lzf for large packets + $pkt = "lzf " . Compress::LZF::compress $pkt + if 1024 <= length $pkt and $self->{can_lzf}; + + # split very large packets + if (8192 < length $pkt and $self->{can_lzf}) { + $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt; + $pkt = "frag"; } + + $self->send_packet ($pkt); } =item $client->ext_msg ($type, @msg) @@ -3060,6 +3097,7 @@ cf::object contr pay_amount pay_player map x y force_find force_add destroy insert remove name archname title slaying race decrease split + value cf::object::player player @@ -3075,9 +3113,9 @@ for ( ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y insert remove inv nrof name archname title slaying race - decrease split destroy change_exp)], + decrease split destroy change_exp value msg lore send_msg)], ["cf::object::player" => qw(player)], - ["cf::player" => qw(peaceful)], + ["cf::player" => qw(peaceful send_msg)], ["cf::map" => qw(trigger)], ) { no strict 'refs'; @@ -3105,6 +3143,8 @@ $qcode =~ s/"/‟/g; # not allowed in #line filenames $qcode =~ s/\n/\\n/g; + %vars = (_dummy => 0) unless %vars; + local $_; local @safe::cf::_safe_eval_args = values %vars; @@ -3343,14 +3383,6 @@ warn "finished reloading resource files\n"; } -sub init { - my $guard = freeze_mainloop; - - evthread_start IO::AIO::poll_fileno; - - reload_resources; -} - sub reload_config { open my $fh, "<:utf8", "$CONFDIR/config" or return; @@ -3391,8 +3423,29 @@ print $fh $$; } +sub main_loop { + warn "EV::loop starting\n"; + if (1) { + EV::loop; + } + warn "EV::loop returned\n"; + goto &main_loop unless $REALLY_UNLOOP; +} + sub main { - atomic; + cf::init_globals; # initialise logging + + LOG llevInfo, "Welcome to Deliantra, v" . VERSION; + LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; + LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; + LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; + + cf::init_experience; + cf::init_anim; + cf::init_attackmess; + cf::init_dynamic; + + $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority # we must not ever block the main coroutine local $Coro::idle = sub { @@ -3403,21 +3456,36 @@ })->prio (Coro::PRIO_MAX); }; - { - my $guard = freeze_mainloop; + evthread_start IO::AIO::poll_fileno; + + cf::sync_job { + reload_resources; reload_config; db_init; + + cf::load_settings; + cf::load_materials; + cf::init_uuid; + cf::init_signals; + cf::init_commands; + cf::init_skills; + + cf::init_beforeplay; + + atomic; + load_extensions; - $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority - } + utime time, time, $RUNTIMEFILE; - utime time, time, $RUNTIMEFILE; + # no (long-running) fork's whatsoever before this point(!) + use POSIX (); + POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; - # no (long-running) fork's whatsoever before this point(!) - POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; + (pop @POST_INIT)->(0) while @POST_INIT; + }; - EV::loop; + main_loop; } ############################################################################# @@ -3483,7 +3551,14 @@ my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 or return; - my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; + my $value = uuid_seq uuid_cur; + + unless ($value) { + warn "cowardly refusing to write zero uuid value!\n"; + return; + } + + my $value = uuid_str $value + $uuid_skip; $uuid_skip = 0; (aio_write $fh, 0, (length $value), $value, 0) <= 0 @@ -3515,39 +3590,49 @@ sub emergency_save() { my $freeze_guard = cf::freeze_mainloop; - warn "enter emergency perl save\n"; + warn "emergency_perl_save: enter\n"; cf::sync_job { + # this is a trade-off: we want to be very quick here, so + # save all maps without fsync, and later call a global sync + # (which in turn might be very very slow) + local $USE_FSYNC = 0; + # use a peculiar iteration method to avoid tripping on perl # refcount bugs in for. also avoids problems with players # and maps saved/destroyed asynchronously. - warn "begin emergency player save\n"; + warn "emergency_perl_save: begin player save\n"; for my $login (keys %cf::PLAYER) { my $pl = $cf::PLAYER{$login} or next; $pl->valid or next; delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt $pl->save; } - warn "end emergency player save\n"; + warn "emergency_perl_save: end player save\n"; - warn "begin emergency map save\n"; + warn "emergency_perl_save: begin map save\n"; for my $path (keys %cf::MAP) { my $map = $cf::MAP{$path} or next; $map->valid or next; $map->save; } - warn "end emergency map save\n"; + warn "emergency_perl_save: end map save\n"; - warn "begin emergency database checkpoint\n"; + warn "emergency_perl_save: begin database checkpoint\n"; BDB::db_env_txn_checkpoint $DB_ENV; - warn "end emergency database checkpoint\n"; + warn "emergency_perl_save: end database checkpoint\n"; - warn "begin write uuid\n"; + warn "emergency_perl_save: begin write uuid\n"; write_uuid_sync 1; - warn "end write uuid\n"; + warn "emergency_perl_save: end write uuid\n"; + }; + + warn "emergency_perl_save: starting sync()\n"; + IO::AIO::aio_sync sub { + warn "emergency_perl_save: finished sync()\n"; }; - warn "leave emergency perl save\n"; + warn "emergency_perl_save: leave\n"; } sub post_cleanup { @@ -3595,6 +3680,8 @@ return if $RELOAD++; + my $t1 = EV::time; + while ($RELOAD) { warn "reloading..."; @@ -3664,7 +3751,7 @@ warn "unloading cf.pm \"a bit\""; delete $INC{"cf.pm"}; - delete $INC{"cf/pod.pm"}; + delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; # don't, removes xs symbols, too, # and global variables created in xs @@ -3682,12 +3769,17 @@ warn "loading extensions"; cf::load_extensions; - warn "reattaching attachments to objects/players"; - _global_reattach; # objects, sockets - warn "reattaching attachments to maps"; - reattach $_ for values %MAP; - warn "reattaching attachments to players"; - reattach $_ for values %PLAYER; + if ($REATTACH_ON_RELOAD) { + warn "reattaching attachments to objects/players"; + _global_reattach; # objects, sockets + warn "reattaching attachments to maps"; + reattach $_ for values %MAP; + warn "reattaching attachments to players"; + reattach $_ for values %PLAYER; + } + + warn "running post_init jobs"; + (pop @POST_INIT)->(1) while @POST_INIT; warn "leaving sync_job"; @@ -3700,6 +3792,9 @@ warn "reloaded"; --$RELOAD; } + + $t1 = EV::time - $t1; + warn "reload completed in ${t1}s\n"; }; our $RELOAD_WATCHER; # used only during reload @@ -3708,9 +3803,13 @@ # doing reload synchronously and two reloads happen back-to-back, # coro crashes during coro_state_free->destroy here. - $RELOAD_WATCHER ||= EV::timer $TICK * 1.5, 0, sub { - do_reload_perl; - undef $RELOAD_WATCHER; + $RELOAD_WATCHER ||= cf::async { + Coro::AIO::aio_wait cache_extensions; + + $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { + do_reload_perl; + undef $RELOAD_WATCHER; + }; }; } @@ -3879,7 +3978,7 @@ } # load additional modules -use cf::pod; +require "cf/$_.pm" for @EXTRA_MODULES; END { cf::emergency_save }