ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.470 by root, Sun Apr 26 19:42:45 2009 UTC vs.
Revision 1.606 by root, Sun Nov 18 08:34:23 2012 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# 18# <http://www.gnu.org/licenses/>.
19#
19# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use 5.10.0; 25use common::sense;
25use utf8;
26use strict qw(vars subs);
27 26
28use Symbol; 27use Symbol;
29use List::Util; 28use List::Util;
30use Socket; 29use Socket;
31use EV; 30use EV;
32use Opcode; 31use Opcode;
33use Safe; 32use Safe;
34use Safe::Hole; 33use Safe::Hole;
35use Storable (); 34use Storable ();
36
37use Guard (); 35use Carp ();
36
37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
40
38use Coro (); 41use Coro ();
39use Coro::State; 42use Coro::State;
40use Coro::Handle; 43use Coro::Handle;
41use Coro::EV; 44use Coro::EV;
42use Coro::AnyEvent; 45use Coro::AnyEvent;
… …
48use Coro::AIO; 51use Coro::AIO;
49use Coro::BDB 1.6; 52use Coro::BDB 1.6;
50use Coro::Storable; 53use Coro::Storable;
51use Coro::Util (); 54use Coro::Util ();
52 55
56use Guard ();
53use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
54use BDB (); 58use BDB ();
55use Data::Dumper; 59use Data::Dumper;
56use Digest::MD5;
57use Fcntl; 60use Fcntl;
58use YAML (); 61use YAML::XS ();
59use IO::AIO (); 62use IO::AIO ();
60use Time::HiRes;
61use Compress::LZF; 63use Compress::LZF;
62use Digest::MD5 (); 64use Digest::MD5 ();
63 65
64AnyEvent::detect; 66AnyEvent::detect;
65 67
… …
72 74
73# make sure c-lzf reinitialises itself 75# make sure c-lzf reinitialises itself
74Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve"; 76Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
75Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 77Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
76 78
79# strictly for debugging
80$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
81
77sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 82sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
83
84our @ORIG_INC;
78 85
79our %COMMAND = (); 86our %COMMAND = ();
80our %COMMAND_TIME = (); 87our %COMMAND_TIME = ();
81 88
82our @EXTS = (); # list of extension package names 89our @EXTS = (); # list of extension package names
83our %EXTCMD = (); 90our %EXTCMD = ();
91our %EXTACMD = ();
84our %EXTICMD = (); 92our %EXTICMD = ();
93our %EXTIACMD = ();
85our %EXT_CORO = (); # coroutines bound to extensions 94our %EXT_CORO = (); # coroutines bound to extensions
86our %EXT_MAP = (); # pluggable maps 95our %EXT_MAP = (); # pluggable maps
87 96
88our $RELOAD; # number of reloads so far, non-zero while in reload 97our $RELOAD; # number of reloads so far, non-zero while in reload
89our @EVENT; 98our @EVENT;
99our @REFLECT; # set by XS
100our %REFLECT; # set by us
90 101
91our $CONFDIR = confdir; 102our $CONFDIR = confdir;
103
92our $DATADIR = datadir; 104our $DATADIR = datadir;
93our $LIBDIR = "$DATADIR/ext"; 105our $LIBDIR = "$DATADIR/ext";
94our $PODDIR = "$DATADIR/pod"; 106our $PODDIR = "$DATADIR/pod";
95our $MAPDIR = "$DATADIR/" . mapdir; 107our $MAPDIR = "$DATADIR/" . mapdir;
108
96our $LOCALDIR = localdir; 109our $LOCALDIR = localdir;
97our $TMPDIR = "$LOCALDIR/" . tmpdir; 110our $TMPDIR = "$LOCALDIR/" . tmpdir;
98our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 111our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
99our $PLAYERDIR = "$LOCALDIR/" . playerdir; 112our $PLAYERDIR = "$LOCALDIR/" . playerdir;
100our $RANDOMDIR = "$LOCALDIR/random"; 113our $RANDOMDIR = "$LOCALDIR/random";
101our $BDBDIR = "$LOCALDIR/db"; 114our $BDBDIR = "$LOCALDIR/db";
102our $PIDFILE = "$LOCALDIR/pid"; 115our $PIDFILE = "$LOCALDIR/pid";
103our $RUNTIMEFILE = "$LOCALDIR/runtime"; 116our $RUNTIMEFILE = "$LOCALDIR/runtime";
104 117
105our %RESOURCE; 118#our %RESOURCE; # unused
119
120our $OUTPUT_RATE_MIN = 3000;
121our $OUTPUT_RATE_MAX = 1000000;
122
123our $MAX_LINKS = 32; # how many chained exits to follow
124our $VERBOSE_IO = 1;
106 125
107our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 126our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
108our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 127our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
109our $NEXT_TICK; 128our $NEXT_TICK;
110our $USE_FSYNC = 1; # use fsync to write maps - default on 129our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
112our $BDB_DEADLOCK_WATCHER; 131our $BDB_DEADLOCK_WATCHER;
113our $BDB_CHECKPOINT_WATCHER; 132our $BDB_CHECKPOINT_WATCHER;
114our $BDB_TRICKLE_WATCHER; 133our $BDB_TRICKLE_WATCHER;
115our $DB_ENV; 134our $DB_ENV;
116 135
117our @EXTRA_MODULES = qw(pod mapscript); 136our @EXTRA_MODULES = qw(pod match mapscript incloader);
118 137
119our %CFG; 138our %CFG;
139our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
120 140
121our $UPTIME; $UPTIME ||= time; 141our $UPTIME; $UPTIME ||= time;
122our $RUNTIME; 142our $RUNTIME = 0;
143our $SERVER_TICK = 0;
123our $NOW; 144our $NOW;
124 145
125our (%PLAYER, %PLAYER_LOADING); # all users 146our (%PLAYER, %PLAYER_LOADING); # all users
126our (%MAP, %MAP_LOADING ); # all maps 147our (%MAP, %MAP_LOADING ); # all maps
127our $LINK_MAP; # the special {link} map, which is always available 148our $LINK_MAP; # the special {link} map, which is always available
… …
134our $JITTER; # average jitter 155our $JITTER; # average jitter
135our $TICK_START; # for load detecting purposes 156our $TICK_START; # for load detecting purposes
136 157
137our @POST_INIT; 158our @POST_INIT;
138 159
139our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow) 160our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
161our $REALLY_UNLOOP; # never set to true, please :)
162
163our $WAIT_FOR_TICK = new Coro::Signal;
164our @WAIT_FOR_TICK_BEGIN;
140 165
141binmode STDOUT; 166binmode STDOUT;
142binmode STDERR; 167binmode STDERR;
143 168
144# read virtual server time, if available 169# read virtual server time, if available
… …
155 180
156our $EMERGENCY_POSITION; 181our $EMERGENCY_POSITION;
157 182
158sub cf::map::normalise; 183sub cf::map::normalise;
159 184
185sub in_main() {
186 $Coro::current == $Coro::main
187}
188
160############################################################################# 189#############################################################################
161 190
191%REFLECT = ();
192for (@REFLECT) {
193 my $reflect = JSON::XS::decode_json $_;
194 $REFLECT{$reflect->{class}} = $reflect;
195}
196
197# this is decidedly evil
198$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
199
200#############################################################################
201
162=head2 GLOBAL VARIABLES 202=head2 GLOBAL VARIABLES
163 203
164=over 4 204=over 4
165 205
166=item $cf::UPTIME 206=item $cf::UPTIME
167 207
168The timestamp of the server start (so not actually an uptime). 208The timestamp of the server start (so not actually an "uptime").
209
210=item $cf::SERVER_TICK
211
212An unsigned integer that starts at zero when the server is started and is
213incremented on every tick.
214
215=item $cf::NOW
216
217The (real) time of the last (current) server tick - updated before and
218after tick processing, so this is useful only as a rough "what time is it
219now" estimate.
220
221=item $cf::TICK
222
223The interval between each server tick, in seconds.
169 224
170=item $cf::RUNTIME 225=item $cf::RUNTIME
171 226
172The time this server has run, starts at 0 and is increased by $cf::TICK on 227The time this server has run, starts at 0 and is increased by $cf::TICK on
173every server tick. 228every server tick.
174 229
175=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 230=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
176$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 231$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
177$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 232$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
178 233
179Various directories - "/etc", read-only install directory, perl-library 234Various directories - "/etc", read-only install directory, perl-library
180directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 235directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
181unique-items directory, player file directory, random maps directory and 236unique-items directory, player file directory, random maps directory and
182database environment. 237database environment.
183 238
184=item $cf::NOW
185
186The time of the last (current) server tick.
187
188=item $cf::TICK
189
190The interval between server ticks, in seconds.
191
192=item $cf::LOADAVG 239=item $cf::LOADAVG
193 240
194The current CPU load on the server (alpha-smoothed), as a value between 0 241The current CPU load on the server (alpha-smoothed), as a value between 0
195(none) and 1 (overloaded), indicating how much time is spent on processing 242(none) and 1 (overloaded), indicating how much time is spent on processing
196objects per tick. Healthy values are < 0.5. 243objects per tick. Healthy values are < 0.5.
… …
204Configuration for the server, loaded from C</etc/deliantra-server/config>, or 251Configuration for the server, loaded from C</etc/deliantra-server/config>, or
205from wherever your confdir points to. 252from wherever your confdir points to.
206 253
207=item cf::wait_for_tick, cf::wait_for_tick_begin 254=item cf::wait_for_tick, cf::wait_for_tick_begin
208 255
209These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 256These are functions that inhibit the current coroutine one tick.
210returns directly I<after> the tick processing (and consequently, can only wake one process 257cf::wait_for_tick_begin only returns directly I<after> the tick
258processing (and consequently, can only wake one thread per tick), while
211per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 259cf::wait_for_tick wakes up all waiters after tick processing.
260
261Note that cf::wait_for_tick will immediately return when the server is not
262ticking, making it suitable for small pauses in threads that need to run
263when the server is paused. If that is not applicable (i.e. you I<really>
264want to wait, use C<$cf::WAIT_FOR_TICK>).
265
266=item $cf::WAIT_FOR_TICK
267
268Note that C<cf::wait_for_tick> is probably the correct thing to use. This
269variable contains a L<Coro::Signal> that is broadcats after every server
270tick. Calling C<< ->wait >> on it will suspend the caller until after the
271next server tick.
272
273=cut
274
275sub wait_for_tick();
276sub wait_for_tick_begin();
212 277
213=item @cf::INVOKE_RESULTS 278=item @cf::INVOKE_RESULTS
214 279
215This array contains the results of the last C<invoke ()> call. When 280This array contains the results of the last C<invoke ()> call. When
216C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 281C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
217that call. 282that call.
218 283
284=item %cf::REFLECT
285
286Contains, for each (C++) class name, a hash reference with information
287about object members (methods, scalars, arrays and flags) and other
288metadata, which is useful for introspection.
289
219=back 290=back
220 291
221=cut 292=cut
222 293
223BEGIN { 294sub error(@) { LOG llevError, join "", @_ }
224 *CORE::GLOBAL::warn = sub { 295sub warn (@) { LOG llevWarn , join "", @_ }
296sub info (@) { LOG llevInfo , join "", @_ }
297sub debug(@) { LOG llevDebug, join "", @_ }
298sub trace(@) { LOG llevTrace, join "", @_ }
299
300$Coro::State::WARNHOOK = sub {
225 my $msg = join "", @_; 301 my $msg = join "", @_;
226 302
227 $msg .= "\n" 303 $msg .= "\n"
228 unless $msg =~ /\n$/; 304 unless $msg =~ /\n$/;
229 305
230 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 306 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
231 307
232 LOG llevError, $msg; 308 LOG llevWarn, $msg;
233 }; 309};
234}
235 310
236$Coro::State::DIEHOOK = sub { 311$Coro::State::DIEHOOK = sub {
237 return unless $^S eq 0; # "eq", not "==" 312 return unless $^S eq 0; # "eq", not "=="
238 313
239 if ($Coro::current == $Coro::main) {#d# 314 error Carp::longmess $_[0];
315
316 if (in_main) {#d#
240 warn "DIEHOOK called in main context, Coro bug?\n";#d# 317 error "DIEHOOK called in main context, Coro bug?\n";#d#
241 return;#d# 318 return;#d#
242 }#d# 319 }#d#
243 320
244 # kill coroutine otherwise 321 # kill coroutine otherwise
245 warn Carp::longmess $_[0];
246 Coro::terminate 322 Coro::terminate
247}; 323};
248
249$SIG{__DIE__} = sub { }; #d#?
250 324
251@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 325@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
252@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 326@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
253@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 327@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
254@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 328@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
268)) { 342)) {
269 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 343 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
270} 344}
271 345
272$EV::DIED = sub { 346$EV::DIED = sub {
273 warn "error in event callback: @_"; 347 warn "error in event callback: $@";
274}; 348};
349
350#############################################################################
351
352sub fork_call(&@);
353sub get_slot($;$$);
275 354
276############################################################################# 355#############################################################################
277 356
278=head2 UTILITY FUNCTIONS 357=head2 UTILITY FUNCTIONS
279 358
… …
300 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 379 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
301 $d 380 $d
302 } || "[unable to dump $_[0]: '$@']"; 381 } || "[unable to dump $_[0]: '$@']";
303} 382}
304 383
384=item $scalar = cf::load_file $path
385
386Loads the given file from path and returns its contents. Croaks on error
387and can block.
388
389=cut
390
391sub load_file($) {
392 0 <= aio_load $_[0], my $data
393 or Carp::croak "$_[0]: $!";
394
395 $data
396}
397
398=item $success = cf::replace_file $path, $data, $sync
399
400Atomically replaces the file at the given $path with new $data, and
401optionally $sync the data to disk before replacing the file.
402
403=cut
404
405sub replace_file($$;$) {
406 my ($path, $data, $sync) = @_;
407
408 my $lock = cf::lock_acquire ("replace_file:$path");
409
410 my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
411 or return;
412
413 $data = $data->() if ref $data;
414
415 length $data == aio_write $fh, 0, (length $data), $data, 0
416 or return;
417
418 !$sync
419 or !aio_fsync $fh
420 or return;
421
422 aio_close $fh
423 and return;
424
425 aio_rename "$path~", $path
426 and return;
427
428 if ($sync) {
429 $path =~ s%/[^/]*$%%;
430 aio_pathsync $path;
431 }
432
433 1
434}
435
305=item $ref = cf::decode_json $json 436=item $ref = cf::decode_json $json
306 437
307Converts a JSON string into the corresponding perl data structure. 438Converts a JSON string into the corresponding perl data structure.
308 439
309=item $json = cf::encode_json $ref 440=item $json = cf::encode_json $ref
… …
315our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 446our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
316 447
317sub encode_json($) { $json_coder->encode ($_[0]) } 448sub encode_json($) { $json_coder->encode ($_[0]) }
318sub decode_json($) { $json_coder->decode ($_[0]) } 449sub decode_json($) { $json_coder->decode ($_[0]) }
319 450
451=item $ref = cf::decode_storable $scalar
452
453Same as Coro::Storable::thaw, so blocks.
454
455=cut
456
457BEGIN { *decode_storable = \&Coro::Storable::thaw }
458
459=item $ref = cf::decode_yaml $scalar
460
461Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
462
463=cut
464
465sub decode_yaml($) {
466 fork_call { YAML::XS::Load $_[0] } @_
467}
468
469=item $scalar = cf::unlzf $scalar
470
471Same as Compress::LZF::compress, but takes server ticks into account, so
472blocks.
473
474=cut
475
476sub unlzf($) {
477 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
478 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
479 Compress::LZF::decompress $_[0]
480}
481
320=item cf::post_init { BLOCK } 482=item cf::post_init { BLOCK }
321 483
322Execute the given codeblock, I<after> all extensions have been (re-)loaded, 484Execute the given codeblock, I<after> all extensions have been (re-)loaded,
323but I<before> the server starts ticking again. 485but I<before> the server starts ticking again.
324 486
325The cdoeblock will have a single boolean argument to indicate whether this 487The codeblock will have a single boolean argument to indicate whether this
326is a reload or not. 488is a reload or not.
327 489
328=cut 490=cut
329 491
330sub post_init(&) { 492sub post_init(&) {
331 push @POST_INIT, shift; 493 push @POST_INIT, shift;
494}
495
496sub _post_init {
497 trace "running post_init jobs";
498
499 # run them in parallel...
500
501 my @join;
502
503 while () {
504 push @join, map &Coro::async ($_, 0), @POST_INIT;
505 @POST_INIT = ();
506
507 @join or last;
508
509 (pop @join)->join;
510 }
332} 511}
333 512
334=item cf::lock_wait $string 513=item cf::lock_wait $string
335 514
336Wait until the given lock is available. See cf::lock_acquire. 515Wait until the given lock is available. See cf::lock_acquire.
… …
375} 554}
376 555
377=item cf::periodic $interval, $cb 556=item cf::periodic $interval, $cb
378 557
379Like EV::periodic, but randomly selects a starting point so that the actions 558Like EV::periodic, but randomly selects a starting point so that the actions
380get spread over timer. 559get spread over time.
381 560
382=cut 561=cut
383 562
384sub periodic($$) { 563sub periodic($$) {
385 my ($interval, $cb) = @_; 564 my ($interval, $cb) = @_;
… …
389 EV::periodic $start, $interval, 0, $cb 568 EV::periodic $start, $interval, 0, $cb
390} 569}
391 570
392=item cf::get_slot $time[, $priority[, $name]] 571=item cf::get_slot $time[, $priority[, $name]]
393 572
394Allocate $time seconds of blocking CPU time at priority C<$priority>: 573Allocate $time seconds of blocking CPU time at priority C<$priority>
395This call blocks and returns only when you have at least C<$time> seconds 574(default: 0): This call blocks and returns only when you have at least
396of cpu time till the next tick. The slot is only valid till the next cede. 575C<$time> seconds of cpu time till the next tick. The slot is only valid
576till the next cede.
577
578Background jobs should use a priority less than zero, interactive jobs
579should use 100 or more.
397 580
398The optional C<$name> can be used to identify the job to run. It might be 581The optional C<$name> can be used to identify the job to run. It might be
399used for statistical purposes and should identify the same time-class. 582used for statistical purposes and should identify the same time-class.
400 583
401Useful for short background jobs. 584Useful for short background jobs.
402 585
403=cut 586=cut
404 587
405our @SLOT_QUEUE; 588our @SLOT_QUEUE;
406our $SLOT_QUEUE; 589our $SLOT_QUEUE;
590our $SLOT_DECAY = 0.9;
407 591
408$SLOT_QUEUE->cancel if $SLOT_QUEUE; 592$SLOT_QUEUE->cancel if $SLOT_QUEUE;
409$SLOT_QUEUE = Coro::async { 593$SLOT_QUEUE = Coro::async {
410 $Coro::current->desc ("timeslot manager"); 594 $Coro::current->desc ("timeslot manager");
411 595
412 my $signal = new Coro::Signal; 596 my $signal = new Coro::Signal;
597 my $busy;
413 598
414 while () { 599 while () {
415 next_job: 600 next_job:
601
416 my $avail = cf::till_tick; 602 my $avail = cf::till_tick;
417 if ($avail > 0.01) { 603
418 for (0 .. $#SLOT_QUEUE) { 604 for (0 .. $#SLOT_QUEUE) {
419 if ($SLOT_QUEUE[$_][0] < $avail) { 605 if ($SLOT_QUEUE[$_][0] <= $avail) {
606 $busy = 0;
420 my $job = splice @SLOT_QUEUE, $_, 1, (); 607 my $job = splice @SLOT_QUEUE, $_, 1, ();
421 $job->[2]->send; 608 $job->[2]->send;
422 Coro::cede; 609 Coro::cede;
423 goto next_job; 610 goto next_job;
424 } 611 } else {
612 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
425 } 613 }
426 } 614 }
427 615
428 if (@SLOT_QUEUE) { 616 if (@SLOT_QUEUE) {
429 # we do not use wait_for_tick() as it returns immediately when tick is inactive 617 # we do not use wait_for_tick() as it returns immediately when tick is inactive
430 push @cf::WAIT_FOR_TICK, $signal; 618 $WAIT_FOR_TICK->wait;
431 $signal->wait;
432 } else { 619 } else {
620 $busy = 0;
433 Coro::schedule; 621 Coro::schedule;
434 } 622 }
435 } 623 }
436}; 624};
437 625
438sub get_slot($;$$) { 626sub get_slot($;$$) {
439 return if tick_inhibit || $Coro::current == $Coro::main; 627 return if tick_inhibit || $Coro::current == $Coro::main;
440 628
441 my ($time, $pri, $name) = @_; 629 my ($time, $pri, $name) = @_;
442 630
443 $time = $TICK * .6 if $time > $TICK * .6; 631 $time = clamp $time, 0.01, $TICK * .6;
632
444 my $sig = new Coro::Signal; 633 my $sig = new Coro::Signal;
445 634
446 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 635 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
447 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 636 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
448 $SLOT_QUEUE->ready; 637 $SLOT_QUEUE->ready;
… …
474=cut 663=cut
475 664
476sub sync_job(&) { 665sub sync_job(&) {
477 my ($job) = @_; 666 my ($job) = @_;
478 667
479 if ($Coro::current == $Coro::main) { 668 if (in_main) {
480 my $time = EV::time; 669 my $time = AE::time;
481 670
482 # this is the main coro, too bad, we have to block 671 # this is the main coro, too bad, we have to block
483 # till the operation succeeds, freezing the server :/ 672 # till the operation succeeds, freezing the server :/
484 673
485 LOG llevError, Carp::longmess "sync job";#d# 674 #LOG llevError, Carp::longmess "sync job";#d#
486 675
487 my $freeze_guard = freeze_mainloop; 676 my $freeze_guard = freeze_mainloop;
488 677
489 my $busy = 1; 678 my $busy = 1;
490 my @res; 679 my @res;
491 680
492 (async { 681 (async {
493 $Coro::current->desc ("sync job coro"); 682 $Coro::current->desc ("sync job coro");
494 @res = eval { $job->() }; 683 @res = eval { $job->() };
495 warn $@ if $@; 684 error $@ if $@;
496 undef $busy; 685 undef $busy;
497 })->prio (Coro::PRIO_MAX); 686 })->prio (Coro::PRIO_MAX);
498 687
499 while ($busy) { 688 while ($busy) {
500 if (Coro::nready) { 689 if (Coro::nready) {
… …
502 } else { 691 } else {
503 EV::loop EV::LOOP_ONESHOT; 692 EV::loop EV::LOOP_ONESHOT;
504 } 693 }
505 } 694 }
506 695
507 my $time = EV::time - $time; 696 my $time = AE::time - $time;
508 697
509 $TICK_START += $time; # do not account sync jobs to server load 698 $TICK_START += $time; # do not account sync jobs to server load
510 699
511 wantarray ? @res : $res[0] 700 wantarray ? @res : $res[0]
512 } else { 701 } else {
… …
534 $EXT_CORO{$coro+0} = $coro; 723 $EXT_CORO{$coro+0} = $coro;
535 724
536 $coro 725 $coro
537} 726}
538 727
539=item fork_call { }, $args 728=item fork_call { }, @args
540 729
541Executes the given code block with the given arguments in a seperate 730Executes the given code block with the given arguments in a seperate
542process, returning the results. Everything must be serialisable with 731process, returning the results. Everything must be serialisable with
543Coro::Storable. May, of course, block. Note that the executed sub may 732Coro::Storable. May, of course, block. Note that the executed sub may
544never block itself or use any form of event handling. 733never block itself or use any form of event handling.
545 734
546=cut 735=cut
547 736
737sub post_fork {
738 reset_signals;
739}
740
548sub fork_call(&@) { 741sub fork_call(&@) {
549 my ($cb, @args) = @_; 742 my ($cb, @args) = @_;
550 743
551 # we seemingly have to make a local copy of the whole thing,
552 # otherwise perl prematurely frees the stuff :/
553 # TODO: investigate and fix (likely this will be rather laborious)
554
555 my @res = Coro::Util::fork_eval { 744 my @res = Coro::Util::fork_eval {
556 reset_signals; 745 cf::post_fork;
557 &$cb 746 &$cb
558 }, @args; 747 } @args;
559 748
560 wantarray ? @res : $res[-1] 749 wantarray ? @res : $res[-1]
750}
751
752sub objinfo {
753 (
754 "counter value" => cf::object::object_count,
755 "objects created" => cf::object::create_count,
756 "objects destroyed" => cf::object::destroy_count,
757 "freelist size" => cf::object::free_count,
758 "allocated objects" => cf::object::objects_size,
759 "active objects" => cf::object::actives_size,
760 )
561} 761}
562 762
563=item $coin = coin_from_name $name 763=item $coin = coin_from_name $name
564 764
565=cut 765=cut
… …
602within each server. 802within each server.
603 803
604=cut 804=cut
605 805
606sub db_table($) { 806sub db_table($) {
807 cf::error "db_get called from main context"
808 if $Coro::current == $Coro::main;
809
607 my ($name) = @_; 810 my ($name) = @_;
608 my $db = BDB::db_create $DB_ENV; 811 my $db = BDB::db_create $DB_ENV;
609 812
610 eval { 813 eval {
611 $db->set_flags (BDB::CHKSUM); 814 $db->set_flags (BDB::CHKSUM);
… …
621} 824}
622 825
623our $DB; 826our $DB;
624 827
625sub db_init { 828sub db_init {
626 cf::sync_job {
627 $DB ||= db_table "db"; 829 $DB ||= db_table "db";
628 };
629} 830}
630 831
631sub db_get($$) { 832sub db_get($$) {
632 my $key = "$_[0]/$_[1]"; 833 my $key = "$_[0]/$_[1]";
633 834
634 cf::sync_job { 835 cf::error "db_get called from main context"
836 if $Coro::current == $Coro::main;
837
635 BDB::db_get $DB, undef, $key, my $data; 838 BDB::db_get $DB, undef, $key, my $data;
636 839
637 $! ? () 840 $! ? ()
638 : $data 841 : $data
639 }
640} 842}
641 843
642sub db_put($$$) { 844sub db_put($$$) {
643 BDB::dbreq_pri 4; 845 BDB::dbreq_pri 4;
644 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 846 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
672 874
673 my @data; 875 my @data;
674 my $md5; 876 my $md5;
675 877
676 for (0 .. $#$src) { 878 for (0 .. $#$src) {
677 0 <= aio_load $src->[$_], $data[$_] 879 $data[$_] = load_file $src->[$_];
678 or Carp::croak "$src->[$_]: $!";
679 } 880 }
680 881
681 # if processing is expensive, check 882 # if processing is expensive, check
682 # checksum first 883 # checksum first
683 if (1) { 884 if (1) {
… …
696 897
697 return db_get cache => "$id/data"; 898 return db_get cache => "$id/data";
698 } 899 }
699 } 900 }
700 901
701 my $t1 = Time::HiRes::time; 902 my $t1 = EV::time;
702 my $data = $process->(\@data); 903 my $data = $process->(\@data);
703 my $t2 = Time::HiRes::time; 904 my $t2 = EV::time;
704 905
705 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 906 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
706 907
707 db_put cache => "$id/data", $data; 908 db_put cache => "$id/data", $data;
708 db_put cache => "$id/md5" , $md5; 909 db_put cache => "$id/md5" , $md5;
709 db_put cache => "$id/meta", $meta; 910 db_put cache => "$id/meta", $meta;
710 911
… …
720 921
721=cut 922=cut
722 923
723sub datalog($@) { 924sub datalog($@) {
724 my ($type, %kv) = @_; 925 my ($type, %kv) = @_;
725 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 926 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
726} 927}
727 928
728=back 929=back
729 930
730=cut 931=cut
… …
925 1126
926 } elsif (exists $cb_id{$type}) { 1127 } elsif (exists $cb_id{$type}) {
927 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1128 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
928 1129
929 } elsif (ref $type) { 1130 } elsif (ref $type) {
930 warn "attaching objects not supported, ignoring.\n"; 1131 error "attaching objects not supported, ignoring.\n";
931 1132
932 } else { 1133 } else {
933 shift @arg; 1134 shift @arg;
934 warn "attach argument '$type' not supported, ignoring.\n"; 1135 error "attach argument '$type' not supported, ignoring.\n";
935 } 1136 }
936 } 1137 }
937} 1138}
938 1139
939sub _object_attach { 1140sub _object_attach {
… …
949 _attach $registry, $klass, @attach; 1150 _attach $registry, $klass, @attach;
950 } 1151 }
951 1152
952 $obj->{$name} = \%arg; 1153 $obj->{$name} = \%arg;
953 } else { 1154 } else {
954 warn "object uses attachment '$name' which is not available, postponing.\n"; 1155 info "object uses attachment '$name' which is not available, postponing.\n";
955 } 1156 }
956 1157
957 $obj->{_attachment}{$name} = undef; 1158 $obj->{_attachment}{$name} = undef;
958} 1159}
959 1160
… …
1018 1219
1019 for (@$callbacks) { 1220 for (@$callbacks) {
1020 eval { &{$_->[1]} }; 1221 eval { &{$_->[1]} };
1021 1222
1022 if ($@) { 1223 if ($@) {
1023 warn "$@";
1024 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1224 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1025 override; 1225 override;
1026 } 1226 }
1027 1227
1028 return 1 if $override; 1228 return 1 if $override;
1029 } 1229 }
… …
1108 for (@$attach) { 1308 for (@$attach) {
1109 my ($klass, @attach) = @$_; 1309 my ($klass, @attach) = @$_;
1110 _attach $registry, $klass, @attach; 1310 _attach $registry, $klass, @attach;
1111 } 1311 }
1112 } else { 1312 } else {
1113 warn "object uses attachment '$name' that is not available, postponing.\n"; 1313 info "object uses attachment '$name' that is not available, postponing.\n";
1114 } 1314 }
1115 } 1315 }
1116} 1316}
1117 1317
1118cf::attachable->attach ( 1318cf::attachable->attach (
… …
1145 my ($filename, $rdata, $objs) = @_; 1345 my ($filename, $rdata, $objs) = @_;
1146 1346
1147 sync_job { 1347 sync_job {
1148 if (length $$rdata) { 1348 if (length $$rdata) {
1149 utf8::decode (my $decname = $filename); 1349 utf8::decode (my $decname = $filename);
1150 warn sprintf "saving %s (%d,%d)\n", 1350 trace sprintf "saving %s (%d,%d)\n",
1151 $decname, length $$rdata, scalar @$objs; 1351 $decname, length $$rdata, scalar @$objs
1352 if $VERBOSE_IO;
1152 1353
1153 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1354 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1154 aio_chmod $fh, SAVE_MODE; 1355 aio_chmod $fh, SAVE_MODE;
1155 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1356 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1156 aio_fsync $fh if $cf::USE_FSYNC; 1357 if ($cf::USE_FSYNC) {
1358 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;
1359 aio_fsync $fh;
1360 }
1157 aio_close $fh; 1361 aio_close $fh;
1158 1362
1159 if (@$objs) { 1363 if (@$objs) {
1160 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1364 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1161 aio_chmod $fh, SAVE_MODE; 1365 aio_chmod $fh, SAVE_MODE;
1162 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1366 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1163 aio_write $fh, 0, (length $data), $data, 0; 1367 aio_write $fh, 0, (length $data), $data, 0;
1164 aio_fsync $fh if $cf::USE_FSYNC; 1368 if ($cf::USE_FSYNC) {
1369 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;
1370 aio_fsync $fh;
1371 }
1165 aio_close $fh; 1372 aio_close $fh;
1166 aio_rename "$filename.pst~", "$filename.pst"; 1373 aio_rename "$filename.pst~", "$filename.pst";
1167 } 1374 }
1168 } else { 1375 } else {
1169 aio_unlink "$filename.pst"; 1376 aio_unlink "$filename.pst";
… …
1172 aio_rename "$filename~", $filename; 1379 aio_rename "$filename~", $filename;
1173 1380
1174 $filename =~ s%/[^/]+$%%; 1381 $filename =~ s%/[^/]+$%%;
1175 aio_pathsync $filename if $cf::USE_FSYNC; 1382 aio_pathsync $filename if $cf::USE_FSYNC;
1176 } else { 1383 } else {
1177 warn "unable to save objects: $filename~: $!\n"; 1384 error "unable to save objects: $filename~: $!\n";
1178 } 1385 }
1179 } else { 1386 } else {
1180 aio_unlink $filename; 1387 aio_unlink $filename;
1181 aio_unlink "$filename.pst"; 1388 aio_unlink "$filename.pst";
1182 } 1389 }
… …
1206 my $st = eval { Coro::Storable::thaw $av }; 1413 my $st = eval { Coro::Storable::thaw $av };
1207 $av = $st->{objs}; 1414 $av = $st->{objs};
1208 } 1415 }
1209 1416
1210 utf8::decode (my $decname = $filename); 1417 utf8::decode (my $decname = $filename);
1211 warn sprintf "loading %s (%d,%d)\n", 1418 trace sprintf "loading %s (%d,%d)\n",
1212 $decname, length $data, scalar @{$av || []}; 1419 $decname, length $data, scalar @{$av || []}
1420 if $VERBOSE_IO;
1213 1421
1214 ($data, $av) 1422 ($data, $av)
1215} 1423}
1216 1424
1217=head2 COMMAND CALLBACKS 1425=head2 COMMAND CALLBACKS
… …
1221=cut 1429=cut
1222 1430
1223############################################################################# 1431#############################################################################
1224# command handling &c 1432# command handling &c
1225 1433
1226=item cf::register_command $name => \&callback($ob,$args); 1434=item cf::register_command $name => \&callback($ob,$args)
1227 1435
1228Register a callback for execution when the client sends the user command 1436Register a callback for execution when the client sends the user command
1229$name. 1437$name.
1230 1438
1231=cut 1439=cut
… …
1237 #warn "registering command '$name/$time' to '$caller'"; 1445 #warn "registering command '$name/$time' to '$caller'";
1238 1446
1239 push @{ $COMMAND{$name} }, [$caller, $cb]; 1447 push @{ $COMMAND{$name} }, [$caller, $cb];
1240} 1448}
1241 1449
1242=item cf::register_extcmd $name => \&callback($pl,$packet); 1450=item cf::register_extcmd $name => \&callback($pl,@args)
1243 1451
1244Register a callback for execution when the client sends an (synchronous) 1452Register a callback for execution when the client sends an (synchronous)
1245extcmd packet. Ext commands will be processed in the order they are 1453extcmd packet. Ext commands will be processed in the order they are
1246received by the server, like other user commands. The first argument is 1454received by the server, like other user commands. The first argument is
1247the logged-in player. Ext commands can only be processed after a player 1455the logged-in player. Ext commands can only be processed after a player
1248has logged in successfully. 1456has logged in successfully.
1249 1457
1250If the callback returns something, it is sent back as if reply was being 1458The values will be sent back to the client.
1251called.
1252 1459
1460=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
1461
1462Same as C<cf::register_extcmd>, but instead of returning values, the
1463callback needs to clal the C<$reply> function.
1464
1253=item cf::register_exticmd $name => \&callback($ns,$packet); 1465=item cf::register_exticmd $name => \&callback($ns,@args)
1254 1466
1255Register a callback for execution when the client sends an (asynchronous) 1467Register a callback for execution when the client sends an (asynchronous)
1256exticmd packet. Exti commands are processed by the server as soon as they 1468exticmd packet. Exti commands are processed by the server as soon as they
1257are received, i.e. out of order w.r.t. other commands. The first argument 1469are received, i.e. out of order w.r.t. other commands. The first argument
1258is a client socket. Exti commands can be received anytime, even before 1470is a client socket. Exti commands can be received anytime, even before
1259log-in. 1471log-in.
1260 1472
1261If the callback returns something, it is sent back as if reply was being 1473The values will be sent back to the client.
1262called.
1263 1474
1264=cut 1475=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1265 1476
1477Same as C<cf::register_extcmd>, but instead of returning values, the
1478callback needs to clal the C<$reply> function.
1479
1480=cut
1481
1266sub register_extcmd { 1482sub register_extcmd($$) {
1267 my ($name, $cb) = @_; 1483 my ($name, $cb) = @_;
1268 1484
1269 $EXTCMD{$name} = $cb; 1485 $EXTCMD{$name} = $cb;
1270} 1486}
1271 1487
1272sub register_exticmd { 1488sub register_async_extcmd($$) {
1273 my ($name, $cb) = @_; 1489 my ($name, $cb) = @_;
1274 1490
1491 $EXTACMD{$name} = $cb;
1492}
1493
1494sub register_exticmd($$) {
1495 my ($name, $cb) = @_;
1496
1275 $EXTICMD{$name} = $cb; 1497 $EXTICMD{$name} = $cb;
1276} 1498}
1277 1499
1500sub register_async_exticmd($$) {
1501 my ($name, $cb) = @_;
1502
1503 $EXTIACMD{$name} = $cb;
1504}
1505
1278use File::Glob (); 1506use File::Glob ();
1279 1507
1280cf::player->attach ( 1508cf::player->attach (
1281 on_command => sub { 1509 on_unknown_command => sub {
1282 my ($pl, $name, $params) = @_; 1510 my ($pl, $name, $params) = @_;
1283 1511
1284 my $cb = $COMMAND{$name} 1512 my $cb = $COMMAND{$name}
1285 or return; 1513 or return;
1286 1514
… …
1294 my ($pl, $buf) = @_; 1522 my ($pl, $buf) = @_;
1295 1523
1296 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1524 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1297 1525
1298 if (ref $msg) { 1526 if (ref $msg) {
1299 my ($type, $reply, @payload) = 1527 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1300 "ARRAY" eq ref $msg
1301 ? @$msg
1302 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1303 1528
1304 my @reply;
1305
1306 if (my $cb = $EXTCMD{$type}) { 1529 if (my $cb = $EXTACMD{$type}) {
1530 $cb->(
1531 $pl,
1532 sub {
1533 $pl->ext_msg ("reply-$reply", @_)
1534 if $reply;
1535 },
1536 @payload
1537 );
1538 } else {
1539 my @reply;
1540
1541 if (my $cb = $EXTCMD{$type}) {
1307 @reply = $cb->($pl, @payload); 1542 @reply = $cb->($pl, @payload);
1543 }
1544
1545 $pl->ext_msg ("reply-$reply", @reply)
1546 if $reply;
1308 } 1547 }
1309 1548
1310 $pl->ext_reply ($reply, @reply)
1311 if $reply;
1312
1313 } else { 1549 } else {
1314 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1550 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1315 } 1551 }
1316 1552
1317 cf::override; 1553 cf::override;
1318 }, 1554 },
1319); 1555);
1320 1556
1321# "readahead" all extensions 1557# "readahead" all extensions
1322sub cache_extensions { 1558sub cache_extensions {
1323 my $grp = IO::AIO::aio_group; 1559 my $grp = IO::AIO::aio_group;
1324 1560
1325 add $grp IO::AIO::aio_readdir $LIBDIR, sub { 1561 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1326 for (grep /\.ext$/, @{$_[0]}) { 1562 for (grep /\.ext$/, @{$_[0]}) {
1327 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; 1563 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1328 } 1564 }
1329 }; 1565 };
1330 1566
1331 $grp 1567 $grp
1332} 1568}
1333 1569
1570sub _ext_cfg_reg($$$$) {
1571 my ($rvar, $varname, $cfgname, $default) = @_;
1572
1573 $cfgname = lc $varname
1574 unless length $cfgname;
1575
1576 $EXT_CFG{$cfgname} = [$rvar, $default];
1577
1578 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1579}
1580
1334sub load_extensions { 1581sub load_extensions {
1582 info "loading extensions...";
1583
1584 %EXT_CFG = ();
1585
1335 cf::sync_job { 1586 cf::sync_job {
1336 my %todo; 1587 my %todo;
1337 1588
1338 for my $path (<$LIBDIR/*.ext>) { 1589 for my $path (<$LIBDIR/*.ext>) {
1339 next unless -r $path; 1590 next unless -r $path;
… …
1357 1608
1358 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1609 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1359 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1610 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1360 1611
1361 $ext{source} = 1612 $ext{source} =
1362 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1613 "package $pkg; use common::sense;\n"
1363 . "#line 1 \"$path\"\n{\n" 1614 . "#line 1 \"$path\"\n{\n"
1364 . $source 1615 . $source
1365 . "\n};\n1"; 1616 . "\n};\n1";
1366 1617
1367 $todo{$base} = \%ext; 1618 $todo{$base} = \%ext;
1368 } 1619 }
1369 1620
1621 my $pass = 0;
1370 my %done; 1622 my %done;
1371 while (%todo) { 1623 while (%todo) {
1372 my $progress; 1624 my $progress;
1373 1625
1626 ++$pass;
1627
1628 ext:
1374 while (my ($k, $v) = each %todo) { 1629 while (my ($k, $v) = each %todo) {
1375 for (split /,\s*/, $v->{meta}{depends}) { 1630 for (split /,\s*/, $v->{meta}{depends}) {
1376 goto skip 1631 next ext
1377 unless exists $done{$_}; 1632 unless exists $done{$_};
1378 } 1633 }
1379 1634
1380 warn "... loading '$k' into '$v->{pkg}'\n"; 1635 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1381 1636
1382 unless (eval $v->{source}) { 1637 my $source = $v->{source};
1638
1639 # support "CONF varname :confname = default" pseudo-statements
1640 $source =~ s{
1641 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1642 }{
1643 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1644 }gmxe;
1645
1646 my $active = eval $source;
1647
1648 if (length $@) {
1383 my $msg = $@ ? "$v->{path}: $@\n" 1649 error "$v->{path}: $@\n";
1384 : "$v->{base}: extension inactive.\n";
1385 1650
1386 if (exists $v->{meta}{mandatory}) {
1387 warn $msg;
1388 cf::cleanup "mandatory extension failed to load, exiting."; 1651 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1389 } 1652 if exists $v->{meta}{mandatory};
1390 1653
1391 warn $msg; 1654 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1655 delete $todo{$k};
1656 } else {
1657 $done{$k} = delete $todo{$k};
1658 push @EXTS, $v->{pkg};
1659 $progress = 1;
1660
1661 info "$v->{base}: extension inactive.\n"
1662 unless $active;
1392 } 1663 }
1393
1394 $done{$k} = delete $todo{$k};
1395 push @EXTS, $v->{pkg};
1396 $progress = 1;
1397 } 1664 }
1398 1665
1399 skip: 1666 unless ($progress) {
1400 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1667 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1401 unless $progress; 1668
1669 while (my ($k, $v) = each %todo) {
1670 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1671 if exists $v->{meta}{mandatory};
1672 }
1673
1674 last;
1675 }
1402 } 1676 }
1403 }; 1677 };
1404} 1678}
1405 1679
1406############################################################################# 1680#############################################################################
… …
1490 $cf::PLAYER{$login} = $pl 1764 $cf::PLAYER{$login} = $pl
1491 } 1765 }
1492 } 1766 }
1493} 1767}
1494 1768
1769cf::player->attach (
1770 on_load => sub {
1771 my ($pl, $path) = @_;
1772
1773 # restore slots saved in save, below
1774 my $slots = delete $pl->{_slots};
1775
1776 $pl->ob->current_weapon ($slots->[0]);
1777 $pl->combat_ob ($slots->[1]);
1778 $pl->ranged_ob ($slots->[2]);
1779 },
1780);
1781
1495sub save($) { 1782sub save($) {
1496 my ($pl) = @_; 1783 my ($pl) = @_;
1497 1784
1498 return if $pl->{deny_save}; 1785 return if $pl->{deny_save};
1499 1786
… …
1504 1791
1505 aio_mkdir playerdir $pl, 0770; 1792 aio_mkdir playerdir $pl, 0770;
1506 $pl->{last_save} = $cf::RUNTIME; 1793 $pl->{last_save} = $cf::RUNTIME;
1507 1794
1508 cf::get_slot 0.01; 1795 cf::get_slot 0.01;
1796
1797 # save slots, to be restored later
1798 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1509 1799
1510 $pl->save_pl ($path); 1800 $pl->save_pl ($path);
1511 cf::cede_to_tick; 1801 cf::cede_to_tick;
1512} 1802}
1513 1803
… …
1547 my $name = $pl->ob->name; 1837 my $name = $pl->ob->name;
1548 1838
1549 $pl->{deny_save} = 1; 1839 $pl->{deny_save} = 1;
1550 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1840 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1551 1841
1552 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1842 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1553 $pl->deactivate; 1843 $pl->deactivate;
1844
1554 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1845 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1555 $pl->ob->check_score;
1556 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1846 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1847 ext::highscore::check ($pl->ob);
1848
1557 $pl->ns->destroy if $pl->ns; 1849 $pl->ns->destroy if $pl->ns;
1558 1850
1559 my $path = playerdir $pl; 1851 my $path = playerdir $pl;
1560 my $temp = "$path~$cf::RUNTIME~deleting~"; 1852 my $temp = "$path~$cf::RUNTIME~deleting~";
1561 aio_rename $path, $temp; 1853 aio_rename $path, $temp;
… …
1615 \@logins 1907 \@logins
1616} 1908}
1617 1909
1618=item $player->maps 1910=item $player->maps
1619 1911
1912=item cf::player::maps $login
1913
1620Returns an arrayref of map paths that are private for this 1914Returns an arrayref of map paths that are private for this
1621player. May block. 1915player. May block.
1622 1916
1623=cut 1917=cut
1624 1918
… …
1645 1939
1646=item $protocol_xml = $player->expand_cfpod ($cfpod) 1940=item $protocol_xml = $player->expand_cfpod ($cfpod)
1647 1941
1648Expand deliantra pod fragments into protocol xml. 1942Expand deliantra pod fragments into protocol xml.
1649 1943
1650=item $player->ext_reply ($msgid, @msg)
1651
1652Sends an ext reply to the player.
1653
1654=cut
1655
1656sub ext_reply($$@) {
1657 my ($self, $id, @msg) = @_;
1658
1659 $self->ns->ext_reply ($id, @msg)
1660}
1661
1662=item $player->ext_msg ($type, @msg) 1944=item $player->ext_msg ($type, @msg)
1663 1945
1664Sends an ext event to the client. 1946Sends an ext event to the client.
1665 1947
1666=cut 1948=cut
… …
1685 1967
1686=cut 1968=cut
1687 1969
1688sub find_by_path($) { 1970sub find_by_path($) {
1689 my ($path) = @_; 1971 my ($path) = @_;
1972
1973 $path =~ s/^~[^\/]*//; # skip ~login
1690 1974
1691 my ($match, $specificity); 1975 my ($match, $specificity);
1692 1976
1693 for my $region (list) { 1977 for my $region (list) {
1694 if ($region->{match} && $path =~ $region->{match}) { 1978 if ($region->{match} && $path =~ $region->{match}) {
… …
1723sub generate_random_map { 2007sub generate_random_map {
1724 my ($self, $rmp) = @_; 2008 my ($self, $rmp) = @_;
1725 2009
1726 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 2010 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1727 2011
1728 # mit "rum" bekleckern, nicht
1729 $self->_create_random_map ( 2012 $self->_create_random_map ($rmp);
1730 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1731 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1732 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1733 $rmp->{exit_on_final_map},
1734 $rmp->{xsize}, $rmp->{ysize},
1735 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1736 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1737 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1738 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1739 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1740 (cf::region::find $rmp->{region}), $rmp->{custom}
1741 )
1742} 2013}
1743 2014
1744=item cf::map->register ($regex, $prio) 2015=item cf::map->register ($regex, $prio)
1745 2016
1746Register a handler for the map path matching the given regex at the 2017Register a handler for the map path matching the given regex at the
… …
1751 2022
1752sub register { 2023sub register {
1753 my (undef, $regex, $prio) = @_; 2024 my (undef, $regex, $prio) = @_;
1754 my $pkg = caller; 2025 my $pkg = caller;
1755 2026
1756 no strict;
1757 push @{"$pkg\::ISA"}, __PACKAGE__; 2027 push @{"$pkg\::ISA"}, __PACKAGE__;
1758 2028
1759 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 2029 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1760} 2030}
1761 2031
1762# also paths starting with '/' 2032# also paths starting with '/'
1763$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 2033$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1764 2034
1765sub thawer_merge { 2035sub thawer_merge {
1766 my ($self, $merge) = @_; 2036 my ($self, $merge) = @_;
1767 2037
1768 # we have to keep some variables in memory intact 2038 # we have to keep some variables in memory intact
… …
1773} 2043}
1774 2044
1775sub normalise { 2045sub normalise {
1776 my ($path, $base) = @_; 2046 my ($path, $base) = @_;
1777 2047
1778 $path = "$path"; # make sure its a string 2048 $path = "$path"; # make sure it's a string
1779 2049
1780 $path =~ s/\.map$//; 2050 $path =~ s/\.map$//;
1781 2051
1782 # map plan: 2052 # map plan:
1783 # 2053 #
… …
1798 $base =~ s{[^/]+/?$}{}; 2068 $base =~ s{[^/]+/?$}{};
1799 $path = "$base/$path"; 2069 $path = "$base/$path";
1800 } 2070 }
1801 2071
1802 for ($path) { 2072 for ($path) {
1803 redo if s{//}{/};
1804 redo if s{/\.?/}{/}; 2073 redo if s{/\.?/}{/};
1805 redo if s{/[^/]+/\.\./}{/}; 2074 redo if s{/[^/]+/\.\./}{/};
1806 } 2075 }
1807 2076
1808 $path 2077 $path
… …
1822 $self->init; # pass $1 etc. 2091 $self->init; # pass $1 etc.
1823 return $self; 2092 return $self;
1824 } 2093 }
1825 } 2094 }
1826 2095
1827 Carp::cluck "unable to resolve path '$path' (base '$base')."; 2096 Carp::cluck "unable to resolve path '$path' (base '$base')";
1828 () 2097 ()
1829} 2098}
1830 2099
2100# may re-bless or do other evil things
1831sub init { 2101sub init {
1832 my ($self) = @_; 2102 my ($self) = @_;
1833 2103
1834 $self 2104 $self
1835} 2105}
… …
1900 $self->{load_path} = $path; 2170 $self->{load_path} = $path;
1901 2171
1902 1 2172 1
1903} 2173}
1904 2174
2175# used to laod the header of an original map
1905sub load_header_orig { 2176sub load_header_orig {
1906 my ($self) = @_; 2177 my ($self) = @_;
1907 2178
1908 $self->load_header_from ($self->load_path) 2179 $self->load_header_from ($self->load_path)
1909} 2180}
1910 2181
2182# used to laod the header of an instantiated map
1911sub load_header_temp { 2183sub load_header_temp {
1912 my ($self) = @_; 2184 my ($self) = @_;
1913 2185
1914 $self->load_header_from ($self->save_path) 2186 $self->load_header_from ($self->save_path)
1915} 2187}
1916 2188
2189# called after loading the header from an instantiated map
1917sub prepare_temp { 2190sub prepare_temp {
1918 my ($self) = @_; 2191 my ($self) = @_;
1919 2192
1920 $self->last_access ((delete $self->{last_access}) 2193 $self->last_access ((delete $self->{last_access})
1921 || $cf::RUNTIME); #d# 2194 || $cf::RUNTIME); #d#
1922 # safety 2195 # safety
1923 $self->{instantiate_time} = $cf::RUNTIME 2196 $self->{instantiate_time} = $cf::RUNTIME
1924 if $self->{instantiate_time} > $cf::RUNTIME; 2197 if $self->{instantiate_time} > $cf::RUNTIME;
1925} 2198}
1926 2199
2200# called after loading the header from an original map
1927sub prepare_orig { 2201sub prepare_orig {
1928 my ($self) = @_; 2202 my ($self) = @_;
1929 2203
1930 $self->{load_original} = 1; 2204 $self->{load_original} = 1;
1931 $self->{instantiate_time} = $cf::RUNTIME; 2205 $self->{instantiate_time} = $cf::RUNTIME;
… …
1955 2229
1956sub find; 2230sub find;
1957sub find { 2231sub find {
1958 my ($path, $origin) = @_; 2232 my ($path, $origin) = @_;
1959 2233
2234 cf::cede_to_tick;
2235
1960 $path = normalise $path, $origin && $origin->path; 2236 $path = normalise $path, $origin;
1961 2237
1962 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2238 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1963 my $guard2 = cf::lock_acquire "map_find:$path"; 2239 my $guard2 = cf::lock_acquire "map_find:$path";
1964 2240
1965 $cf::MAP{$path} || do { 2241 $cf::MAP{$path} || do {
… …
1982 2258
1983 $cf::MAP{$path} = $map 2259 $cf::MAP{$path} = $map
1984 } 2260 }
1985} 2261}
1986 2262
1987sub pre_load { } 2263sub pre_load { }
1988sub post_load { } 2264#sub post_load { } # XS
1989 2265
1990sub load { 2266sub load {
1991 my ($self) = @_; 2267 my ($self) = @_;
1992 2268
1993 local $self->{deny_reset} = 1; # loading can take a long time 2269 local $self->{deny_reset} = 1; # loading can take a long time
… …
1996 2272
1997 { 2273 {
1998 my $guard = cf::lock_acquire "map_data:$path"; 2274 my $guard = cf::lock_acquire "map_data:$path";
1999 2275
2000 return unless $self->valid; 2276 return unless $self->valid;
2001 return unless $self->in_memory == cf::MAP_SWAPPED; 2277 return unless $self->state == cf::MAP_SWAPPED;
2002
2003 $self->in_memory (cf::MAP_LOADING);
2004 2278
2005 $self->alloc; 2279 $self->alloc;
2006 2280
2007 $self->pre_load; 2281 $self->pre_load;
2008 cf::cede_to_tick; 2282 cf::cede_to_tick;
2009 2283
2284 if (exists $self->{load_path}) {
2010 my $f = new_from_file cf::object::thawer $self->{load_path}; 2285 my $f = new_from_file cf::object::thawer $self->{load_path};
2011 $f->skip_block; 2286 $f->skip_block;
2012 $self->_load_objects ($f) 2287 $self->_load_objects ($f)
2013 or return; 2288 or return;
2014 2289
2015 $self->post_load_original 2290 $self->post_load_original
2016 if delete $self->{load_original}; 2291 if delete $self->{load_original};
2017 2292
2018 if (my $uniq = $self->uniq_path) { 2293 if (my $uniq = $self->uniq_path) {
2019 utf8::encode $uniq; 2294 utf8::encode $uniq;
2020 unless (aio_stat $uniq) { 2295 unless (aio_stat $uniq) {
2021 if (my $f = new_from_file cf::object::thawer $uniq) { 2296 if (my $f = new_from_file cf::object::thawer $uniq) {
2022 $self->clear_unique_items; 2297 $self->clear_unique_items;
2023 $self->_load_objects ($f); 2298 $self->_load_objects ($f);
2024 $f->resolve_delayed_derefs; 2299 $f->resolve_delayed_derefs;
2300 }
2025 } 2301 }
2026 } 2302 }
2027 }
2028 2303
2029 $f->resolve_delayed_derefs; 2304 $f->resolve_delayed_derefs;
2305 } else {
2306 $self->post_load_original
2307 if delete $self->{load_original};
2308 }
2309
2310 $self->state (cf::MAP_INACTIVE);
2030 2311
2031 cf::cede_to_tick; 2312 cf::cede_to_tick;
2032 # now do the right thing for maps 2313 # now do the right thing for maps
2033 $self->link_multipart_objects; 2314 $self->link_multipart_objects;
2034 $self->difficulty ($self->estimate_difficulty) 2315 $self->difficulty ($self->estimate_difficulty)
… …
2038 unless ($self->{deny_activate}) { 2319 unless ($self->{deny_activate}) {
2039 $self->decay_objects; 2320 $self->decay_objects;
2040 $self->fix_auto_apply; 2321 $self->fix_auto_apply;
2041 $self->update_buttons; 2322 $self->update_buttons;
2042 cf::cede_to_tick; 2323 cf::cede_to_tick;
2043 $self->activate; 2324 #$self->activate; # no longer activate maps automatically
2044 } 2325 }
2045 2326
2046 $self->{last_save} = $cf::RUNTIME; 2327 $self->{last_save} = $cf::RUNTIME;
2047 $self->last_access ($cf::RUNTIME); 2328 $self->last_access ($cf::RUNTIME);
2048
2049 $self->in_memory (cf::MAP_ACTIVE);
2050 } 2329 }
2051 2330
2052 $self->post_load; 2331 $self->post_load;
2053}
2054 2332
2333 1
2334}
2335
2336# customize the map for a given player, i.e.
2337# return the _real_ map. used by e.g. per-player
2338# maps to change the path to ~playername/mappath
2055sub customise_for { 2339sub customise_for {
2056 my ($self, $ob) = @_; 2340 my ($self, $ob) = @_;
2057 2341
2058 return find "~" . $ob->name . "/" . $self->{path} 2342 return find "~" . $ob->name . "/" . $self->{path}
2059 if $self->per_player; 2343 if $self->per_player;
… …
2062# if $self->per_party; 2346# if $self->per_party;
2063 2347
2064 $self 2348 $self
2065} 2349}
2066 2350
2067# find and load all maps in the 3x3 area around a map
2068sub load_neighbours {
2069 my ($map) = @_;
2070
2071 my @neigh; # diagonal neighbours
2072
2073 for (0 .. 3) {
2074 my $neigh = $map->tile_path ($_)
2075 or next;
2076 $neigh = find $neigh, $map
2077 or next;
2078 $neigh->load;
2079
2080 push @neigh,
2081 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2082 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2083 }
2084
2085 for (grep defined $_->[0], @neigh) {
2086 my ($path, $origin) = @$_;
2087 my $neigh = find $path, $origin
2088 or next;
2089 $neigh->load;
2090 }
2091}
2092
2093sub find_sync { 2351sub find_sync {
2094 my ($path, $origin) = @_; 2352 my ($path, $origin) = @_;
2095 2353
2096 cf::sync_job { find $path, $origin } 2354 # it's a bug to call this from the main context
2355 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2356 if $Coro::current == $Coro::main;
2357
2358 find $path, $origin
2097} 2359}
2098 2360
2099sub do_load_sync { 2361sub do_load_sync {
2100 my ($map) = @_; 2362 my ($map) = @_;
2101 2363
2364 # it's a bug to call this from the main context
2102 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2365 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2103 if $Coro::current == $Coro::main; 2366 if $Coro::current == $Coro::main;
2104 2367
2105 cf::sync_job { $map->load }; 2368 $map->load;
2106} 2369}
2107 2370
2108our %MAP_PREFETCH; 2371our %MAP_PREFETCH;
2109our $MAP_PREFETCHER = undef; 2372our $MAP_PREFETCHER = undef;
2110 2373
2111sub find_async { 2374sub find_async {
2112 my ($path, $origin, $load) = @_; 2375 my ($path, $origin, $load) = @_;
2113 2376
2114 $path = normalise $path, $origin && $origin->{path}; 2377 $path = normalise $path, $origin;
2115 2378
2116 if (my $map = $cf::MAP{$path}) { 2379 if (my $map = $cf::MAP{$path}) {
2117 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2380 return $map if !$load || $map->linkable;
2118 } 2381 }
2119 2382
2120 $MAP_PREFETCH{$path} |= $load; 2383 $MAP_PREFETCH{$path} |= $load;
2121 2384
2122 $MAP_PREFETCHER ||= cf::async { 2385 $MAP_PREFETCHER ||= cf::async {
… …
2136 $MAP_PREFETCHER->prio (6); 2399 $MAP_PREFETCHER->prio (6);
2137 2400
2138 () 2401 ()
2139} 2402}
2140 2403
2404# common code, used by both ->save and ->swapout
2141sub save { 2405sub _save {
2142 my ($self) = @_; 2406 my ($self) = @_;
2143
2144 my $lock = cf::lock_acquire "map_data:$self->{path}";
2145 2407
2146 $self->{last_save} = $cf::RUNTIME; 2408 $self->{last_save} = $cf::RUNTIME;
2147 2409
2148 return unless $self->dirty; 2410 return unless $self->dirty;
2149 2411
… …
2169 } else { 2431 } else {
2170 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2432 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2171 } 2433 }
2172} 2434}
2173 2435
2436sub save {
2437 my ($self) = @_;
2438
2439 my $lock = cf::lock_acquire "map_data:$self->{path}";
2440
2441 $self->_save;
2442}
2443
2174sub swap_out { 2444sub swap_out {
2175 my ($self) = @_; 2445 my ($self) = @_;
2176 2446
2177 # save first because save cedes
2178 $self->save;
2179
2180 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2447 my $lock = cf::lock_acquire "map_data:$self->{path}";
2181 2448
2449 return if !$self->linkable;
2450 return if $self->{deny_save};
2182 return if $self->players; 2451 return if $self->players;
2183 return if $self->in_memory != cf::MAP_ACTIVE; 2452
2453 # first deactivate the map and "unlink" it from the core
2454 $self->deactivate;
2455 $_->clear_links_to ($self) for values %cf::MAP;
2456 $self->state (cf::MAP_SWAPPED);
2457
2458 # then atomically save
2459 $self->_save;
2460
2461 # then free the map
2462 $self->clear;
2463}
2464
2465sub reset_at {
2466 my ($self) = @_;
2467
2468 # TODO: safety, remove and allow resettable per-player maps
2184 return if $self->{deny_save}; 2469 return 1e99 if $self->{deny_reset};
2185 2470
2471 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2472 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2473
2474 $time + $to
2475}
2476
2477sub should_reset {
2478 my ($self) = @_;
2479
2480 $self->reset_at <= $cf::RUNTIME
2481}
2482
2483sub reset {
2484 my ($self) = @_;
2485
2486 my $lock = cf::lock_acquire "map_data:$self->{path}";
2487
2488 return if $self->players;
2489
2490 cf::trace "resetting map ", $self->path, "\n";
2491
2186 $self->in_memory (cf::MAP_SWAPPED); 2492 $self->state (cf::MAP_SWAPPED);
2493
2494 # need to save uniques path
2495 unless ($self->{deny_save}) {
2496 my $uniq = $self->uniq_path; utf8::encode $uniq;
2497
2498 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2499 if $uniq;
2500 }
2501
2502 delete $cf::MAP{$self->path};
2187 2503
2188 $self->deactivate; 2504 $self->deactivate;
2189 $_->clear_links_to ($self) for values %cf::MAP; 2505 $_->clear_links_to ($self) for values %cf::MAP;
2190 $self->clear; 2506 $self->clear;
2191}
2192
2193sub reset_at {
2194 my ($self) = @_;
2195
2196 # TODO: safety, remove and allow resettable per-player maps
2197 return 1e99 if $self->{deny_reset};
2198
2199 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2200 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2201
2202 $time + $to
2203}
2204
2205sub should_reset {
2206 my ($self) = @_;
2207
2208 $self->reset_at <= $cf::RUNTIME
2209}
2210
2211sub reset {
2212 my ($self) = @_;
2213
2214 my $lock = cf::lock_acquire "map_data:$self->{path}";
2215
2216 return if $self->players;
2217
2218 warn "resetting map ", $self->path;
2219
2220 $self->in_memory (cf::MAP_SWAPPED);
2221
2222 # need to save uniques path
2223 unless ($self->{deny_save}) {
2224 my $uniq = $self->uniq_path; utf8::encode $uniq;
2225
2226 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2227 if $uniq;
2228 }
2229
2230 delete $cf::MAP{$self->path};
2231
2232 $self->deactivate;
2233 $_->clear_links_to ($self) for values %cf::MAP;
2234 $self->clear;
2235 2507
2236 $self->unlink_save; 2508 $self->unlink_save;
2237 $self->destroy; 2509 $self->destroy;
2238} 2510}
2239 2511
… …
2247 2519
2248 delete $cf::MAP{$self->path}; 2520 delete $cf::MAP{$self->path};
2249 2521
2250 $self->unlink_save; 2522 $self->unlink_save;
2251 2523
2252 bless $self, "cf::map"; 2524 bless $self, "cf::map::wrap";
2253 delete $self->{deny_reset}; 2525 delete $self->{deny_reset};
2254 $self->{deny_save} = 1; 2526 $self->{deny_save} = 1;
2255 $self->reset_timeout (1); 2527 $self->reset_timeout (1);
2256 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2528 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2257 2529
… …
2314 : normalise $_ 2586 : normalise $_
2315 } @{ aio_readdir $UNIQUEDIR or [] } 2587 } @{ aio_readdir $UNIQUEDIR or [] }
2316 ] 2588 ]
2317} 2589}
2318 2590
2591=item cf::map::static_maps
2592
2593Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2594file in the shared directory excluding F</styles> and F</editor>). May
2595block.
2596
2597=cut
2598
2599sub static_maps() {
2600 my @dirs = "";
2601 my @maps;
2602
2603 while (@dirs) {
2604 my $dir = shift @dirs;
2605
2606 next if $dir eq "/styles" || $dir eq "/editor";
2607
2608 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2609 or return;
2610
2611 for (@$files) {
2612 s/\.map$// or next;
2613 utf8::decode $_;
2614 push @maps, "$dir/$_";
2615 }
2616
2617 push @dirs, map "$dir/$_", @$dirs;
2618 }
2619
2620 \@maps
2621}
2622
2319=back 2623=back
2320 2624
2321=head3 cf::object 2625=head3 cf::object
2322 2626
2323=cut 2627=cut
… …
2346 2650
2347Creates and returns a persistent reference to an object that can be stored as a string. 2651Creates and returns a persistent reference to an object that can be stored as a string.
2348 2652
2349=item $ob = cf::object::deref ($refstring) 2653=item $ob = cf::object::deref ($refstring)
2350 2654
2351returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2655returns the objetc referenced by refstring. may return undef when it cannot find the object,
2352even if the object actually exists. May block. 2656even if the object actually exists. May block.
2353 2657
2354=cut 2658=cut
2355 2659
2356sub deref { 2660sub deref {
… …
2455 2759
2456Freezes the player and moves him/her to a special map (C<{link}>). 2760Freezes the player and moves him/her to a special map (C<{link}>).
2457 2761
2458The player should be reasonably safe there for short amounts of time (e.g. 2762The player should be reasonably safe there for short amounts of time (e.g.
2459for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2763for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2460though, as the palyer cannot control the character while it is on the link 2764though, as the player cannot control the character while it is on the link
2461map. 2765map.
2462 2766
2463Will never block. 2767Will never block.
2464 2768
2465=item $player_object->leave_link ($map, $x, $y) 2769=item $player_object->leave_link ($map, $x, $y)
… …
2486sub cf::object::player::enter_link { 2790sub cf::object::player::enter_link {
2487 my ($self) = @_; 2791 my ($self) = @_;
2488 2792
2489 $self->deactivate_recursive; 2793 $self->deactivate_recursive;
2490 2794
2795 ++$self->{_link_recursion};
2796
2491 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2797 return if UNIVERSAL::isa $self->map, "ext::map_link";
2492 2798
2493 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2799 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2494 if $self->map && $self->map->{path} ne "{link}"; 2800 if $self->map && $self->map->{path} ne "{link}";
2495 2801
2496 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2802 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2497} 2803}
2498 2804
2499sub cf::object::player::leave_link { 2805sub cf::object::player::leave_link {
2500 my ($self, $map, $x, $y) = @_; 2806 my ($self, $map, $x, $y) = @_;
2501 2807
… …
2518 ($x, $y) = (-1, -1) 2824 ($x, $y) = (-1, -1)
2519 unless (defined $x) && (defined $y); 2825 unless (defined $x) && (defined $y);
2520 2826
2521 # use -1 or undef as default coordinates, not 0, 0 2827 # use -1 or undef as default coordinates, not 0, 0
2522 ($x, $y) = ($map->enter_x, $map->enter_y) 2828 ($x, $y) = ($map->enter_x, $map->enter_y)
2523 if $x <=0 && $y <= 0; 2829 if $x <= 0 && $y <= 0;
2524 2830
2525 $map->load; 2831 $map->load;
2526 $map->load_neighbours;
2527 2832
2528 return unless $self->contr->active; 2833 return unless $self->contr->active;
2529 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2530 $self->activate_recursive;
2531 2834
2532 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2835 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2533 $self->enter_map ($map, $x, $y); 2836 if ($self->enter_map ($map, $x, $y)) {
2534} 2837 # entering was successful
2838 delete $self->{_link_recursion};
2839 # only activate afterwards, to support waiting in hooks
2840 $self->activate_recursive;
2841 }
2535 2842
2843}
2844
2536=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2845=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2537 2846
2538Moves the player to the given map-path and coordinates by first freezing 2847Moves the player to the given map-path and coordinates by first freezing
2539her, loading and preparing them map, calling the provided $check callback 2848her, loading and preparing them map, calling the provided $check callback
2540that has to return the map if sucecssful, and then unfreezes the player on 2849that has to return the map if sucecssful, and then unfreezes the player on
2541the new (success) or old (failed) map position. In either case, $done will 2850the new (success) or old (failed) map position. In either case, $done will
… …
2548 2857
2549our $GOTOGEN; 2858our $GOTOGEN;
2550 2859
2551sub cf::object::player::goto { 2860sub cf::object::player::goto {
2552 my ($self, $path, $x, $y, $check, $done) = @_; 2861 my ($self, $path, $x, $y, $check, $done) = @_;
2862
2863 if ($self->{_link_recursion} >= $MAX_LINKS) {
2864 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2865 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2866 ($path, $x, $y) = @$EMERGENCY_POSITION;
2867 }
2553 2868
2554 # do generation counting so two concurrent goto's will be executed in-order 2869 # do generation counting so two concurrent goto's will be executed in-order
2555 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2870 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2556 2871
2557 $self->enter_link; 2872 $self->enter_link;
… …
2577 ($path, $x, $y) = (undef, undef, undef); 2892 ($path, $x, $y) = (undef, undef, undef);
2578 } 2893 }
2579 } 2894 }
2580 2895
2581 my $map = eval { 2896 my $map = eval {
2582 my $map = defined $path ? cf::map::find $path : undef; 2897 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2583 2898
2584 if ($map) { 2899 if ($map) {
2585 $map = $map->customise_for ($self); 2900 $map = $map->customise_for ($self);
2586 $map = $check->($map) if $check && $map; 2901 $map = $check->($map, $x, $y, $self) if $check && $map;
2587 } else { 2902 } else {
2588 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2903 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2589 } 2904 }
2590 2905
2591 $map 2906 $map
… …
2599 if ($gen == $self->{_goto_generation}) { 2914 if ($gen == $self->{_goto_generation}) {
2600 delete $self->{_goto_generation}; 2915 delete $self->{_goto_generation};
2601 $self->leave_link ($map, $x, $y); 2916 $self->leave_link ($map, $x, $y);
2602 } 2917 }
2603 2918
2604 $done->() if $done; 2919 $done->($self) if $done;
2605 })->prio (1); 2920 })->prio (1);
2606} 2921}
2607 2922
2608=item $player_object->enter_exit ($exit_object) 2923=item $player_object->enter_exit ($exit_object)
2609 2924
… …
2677 $Coro::current->{desc} = "enter_exit"; 2992 $Coro::current->{desc} = "enter_exit";
2678 2993
2679 unless (eval { 2994 unless (eval {
2680 $self->deactivate_recursive; # just to be sure 2995 $self->deactivate_recursive; # just to be sure
2681 2996
2682 # random map handling
2683 {
2684 my $guard = cf::lock_acquire "exit_prepare:$exit";
2685
2686 prepare_random_map $exit
2687 if $exit->slaying eq "/!";
2688 }
2689
2690 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2997 my $map = cf::map::normalise $exit->slaying, $exit->map;
2691 my $x = $exit->stats->hp; 2998 my $x = $exit->stats->hp;
2692 my $y = $exit->stats->sp; 2999 my $y = $exit->stats->sp;
3000
3001 # special map handling
3002 my $slaying = $exit->slaying;
3003
3004 # special map handling
3005 if ($slaying eq "/!") {
3006 my $guard = cf::lock_acquire "exit_prepare:$exit";
3007
3008 prepare_random_map $exit
3009 if $exit->slaying eq "/!"; # need to re-check after getting the lock
3010
3011 $map = $exit->slaying;
3012
3013 } elsif ($slaying eq '!up') {
3014 $map = $exit->map->tile_path (cf::TILE_UP);
3015 $x = $exit->x;
3016 $y = $exit->y;
3017
3018 } elsif ($slaying eq '!down') {
3019 $map = $exit->map->tile_path (cf::TILE_DOWN);
3020 $x = $exit->x;
3021 $y = $exit->y;
3022 }
2693 3023
2694 $self->goto ($map, $x, $y); 3024 $self->goto ($map, $x, $y);
2695 3025
2696 # if exit is damned, update players death & WoR home-position 3026 # if exit is damned, update players death & WoR home-position
2697 $self->contr->savebed ($map, $x, $y) 3027 $self->contr->savebed ($map, $x, $y)
… …
2702 $self->message ("Something went wrong deep within the deliantra server. " 3032 $self->message ("Something went wrong deep within the deliantra server. "
2703 . "I'll try to bring you back to the map you were before. " 3033 . "I'll try to bring you back to the map you were before. "
2704 . "Please report this to the dungeon master!", 3034 . "Please report this to the dungeon master!",
2705 cf::NDI_UNIQUE | cf::NDI_RED); 3035 cf::NDI_UNIQUE | cf::NDI_RED);
2706 3036
2707 warn "ERROR in enter_exit: $@"; 3037 error "ERROR in enter_exit: $@";
2708 $self->leave_link; 3038 $self->leave_link;
2709 } 3039 }
2710 })->prio (1); 3040 })->prio (1);
2711} 3041}
2712 3042
… …
2723 3053
2724sub cf::client::send_drawinfo { 3054sub cf::client::send_drawinfo {
2725 my ($self, $text, $flags) = @_; 3055 my ($self, $text, $flags) = @_;
2726 3056
2727 utf8::encode $text; 3057 utf8::encode $text;
2728 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 3058 $self->send_packet (sprintf "msg %d 0 %s", $flags || cf::NDI_BLACK, $text);
3059}
3060
3061=item $client->send_big_packet ($pkt)
3062
3063Like C<send_packet>, but tries to compress large packets, and fragments
3064them as required.
3065
3066=cut
3067
3068our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
3069
3070sub cf::client::send_big_packet {
3071 my ($self, $pkt) = @_;
3072
3073 # try lzf for large packets
3074 $pkt = "lzf " . Compress::LZF::compress $pkt
3075 if 1024 <= length $pkt and $self->{can_lzf};
3076
3077 # split very large packets
3078 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3079 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3080 $pkt = "frag";
3081 }
3082
3083 $self->send_packet ($pkt);
2729} 3084}
2730 3085
2731=item $client->send_msg ($channel, $msg, $color, [extra...]) 3086=item $client->send_msg ($channel, $msg, $color, [extra...])
2732 3087
2733Send a drawinfo or msg packet to the client, formatting the msg for the 3088Send a msg packet to the client, formatting the msg for the client if
2734client if neccessary. C<$type> should be a string identifying the type of 3089necessary. C<$type> should be a string identifying the type of the
2735the message, with C<log> being the default. If C<$color> is negative, suppress 3090message, with C<log> being the default. If C<$color> is negative, suppress
2736the message unless the client supports the msg packet. 3091the message unless the client supports the msg packet.
2737 3092
2738=cut 3093=cut
2739 3094
2740# non-persistent channels (usually the info channel) 3095# non-persistent channels (usually the info channel)
2741our %CHANNEL = ( 3096our %CHANNEL = (
3097 "c/motd" => {
3098 id => "infobox",
3099 title => "MOTD",
3100 reply => undef,
3101 tooltip => "The message of the day",
3102 },
2742 "c/identify" => { 3103 "c/identify" => {
2743 id => "infobox", 3104 id => "infobox",
2744 title => "Identify", 3105 title => "Identify",
2745 reply => undef, 3106 reply => undef,
2746 tooltip => "Items recently identified", 3107 tooltip => "Items recently identified",
… …
2748 "c/examine" => { 3109 "c/examine" => {
2749 id => "infobox", 3110 id => "infobox",
2750 title => "Examine", 3111 title => "Examine",
2751 reply => undef, 3112 reply => undef,
2752 tooltip => "Signs and other items you examined", 3113 tooltip => "Signs and other items you examined",
3114 },
3115 "c/shopinfo" => {
3116 id => "infobox",
3117 title => "Shop Info",
3118 reply => undef,
3119 tooltip => "What your bargaining skill tells you about the shop",
2753 }, 3120 },
2754 "c/book" => { 3121 "c/book" => {
2755 id => "infobox", 3122 id => "infobox",
2756 title => "Book", 3123 title => "Book",
2757 reply => undef, 3124 reply => undef,
… …
2803 id => "infobox", 3170 id => "infobox",
2804 title => "Pets", 3171 title => "Pets",
2805 reply => undef, 3172 reply => undef,
2806 tooltip => "Shows information abotu your pets/a specific pet", 3173 tooltip => "Shows information abotu your pets/a specific pet",
2807 }, 3174 },
3175 "c/perceiveself" => {
3176 id => "infobox",
3177 title => "Perceive Self",
3178 reply => undef,
3179 tooltip => "You gained detailed knowledge about yourself",
3180 },
2808 "c/uptime" => { 3181 "c/uptime" => {
2809 id => "infobox", 3182 id => "infobox",
2810 title => "Uptime", 3183 title => "Uptime",
2811 reply => undef, 3184 reply => undef,
2812 tooltip => "How long the server has been running since last restart", 3185 tooltip => "How long the server has been running since last restart",
… …
2827 id => "death", 3200 id => "death",
2828 title => "Death", 3201 title => "Death",
2829 reply => undef, 3202 reply => undef,
2830 tooltip => "Reason for and more info about your most recent death", 3203 tooltip => "Reason for and more info about your most recent death",
2831 }, 3204 },
3205 "c/fatal" => {
3206 id => "fatal",
3207 title => "Fatal Error",
3208 reply => undef,
3209 tooltip => "Reason for the server disconnect",
3210 },
2832 "c/say" => $SAY_CHANNEL, 3211 "c/say" => $SAY_CHANNEL,
2833 "c/chat" => $CHAT_CHANNEL, 3212 "c/chat" => $CHAT_CHANNEL,
2834); 3213);
2835 3214
2836sub cf::client::send_msg { 3215sub cf::client::send_msg {
… …
2867 my $pkt = "msg " 3246 my $pkt = "msg "
2868 . $self->{json_coder}->encode ( 3247 . $self->{json_coder}->encode (
2869 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3248 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2870 ); 3249 );
2871 3250
2872 # try lzf for large packets
2873 $pkt = "lzf " . Compress::LZF::compress $pkt
2874 if 1024 <= length $pkt and $self->{can_lzf};
2875
2876 # split very large packets
2877 if (8192 < length $pkt and $self->{can_lzf}) {
2878 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2879 $pkt = "frag";
2880 }
2881
2882 $self->send_packet ($pkt); 3251 $self->send_big_packet ($pkt);
2883} 3252}
2884 3253
2885=item $client->ext_msg ($type, @msg) 3254=item $client->ext_msg ($type, @msg)
2886 3255
2887Sends an ext event to the client. 3256Sends an ext event to the client.
… …
2889=cut 3258=cut
2890 3259
2891sub cf::client::ext_msg($$@) { 3260sub cf::client::ext_msg($$@) {
2892 my ($self, $type, @msg) = @_; 3261 my ($self, $type, @msg) = @_;
2893 3262
2894 if ($self->extcmd == 2) {
2895 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3263 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2896 } elsif ($self->extcmd == 1) { # TODO: remove
2897 push @msg, msgtype => "event_$type";
2898 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2899 }
2900}
2901
2902=item $client->ext_reply ($msgid, @msg)
2903
2904Sends an ext reply to the client.
2905
2906=cut
2907
2908sub cf::client::ext_reply($$@) {
2909 my ($self, $id, @msg) = @_;
2910
2911 if ($self->extcmd == 2) {
2912 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2913 } elsif ($self->extcmd == 1) {
2914 #TODO: version 1, remove
2915 unshift @msg, msgtype => "reply", msgid => $id;
2916 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2917 }
2918} 3264}
2919 3265
2920=item $success = $client->query ($flags, "text", \&cb) 3266=item $success = $client->query ($flags, "text", \&cb)
2921 3267
2922Queues a query to the client, calling the given callback with 3268Queues a query to the client, calling the given callback with
… …
2977 my ($ns, $buf) = @_; 3323 my ($ns, $buf) = @_;
2978 3324
2979 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3325 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2980 3326
2981 if (ref $msg) { 3327 if (ref $msg) {
2982 my ($type, $reply, @payload) = 3328 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
2983 "ARRAY" eq ref $msg
2984 ? @$msg
2985 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2986 3329
2987 my @reply;
2988
2989 if (my $cb = $EXTICMD{$type}) { 3330 if (my $cb = $EXTIACMD{$type}) {
3331 $cb->(
3332 $ns,
3333 sub {
3334 $ns->ext_msg ("reply-$reply", @_)
3335 if $reply;
3336 },
3337 @payload
3338 );
3339 } else {
3340 my @reply;
3341
3342 if (my $cb = $EXTICMD{$type}) {
2990 @reply = $cb->($ns, @payload); 3343 @reply = $cb->($ns, @payload);
3344 }
3345
3346 $ns->ext_msg ("reply-$reply", @reply)
3347 if $reply;
2991 } 3348 }
2992
2993 $ns->ext_reply ($reply, @reply)
2994 if $reply;
2995
2996 } else { 3349 } else {
2997 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3350 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2998 } 3351 }
2999 3352
3000 cf::override; 3353 cf::override;
3001 }, 3354 },
3002); 3355);
… …
3022 3375
3023 $coro 3376 $coro
3024} 3377}
3025 3378
3026cf::client->attach ( 3379cf::client->attach (
3027 on_destroy => sub { 3380 on_client_destroy => sub {
3028 my ($ns) = @_; 3381 my ($ns) = @_;
3029 3382
3030 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3383 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3031 }, 3384 },
3032); 3385);
… …
3048our $safe_hole = new Safe::Hole; 3401our $safe_hole = new Safe::Hole;
3049 3402
3050$SIG{FPE} = 'IGNORE'; 3403$SIG{FPE} = 'IGNORE';
3051 3404
3052$safe->permit_only (Opcode::opset qw( 3405$safe->permit_only (Opcode::opset qw(
3053 :base_core :base_mem :base_orig :base_math 3406 :base_core :base_mem :base_orig :base_math :base_loop
3054 grepstart grepwhile mapstart mapwhile 3407 grepstart grepwhile mapstart mapwhile
3055 sort time 3408 sort time
3056)); 3409));
3057 3410
3058# here we export the classes and methods available to script code 3411# here we export the classes and methods available to script code
… …
3083 decrease split destroy change_exp value msg lore send_msg)], 3436 decrease split destroy change_exp value msg lore send_msg)],
3084 ["cf::object::player" => qw(player)], 3437 ["cf::object::player" => qw(player)],
3085 ["cf::player" => qw(peaceful send_msg)], 3438 ["cf::player" => qw(peaceful send_msg)],
3086 ["cf::map" => qw(trigger)], 3439 ["cf::map" => qw(trigger)],
3087) { 3440) {
3088 no strict 'refs';
3089 my ($pkg, @funs) = @$_; 3441 my ($pkg, @funs) = @$_;
3090 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3442 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3091 for @funs; 3443 for @funs;
3092} 3444}
3093 3445
… …
3110 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3462 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3111 $qcode =~ s/\n/\\n/g; 3463 $qcode =~ s/\n/\\n/g;
3112 3464
3113 %vars = (_dummy => 0) unless %vars; 3465 %vars = (_dummy => 0) unless %vars;
3114 3466
3467 my @res;
3115 local $_; 3468 local $_;
3116 local @safe::cf::_safe_eval_args = values %vars;
3117 3469
3118 my $eval = 3470 my $eval =
3119 "do {\n" 3471 "do {\n"
3120 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3472 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3121 . "#line 0 \"{$qcode}\"\n" 3473 . "#line 0 \"{$qcode}\"\n"
3122 . $code 3474 . $code
3123 . "\n}" 3475 . "\n}"
3124 ; 3476 ;
3125 3477
3478 if ($CFG{safe_eval}) {
3126 sub_generation_inc; 3479 sub_generation_inc;
3480 local @safe::cf::_safe_eval_args = values %vars;
3127 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3481 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3128 sub_generation_inc; 3482 sub_generation_inc;
3483 } else {
3484 local @cf::_safe_eval_args = values %vars;
3485 @res = wantarray ? eval eval : scalar eval $eval;
3486 }
3129 3487
3130 if ($@) { 3488 if ($@) {
3131 warn "$@"; 3489 warn "$@",
3132 warn "while executing safe code '$code'\n"; 3490 "while executing safe code '$code'\n",
3133 warn "with arguments " . (join " ", %vars) . "\n"; 3491 "with arguments " . (join " ", %vars) . "\n";
3134 } 3492 }
3135 3493
3136 wantarray ? @res : $res[0] 3494 wantarray ? @res : $res[0]
3137} 3495}
3138 3496
… …
3152=cut 3510=cut
3153 3511
3154sub register_script_function { 3512sub register_script_function {
3155 my ($fun, $cb) = @_; 3513 my ($fun, $cb) = @_;
3156 3514
3157 no strict 'refs'; 3515 $fun = "safe::$fun" if $CFG{safe_eval};
3158 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3516 *$fun = $safe_hole->wrap ($cb);
3159} 3517}
3160 3518
3161=back 3519=back
3162 3520
3163=cut 3521=cut
3164 3522
3165############################################################################# 3523#############################################################################
3166# the server's init and main functions 3524# the server's init and main functions
3167 3525
3526{
3527 package cf::face;
3528
3529 our %HASH; # hash => idx
3530 our @DATA; # dynamically-created facedata, only faceste 0 used
3531 our @FOFS; # file offset, if > 0
3532 our @SIZE; # size of face, in octets
3533 our @META; # meta hash of face, if any
3534 our $DATAFH; # facedata filehandle
3535
3536 # internal api, not finalised
3537 sub set {
3538 my ($name, $type, $data) = @_;
3539
3540 my $idx = cf::face::find $name;
3541
3542 if ($idx) {
3543 delete $HASH{cf::face::get_csum $idx};
3544 } else {
3545 $idx = cf::face::alloc $name;
3546 }
3547
3548 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3549
3550 cf::face::set_type $idx, $type;
3551 cf::face::set_csum $idx, 0, $hash;
3552
3553 # we need to destroy the SV itself, not just modify it, as a running ix
3554 # might hold a reference to it: "delete" achieves that.
3555 delete $FOFS[0][$idx];
3556 delete $DATA[0][$idx];
3557 $DATA[0][$idx] = $data;
3558 $SIZE[0][$idx] = length $data;
3559 delete $META[$idx];
3560 $HASH{$hash} = $idx;#d#
3561
3562 $idx
3563 }
3564
3565 sub _get_data($$$) {
3566 my ($idx, $set, $cb) = @_;
3567
3568 if (defined $DATA[$set][$idx]) {
3569 $cb->($DATA[$set][$idx]);
3570 } elsif (my $fofs = $FOFS[$set][$idx]) {
3571 my $size = $SIZE[$set][$idx];
3572 my $buf;
3573 IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
3574 if ($_[0] == $size) {
3575 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3576 $cb->($buf);
3577 } else {
3578 cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
3579 }
3580 };
3581 } else {
3582 cf::error "requested facedata for unknown face $idx#$set, ignoring.";
3583 }
3584 }
3585
3586 # rather ineffient
3587 sub cf::face::get_data($;$) {
3588 my ($idx, $set) = @_;
3589
3590 _get_data $idx, $set, Coro::rouse_cb;
3591 Coro::rouse_wait
3592 }
3593
3594 sub cf::face::ix {
3595 my ($ns, $set, $idx, $pri) = @_;
3596
3597 _get_data $idx, $set, sub {
3598 $ns->ix_send ($idx, $pri, $_[0]);
3599 };
3600 }
3601}
3602
3168sub load_facedata($) { 3603sub load_facedata($) {
3169 my ($path) = @_; 3604 my ($path) = @_;
3170 3605
3171 # HACK to clear player env face cache, we need some signal framework
3172 # for this (global event?)
3173 %ext::player_env::MUSIC_FACE_CACHE = ();
3174
3175 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3606 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3176 3607
3177 warn "loading facedata from $path\n"; 3608 trace "loading facedata from $path\n";
3178 3609
3179 my $facedata; 3610 my $facedata = decode_storable load_file "$path/faceinfo";
3180 0 < aio_load $path, $facedata
3181 or die "$path: $!";
3182
3183 $facedata = Coro::Storable::thaw $facedata;
3184 3611
3185 $facedata->{version} == 2 3612 $facedata->{version} == 2
3186 or cf::cleanup "$path: version mismatch, cannot proceed."; 3613 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3187 3614
3188 # patch in the exptable 3615 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3189 $facedata->{resource}{"res/exp_table"} = { 3616 or cf::cleanup "$path/facedata: $!, cannot proceed.";
3190 type => FT_RSRC, 3617
3191 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3618 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3192 }; 3619
3193 cf::cede_to_tick; 3620 # BEGIN ATOMIC
3621 # from here on, everything must be atomic - no thread switch allowed
3622 my $t1 = EV::time;
3194 3623
3195 { 3624 {
3196 my $faces = $facedata->{faceinfo}; 3625 my $faces = $facedata->{faceinfo};
3197 3626
3198 while (my ($face, $info) = each %$faces) { 3627 for my $face (sort keys %$faces) {
3628 my $info = $faces->{$face};
3199 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3629 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3200 3630
3201 cf::face::set_visibility $idx, $info->{visibility}; 3631 cf::face::set_visibility $idx, $info->{visibility};
3202 cf::face::set_magicmap $idx, $info->{magicmap}; 3632 cf::face::set_magicmap $idx, $info->{magicmap};
3203 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3633 cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
3204 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3634 cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
3205 3635 cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3206 cf::cede_to_tick; 3636 $cf::face::HASH{$info->{hash64}} = $idx;
3637 delete $cf::face::META[$idx];
3207 } 3638 }
3208 3639
3209 while (my ($face, $info) = each %$faces) { 3640 while (my ($face, $info) = each %$faces) {
3210 next unless $info->{smooth}; 3641 next unless $info->{smooth};
3211 3642
… …
3214 3645
3215 if (my $smooth = cf::face::find $info->{smooth}) { 3646 if (my $smooth = cf::face::find $info->{smooth}) {
3216 cf::face::set_smooth $idx, $smooth; 3647 cf::face::set_smooth $idx, $smooth;
3217 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3648 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3218 } else { 3649 } else {
3219 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3650 error "smooth face '$info->{smooth}' not found for face '$face'";
3220 } 3651 }
3221
3222 cf::cede_to_tick;
3223 } 3652 }
3224 } 3653 }
3225 3654
3226 { 3655 {
3227 my $anims = $facedata->{animinfo}; 3656 my $anims = $facedata->{animinfo};
3228 3657
3229 while (my ($anim, $info) = each %$anims) { 3658 while (my ($anim, $info) = each %$anims) {
3230 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3659 cf::anim::set $anim, $info->{frames}, $info->{facings};
3231 cf::cede_to_tick;
3232 } 3660 }
3233 3661
3234 cf::anim::invalidate_all; # d'oh 3662 cf::anim::invalidate_all; # d'oh
3235 } 3663 }
3236 3664
3237 { 3665 {
3238 # TODO: for gcfclient pleasure, we should give resources
3239 # that gcfclient doesn't grok a >10000 face index.
3240 my $res = $facedata->{resource}; 3666 my $res = $facedata->{resource};
3241 3667
3242 while (my ($name, $info) = each %$res) { 3668 while (my ($name, $info) = each %$res) {
3243 if (defined $info->{type}) { 3669 if (defined (my $type = $info->{type})) {
3670 # TODO: different hash - must free and use new index, or cache ixface data queue
3244 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3671 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3245 my $data;
3246 3672
3247 if ($info->{type} & 1) {
3248 # prepend meta info
3249
3250 my $meta = $enc->encode ({
3251 name => $name,
3252 %{ $info->{meta} || {} },
3253 });
3254
3255 $data = pack "(w/a*)*", $meta, $info->{data};
3256 } else {
3257 $data = $info->{data};
3258 }
3259
3260 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3261 cf::face::set_type $idx, $info->{type}; 3673 cf::face::set_type $idx, $type;
3674 cf::face::set_csum $idx, 0, $info->{hash};
3675 $cf::face::SIZE[0][$idx] = $info->{size};
3676 $cf::face::FOFS[0][$idx] = $info->{fofs};
3677 $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3678 $cf::face::HASH{$info->{hash}} = $idx;
3262 } else { 3679 } else {
3263 $RESOURCE{$name} = $info; 3680# $RESOURCE{$name} = $info; # unused
3264 } 3681 }
3265
3266 cf::cede_to_tick;
3267 } 3682 }
3268 } 3683 }
3684
3685 ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
3686
3687 # HACK to clear player env face cache, we need some signal framework
3688 # for this (global event?)
3689 %ext::player_env::MUSIC_FACE_CACHE = ();
3690
3691 # END ATOMIC
3692
3693 cf::debug "facedata atomic update time ", EV::time - $t1;
3269 3694
3270 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3695 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3271 3696
3697 aio_close $fh if $fh; # close old facedata
3698
3272 1 3699 1
3273} 3700}
3274
3275cf::global->attach (on_resource_update => sub {
3276 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3277 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3278
3279 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3280 my $sound = $soundconf->{compat}[$_]
3281 or next;
3282
3283 my $face = cf::face::find "sound/$sound->[1]";
3284 cf::sound::set $sound->[0] => $face;
3285 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3286 }
3287
3288 while (my ($k, $v) = each %{$soundconf->{event}}) {
3289 my $face = cf::face::find "sound/$v";
3290 cf::sound::set $k => $face;
3291 }
3292 }
3293});
3294 3701
3295register_exticmd fx_want => sub { 3702register_exticmd fx_want => sub {
3296 my ($ns, $want) = @_; 3703 my ($ns, $want) = @_;
3297 3704
3298 while (my ($k, $v) = each %$want) { 3705 while (my ($k, $v) = each %$want) {
… …
3306 my $status = load_resource_file_ $_[0]; 3713 my $status = load_resource_file_ $_[0];
3307 get_slot 0.1, 100; 3714 get_slot 0.1, 100;
3308 cf::arch::commit_load; 3715 cf::arch::commit_load;
3309 3716
3310 $status 3717 $status
3718}
3719
3720sub reload_exp_table {
3721 _reload_exp_table;
3722
3723 cf::face::set
3724 "res/exp_table" => FT_RSRC,
3725 JSON::XS->new->utf8->canonical->encode (
3726 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3727 );
3728}
3729
3730sub reload_materials {
3731 _reload_materials;
3311} 3732}
3312 3733
3313sub reload_regions { 3734sub reload_regions {
3314 # HACK to clear player env face cache, we need some signal framework 3735 # HACK to clear player env face cache, we need some signal framework
3315 # for this (global event?) 3736 # for this (global event?)
… …
3323 if exists $_->{match}; 3744 if exists $_->{match};
3324 } 3745 }
3325} 3746}
3326 3747
3327sub reload_facedata { 3748sub reload_facedata {
3328 load_facedata "$DATADIR/facedata" 3749 load_facedata $DATADIR
3329 or die "unable to load facedata\n"; 3750 or die "unable to load facedata\n";
3330} 3751}
3331 3752
3332sub reload_archetypes { 3753sub reload_archetypes {
3333 load_resource_file "$DATADIR/archetypes" 3754 load_resource_file "$DATADIR/archetypes"
3334 or die "unable to load archetypes\n"; 3755 or die "unable to load archetypes\n";
3756
3757 cf::face::set
3758 "res/skill_info" => FT_RSRC,
3759 JSON::XS->new->utf8->canonical->encode (
3760 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3761 );
3762
3763 cf::face::set
3764 "res/spell_paths" => FT_RSRC,
3765 JSON::XS->new->utf8->canonical->encode (
3766 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3767 );
3335} 3768}
3336 3769
3337sub reload_treasures { 3770sub reload_treasures {
3338 load_resource_file "$DATADIR/treasures" 3771 load_resource_file "$DATADIR/treasures"
3339 or die "unable to load treasurelists\n"; 3772 or die "unable to load treasurelists\n";
3340} 3773}
3341 3774
3775sub reload_sound {
3776 trace "loading sound config from $DATADIR/sound\n";
3777
3778 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3779
3780 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3781 my $sound = $soundconf->{compat}[$_]
3782 or next;
3783
3784 my $face = cf::face::find "sound/$sound->[1]";
3785 cf::sound::set $sound->[0] => $face;
3786 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3787 }
3788
3789 while (my ($k, $v) = each %{$soundconf->{event}}) {
3790 my $face = cf::face::find "sound/$v";
3791 cf::sound::set $k => $face;
3792 }
3793}
3794
3342sub reload_resources { 3795sub reload_resources {
3343 warn "reloading resource files...\n"; 3796 trace "reloading resource files...\n";
3344 3797
3798 reload_materials;
3345 reload_facedata; 3799 reload_facedata;
3800 reload_exp_table;
3801 reload_sound;
3346 reload_archetypes; 3802 reload_archetypes;
3347 reload_regions; 3803 reload_regions;
3348 reload_treasures; 3804 reload_treasures;
3349 3805
3350 warn "finished reloading resource files\n"; 3806 trace "finished reloading resource files\n";
3351} 3807}
3352 3808
3353sub reload_config { 3809sub reload_config {
3354 open my $fh, "<:utf8", "$CONFDIR/config" 3810 trace "reloading config file...\n";
3355 or return;
3356 3811
3357 local $/; 3812 my $config = load_file "$CONFDIR/config";
3358 *CFG = YAML::Load <$fh>; 3813 utf8::decode $config;
3814 *CFG = decode_yaml $config;
3359 3815
3360 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3816 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3361 3817
3362 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3818 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3363 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3819 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3364 3820
3365 if (exists $CFG{mlockall}) { 3821 if (exists $CFG{mlockall}) {
… …
3388 3844
3389 seek $fh, 0, 0; 3845 seek $fh, 0, 0;
3390 print $fh $$; 3846 print $fh $$;
3391} 3847}
3392 3848
3849sub main_loop {
3850 trace "EV::loop starting\n";
3851 if (1) {
3852 EV::loop;
3853 }
3854 trace "EV::loop returned\n";
3855 goto &main_loop unless $REALLY_UNLOOP;
3856}
3857
3393sub main { 3858sub main {
3394 cf::init_globals; # initialise logging 3859 cf::init_globals; # initialise logging
3395 3860
3396 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3861 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3397 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3862 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3398 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3863 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3399 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3864 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3400 3865
3401 cf::init_experience;
3402 cf::init_anim;
3403 cf::init_attackmess;
3404 cf::init_dynamic;
3405
3406 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3866 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3407 3867
3408 # we must not ever block the main coroutine 3868 # we must not ever block the main coroutine
3409 local $Coro::idle = sub { 3869 $Coro::idle = sub {
3410 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3870 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3411 (async { 3871 (async {
3412 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3872 $Coro::current->{desc} = "IDLE BUG HANDLER";
3413 EV::loop EV::LOOP_ONESHOT; 3873 EV::loop EV::LOOP_ONESHOT;
3414 })->prio (Coro::PRIO_MAX); 3874 })->prio (Coro::PRIO_MAX);
3415 }; 3875 };
3416 3876
3417 evthread_start IO::AIO::poll_fileno; 3877 evthread_start IO::AIO::poll_fileno;
3418 3878
3419 cf::sync_job { 3879 cf::sync_job {
3880 cf::incloader::init ();
3881
3882 db_init;
3883
3884 cf::init_anim;
3885 cf::init_attackmess;
3886 cf::init_dynamic;
3887
3888 cf::load_settings;
3889
3420 reload_resources; 3890 reload_resources;
3421 reload_config; 3891 reload_config;
3422 db_init;
3423 3892
3424 cf::load_settings;
3425 cf::load_materials;
3426 cf::init_uuid; 3893 cf::init_uuid;
3427 cf::init_signals; 3894 cf::init_signals;
3428 cf::init_commands;
3429 cf::init_skills; 3895 cf::init_skills;
3430 3896
3431 cf::init_beforeplay; 3897 cf::init_beforeplay;
3432 3898
3433 atomic; 3899 atomic;
… …
3435 load_extensions; 3901 load_extensions;
3436 3902
3437 utime time, time, $RUNTIMEFILE; 3903 utime time, time, $RUNTIMEFILE;
3438 3904
3439 # no (long-running) fork's whatsoever before this point(!) 3905 # no (long-running) fork's whatsoever before this point(!)
3906 use POSIX ();
3440 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3907 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3441 3908
3442 (pop @POST_INIT)->(0) while @POST_INIT; 3909 cf::_post_init 0;
3443 }; 3910 };
3444 3911
3445 EV::loop; 3912 cf::object::thawer::errors_are_fatal 0;
3913 info "parse errors in files are no longer fatal from this point on.\n";
3914
3915 AE::postpone {
3916 undef &main; # free gobs of memory :)
3917 };
3918
3919 goto &main_loop;
3446} 3920}
3447 3921
3448############################################################################# 3922#############################################################################
3449# initialisation and cleanup 3923# initialisation and cleanup
3450 3924
3451# install some emergency cleanup handlers 3925# install some emergency cleanup handlers
3452BEGIN { 3926BEGIN {
3453 our %SIGWATCHER = (); 3927 our %SIGWATCHER = ();
3454 for my $signal (qw(INT HUP TERM)) { 3928 for my $signal (qw(INT HUP TERM)) {
3455 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3929 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3456 cf::cleanup "SIG$signal"; 3930 cf::cleanup "SIG$signal";
3457 }; 3931 };
3458 } 3932 }
3459} 3933}
3460 3934
3461sub write_runtime_sync { 3935sub write_runtime_sync {
3936 my $t0 = AE::time;
3937
3462 # first touch the runtime file to show we are still running: 3938 # first touch the runtime file to show we are still running:
3463 # the fsync below can take a very very long time. 3939 # the fsync below can take a very very long time.
3464 3940
3465 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3941 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3466 3942
3467 my $guard = cf::lock_acquire "write_runtime"; 3943 my $guard = cf::lock_acquire "write_runtime";
3468 3944
3469 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3945 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3470 or return; 3946 or return;
3471 3947
3472 my $value = $cf::RUNTIME + 90 + 10; 3948 my $value = $cf::RUNTIME + 90 + 10;
3473 # 10 is the runtime save interval, for a monotonic clock 3949 # 10 is the runtime save interval, for a monotonic clock
3474 # 60 allows for the watchdog to kill the server. 3950 # 60 allows for the watchdog to kill the server.
… …
3487 or return; 3963 or return;
3488 3964
3489 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3965 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3490 and return; 3966 and return;
3491 3967
3492 warn "runtime file written.\n"; 3968 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3493 3969
3494 1 3970 1
3495} 3971}
3496 3972
3497our $uuid_lock; 3973our $uuid_lock;
… …
3509 or return; 3985 or return;
3510 3986
3511 my $value = uuid_seq uuid_cur; 3987 my $value = uuid_seq uuid_cur;
3512 3988
3513 unless ($value) { 3989 unless ($value) {
3514 warn "cowardly refusing to write zero uuid value!\n"; 3990 info "cowardly refusing to write zero uuid value!\n";
3515 return; 3991 return;
3516 } 3992 }
3517 3993
3518 my $value = uuid_str $value + $uuid_skip; 3994 my $value = uuid_str $value + $uuid_skip;
3519 $uuid_skip = 0; 3995 $uuid_skip = 0;
… …
3529 or return; 4005 or return;
3530 4006
3531 aio_rename "$uuid~", $uuid 4007 aio_rename "$uuid~", $uuid
3532 and return; 4008 and return;
3533 4009
3534 warn "uuid file written ($value).\n"; 4010 trace "uuid file written ($value).\n";
3535 4011
3536 1 4012 1
3537 4013
3538} 4014}
3539 4015
… …
3545} 4021}
3546 4022
3547sub emergency_save() { 4023sub emergency_save() {
3548 my $freeze_guard = cf::freeze_mainloop; 4024 my $freeze_guard = cf::freeze_mainloop;
3549 4025
3550 warn "emergency_perl_save: enter\n"; 4026 info "emergency_perl_save: enter\n";
4027
4028 # this is a trade-off: we want to be very quick here, so
4029 # save all maps without fsync, and later call a global sync
4030 # (which in turn might be very very slow)
4031 local $USE_FSYNC = 0;
3551 4032
3552 cf::sync_job { 4033 cf::sync_job {
3553 # this is a trade-off: we want to be very quick here, so 4034 cf::write_runtime_sync; # external watchdog should not bark
3554 # save all maps without fsync, and later call a global sync
3555 # (which in turn might be very very slow)
3556 local $USE_FSYNC = 0;
3557 4035
3558 # use a peculiar iteration method to avoid tripping on perl 4036 # use a peculiar iteration method to avoid tripping on perl
3559 # refcount bugs in for. also avoids problems with players 4037 # refcount bugs in for. also avoids problems with players
3560 # and maps saved/destroyed asynchronously. 4038 # and maps saved/destroyed asynchronously.
3561 warn "emergency_perl_save: begin player save\n"; 4039 info "emergency_perl_save: begin player save\n";
3562 for my $login (keys %cf::PLAYER) { 4040 for my $login (keys %cf::PLAYER) {
3563 my $pl = $cf::PLAYER{$login} or next; 4041 my $pl = $cf::PLAYER{$login} or next;
3564 $pl->valid or next; 4042 $pl->valid or next;
3565 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 4043 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3566 $pl->save; 4044 $pl->save;
3567 } 4045 }
3568 warn "emergency_perl_save: end player save\n"; 4046 info "emergency_perl_save: end player save\n";
3569 4047
4048 cf::write_runtime_sync; # external watchdog should not bark
4049
3570 warn "emergency_perl_save: begin map save\n"; 4050 info "emergency_perl_save: begin map save\n";
3571 for my $path (keys %cf::MAP) { 4051 for my $path (keys %cf::MAP) {
3572 my $map = $cf::MAP{$path} or next; 4052 my $map = $cf::MAP{$path} or next;
3573 $map->valid or next; 4053 $map->valid or next;
3574 $map->save; 4054 $map->save;
3575 } 4055 }
3576 warn "emergency_perl_save: end map save\n"; 4056 info "emergency_perl_save: end map save\n";
3577 4057
4058 cf::write_runtime_sync; # external watchdog should not bark
4059
3578 warn "emergency_perl_save: begin database checkpoint\n"; 4060 info "emergency_perl_save: begin database checkpoint\n";
3579 BDB::db_env_txn_checkpoint $DB_ENV; 4061 BDB::db_env_txn_checkpoint $DB_ENV;
3580 warn "emergency_perl_save: end database checkpoint\n"; 4062 info "emergency_perl_save: end database checkpoint\n";
3581 4063
3582 warn "emergency_perl_save: begin write uuid\n"; 4064 info "emergency_perl_save: begin write uuid\n";
3583 write_uuid_sync 1; 4065 write_uuid_sync 1;
3584 warn "emergency_perl_save: end write uuid\n"; 4066 info "emergency_perl_save: end write uuid\n";
4067
4068 cf::write_runtime_sync; # external watchdog should not bark
4069
4070 trace "emergency_perl_save: syncing database to disk";
4071 BDB::db_env_txn_checkpoint $DB_ENV;
4072
4073 info "emergency_perl_save: starting sync\n";
4074 IO::AIO::aio_sync sub {
4075 info "emergency_perl_save: finished sync\n";
4076 };
4077
4078 cf::write_runtime_sync; # external watchdog should not bark
4079
4080 trace "emergency_perl_save: flushing outstanding aio requests";
4081 while (IO::AIO::nreqs || BDB::nreqs) {
4082 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
4083 }
4084
4085 cf::write_runtime_sync; # external watchdog should not bark
3585 }; 4086 };
3586 4087
3587 warn "emergency_perl_save: starting sync()\n";
3588 IO::AIO::aio_sync sub {
3589 warn "emergency_perl_save: finished sync()\n";
3590 };
3591
3592 warn "emergency_perl_save: leave\n"; 4088 info "emergency_perl_save: leave\n";
3593} 4089}
3594 4090
3595sub post_cleanup { 4091sub post_cleanup {
3596 my ($make_core) = @_; 4092 my ($make_core) = @_;
3597 4093
4094 IO::AIO::flush;
4095
3598 warn Carp::longmess "post_cleanup backtrace" 4096 error Carp::longmess "post_cleanup backtrace"
3599 if $make_core; 4097 if $make_core;
3600 4098
3601 my $fh = pidfile; 4099 my $fh = pidfile;
3602 unlink $PIDFILE if <$fh> == $$; 4100 unlink $PIDFILE if <$fh> == $$;
3603} 4101}
… …
3623 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 4121 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3624 for my $name (keys %$leaf_symtab) { 4122 for my $name (keys %$leaf_symtab) {
3625 _gv_clear *{"$pkg$name"}; 4123 _gv_clear *{"$pkg$name"};
3626# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 4124# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3627 } 4125 }
3628 warn "cleared package $pkg\n";#d#
3629} 4126}
3630 4127
3631sub do_reload_perl() { 4128sub do_reload_perl() {
3632 # can/must only be called in main 4129 # can/must only be called in main
3633 if ($Coro::current != $Coro::main) { 4130 unless (in_main) {
3634 warn "can only reload from main coroutine"; 4131 error "can only reload from main coroutine";
3635 return; 4132 return;
3636 } 4133 }
3637 4134
3638 return if $RELOAD++; 4135 return if $RELOAD++;
3639 4136
3640 my $t1 = EV::time; 4137 my $t1 = AE::time;
3641 4138
3642 while ($RELOAD) { 4139 while ($RELOAD) {
3643 warn "reloading..."; 4140 cf::get_slot 0.1, -1, "reload_perl";
4141 info "perl_reload: reloading...";
3644 4142
3645 warn "entering sync_job"; 4143 trace "perl_reload: entering sync_job";
3646 4144
3647 cf::sync_job { 4145 cf::sync_job {
3648 cf::write_runtime_sync; # external watchdog should not bark
3649 cf::emergency_save; 4146 #cf::emergency_save;
3650 cf::write_runtime_sync; # external watchdog should not bark
3651 4147
3652 warn "syncing database to disk";
3653 BDB::db_env_txn_checkpoint $DB_ENV;
3654
3655 # if anything goes wrong in here, we should simply crash as we already saved
3656
3657 warn "flushing outstanding aio requests";
3658 while (IO::AIO::nreqs || BDB::nreqs) {
3659 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3660 }
3661
3662 warn "cancelling all extension coros"; 4148 trace "perl_reload: cancelling all extension coros";
3663 $_->cancel for values %EXT_CORO; 4149 $_->cancel for values %EXT_CORO;
3664 %EXT_CORO = (); 4150 %EXT_CORO = ();
3665 4151
3666 warn "removing commands"; 4152 trace "perl_reload: removing commands";
3667 %COMMAND = (); 4153 %COMMAND = ();
3668 4154
3669 warn "removing ext/exti commands"; 4155 trace "perl_reload: removing ext/exti commands";
3670 %EXTCMD = (); 4156 %EXTCMD = ();
3671 %EXTICMD = (); 4157 %EXTICMD = ();
3672 4158
3673 warn "unloading/nuking all extensions"; 4159 trace "perl_reload: unloading/nuking all extensions";
3674 for my $pkg (@EXTS) { 4160 for my $pkg (@EXTS) {
3675 warn "... unloading $pkg"; 4161 trace "... unloading $pkg";
3676 4162
3677 if (my $cb = $pkg->can ("unload")) { 4163 if (my $cb = $pkg->can ("unload")) {
3678 eval { 4164 eval {
3679 $cb->($pkg); 4165 $cb->($pkg);
3680 1 4166 1
3681 } or warn "$pkg unloaded, but with errors: $@"; 4167 } or error "$pkg unloaded, but with errors: $@";
3682 } 4168 }
3683 4169
3684 warn "... clearing $pkg"; 4170 trace "... clearing $pkg";
3685 clear_package $pkg; 4171 clear_package $pkg;
3686 } 4172 }
3687 4173
3688 warn "unloading all perl modules loaded from $LIBDIR"; 4174 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3689 while (my ($k, $v) = each %INC) { 4175 while (my ($k, $v) = each %INC) {
3690 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4176 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3691 4177
3692 warn "... unloading $k"; 4178 trace "... unloading $k";
3693 delete $INC{$k}; 4179 delete $INC{$k};
3694 4180
3695 $k =~ s/\.pm$//; 4181 $k =~ s/\.pm$//;
3696 $k =~ s/\//::/g; 4182 $k =~ s/\//::/g;
3697 4183
… …
3700 } 4186 }
3701 4187
3702 clear_package $k; 4188 clear_package $k;
3703 } 4189 }
3704 4190
3705 warn "getting rid of safe::, as good as possible"; 4191 trace "perl_reload: getting rid of safe::, as good as possible";
3706 clear_package "safe::$_" 4192 clear_package "safe::$_"
3707 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4193 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3708 4194
3709 warn "unloading cf.pm \"a bit\""; 4195 trace "perl_reload: unloading cf.pm \"a bit\"";
3710 delete $INC{"cf.pm"}; 4196 delete $INC{"cf.pm"};
3711 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4197 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3712 4198
3713 # don't, removes xs symbols, too, 4199 # don't, removes xs symbols, too,
3714 # and global variables created in xs 4200 # and global variables created in xs
3715 #clear_package __PACKAGE__; 4201 #clear_package __PACKAGE__;
3716 4202
3717 warn "unload completed, starting to reload now"; 4203 info "perl_reload: unload completed, starting to reload now";
3718 4204
3719 warn "reloading cf.pm"; 4205 trace "perl_reload: reloading cf.pm";
3720 require cf; 4206 require cf;
3721 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 4207 cf::_connect_to_perl_1;
3722 4208
3723 warn "loading config and database again"; 4209 trace "perl_reload: loading config and database again";
3724 cf::reload_config; 4210 cf::reload_config;
3725 4211
3726 warn "loading extensions"; 4212 trace "perl_reload: loading extensions";
3727 cf::load_extensions; 4213 cf::load_extensions;
3728 4214
3729 if ($REATTACH_ON_RELOAD) { 4215 if ($REATTACH_ON_RELOAD) {
3730 warn "reattaching attachments to objects/players"; 4216 trace "perl_reload: reattaching attachments to objects/players";
3731 _global_reattach; # objects, sockets 4217 _global_reattach; # objects, sockets
3732 warn "reattaching attachments to maps"; 4218 trace "perl_reload: reattaching attachments to maps";
3733 reattach $_ for values %MAP; 4219 reattach $_ for values %MAP;
3734 warn "reattaching attachments to players"; 4220 trace "perl_reload: reattaching attachments to players";
3735 reattach $_ for values %PLAYER; 4221 reattach $_ for values %PLAYER;
3736 } 4222 }
3737 4223
3738 warn "running post_init jobs"; 4224 cf::_post_init 1;
3739 (pop @POST_INIT)->(1) while @POST_INIT;
3740 4225
3741 warn "leaving sync_job"; 4226 trace "perl_reload: leaving sync_job";
3742 4227
3743 1 4228 1
3744 } or do { 4229 } or do {
3745 warn $@; 4230 error $@;
3746 cf::cleanup "error while reloading, exiting."; 4231 cf::cleanup "perl_reload: error, exiting.";
3747 }; 4232 };
3748 4233
3749 warn "reloaded";
3750 --$RELOAD; 4234 --$RELOAD;
3751 } 4235 }
3752 4236
3753 $t1 = EV::time - $t1; 4237 $t1 = AE::time - $t1;
3754 warn "reload completed in ${t1}s\n"; 4238 info "perl_reload: completed in ${t1}s\n";
3755}; 4239};
3756 4240
3757our $RELOAD_WATCHER; # used only during reload 4241our $RELOAD_WATCHER; # used only during reload
3758 4242
3759sub reload_perl() { 4243sub reload_perl() {
… …
3761 # coro crashes during coro_state_free->destroy here. 4245 # coro crashes during coro_state_free->destroy here.
3762 4246
3763 $RELOAD_WATCHER ||= cf::async { 4247 $RELOAD_WATCHER ||= cf::async {
3764 Coro::AIO::aio_wait cache_extensions; 4248 Coro::AIO::aio_wait cache_extensions;
3765 4249
3766 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 4250 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3767 do_reload_perl; 4251 do_reload_perl;
3768 undef $RELOAD_WATCHER; 4252 undef $RELOAD_WATCHER;
3769 }; 4253 };
3770 }; 4254 };
3771} 4255}
… …
3780 reload_perl; 4264 reload_perl;
3781 }; 4265 };
3782 } 4266 }
3783}; 4267};
3784 4268
3785unshift @INC, $LIBDIR; 4269#############################################################################
3786 4270
3787my $bug_warning = 0; 4271my $bug_warning = 0;
3788 4272
3789our @WAIT_FOR_TICK;
3790our @WAIT_FOR_TICK_BEGIN;
3791
3792sub wait_for_tick { 4273sub wait_for_tick() {
3793 return if tick_inhibit || $Coro::current == $Coro::main; 4274 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3794 4275
3795 my $signal = new Coro::Signal; 4276 $WAIT_FOR_TICK->wait;
3796 push @WAIT_FOR_TICK, $signal;
3797 $signal->wait;
3798} 4277}
3799 4278
3800sub wait_for_tick_begin { 4279sub wait_for_tick_begin() {
3801 return if tick_inhibit || $Coro::current == $Coro::main; 4280 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3802 4281
3803 my $signal = new Coro::Signal; 4282 my $signal = new Coro::Signal;
3804 push @WAIT_FOR_TICK_BEGIN, $signal; 4283 push @WAIT_FOR_TICK_BEGIN, $signal;
3805 $signal->wait; 4284 $signal->wait;
3806} 4285}
… …
3810 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4289 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3811 unless ++$bug_warning > 10; 4290 unless ++$bug_warning > 10;
3812 return; 4291 return;
3813 } 4292 }
3814 4293
3815 cf::server_tick; # one server iteration 4294 cf::one_tick; # one server iteration
4295
4296 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3816 4297
3817 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4298 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3818 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4299 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3819 Coro::async_pool { 4300 Coro::async_pool {
3820 $Coro::current->{desc} = "runtime saver"; 4301 $Coro::current->{desc} = "runtime saver";
3821 write_runtime_sync 4302 write_runtime_sync
3822 or warn "ERROR: unable to write runtime file: $!"; 4303 or error "ERROR: unable to write runtime file: $!";
3823 }; 4304 };
3824 } 4305 }
3825 4306
3826 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4307 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3827 $sig->send; 4308 $sig->send;
3828 } 4309 }
3829 while (my $sig = shift @WAIT_FOR_TICK) { 4310 $WAIT_FOR_TICK->broadcast;
3830 $sig->send;
3831 }
3832 4311
3833 $LOAD = ($NOW - $TICK_START) / $TICK; 4312 $LOAD = ($NOW - $TICK_START) / $TICK;
3834 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4313 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3835 4314
3836 if (0) { 4315 if (0) {
3837 if ($NEXT_TICK) { 4316 if ($NEXT_TICK) {
3838 my $jitter = $TICK_START - $NEXT_TICK; 4317 my $jitter = $TICK_START - $NEXT_TICK;
3839 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4318 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3840 warn "jitter $JITTER\n";#d# 4319 debug "jitter $JITTER\n";#d#
3841 } 4320 }
3842 } 4321 }
3843} 4322}
3844 4323
3845{ 4324{
3846 # configure BDB 4325 # configure BDB
4326 info "initialising database";
3847 4327
3848 BDB::min_parallel 8; 4328 BDB::min_parallel 16;
3849 BDB::max_poll_reqs $TICK * 0.1; 4329 BDB::max_poll_reqs $TICK * 0.1;
3850 $AnyEvent::BDB::WATCHER->priority (1); 4330 #$AnyEvent::BDB::WATCHER->priority (1);
3851 4331
3852 unless ($DB_ENV) { 4332 unless ($DB_ENV) {
3853 $DB_ENV = BDB::db_env_create; 4333 $DB_ENV = BDB::db_env_create;
3854 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4334 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3855 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4335 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
3880 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4360 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3881 }; 4361 };
3882 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4362 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3883 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4363 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3884 }; 4364 };
4365
4366 info "database initialised";
3885} 4367}
3886 4368
3887{ 4369{
3888 # configure IO::AIO 4370 # configure IO::AIO
3889 4371
4372 info "initialising aio";
3890 IO::AIO::min_parallel 8; 4373 IO::AIO::min_parallel 8;
3891 IO::AIO::max_poll_time $TICK * 0.1; 4374 IO::AIO::max_poll_time $TICK * 0.1;
3892 undef $AnyEvent::AIO::WATCHER; 4375 undef $AnyEvent::AIO::WATCHER;
4376 info "aio initialised";
3893} 4377}
3894 4378
3895my $_log_backtrace; 4379our $_log_backtrace;
4380our $_log_backtrace_last;
3896 4381
3897sub _log_backtrace { 4382sub _log_backtrace {
3898 my ($msg, @addr) = @_; 4383 my ($msg, @addr) = @_;
3899 4384
3900 $msg =~ s/\n//; 4385 $msg =~ s/\n$//;
3901 4386
4387 if ($_log_backtrace_last eq $msg) {
4388 LOG llevInfo, "[ABT] $msg\n";
4389 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3902 # limit the # of concurrent backtraces 4390 # limit the # of concurrent backtraces
3903 if ($_log_backtrace < 2) { 4391 } elsif ($_log_backtrace < 2) {
4392 $_log_backtrace_last = $msg;
3904 ++$_log_backtrace; 4393 ++$_log_backtrace;
3905 my $perl_bt = Carp::longmess $msg; 4394 my $perl_bt = Carp::longmess $msg;
3906 async { 4395 async {
3907 $Coro::current->{desc} = "abt $msg"; 4396 $Coro::current->{desc} = "abt $msg";
3908 4397
… …
3928 LOG llevInfo, "[ABT] $_\n" for @bt; 4417 LOG llevInfo, "[ABT] $_\n" for @bt;
3929 --$_log_backtrace; 4418 --$_log_backtrace;
3930 }; 4419 };
3931 } else { 4420 } else {
3932 LOG llevInfo, "[ABT] $msg\n"; 4421 LOG llevInfo, "[ABT] $msg\n";
3933 LOG llevInfo, "[ABT] [suppressed]\n"; 4422 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3934 } 4423 }
3935} 4424}
3936 4425
3937# load additional modules 4426# load additional modules
3938require "cf/$_.pm" for @EXTRA_MODULES; 4427require "cf/$_.pm" for @EXTRA_MODULES;
4428cf::_connect_to_perl_2;
3939 4429
3940END { cf::emergency_save } 4430END { cf::emergency_save }
3941 4431
39421 44321
3943 4433

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines