--- deliantra/server/lib/cf.pm 2007/07/24 04:55:34 1.318
+++ deliantra/server/lib/cf.pm 2007/10/26 04:47:00 1.393
@@ -6,13 +6,13 @@
use Symbol;
use List::Util;
use Socket;
-use Storable;
use Event;
use Opcode;
use Safe;
use Safe::Hole;
+use Storable ();
-use Coro 3.61 ();
+use Coro 4.1 ();
use Coro::State;
use Coro::Handle;
use Coro::Event;
@@ -21,14 +21,15 @@
use Coro::Semaphore;
use Coro::AIO;
use Coro::Storable;
+use Coro::Util ();
-use JSON::XS 1.4 ();
+use JSON::XS ();
use BDB ();
use Data::Dumper;
use Digest::MD5;
use Fcntl;
use YAML::Syck ();
-use IO::AIO 2.32 ();
+use IO::AIO 2.51 ();
use Time::HiRes;
use Compress::LZF;
use Digest::MD5 ();
@@ -81,6 +82,9 @@
our $USE_FSYNC = 1; # use fsync to write maps - default off
our $BDB_POLL_WATCHER;
+our $BDB_DEADLOCK_WATCHER;
+our $BDB_CHECKPOINT_WATCHER;
+our $BDB_TRICKLE_WATCHER;
our $DB_ENV;
our %CFG;
@@ -88,8 +92,8 @@
our $UPTIME; $UPTIME ||= time;
our $RUNTIME;
-our %PLAYER; # all users
-our %MAP; # all maps
+our (%PLAYER, %PLAYER_LOADING); # all users
+our (%MAP, %MAP_LOADING ); # all maps
our $LINK_MAP; # the special {link} map, which is always available
# used to convert map paths into valid unix filenames by replacing / by ∕
@@ -188,7 +192,6 @@
$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
- utf8::encode $msg;
LOG llevError, $msg;
};
}
@@ -273,6 +276,9 @@
for example when the coroutine gets canceled), the lock is automatically
returned.
+Locks are *not* recursive, locking from the same coro twice results in a
+deadlocked coro.
+
Lock names should begin with a unique identifier (for example, cf::map::find
uses map_find and cf::map::load uses map_load).
@@ -283,10 +289,16 @@
=cut
our %LOCK;
+our %LOCKER;#d#
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;
@@ -301,8 +313,10 @@
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} };
}
@@ -342,6 +356,8 @@
$SLOT_QUEUE->cancel if $SLOT_QUEUE;
$SLOT_QUEUE = Coro::async {
+ $Coro::current->desc ("timeslot manager");
+
my $signal = new Coro::Signal;
while () {
@@ -359,7 +375,7 @@
}
if (@SLOT_QUEUE) {
- # we do not use wait_For_tick() as it returns immediately when tick is inactive
+ # we do not use wait_for_tick() as it returns immediately when tick is inactive
push @cf::WAIT_FOR_TICK, $signal;
$signal->wait;
} else {
@@ -413,6 +429,8 @@
# this is the main coro, too bad, we have to block
# till the operation succeeds, freezing the server :/
+ LOG llevError, Carp::longmess "sync job";#d#
+
# TODO: use suspend/resume instead
# (but this is cancel-safe)
my $freeze_guard = freeze_mainloop;
@@ -421,13 +439,18 @@
my @res;
(async {
+ $Coro::current->desc ("sync job coro");
@res = eval { $job->() };
warn $@ if $@;
undef $busy;
})->prio (Coro::PRIO_MAX);
while ($busy) {
- Coro::cede or Event::one_event;
+ if (Coro::nready) {
+ Coro::cede_notself;
+ } else {
+ Event::one_event;
+ }
}
$time = Event::time - $time;
@@ -474,57 +497,19 @@
=cut
-sub _store_scalar {
- open my $fh, ">", \my $buf
- or die "fork_call: cannot open fh-to-buf in child : $!";
- Storable::store_fd $_[0], $fh;
- close $fh;
-
- $buf
-}
-
sub fork_call(&@) {
my ($cb, @args) = @_;
-# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
-# or die "socketpair: $!";
- pipe my $fh1, my $fh2
- or die "pipe: $!";
-
- if (my $pid = fork) {
- close $fh2;
-
- my $res = (Coro::Handle::unblock $fh1)->readline (undef);
- warn "pst<$res>" unless $res =~ /^pst/;
- $res = Coro::Storable::thaw $res;
-
- waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
+ # we seemingly have to make a local copy of the whole thing,
+ # otherwise perl prematurely frees the stuff :/
+ # TODO: investigate and fix (likely this will be rather laborious)
- Carp::confess $$res unless "ARRAY" eq ref $res;
-
- return wantarray ? @$res : $res->[-1];
- } else {
+ my @res = Coro::Util::fork_eval {
reset_signals;
- local $SIG{__WARN__};
- local $SIG{__DIE__};
- # just in case, this hack effectively disables event
- # in the child. cleaner and slower would be canceling all watchers,
- # but this works for the time being.
- local $Coro::idle;
- $Coro::current->prio (Coro::PRIO_MAX);
+ &$cb
+ }, @args;
- eval {
- close $fh1;
-
- my @res = eval { $cb->(@args) };
-
- syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
- close $fh2;
- };
-
- warn $@ if $@;
- _exit 0;
- }
+ wantarray ? @res : $res[-1]
}
=item $value = cf::db_get $family => $key
@@ -536,25 +521,36 @@
Stores the given C<$value> in the family. It can currently store binary
data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
+=item $db = cf::db_table "name"
+
+Create and/or open a new database table. The string must not be "db" and must be unique
+within each server.
+
=cut
-our $DB;
+sub db_table($) {
+ my ($name) = @_;
+ my $db = BDB::db_create $DB_ENV;
-sub db_init {
- unless ($DB) {
- $DB = BDB::db_create $DB_ENV;
+ eval {
+ $db->set_flags (BDB::CHKSUM);
- cf::sync_job {
- eval {
- $DB->set_flags (BDB::CHKSUM);
+ utf8::encode $name;
+ BDB::db_open $db, undef, $name, undef, BDB::BTREE,
+ BDB::CREATE | BDB::AUTO_COMMIT, 0666;
+ cf::cleanup "db_open(db): $!" if $!;
+ };
+ cf::cleanup "db_open(db): $@" if $@;
- BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
- BDB::CREATE | BDB::AUTO_COMMIT, 0666;
- cf::cleanup "db_open(db): $!" if $!;
- };
- cf::cleanup "db_open(db): $@" if $@;
- };
- }
+ $db
+}
+
+our $DB;
+
+sub db_init {
+ cf::sync_job {
+ $DB ||= db_table "db";
+ };
}
sub db_get($$) {
@@ -614,7 +610,7 @@
join "\x00",
$processversion,
map {
- Coro::cede;
+ cf::cede_to_tick;
($src->[$_], Digest::MD5::md5_hex $data[$_])
} 0.. $#$src;
@@ -976,16 +972,47 @@
#############################################################################
# object support
-#
+sub _object_equal($$);
+sub _object_equal($$) {
+ my ($a, $b) = @_;
+
+ return 0 unless (ref $a) eq (ref $b);
+
+ if ("HASH" eq ref $a) {
+ my @ka = keys %$a;
+ my @kb = keys %$b;
+
+ return 0 if @ka != @kb;
+
+ for (0 .. $#ka) {
+ return 0 unless $ka[$_] eq $kb[$_];
+ return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
+ }
+
+ } elsif ("ARRAY" eq ref $a) {
+
+ return 0 if @$a != @$b;
+
+ for (0 .. $#$a) {
+ return 0 unless _object_equal $a->[$_], $b->[$_];
+ }
+
+ } elsif ($a ne $b) {
+ return 0;
+ }
+
+ 1
+}
+
+our $SLOW_MERGES;#d#
sub _can_merge {
my ($ob1, $ob2) = @_;
- local $Storable::canonical = 1;
- my $fob1 = Storable::freeze $ob1;
- my $fob2 = Storable::freeze $ob2;
+ ++$SLOW_MERGES;#d#
- $fob1 eq $fob2
+ # we do the slow way here
+ return _object_equal $ob1, $ob2
}
sub reattach {
@@ -1043,8 +1070,9 @@
sync_job {
if (length $$rdata) {
+ utf8::decode (my $decname = $filename);
warn sprintf "saving %s (%d,%d)\n",
- $filename, length $$rdata, scalar @$objs;
+ $decname, length $$rdata, scalar @$objs;
if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
chmod SAVE_MODE, $fh;
@@ -1055,7 +1083,7 @@
if (@$objs) {
if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
chmod SAVE_MODE, $fh;
- my $data = Storable::nfreeze { version => 1, objs => $objs };
+ my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
aio_write $fh, 0, (length $data), $data, 0;
aio_fsync $fh if $cf::USE_FSYNC;
close $fh;
@@ -1073,7 +1101,7 @@
aio_unlink $filename;
aio_unlink "$filename.pst";
}
- }
+ };
}
sub object_freezer_as_string {
@@ -1095,12 +1123,16 @@
unless (aio_stat "$filename.pst") {
(aio_load "$filename.pst", $av) >= 0
or return;
- $av = eval { (Storable::thaw $av)->{objs} };
+
+ my $st = eval { Coro::Storable::thaw $av };
+ $av = $st->{objs};
}
- warn sprintf "loading %s (%d)\n",
- $filename, length $data, scalar @{$av || []};
- return ($data, $av);
+ utf8::decode (my $decname = $filename);
+ warn sprintf "loading %s (%d,%d)\n",
+ $decname, length $data, scalar @{$av || []};
+
+ ($data, $av)
}
=head2 COMMAND CALLBACKS
@@ -1188,12 +1220,15 @@
? @$msg
: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
- if (my $cb = $EXTCMD{$type}) {
- my @reply = $cb->($pl, @payload);
+ my @reply;
- $pl->ext_reply ($reply, @reply)
- if $reply;
+ if (my $cb = $EXTCMD{$type}) {
+ @reply = $cb->($pl, @payload);
}
+
+ $pl->ext_reply ($reply, @reply)
+ if $reply;
+
} else {
warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
}
@@ -1293,6 +1328,20 @@
=over 4
+=item cf::player::num_playing
+
+Returns the official number of playing players, as per the Crossfire metaserver rules.
+
+=cut
+
+sub num_playing {
+ scalar grep
+ $_->ob->map
+ && !$_->hidden
+ && !$_->ob->flag (cf::FLAG_WIZ),
+ cf::player::list
+}
+
=item cf::player::find $login
Returns the given player object, loading it if necessary (might block).
@@ -1337,8 +1386,13 @@
aio_unlink +(playerdir $login) . "/$login.pl.pst";
aio_unlink +(playerdir $login) . "/$login.pl";
- my $pl = load_pl path $login
+ my $f = new_from_file cf::object::thawer path $login
or return;
+
+ my $pl = cf::player::load_pl $f
+ or return;
+ local $cf::PLAYER_LOADING{$login} = $pl;
+ $f->resolve_delayed_derefs;
$cf::PLAYER{$login} = $pl
}
}
@@ -1358,7 +1412,7 @@
$pl->{last_save} = $cf::RUNTIME;
$pl->save_pl ($path);
- Coro::cede;
+ cf::cede_to_tick;
}
sub new($) {
@@ -1374,6 +1428,16 @@
$self
}
+=item $player->send_msg ($channel, $msg, $color, [extra...])
+
+=cut
+
+sub send_msg {
+ my $ns = shift->ns
+ or return;
+ $ns->send_msg (@_);
+}
+
=item $pl->quit_character
Nukes the player without looking back. If logged in, the connection will
@@ -1436,9 +1500,14 @@
my @logins;
for my $login (@$dirs) {
- my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
- aio_read $fh, 0, 512, my $buf, 0 or next;
- $buf !~ /^password -------------$/m or next; # official not-valid tag
+ my $path = path $login;
+
+ # a .pst is a dead give-away for a valid player
+ unless (-e "$path.pst") {
+ my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
+ aio_read $fh, 0, 512, my $buf, 0 or next;
+ $buf !~ /^password -------------$/m or next; # official not-valid tag
+ }
utf8::decode $login;
push @logins, $login;
@@ -1481,45 +1550,88 @@
=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), (local $_)) = @_;
+ 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;
+ }
+ }
- # escape & and <
- s/&/&/g;
- s/(?, I<>, U<> etc.
- s/B<([^\>]*)>/$1<\/b>/
- || s/I<([^\>]*)>/$1<\/i>/
- || s/U<([^\>]*)>/$1<\/u>/
- # replace G tags
- || s{G<([^>|]*)\|([^>]*)>}{
- $self->gender ? $2 : $1
- }ge
- # replace H
- || s{H<([^\>]*)>}
- {
- ("[$1 (Use hintmode to suppress hints)]",
- "[Hint suppressed, see hintmode]",
- "")
- [$self->{hintmode}]
- }ge;
-
- # 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
+ 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}
@@ -1534,13 +1646,7 @@
sub ext_reply($$@) {
my ($self, $id, @msg) = @_;
- if ($self->ns->extcmd == 2) {
- $self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
- } elsif ($self->ns->extcmd == 1) {
- #TODO: version 1, remove
- unshift @msg, msgtype => "reply", msgid => $id;
- $self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
- }
+ $self->ns->ext_reply ($id, @msg)
}
=item $player->ext_msg ($type, @msg)
@@ -1778,12 +1884,15 @@
my ($self, $path) = @_;
utf8::encode $path;
- #aio_open $path, O_RDONLY, 0
- # or return;
+ my $f = new_from_file cf::object::thawer $path
+ or return;
- $self->_load_header ($path)
+ $self->_load_header ($f)
or return;
+ local $MAP_LOADING{$self->{path}} = $self;
+ $f->resolve_delayed_derefs;
+
$self->{load_path} = $path;
1
@@ -1846,10 +1955,13 @@
$path = normalise $path, $origin && $origin->path;
+ cf::lock_wait "map_data:$path";#d#remove
cf::lock_wait "map_find:$path";
$cf::MAP{$path} || do {
- my $guard = cf::lock_acquire "map_find:$path";
+ my $guard1 = cf::lock_acquire "map_find:$path";
+ my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
+
my $map = new_from_path cf::map $path
or return;
@@ -1861,8 +1973,9 @@
if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
# doing this can freeze the server in a sync job, obviously
#$cf::WAIT_FOR_TICK->wait;
+ undef $guard1;
+ undef $guard2;
$map->reset;
- undef $guard;
return find $path;
}
@@ -1881,18 +1994,21 @@
my $path = $self->{path};
{
- my $guard = cf::lock_acquire "map_load:$path";
+ my $guard = cf::lock_acquire "map_data:$path";
- return if $self->in_memory != cf::MAP_SWAPPED;
+ return unless $self->valid;
+ return unless $self->in_memory == cf::MAP_SWAPPED;
$self->in_memory (cf::MAP_LOADING);
$self->alloc;
$self->pre_load;
- Coro::cede;
+ cf::cede_to_tick;
- $self->_load_objects ($self->{load_path}, 1)
+ my $f = new_from_file cf::object::thawer $self->{load_path};
+ $f->skip_block;
+ $self->_load_objects ($f)
or return;
$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
@@ -1900,29 +2016,37 @@
if (my $uniq = $self->uniq_path) {
utf8::encode $uniq;
- if (aio_open $uniq, O_RDONLY, 0) {
- $self->clear_unique_items;
- $self->_load_objects ($uniq, 0);
+ unless (aio_stat $uniq) {
+ if (my $f = new_from_file cf::object::thawer $uniq) {
+ $self->clear_unique_items;
+ $self->_load_objects ($f);
+ $f->resolve_delayed_derefs;
+ }
}
}
- Coro::cede;
+ $f->resolve_delayed_derefs;
+
+ cf::cede_to_tick;
# now do the right thing for maps
$self->link_multipart_objects;
$self->difficulty ($self->estimate_difficulty)
unless $self->difficulty;
- Coro::cede;
+ cf::cede_to_tick;
unless ($self->{deny_activate}) {
$self->decay_objects;
$self->fix_auto_apply;
$self->update_buttons;
- Coro::cede;
+ cf::cede_to_tick;
$self->set_darkness_map;
- Coro::cede;
+ cf::cede_to_tick;
$self->activate;
}
+ $self->{last_save} = $cf::RUNTIME;
+ $self->last_access ($cf::RUNTIME);
+
$self->in_memory (cf::MAP_IN_MEMORY);
}
@@ -1942,10 +2066,10 @@
}
# find and load all maps in the 3x3 area around a map
-sub load_diag {
+sub load_neighbours {
my ($map) = @_;
- my @diag; # diagonal neighbours
+ my @neigh; # diagonal neighbours
for (0 .. 3) {
my $neigh = $map->tile_path ($_)
@@ -1954,12 +2078,14 @@
or next;
$neigh->load;
- push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
- [$neigh->tile_path (($_ + 1) % 4), $neigh];
+ push @neigh,
+ [$neigh->tile_path (($_ + 3) % 4), $neigh],
+ [$neigh->tile_path (($_ + 1) % 4), $neigh];
}
- for (@diag) {
- my $neigh = find @$_
+ for (grep defined $_->[0], @neigh) {
+ my ($path, $origin) = @$_;
+ my $neigh = find $path, $origin
or next;
$neigh->load;
}
@@ -1974,6 +2100,9 @@
sub do_load_sync {
my ($map) = @_;
+ cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
+ if $Coro::current == $Coro::main;
+
cf::sync_job { $map->load };
}
@@ -1981,23 +2110,26 @@
our $MAP_PREFETCHER = undef;
sub find_async {
- my ($path, $origin) = @_;
+ my ($path, $origin, $load) = @_;
$path = normalise $path, $origin && $origin->{path};
if (my $map = $cf::MAP{$path}) {
- return $map if $map->in_memory == cf::MAP_IN_MEMORY;
+ return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
}
- undef $MAP_PREFETCH{$path};
+ $MAP_PREFETCH{$path} |= $load;
+
$MAP_PREFETCHER ||= cf::async {
+ $Coro::current->{desc} = "map prefetcher";
+
while (%MAP_PREFETCH) {
- for my $path (keys %MAP_PREFETCH) {
- if (my $map = find $path) {
- $map->load;
+ while (my ($k, $v) = each %MAP_PREFETCH) {
+ if (my $map = find $k) {
+ $map->load if $v;
}
- delete $MAP_PREFETCH{$path};
+ delete $MAP_PREFETCH{$k};
}
}
undef $MAP_PREFETCHER;
@@ -2010,7 +2142,7 @@
sub save {
my ($self) = @_;
- my $lock = cf::lock_acquire "map_data:" . $self->path;
+ my $lock = cf::lock_acquire "map_data:$self->{path}";
$self->{last_save} = $cf::RUNTIME;
@@ -2026,6 +2158,7 @@
local $self->{last_access} = $self->last_access;#d#
cf::async {
+ $Coro::current->{desc} = "map player save";
$_->contr->save for $self->players;
};
@@ -2043,14 +2176,17 @@
# save first because save cedes
$self->save;
- my $lock = cf::lock_acquire "map_data:" . $self->path;
+ my $lock = cf::lock_acquire "map_data:$self->{path}";
return if $self->players;
return if $self->in_memory != cf::MAP_IN_MEMORY;
return if $self->{deny_save};
- $self->clear;
$self->in_memory (cf::MAP_SWAPPED);
+
+ $self->deactivate;
+ $_->clear_links_to ($self) for values %cf::MAP;
+ $self->clear;
}
sub reset_at {
@@ -2092,9 +2228,9 @@
delete $cf::MAP{$self->path};
- $self->clear;
-
+ $self->deactivate;
$_->clear_links_to ($self) for values %cf::MAP;
+ $self->clear;
$self->unlink_save;
$self->destroy;
@@ -2105,17 +2241,21 @@
sub nuke {
my ($self) = @_;
- delete $cf::MAP{$self->path};
+ {
+ my $lock = cf::lock_acquire "map_data:$self->{path}";
- $self->unlink_save;
+ delete $cf::MAP{$self->path};
- bless $self, "cf::map";
- delete $self->{deny_reset};
- $self->{deny_save} = 1;
- $self->reset_timeout (1);
- $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
+ $self->unlink_save;
- $cf::MAP{$self->path} = $self;
+ bless $self, "cf::map";
+ delete $self->{deny_reset};
+ $self->{deny_save} = 1;
+ $self->reset_timeout (1);
+ $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
+
+ $cf::MAP{$self->path} = $self;
+ }
$self->reset; # polite request, might not happen
}
@@ -2201,6 +2341,34 @@
inv_recursive_ inv $_[0]
}
+=item $ref = $ob->ref
+
+creates and returns a persistent reference to an objetc that can be stored as a string.
+
+=item $ob = cf::object::deref ($refstring)
+
+returns the objetc referenced by refstring. may return undef when it cnanot find the object,
+even if the object actually exists. May block.
+
+=cut
+
+sub deref {
+ my ($ref) = @_;
+
+ if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
+ my ($uuid, $name) = ($1, $2);
+ my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
+ or return;
+ $pl->ob->uuid eq $uuid
+ or return;
+
+ $pl->ob
+ } else {
+ warn "$ref: cannot resolve object reference\n";
+ undef
+ }
+}
+
package cf;
=back
@@ -2242,6 +2410,16 @@
}
}
+=item $object->send_msg ($channel, $msg, $color, [extra...])
+
+=cut
+
+sub cf::object::send_msg {
+ my $pl = shift->contr
+ or return;
+ $pl->send_msg (@_);
+}
+
=item $player_object->may ("access")
Returns wether the given player is authorized to access resource "access"
@@ -2328,7 +2506,7 @@
if $x <=0 && $y <= 0;
$map->load;
- $map->load_diag;
+ $map->load_neighbours;
return unless $self->contr->active;
$self->activate_recursive;
@@ -2358,14 +2536,35 @@
$self->enter_link;
(async {
+ $Coro::current->{desc} = "player::goto $path $x $y";
+
+ # *tag paths override both path and x|y
+ if ($path =~ /^\*(.*)$/) {
+ if (my @obs = grep $_->map, ext::map_tags::find $1) {
+ my $ob = $obs[rand @obs];
+
+ # see if we actually can go there
+ if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
+ $ob = $obs[rand @obs];
+ } else {
+ $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
+ }
+ # else put us there anyways for now #d#
+
+ ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
+ } else {
+ ($path, $x, $y) = (undef, undef, undef);
+ }
+ }
+
my $map = eval {
- my $map = cf::map::find $path;
+ my $map = defined $path ? cf::map::find $path : undef;
if ($map) {
$map = $map->customise_for ($self);
$map = $check->($map) if $check && $map;
} else {
- $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
+ $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
}
$map
@@ -2465,6 +2664,8 @@
if $exit->flag (FLAG_DAMNED);
(async {
+ $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
+
$self->deactivate_recursive; # just to be sure
unless (eval {
$self->goto ($slaying, $hp, $sp);
@@ -2509,18 +2710,80 @@
=cut
+# non-persistent channels (usually the info channel)
+our %CHANNEL = (
+ "c/identify" => {
+ id => "infobox",
+ title => "Identify",
+ reply => undef,
+ tooltip => "Items recently identified",
+ },
+ "c/examine" => {
+ id => "infobox",
+ title => "Examine",
+ reply => undef,
+ tooltip => "Signs and other items you examined",
+ },
+ "c/book" => {
+ id => "infobox",
+ title => "Book",
+ reply => undef,
+ tooltip => "The contents of a note or book",
+ },
+ "c/lookat" => {
+ id => "infobox",
+ title => "Look",
+ reply => undef,
+ tooltip => "What you saw there",
+ },
+ "c/who" => {
+ id => "infobox",
+ title => "Players",
+ reply => undef,
+ tooltip => "Shows players who are currently online",
+ },
+ "c/body" => {
+ id => "infobox",
+ title => "Body Parts",
+ reply => undef,
+ tooltip => "Shows which body parts you posess and are available",
+ },
+ "c/uptime" => {
+ id => "infobox",
+ title => "Uptime",
+ reply => undef,
+ tooltip => "How long the server has been running since last restart",
+ },
+ "c/mapinfo" => {
+ id => "infobox",
+ title => "Map Info",
+ reply => undef,
+ tooltip => "Information related to the maps",
+ },
+);
+
sub cf::client::send_msg {
my ($self, $channel, $msg, $color, @extra) = @_;
$msg = $self->pl->expand_cfpod ($msg);
- $color &= ~cf::NDI_UNIQUE; # just in case...
+ $color &= cf::NDI_CLIENT_MASK; # just in case...
+
+ # check predefined channels, for the benefit of C
+ if ($CHANNEL{$channel}) {
+ $channel = $CHANNEL{$channel};
+
+ $self->ext_msg (channel_info => $channel)
+ if $self->can_msg;
+
+ $channel = $channel->{id};
- if (ref $channel) {
+ } 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);
+ $self->ext_msg (channel_info => $channel)
+ if $self->can_msg;
}
$channel = $channel->{id};
@@ -2529,21 +2792,31 @@
return unless @extra || length $msg;
if ($self->can_msg) {
- $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));
- } else {
- # 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]/;
- }
+ # 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 =~ /\[/) {
- $self->send_packet ("drawextinfo $color 4 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")
@@ -2561,16 +2834,32 @@
sub cf::client::ext_msg($$@) {
my ($self, $type, @msg) = @_;
- my $extcmd = $self->extcmd;
-
- if ($extcmd == 2) {
+ if ($self->extcmd == 2) {
$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
- } elsif ($extcmd == 1) { # TODO: remove
+ } elsif ($self->extcmd == 1) { # TODO: remove
push @msg, msgtype => "event_$type";
$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
}
}
+=item $client->ext_reply ($msgid, @msg)
+
+Sends an ext reply to the client.
+
+=cut
+
+sub cf::client::ext_reply($$@) {
+ my ($self, $id, @msg) = @_;
+
+ if ($self->extcmd == 2) {
+ $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
+ } elsif ($self->extcmd == 1) {
+ #TODO: version 1, remove
+ unshift @msg, msgtype => "reply", msgid => $id;
+ $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
+ }
+}
+
=item $success = $client->query ($flags, "text", \&cb)
Queues a query to the client, calling the given callback with
@@ -2638,12 +2927,15 @@
? @$msg
: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
- if (my $cb = $EXTICMD{$type}) {
- my @reply = $cb->($ns, @payload);
+ my @reply;
- $ns->ext_reply ($reply, @reply)
- if $reply;
+ if (my $cb = $EXTICMD{$type}) {
+ @reply = $cb->($ns, @payload);
}
+
+ $ns->ext_reply ($reply, @reply)
+ if $reply;
+
} else {
warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
}
@@ -2700,7 +2992,11 @@
$SIG{FPE} = 'IGNORE';
-$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
+$safe->permit_only (Opcode::opset qw(
+ :base_core :base_mem :base_orig :base_math
+ grepstart grepwhile mapstart mapwhile
+ sort time
+));
# here we export the classes and methods available to script code
@@ -2709,8 +3005,8 @@
The following functions and methods are available within a safe environment:
cf::object
- contr pay_amount pay_player map x y force_find force_add
- insert remove
+ contr pay_amount pay_player map x y force_find force_add destroy
+ insert remove name archname title slaying race decrease_ob_nr
cf::object::player
player
@@ -2725,7 +3021,8 @@
for (
["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
- insert remove)],
+ insert remove inv name archname title slaying race
+ decrease_ob_nr destroy)],
["cf::object::player" => qw(player)],
["cf::player" => qw(peaceful)],
["cf::map" => qw(trigger)],
@@ -2811,6 +3108,12 @@
sub load_facedata($) {
my ($path) = @_;
+ # HACK to clear player env face cache, we need some signal framework
+ # for this (global event?)
+ %ext::player_env::MUSIC_FACE_CACHE = ();
+
+ my $enc = JSON::XS->new->utf8->canonical->relaxed;
+
warn "loading facedata from $path\n";
my $facedata;
@@ -2822,6 +3125,13 @@
$facedata->{version} == 2
or cf::cleanup "$path: version mismatch, cannot proceed.";
+ # patch in the exptable
+ $facedata->{resource}{"res/exp_table"} = {
+ type => FT_RSRC,
+ data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
+ };
+ cf::cede_to_tick;
+
{
my $faces = $facedata->{faceinfo};
@@ -2829,8 +3139,8 @@
my $idx = (cf::face::find $face) || cf::face::alloc $face;
cf::face::set_visibility $idx, $info->{visibility};
cf::face::set_magicmap $idx, $info->{magicmap};
- cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
- cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
+ cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
+ cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
cf::cede_to_tick;
}
@@ -2865,31 +3175,49 @@
# TODO: for gcfclient pleasure, we should give resources
# that gcfclient doesn't grok a >10000 face index.
my $res = $facedata->{resource};
- my $enc = JSON::XS->new->utf8->canonical;
- while (my ($name, $info) = each %$res) {
- my $meta = $enc->encode ({
- name => $name,
- copyright => $info->{copyright}, #TODO#
- });
+ my $soundconf = delete $res->{"res/sound.conf"};
+ while (my ($name, $info) = each %$res) {
my $idx = (cf::face::find $name) || cf::face::alloc $name;
+ my $data;
if ($info->{type} & 1) {
# prepend meta info
- my $data = pack "(w/a*)*", $meta, $info->{data};
- my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
+ my $meta = $enc->encode ({
+ name => $name,
+ %{ $info->{meta} || {} },
+ });
- cf::face::set_data $idx, 0, $data, $chk;
+ $data = pack "(w/a*)*", $meta, $info->{data};
} else {
- cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
+ $data = $info->{data};
}
+ cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
cf::face::set_type $idx, $info->{type};
cf::cede_to_tick;
}
+
+ if ($soundconf) {
+ $soundconf = $enc->decode (delete $soundconf->{data});
+
+ for (0 .. SOUND_CAST_SPELL_0 - 1) {
+ my $sound = $soundconf->{compat}[$_]
+ or next;
+
+ my $face = cf::face::find "sound/$sound->[1]";
+ cf::sound::set $sound->[0] => $face;
+ cf::sound::old_sound_index $_, $face; # gcfclient-compat
+ }
+
+ while (my ($k, $v) = each %{$soundconf->{event}}) {
+ my $face = cf::face::find "sound/$v";
+ cf::sound::set $k => $face;
+ }
+ }
}
1
@@ -2904,6 +3232,10 @@
};
sub reload_regions {
+ # HACK to clear player env face cache, we need some signal framework
+ # for this (global event?)
+ %ext::player_env::MUSIC_FACE_CACHE = ();
+
load_resource_file "$MAPDIR/regions"
or die "unable to load regions file\n";
@@ -2949,7 +3281,7 @@
reload_resources;
}
-sub cfg_load {
+sub reload_config {
open my $fh, "<:utf8", "$CONFDIR/config"
or return;
@@ -2975,11 +3307,12 @@
local $Coro::idle = sub {
Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
(async {
+ $Coro::current->{desc} = "IDLE BUG HANDLER";
Event::one_event;
})->prio (Coro::PRIO_MAX);
};
- cfg_load;
+ reload_config;
db_init;
load_extensions;
@@ -3056,6 +3389,7 @@
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";
@@ -3113,7 +3447,7 @@
for (;;) {
BDB::flush;
IO::AIO::flush;
- Coro::cede;
+ Coro::cede_notself;
last unless IO::AIO::nreqs || BDB::nreqs;
warn "iterate...";
}
@@ -3182,7 +3516,7 @@
cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
warn "loading config and database again";
- cf::cfg_load;
+ cf::reload_config;
warn "loading extensions";
cf::load_extensions;
@@ -3228,7 +3562,10 @@
if ($who->flag (FLAG_WIZ)) {
$who->message ("reloading server.");
- async { reload_perl };
+ async {
+ $Coro::current->{desc} = "perl_reload";
+ reload_perl;
+ };
}
};
@@ -3257,8 +3594,6 @@
$signal->wait;
}
- my $min = 1e6;#d#
- my $avg = 10;
$TICK_WATCHER = Event->timer (
reentrant => 0,
parked => 1,
@@ -3276,43 +3611,18 @@
cf::server_tick; # one server iteration
- 0 && sync_job {#d#
- for(1..10) {
- my $t = Event::time;
- my $map = my $map = new_from_path cf::map "/tmp/x.map"
- or die;
-
- $map->width (50);
- $map->height (50);
- $map->alloc;
- $map->_load_objects ("/tmp/x.map", 1);
- my $t = Event::time - $t;
-
- #next unless $t < 0.0013;#d#
- if ($t < $min) {
- $min = $t;
- }
- $avg = $avg * 0.99 + $t * 0.01;
- }
- warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
- exit 0;
- # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
- };
-
$RUNTIME += $TICK;
$NEXT_TICK += $TICK;
if ($NOW >= $NEXT_RUNTIME_WRITE) {
$NEXT_RUNTIME_WRITE = $NOW + 10;
Coro::async_pool {
+ $Coro::current->{desc} = "runtime saver";
write_runtime
or warn "ERROR: unable to write runtime file: $!";
};
}
-# my $AFTER = Event::time;
-# warn $AFTER - $NOW;#d#
-
if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
$sig->send;
}
@@ -3332,12 +3642,11 @@
$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
_post_tick;
-
-
},
);
{
+ BDB::min_parallel 8;
BDB::max_poll_time $TICK * 0.1;
$BDB_POLL_WATCHER = Event->io (
reentrant => 0,
@@ -3347,7 +3656,6 @@
data => WF_AUTOCANCEL,
cb => \&BDB::poll_cb,
);
- BDB::min_parallel 8;
BDB::set_sync_prepare {
my $status;
@@ -3366,6 +3674,10 @@
unless ($DB_ENV) {
$DB_ENV = BDB::db_env_create;
+ $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
+ | BDB::LOG_AUTOREMOVE, 1);
+ $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
+ $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
cf::sync_job {
eval {
@@ -3377,14 +3689,42 @@
0666;
cf::cleanup "db_env_open($BDBDIR): $!" if $!;
-
- $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
- $DB_ENV->set_lk_detect;
};
cf::cleanup "db_env_open(db): $@" if $@;
};
}
+
+ $BDB_DEADLOCK_WATCHER = Event->timer (
+ after => 3,
+ interval => 1,
+ hard => 1,
+ prio => 0,
+ data => WF_AUTOCANCEL,
+ cb => sub {
+ BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
+ },
+ );
+ $BDB_CHECKPOINT_WATCHER = Event->timer (
+ after => 11,
+ interval => 60,
+ hard => 1,
+ prio => 0,
+ data => WF_AUTOCANCEL,
+ cb => sub {
+ BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
+ },
+ );
+ $BDB_TRICKLE_WATCHER = Event->timer (
+ after => 5,
+ interval => 10,
+ hard => 1,
+ prio => 0,
+ data => WF_AUTOCANCEL,
+ cb => sub {
+ BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
+ },
+ );
}
{
@@ -3397,7 +3737,7 @@
data => WF_AUTOCANCEL,
fd => IO::AIO::poll_fileno,
poll => 'r',
- prio => 6,
+ prio => 0,
cb => \&IO::AIO::poll_cb,
);
}
@@ -3413,6 +3753,8 @@
if ($_log_backtrace < 2) {
++$_log_backtrace;
async {
+ $Coro::current->{desc} = "abt $msg";
+
my @bt = fork_call {
@addr = map { sprintf "%x", $_ } @addr;
my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;