--- deliantra/server/lib/cf.pm 2008/07/14 16:42:49 1.439 +++ deliantra/server/lib/cf.pm 2008/09/19 05:30:23 1.448 @@ -21,8 +21,9 @@ package cf; +use 5.10.0; use utf8; -use strict; +use strict "vars", "subs"; use Symbol; use List::Util; @@ -36,6 +37,7 @@ use Coro (); use Coro::State; use Coro::Handle; +use Coro::EV; use Coro::AnyEvent; use Coro::Timer; use Coro::Signal; @@ -63,10 +65,26 @@ # $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 +{ + # very ugly, but ensure we acquire the storable lock + + sub net_mstore { + my $guard = Coro::Storable::guard; + &Storable::net_mstore + } + + sub mretrieve { + my $guard = Coro::Storable::guard; + &Storable::mretrieve + } + + Compress::LZF::set_serializer "Coro::Storable", "cf::net_mstore", "cf::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 = (); @@ -81,17 +99,20 @@ our $RELOAD; # number of reloads so far 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(!) @@ -126,9 +147,9 @@ 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.; } @@ -245,9 +266,9 @@ cf::object cf::object::player cf::client cf::player cf::arch cf::living - cf::map cf::party cf::region + cf::map cf::mapspace + cf::party cf::region )) { - no strict 'refs'; @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; } @@ -727,7 +748,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. @@ -787,7 +808,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: @@ -1088,7 +1109,8 @@ # basically do the same as instantiate, without calling instantiate my ($obj) = @_; - bless $obj, ref $obj; # re-bless in case extensions have been reloaded + # no longer needed after getting rid of delete_package? + #bless $obj, ref $obj; # re-bless in case extensions have been reloaded my $registry = $obj->registry; @@ -1334,7 +1356,7 @@ if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; $ext{source} = - "package $pkg; use strict; use utf8;\n" + "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" . "#line 1 \"$path\"\n{\n" . $source . "\n};\n1"; @@ -1384,7 +1406,7 @@ =head2 CORE EXTENSIONS -Functions and methods that extend core crossfire objects. +Functions and methods that extend core deliantra objects. =cut @@ -1522,7 +1544,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; @@ -1618,98 +1640,9 @@ \@paths } -=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) - -Expand crossfire pod fragments into protocol xml. - -=cut - -use re 'eval'; - -my $group; -my $interior; $interior = qr{ - # match a pod interior sequence sans C<< >> - (?: - \ (.*?)\ (?{ $group = $^N }) - | < (??{$interior}) > - ) -}x; - -sub expand_cfpod { - my ($self, $pod) = @_; - - my $xml; - - while () { - if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) { - $group = $1; - - $group =~ s/&/&/g; - $group =~ s/]*) (?{ $group = $^N }) - | < $interior > - ) - > - %gcsx - ) { - my ($code, $data) = ($1, $group); - - if ($code eq "B") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "I") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "U") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "C") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "T") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "G") { - my ($male, $female) = split /\|/, $data; - $data = $self->gender ? $female : $male; - $xml .= expand_cfpod ($self, $data); - } elsif ($code eq "H") { - $xml .= ("[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]", - "[Hint suppressed, see hintmode]", - "") - [$self->{hintmode}]; - } else { - $xml .= "error processing '$code($data)' directive"; - } - } else { - if ($pod =~ /\G(.+)/) { - warn "parse error while expanding $pod (at $1)"; - } - last; - } - } - - for ($xml) { - # create single paragraphs (very hackish) - s/(?<=\S)\n(?=\w)/ /g; - - # compress some whitespace - s/\s+\n/\n/g; # ws line-ends - s/\n\n+/\n/g; # double lines - s/^\n+//; # beginning lines - s/\n+$//; # ending lines - } - - $xml -} - -no re 'eval'; +=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) @@ -2533,8 +2466,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. @@ -2602,6 +2537,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 @@ -2774,7 +2710,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); @@ -2873,7 +2809,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... @@ -2904,8 +2841,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 @@ -3427,7 +3378,28 @@ } } +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 { + atomic; + # 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# @@ -3446,6 +3418,11 @@ $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}; + EV::loop; } @@ -3463,16 +3440,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; @@ -3492,7 +3467,7 @@ close $fh or return; - aio_rename "$runtime~", $runtime + aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE and return; warn "runtime file written.\n"; @@ -3586,8 +3561,39 @@ warn Carp::longmess "post_cleanup backtrace" if $make_core; + + my $fh = pidfile; + unlink $PIDFILE if <$fh> == $$; } +# a safer delete_package, copied from Symbol +sub clear_package($) { + my $pkg = shift; + + # expand to full symbol table name if needed + unless ($pkg =~ /^main::.*::$/) { + $pkg = "main$pkg" if $pkg =~ /^::/; + $pkg = "main::$pkg" unless $pkg =~ /^main::/; + $pkg .= '::' unless $pkg =~ /::$/; + } + + my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + my $stem_symtab = *{$stem}{HASH}; + + defined $stem_symtab and exists $stem_symtab->{$leaf} + or return; + + # clear all symbols + my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; + for my $name (keys %$leaf_symtab) { + _gv_clear *{"$pkg$name"}; +# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; + } + 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) { @@ -3595,114 +3601,113 @@ return; } - warn "reloading..."; + return if $RELOAD++; - warn "entering sync_job"; + while ($RELOAD) { + warn "reloading..."; - cf::sync_job { - cf::write_runtime_sync; # external watchdog should not bark - cf::emergency_save; - cf::write_runtime_sync; # external watchdog should not bark + warn "entering sync_job"; - warn "syncing database to disk"; - BDB::db_env_txn_checkpoint $DB_ENV; + cf::sync_job { + cf::write_runtime_sync; # external watchdog should not bark + cf::emergency_save; + cf::write_runtime_sync; # external watchdog should not bark - # if anything goes wrong in here, we should simply crash as we already saved + warn "syncing database to disk"; + BDB::db_env_txn_checkpoint $DB_ENV; - warn "flushing outstanding aio requests"; - for (;;) { - BDB::flush; - IO::AIO::flush; - Coro::cede_notself; - last unless IO::AIO::nreqs || BDB::nreqs; - warn "iterate..."; - } + # if anything goes wrong in here, we should simply crash as we already saved + + warn "flushing outstanding aio requests"; + while (IO::AIO::nreqs || BDB::nreqs) { + Coro::EV::timer_once 0.01; # let the sync_job do it's thing + } - ++$RELOAD; + warn "cancelling all extension coros"; + $_->cancel for values %EXT_CORO; + %EXT_CORO = (); - warn "cancelling all extension coros"; - $_->cancel for values %EXT_CORO; - %EXT_CORO = (); + warn "removing commands"; + %COMMAND = (); - warn "removing commands"; - %COMMAND = (); + warn "removing ext/exti commands"; + %EXTCMD = (); + %EXTICMD = (); - warn "removing ext/exti commands"; - %EXTCMD = (); - %EXTICMD = (); + warn "unloading/nuking all extensions"; + for my $pkg (@EXTS) { + warn "... unloading $pkg"; - warn "unloading/nuking all extensions"; - for my $pkg (@EXTS) { - warn "... unloading $pkg"; + if (my $cb = $pkg->can ("unload")) { + eval { + $cb->($pkg); + 1 + } or warn "$pkg unloaded, but with errors: $@"; + } - if (my $cb = $pkg->can ("unload")) { - eval { - $cb->($pkg); - 1 - } or warn "$pkg unloaded, but with errors: $@"; + warn "... clearing $pkg"; + clear_package $pkg; } - warn "... nuking $pkg"; - Symbol::delete_package $pkg; - } + warn "unloading all perl modules loaded from $LIBDIR"; + while (my ($k, $v) = each %INC) { + next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; - warn "unloading all perl modules loaded from $LIBDIR"; - while (my ($k, $v) = each %INC) { - next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; + warn "... unloading $k"; + delete $INC{$k}; - warn "... unloading $k"; - delete $INC{$k}; + $k =~ s/\.pm$//; + $k =~ s/\//::/g; - $k =~ s/\.pm$//; - $k =~ s/\//::/g; + if (my $cb = $k->can ("unload_module")) { + $cb->(); + } - if (my $cb = $k->can ("unload_module")) { - $cb->(); + clear_package $k; } - Symbol::delete_package $k; - } - - warn "getting rid of safe::, as good as possible"; - Symbol::delete_package "safe::$_" - for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); + warn "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); - warn "unloading cf.pm \"a bit\""; - delete $INC{"cf.pm"}; - delete $INC{"cf/pod.pm"}; + warn "unloading cf.pm \"a bit\""; + delete $INC{"cf.pm"}; + delete $INC{"cf/pod.pm"}; - # don't, removes xs symbols, too, - # and global variables created in xs - #Symbol::delete_package __PACKAGE__; + # don't, removes xs symbols, too, + # and global variables created in xs + #clear_package __PACKAGE__; - warn "unload completed, starting to reload now"; + warn "unload completed, starting to reload now"; - warn "reloading cf.pm"; - require cf; - cf::_connect_to_perl; # nominally unnecessary, but cannot hurt + warn "reloading cf.pm"; + require cf; + cf::_connect_to_perl; # nominally unnecessary, but cannot hurt - warn "loading config and database again"; - cf::reload_config; + warn "loading config and database again"; + cf::reload_config; - warn "loading extensions"; - cf::load_extensions; + 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; + 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 "leaving sync_job"; + warn "leaving sync_job"; - 1 - } or do { - warn $@; - cf::cleanup "error while reloading, exiting."; - }; + 1 + } or do { + warn $@; + cf::cleanup "error while reloading, exiting."; + }; - warn "reloaded"; + warn "reloaded"; + --$RELOAD; + } }; our $RELOAD_WATCHER; # used only during reload @@ -3849,6 +3854,7 @@ # limit the # of concurrent backtraces if ($_log_backtrace < 2) { ++$_log_backtrace; + my $perl_bt = Carp::longmess $msg; async { $Coro::current->{desc} = "abt $msg"; @@ -3869,7 +3875,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; };