--- deliantra/server/lib/cf.pm 2008/08/31 09:03:31 1.442 +++ deliantra/server/lib/cf.pm 2008/12/15 17:04:53 1.460 @@ -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; @@ -65,10 +67,13 @@ # $Storable::canonical = 1; # reduce rsync transfers Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator -Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later $Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority +# make sure c-lzf reinitialises itself +Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve"; +Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later + sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload our %COMMAND = (); @@ -80,20 +85,23 @@ our %EXT_CORO = (); # coroutines bound to extensions our %EXT_MAP = (); # pluggable maps -our $RELOAD; # number of reloads so far +our $RELOAD; # number of reloads so far, non-zero while in reload our @EVENT; -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; -our $PLAYERDIR = "$LOCALDIR/" . playerdir; -our $RANDOMDIR = "$LOCALDIR/random"; -our $BDBDIR = "$LOCALDIR/db"; +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; +our $PLAYERDIR = "$LOCALDIR/" . playerdir; +our $RANDOMDIR = "$LOCALDIR/random"; +our $BDBDIR = "$LOCALDIR/db"; +our $PIDFILE = "$LOCALDIR/pid"; +our $RUNTIMEFILE = "$LOCALDIR/runtime"; + our %RESOURCE; our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) @@ -124,13 +132,17 @@ our $JITTER; # average jitter our $TICK_START; # for load detecting purposes +our @POST_INIT; + +our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow) + binmode STDOUT; binmode STDERR; # read virtual server time, if available -unless ($RUNTIME || !-e "$LOCALDIR/runtime") { - open my $fh, "<", "$LOCALDIR/runtime" - or die "unable to read runtime file: $!"; +unless ($RUNTIME || !-e $RUNTIMEFILE) { + open my $fh, "<", $RUNTIMEFILE + or die "unable to read $RUNTIMEFILE file: $!"; $RUNTIME = <$fh> + 0.; } @@ -301,6 +313,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. @@ -308,7 +334,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. @@ -324,50 +350,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}) { - 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 @@ -729,7 +729,7 @@ =head2 ATTACHABLE OBJECTS -Many objects in crossfire are so-called attachable objects. That means you can +Many objects in deliantra are so-called attachable objects. That means you can attach callbacks/event handlers (a collection of which is called an "attachment") to it. All such attachable objects support the following methods. @@ -789,7 +789,7 @@ Register an attachment by C<$name> through which attachable objects of the given CLASS can refer to this attachment. -Some classes such as crossfire maps and objects can specify attachments +Some classes such as deliantra maps and objects can specify attachments that are attached at load/instantiate time, thus the need for a name. These calls expect any number of the following handler/hook descriptions: @@ -1166,8 +1166,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; @@ -1268,6 +1271,8 @@ $EXTICMD{$name} = $cb; } +use File::Glob (); + cf::player->attach ( on_command => sub { my ($pl, $name, $params) = @_; @@ -1309,6 +1314,19 @@ }, ); +# "readahead" all extensions +sub cache_extensions { + my $grp = IO::AIO::aio_group; + + add $grp IO::AIO::aio_readdir $LIBDIR, sub { + for (grep /\.ext$/, @{$_[0]}) { + add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; + } + }; + + $grp +} + sub load_extensions { cf::sync_job { my %todo; @@ -1387,7 +1405,7 @@ =head2 CORE EXTENSIONS -Functions and methods that extend core crossfire objects. +Functions and methods that extend core deliantra objects. =cut @@ -1440,7 +1458,7 @@ my ($login) = @_; $cf::PLAYER{$login} - or cf::sync_job { !aio_stat path $login } + or !aio_stat path $login } sub find($) { @@ -1525,7 +1543,7 @@ my $name = $pl->ob->name; $pl->{deny_save} = 1; - $pl->password ("*"); # this should lock out the player until we nuked the dir + $pl->password ("*"); # this should lock out the player until we have nuked the dir $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; $pl->deactivate; @@ -1621,100 +1639,9 @@ \@paths } -=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) - -Expand crossfire pod fragments into protocol xml. - -=cut - -sub expand_cfpod { - my ($self, $pod) = @_; - - my @nest = [qr<\G$>, undef, ""]; - my $xml; - - for ($pod) { - while () { - if (/\G( (?: [^BCEGHITUZ&>\n\ ]+ | [BCEGHITUZ](?!<) | \ (?!>) )+ )/xgcs) { - $xml .= $1; - } elsif (/\G\n(?=\S)/xgcs) { - $xml .= " "; - } elsif (/\G\n/xgcs) { - $xml .= "\n"; - } elsif (/\G ([BCEGHITUZ]) (< (?: <+\ | (?!<) ) )/xgcs) { - my ($code, $delim) = ($1, scalar reverse $2); - $delim =~ y//; # delim now contains the stop sequence - $delim = qr{\G\Q$delim}; - - my $cb; - - if ($code eq "B") { - $cb = sub { "$_[0]" }; - } elsif ($code eq "C") { - $cb = sub { "$_[0]" }; - } elsif ($code eq "E") { - $cb = sub { warn "E<$_[0]>\n";"&$_[0];" }; - } elsif ($code eq "G") { - $cb = sub { - my ($male, $female) = split /\|/, $_[0]; - $self->gender ? $female : $male - }; - } elsif ($code eq "H") { - $cb = sub { - ( - "[$_[0] (Use hintmode to suppress hints)]", - "[Hint suppressed, see hintmode]", - "", - )[$self->{hintmode}]; - }; - } elsif ($code eq "I") { - $cb = sub { "$_[0]" }; - } elsif ($code eq "T") { - $cb = sub { "$_[0]" }; - } elsif ($code eq "U") { - $cb = sub { "$_[0]" }; - } elsif ($code eq "Z") { - $cb = sub { }; - } else { - die "FATAL error in expand_cfpod"; - } - - push @nest, [$delim, $cb, $xml]; - undef $xml; - - } elsif ($_ =~ /$nest[-1][0]/gcs) { - my $nest = pop @nest; - - if ($nest->[1]) { - $xml = $nest->[2] . $nest->[1]->($xml); - } else { - last; - } - } elsif (/\G/xgcs) { - $xml .= ">"; - } else { - if ($pod =~ /\G(.+)/xgcs) { - warn "parse error (at $1)($nest[-1][0]) while expanding cfpod:\n$pod"; - last; - } else { - warn "parse error (unclosed interior sequence at end of cfpod) while expanding cfpod:\n$pod"; - return "Sorry, the server encountered an internal error when formatting this message, please report this."; - } - } - } - } - - $xml -} +=item $protocol_xml = $player->expand_cfpod ($cfpod) -sub hintmode { - $_[0]{hintmode} = $_[1] if @_ > 1; - $_[0]{hintmode} -} +Expand deliantra pod fragments into protocol xml. =item $player->ext_reply ($msgid, @msg) @@ -2037,13 +1964,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; @@ -2538,8 +2462,10 @@ Freezes the player and moves him/her to a special map (C<{link}>). -The player should be reasonably safe there for short amounts of time. You -I call C as soon as possible, though. +The player should be reasonably safe there for short amounts of time (e.g. +for loading a map). You I call C as soon as possible, +though, as the palyer cannot control the character while it is on the link +map. Will never block. @@ -2607,6 +2533,7 @@ $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 @@ -2779,7 +2706,7 @@ 1 }) { - $self->message ("Something went wrong deep within the crossfire server. " + $self->message ("Something went wrong deep within the deliantra server. " . "I'll try to bring you back to the map you were before. " . "Please report this to the dungeon master!", cf::NDI_UNIQUE | cf::NDI_RED); @@ -2855,6 +2782,12 @@ reply => undef, tooltip => "Shows which body parts you posess and are available", }, + "c/skills" => { + id => "infobox", + title => "Skills", + reply => undef, + tooltip => "Shows your experience per skill and item power", + }, "c/uptime" => { id => "infobox", title => "Uptime", @@ -2878,7 +2811,8 @@ sub cf::client::send_msg { my ($self, $channel, $msg, $color, @extra) = @_; - $msg = $self->pl->expand_cfpod ($msg); + $msg = $self->pl->expand_cfpod ($msg) + unless $color & cf::NDI_VERBATIM; $color &= cf::NDI_CLIENT_MASK; # just in case... @@ -2909,8 +2843,22 @@ $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) if $color & cf::NDI_DEF; - $self->send_packet ("msg " . $self->{json_coder}->encode ( - [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); + 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 @@ -3403,14 +3351,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; @@ -3432,7 +3372,41 @@ } } +sub pidfile() { + sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT + or die "$PIDFILE: $!"; + flock $fh, &Fcntl::LOCK_EX + or die "$PIDFILE: flock: $!"; + $fh +} + +# make sure only one server instance is running at any one time +sub atomic { + my $fh = pidfile; + + my $pid = <$fh>; + kill 9, $pid if $pid > 0; + + seek $fh, 0, 0; + print $fh $$; +} + sub main { + 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; + cf::init_block; + + $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority + # 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# @@ -3442,14 +3416,33 @@ })->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; + + # 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; } @@ -3468,16 +3461,14 @@ } sub write_runtime_sync { - my $runtime = "$LOCALDIR/runtime"; - # first touch the runtime file to show we are still running: # the fsync below can take a very very long time. - IO::AIO::aio_utime $runtime, undef, undef; + IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; my $guard = cf::lock_acquire "write_runtime"; - my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 + my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 or return; my $value = $cf::RUNTIME + 90 + 10; @@ -3497,7 +3488,7 @@ close $fh or return; - aio_rename "$runtime~", $runtime + aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE and return; warn "runtime file written.\n"; @@ -3519,7 +3510,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 @@ -3551,39 +3549,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 { @@ -3591,6 +3599,9 @@ warn Carp::longmess "post_cleanup backtrace" if $make_core; + + my $fh = pidfile; + unlink $PIDFILE if <$fh> == $$; } # a safer delete_package, copied from Symbol @@ -3616,11 +3627,9 @@ _gv_clear *{"$pkg$name"}; # use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; } - warn "cleared package #$pkg\n";#d# + warn "cleared package $pkg\n";#d# } -our $RELOAD; # how many times to reload - sub do_reload_perl() { # can/must only be called in main if ($Coro::current != $Coro::main) { @@ -3630,6 +3639,8 @@ return if $RELOAD++; + my $t1 = EV::time; + while ($RELOAD) { warn "reloading..."; @@ -3717,12 +3728,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"; @@ -3735,6 +3751,9 @@ warn "reloaded"; --$RELOAD; } + + $t1 = EV::time - $t1; + warn "reload completed in ${t1}s\n"; }; our $RELOAD_WATCHER; # used only during reload @@ -3743,9 +3762,13 @@ # doing reload synchronously and two reloads happen back-to-back, # coro crashes during coro_state_free->destroy here. - $RELOAD_WATCHER ||= EV::timer 0, 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; + }; }; } @@ -3881,6 +3904,7 @@ # limit the # of concurrent backtraces if ($_log_backtrace < 2) { ++$_log_backtrace; + my $perl_bt = Carp::longmess $msg; async { $Coro::current->{desc} = "abt $msg"; @@ -3901,7 +3925,8 @@ @funcs }; - LOG llevInfo, "[ABT] $msg\n"; + LOG llevInfo, "[ABT] $perl_bt\n"; + LOG llevInfo, "[ABT] --- C backtrace follows ---\n"; LOG llevInfo, "[ABT] $_\n" for @bt; --$_log_backtrace; };