--- deliantra/server/lib/cf.pm 2008/08/30 05:19:03 1.441
+++ deliantra/server/lib/cf.pm 2009/10/24 06:16:40 1.490
@@ -1,29 +1,30 @@
-#
+#
# This file is part of Deliantra, the Roguelike Realtime MMORPG.
#
# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
#
-# Deliantra is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
+# Deliantra is free software: you can redistribute it and/or modify it under
+# the terms of the Affero GNU General Public License as published by the
+# Free Software Foundation, either version 3 of the License, or (at your
+# option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see .
+# You should have received a copy of the Affero GNU General Public License
+# and the GNU General Public License along with this program. If not, see
+# .
#
# The authors can be reached via e-mail to
-#
+#
package cf;
use 5.10.0;
use utf8;
-use strict "vars", "subs";
+use strict qw(vars subs);
use Symbol;
use List::Util;
@@ -34,6 +35,7 @@
use Safe::Hole;
use Storable ();
+use Guard ();
use Coro ();
use Coro::State;
use Coro::Handle;
@@ -42,6 +44,7 @@
use Coro::Timer;
use Coro::Signal;
use Coro::Semaphore;
+use Coro::SemaphoreSet;
use Coro::AnyEvent;
use Coro::AIO;
use Coro::BDB 1.6;
@@ -53,7 +56,7 @@
use Data::Dumper;
use Digest::MD5;
use Fcntl;
-use YAML ();
+use YAML::XS ();
use IO::AIO ();
use Time::HiRes;
use Compress::LZF;
@@ -65,10 +68,16 @@
#
$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
+
+# strictly for debugging
+$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
+
sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
our %COMMAND = ();
@@ -80,32 +89,39 @@
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 @REFLECT; # set by XS
+our %REFLECT; # set by us
+
+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 $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 %RESOURCE;
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 match mapscript);
+
our %CFG;
our $UPTIME; $UPTIME ||= time;
@@ -124,16 +140,23 @@
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;
# 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.;
}
+eval "sub TICK() { $TICK } 1" or die;
+
mkdir $_
for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
@@ -143,6 +166,17 @@
#############################################################################
+%REFLECT = ();
+for (@REFLECT) {
+ my $reflect = JSON::XS::decode_json $_;
+ $REFLECT{$reflect->{class}} = $reflect;
+}
+
+# this is decidedly evil
+$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
+
+#############################################################################
+
=head2 GLOBAL VARIABLES
=over 4
@@ -196,42 +230,45 @@
=item @cf::INVOKE_RESULTS
-This array contains the results of the last C call. When
+This array contains the results of the last C call. When
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';
@@ -301,6 +338,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 +359,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 +375,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 +754,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 +814,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:
@@ -1149,7 +1174,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) {
@@ -1157,7 +1185,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";
}
@@ -1166,8 +1197,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 +1302,8 @@
$EXTICMD{$name} = $cb;
}
+use File::Glob ();
+
cf::player->attach (
on_command => sub {
my ($pl, $name, $params) = @_;
@@ -1309,6 +1345,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;
@@ -1387,7 +1436,7 @@
=head2 CORE EXTENSIONS
-Functions and methods that extend core crossfire objects.
+Functions and methods that extend core deliantra objects.
=cut
@@ -1440,7 +1489,7 @@
my ($login) = @_;
$cf::PLAYER{$login}
- or cf::sync_job { !aio_stat path $login }
+ or !aio_stat path $login
}
sub find($) {
@@ -1525,7 +1574,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,98 +1670,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/</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';
+=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)
@@ -1935,15 +1895,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) = @_;
@@ -2035,13 +1986,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;
@@ -2119,8 +2067,6 @@
$self->fix_auto_apply;
$self->update_buttons;
cf::cede_to_tick;
- $self->set_darkness_map;
- cf::cede_to_tick;
$self->activate;
}
@@ -2296,7 +2242,7 @@
return if $self->players;
- warn "resetting map ", $self->path;
+ warn "resetting map ", $self->path, "\n";
$self->in_memory (cf::MAP_SWAPPED);
@@ -2397,6 +2343,37 @@
]
}
+=item cf::map::static_maps
+
+Returns an arrayref if paths of all static maps (all preinstalled F<.map>
+file in the shared directory excluding F). May block.
+
+=cut
+
+sub static_maps() {
+ my @dirs = "";
+ my @maps;
+
+ while (@dirs) {
+ my $dir = shift @dirs;
+
+ next if $dir eq "/styles";
+
+ my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
+ or return;
+
+ for (@$files) {
+ s/\.map$// or next;
+ utf8::decode $_;
+ push @maps, "$dir/$_";
+ }
+
+ push @dirs, map "$dir/$_", @$dirs;
+ }
+
+ \@maps
+}
+
=back
=head3 cf::object
@@ -2471,7 +2448,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 = {
@@ -2536,8 +2513,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.
@@ -2605,10 +2584,12 @@
$map->load_neighbours;
return unless $self->contr->active;
- $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->()]])
@@ -2777,7 +2758,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);
@@ -2817,6 +2798,12 @@
# non-persistent channels (usually the info channel)
our %CHANNEL = (
+ "c/motd" => {
+ id => "infobox",
+ title => "MOTD",
+ reply => undef,
+ tooltip => "The message of the day",
+ },
"c/identify" => {
id => "infobox",
title => "Identify",
@@ -2829,6 +2816,12 @@
reply => undef,
tooltip => "Signs and other items you examined",
},
+ "c/shopinfo" => {
+ id => "infobox",
+ title => "Shop Info",
+ reply => undef,
+ tooltip => "What your bargaining skill tells you about the shop",
+ },
"c/book" => {
id => "infobox",
title => "Book",
@@ -2853,6 +2846,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",
@@ -2871,12 +2900,21 @@
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 {
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...
@@ -2884,17 +2922,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};
@@ -2902,38 +2937,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;
-
- $self->send_packet ("msg " . $self->{json_coder}->encode (
- [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
- } 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)
@@ -3118,6 +3141,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
@@ -3133,9 +3157,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';
@@ -3163,6 +3187,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;
@@ -3401,20 +3427,14 @@
warn "finished reloading resource files\n";
}
-sub init {
- my $guard = freeze_mainloop;
-
- evthread_start IO::AIO::poll_fileno;
-
- reload_resources;
-}
-
sub reload_config {
+ warn "reloading config file...\n";
+
open my $fh, "<:utf8", "$CONFDIR/config"
or return;
local $/;
- *CFG = YAML::Load <$fh>;
+ *CFG = YAML::XS::Load scalar <$fh>;
$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
@@ -3428,9 +3448,53 @@
};
warn $@ if $@;
}
+
+ warn "finished reloading resource files\n";
+}
+
+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_loop {
+ warn "EV::loop starting\n";
+ if (1) {
+ EV::loop;
+ }
+ warn "EV::loop returned\n";
+ goto &main_loop unless $REALLY_UNLOOP;
}
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;
+
+ $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#
@@ -3440,16 +3504,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;
+
+ # no (long-running) fork's whatsoever before this point(!)
+ use POSIX ();
+ POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
+
+ (pop @POST_INIT)->(0) while @POST_INIT;
+ };
- EV::loop;
+ main_loop;
}
#############################################################################
@@ -3466,16 +3550,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;
@@ -3495,7 +3577,7 @@
close $fh
or return;
- aio_rename "$runtime~", $runtime
+ aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
and return;
warn "runtime file written.\n";
@@ -3517,7 +3599,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
@@ -3549,39 +3638,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 {
@@ -3589,6 +3688,9 @@
warn Carp::longmess "post_cleanup backtrace"
if $make_core;
+
+ my $fh = pidfile;
+ unlink $PIDFILE if <$fh> == $$;
}
# a safer delete_package, copied from Symbol
@@ -3614,11 +3716,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) {
@@ -3628,6 +3728,8 @@
return if $RELOAD++;
+ my $t1 = EV::time;
+
while ($RELOAD) {
warn "reloading...";
@@ -3697,7 +3799,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
@@ -3707,7 +3809,7 @@
warn "reloading cf.pm";
require cf;
- cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
+ cf::_connect_to_perl_1;
warn "loading config and database again";
cf::reload_config;
@@ -3715,12 +3817,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";
@@ -3733,6 +3840,9 @@
warn "reloaded";
--$RELOAD;
}
+
+ $t1 = EV::time - $t1;
+ warn "reload completed in ${t1}s\n";
};
our $RELOAD_WATCHER; # used only during reload
@@ -3741,9 +3851,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;
+ };
};
}
@@ -3879,6 +3993,7 @@
# limit the # of concurrent backtraces
if ($_log_backtrace < 2) {
++$_log_backtrace;
+ my $perl_bt = Carp::longmess $msg;
async {
$Coro::current->{desc} = "abt $msg";
@@ -3899,7 +4014,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;
};
@@ -3910,7 +4026,8 @@
}
# load additional modules
-use cf::pod;
+require "cf/$_.pm" for @EXTRA_MODULES;
+cf::_connect_to_perl_2;
END { cf::emergency_save }