--- deliantra/server/lib/cf.pm 2007/09/08 18:15:55 1.359
+++ deliantra/server/lib/cf.pm 2007/10/26 04:44:54 1.392
@@ -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.64 ();
+use Coro 4.1 ();
use Coro::State;
use Coro::Handle;
use Coro::Event;
@@ -29,7 +29,7 @@
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 ();
@@ -82,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;
@@ -189,7 +192,6 @@
$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
- utf8::encode $msg;
LOG llevError, $msg;
};
}
@@ -354,6 +356,8 @@
$SLOT_QUEUE->cancel if $SLOT_QUEUE;
$SLOT_QUEUE = Coro::async {
+ $Coro::current->desc ("timeslot manager");
+
my $signal = new Coro::Signal;
while () {
@@ -371,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 {
@@ -425,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;
@@ -433,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;
@@ -510,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($$) {
@@ -950,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 {
@@ -1015,12 +1068,11 @@
sub object_freezer_save {
my ($filename, $rdata, $objs) = @_;
- my $guard = cf::lock_acquire "io";
-
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;
@@ -1031,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;
@@ -1050,8 +1102,6 @@
aio_unlink "$filename.pst";
}
};
-
- undef $guard;
}
sub object_freezer_as_string {
@@ -1067,8 +1117,6 @@
my ($data, $av);
- my $guard = cf::lock_acquire "io";
-
(aio_load $filename, $data) >= 0
or return;
@@ -1076,12 +1124,13 @@
(aio_load "$filename.pst", $av) >= 0
or return;
- undef $guard;
- $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 || []};
+ utf8::decode (my $decname = $filename);
+ warn sprintf "loading %s (%d,%d)\n",
+ $decname, length $data, scalar @{$av || []};
($data, $av)
}
@@ -1279,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).
@@ -1326,7 +1389,6 @@
my $f = new_from_file cf::object::thawer path $login
or return;
- $f->next;
my $pl = cf::player::load_pl $f
or return;
local $cf::PLAYER_LOADING{$login} = $pl;
@@ -1488,44 +1550,83 @@
=cut
+ use re 'eval';
+
+my $group;
+my $interior; $interior = qr{
+ (?:
+ \ (.*?)\ (?{ $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;
+ }
+ }
+
+ for ($xml) {
+ # create single paragraphs (very hackish)
+ s/(?<=\S)\n(?=\w)/ /g;
- # escape & and <
- s/&/&/g;
- s/(?, I<>, U<> etc.
- s/B<([^\>]*)>/$1<\/b>/
- || s/I<([^\>]*)>/$1<\/i>/
- || s/U<([^\>]*)>/$1<\/u>/
- || s/T<([^\>]*)>/$1<\/b><\/big>/
- # 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
+ # 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
}
sub hintmode {
@@ -1893,7 +1994,7 @@
my $guard = cf::lock_acquire "map_data:$path";
return unless $self->valid;
- return if $self->in_memory != cf::MAP_SWAPPED;
+ return unless $self->in_memory == cf::MAP_SWAPPED;
$self->in_memory (cf::MAP_LOADING);
@@ -2017,6 +2118,8 @@
$MAP_PREFETCH{$path} |= $load;
$MAP_PREFETCHER ||= cf::async {
+ $Coro::current->{desc} = "map prefetcher";
+
while (%MAP_PREFETCH) {
while (my ($k, $v) = each %MAP_PREFETCH) {
if (my $map = find $k) {
@@ -2052,6 +2155,7 @@
local $self->{last_access} = $self->last_access;#d#
cf::async {
+ $Coro::current->{desc} = "map player save";
$_->contr->save for $self->players;
};
@@ -2248,10 +2352,7 @@
sub deref {
my ($ref) = @_;
- # temporary compatibility#TODO#remove
- $ref =~ s{^<}{player/<};
-
- if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
+ 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;
@@ -2432,14 +2533,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
@@ -2539,6 +2661,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);
@@ -2583,19 +2707,56 @@
=cut
+# non-persistent channels (usually the info channel)
our %CHANNEL = (
"c/identify" => {
- id => "identify",
+ id => "infobox",
title => "Identify",
reply => undef,
tooltip => "Items recently identified",
},
"c/examine" => {
- id => "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 {
@@ -2606,9 +2767,15 @@
$color &= cf::NDI_CLIENT_MASK; # just in case...
# check predefined channels, for the benefit of C
- $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
+ if ($CHANNEL{$channel}) {
+ $channel = $CHANNEL{$channel};
+
+ $self->ext_msg (channel_info => $channel)
+ if $self->can_msg;
- if (ref $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;
@@ -2835,7 +3002,7 @@
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
+ 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
@@ -2852,7 +3019,7 @@
for (
["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
insert remove inv name archname title slaying race
- decrease_ob_nr)],
+ decrease_ob_nr destroy)],
["cf::object::player" => qw(player)],
["cf::player" => qw(peaceful)],
["cf::map" => qw(trigger)],
@@ -3137,6 +3304,7 @@
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);
};
@@ -3218,6 +3386,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";
@@ -3275,7 +3444,7 @@
for (;;) {
BDB::flush;
IO::AIO::flush;
- Coro::cede;
+ Coro::cede_notself;
last unless IO::AIO::nreqs || BDB::nreqs;
warn "iterate...";
}
@@ -3390,7 +3559,10 @@
if ($who->flag (FLAG_WIZ)) {
$who->message ("reloading server.");
- async { reload_perl };
+ async {
+ $Coro::current->{desc} = "perl_reload";
+ reload_perl;
+ };
}
};
@@ -3419,8 +3591,6 @@
$signal->wait;
}
- my $min = 1e6;#d#
- my $avg = 10;
$TICK_WATCHER = Event->timer (
reentrant => 0,
parked => 1,
@@ -3438,43 +3608,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); #TODO: does not work
- 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;
}
@@ -3494,12 +3639,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,
@@ -3509,7 +3653,6 @@
data => WF_AUTOCANCEL,
cb => \&BDB::poll_cb,
);
- BDB::min_parallel 8;
BDB::set_sync_prepare {
my $status;
@@ -3528,6 +3671,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 {
@@ -3539,14 +3686,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 { };
+ },
+ );
}
{
@@ -3559,7 +3734,7 @@
data => WF_AUTOCANCEL,
fd => IO::AIO::poll_fileno,
poll => 'r',
- prio => 6,
+ prio => 0,
cb => \&IO::AIO::poll_cb,
);
}
@@ -3575,6 +3750,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;