--- deliantra/server/lib/cf.pm 2008/07/08 08:33:27 1.437
+++ deliantra/server/lib/cf.pm 2008/09/22 01:33:09 1.450
@@ -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,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 = ();
@@ -81,17 +86,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 +134,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 +253,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 +735,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 +795,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 +1096,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 +1343,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 +1393,7 @@
=head2 CORE EXTENSIONS
-Functions and methods that extend core crossfire objects.
+Functions and methods that extend core deliantra objects.
=cut
@@ -1522,7 +1531,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 +1627,9 @@
\@paths
}
-=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
-
-Expand crossfire pod fragments into protocol xml.
-
-=cut
-
-use re 'eval';
+=item $protocol_xml = $player->expand_cfpod ($cfpod)
-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/</g;
-
- $xml .= $group;
- } elsif ($pod =~ m%\G
- ([BCGHITU])
- <
- (?:
- ([^<>]*) (?{ $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';
-
-sub hintmode {
- $_[0]{hintmode} = $_[1] if @_ > 1;
- $_[0]{hintmode}
-}
+Expand deliantra pod fragments into protocol xml.
=item $player->ext_reply ($msgid, @msg)
@@ -2088,7 +2008,7 @@
$self->_load_objects ($f)
or return;
- $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
+ $self->post_load_original
if delete $self->{load_original};
if (my $uniq = $self->uniq_path) {
@@ -2533,8 +2453,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 +2524,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 +2697,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);
@@ -2850,6 +2773,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",
@@ -2873,7 +2802,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 +2834,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
@@ -3130,7 +3074,7 @@
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)],
+ decrease split destroy change_exp)],
["cf::object::player" => qw(player)],
["cf::player" => qw(peaceful)],
["cf::map" => qw(trigger)],
@@ -3427,7 +3371,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 +3411,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 +3433,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 +3460,7 @@
close $fh
or return;
- aio_rename "$runtime~", $runtime
+ aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
and return;
warn "runtime file written.\n";
@@ -3586,8 +3554,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 +3594,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 +3847,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 +3868,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;
};