--- deliantra/server/lib/cf.pm 2008/08/31 09:03:31 1.442
+++ deliantra/server/lib/cf.pm 2008/09/19 05:30:23 1.448
@@ -65,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 = ();
@@ -83,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(!)
@@ -128,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.;
}
@@ -729,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.
@@ -789,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:
@@ -1387,7 +1406,7 @@
=head2 CORE EXTENSIONS
-Functions and methods that extend core crossfire objects.
+Functions and methods that extend core deliantra objects.
=cut
@@ -1525,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;
@@ -1621,100 +1640,9 @@
\@paths
}
-=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
+=item $protocol_xml = $player->expand_cfpod ($cfpod)
-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
-}
-
-sub hintmode {
- $_[0]{hintmode} = $_[1] if @_ > 1;
- $_[0]{hintmode}
-}
+Expand deliantra pod fragments into protocol xml.
=item $player->ext_reply ($msgid, @msg)
@@ -2538,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.
@@ -2607,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
@@ -2779,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);
@@ -2878,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...
@@ -2909,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
@@ -3432,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#
@@ -3451,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;
}
@@ -3468,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;
@@ -3497,7 +3467,7 @@
close $fh
or return;
- aio_rename "$runtime~", $runtime
+ aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
and return;
warn "runtime file written.\n";
@@ -3591,6 +3561,9 @@
warn Carp::longmess "post_cleanup backtrace"
if $make_core;
+
+ my $fh = pidfile;
+ unlink $PIDFILE if <$fh> == $$;
}
# a safer delete_package, copied from Symbol
@@ -3881,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";
@@ -3901,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;
};