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.513 by root, Mon Apr 12 05:22:38 2010 UTC vs.
Revision 1.597 by root, Sun Nov 11 02:14:37 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,2009,2010 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 it under 6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the 7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your 8# Free Software Foundation, either version 3 of the License, or (at your
9# 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 Affero GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>. 18# <http://www.gnu.org/licenses/>.
19# 19#
20# 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>
21# 21#
22 22
23package cf; 23package cf;
24 24
25use 5.10.0; 25use common::sense;
26use utf8;
27use strict qw(vars subs);
28 26
29use Symbol; 27use Symbol;
30use List::Util; 28use List::Util;
31use Socket; 29use Socket;
32use EV; 30use EV;
… …
34use Safe; 32use Safe;
35use Safe::Hole; 33use Safe::Hole;
36use Storable (); 34use Storable ();
37use Carp (); 35use Carp ();
38 36
39use Guard (); 37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
40
40use Coro (); 41use Coro ();
41use Coro::State; 42use Coro::State;
42use Coro::Handle; 43use Coro::Handle;
43use Coro::EV; 44use Coro::EV;
44use Coro::AnyEvent; 45use Coro::AnyEvent;
… …
50use Coro::AIO; 51use Coro::AIO;
51use Coro::BDB 1.6; 52use Coro::BDB 1.6;
52use Coro::Storable; 53use Coro::Storable;
53use Coro::Util (); 54use Coro::Util ();
54 55
56use Guard ();
55use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
56use BDB (); 58use BDB ();
57use Data::Dumper; 59use Data::Dumper;
58use Fcntl; 60use Fcntl;
59use YAML::XS (); 61use YAML::XS ();
… …
78# strictly for debugging 80# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; 81$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
80 82
81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 83sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
82 84
85our @ORIG_INC;
86
83our %COMMAND = (); 87our %COMMAND = ();
84our %COMMAND_TIME = (); 88our %COMMAND_TIME = ();
85 89
86our @EXTS = (); # list of extension package names 90our @EXTS = (); # list of extension package names
87our %EXTCMD = (); 91our %EXTCMD = ();
92our %EXTACMD = ();
88our %EXTICMD = (); 93our %EXTICMD = ();
94our %EXTIACMD = ();
89our %EXT_CORO = (); # coroutines bound to extensions 95our %EXT_CORO = (); # coroutines bound to extensions
90our %EXT_MAP = (); # pluggable maps 96our %EXT_MAP = (); # pluggable maps
91 97
92our $RELOAD; # number of reloads so far, non-zero while in reload 98our $RELOAD; # number of reloads so far, non-zero while in reload
93our @EVENT; 99our @EVENT;
94our @REFLECT; # set by XS 100our @REFLECT; # set by XS
95our %REFLECT; # set by us 101our %REFLECT; # set by us
96 102
97our $CONFDIR = confdir; 103our $CONFDIR = confdir;
104
98our $DATADIR = datadir; 105our $DATADIR = datadir;
99our $LIBDIR = "$DATADIR/ext"; 106our $LIBDIR = "$DATADIR/ext";
100our $PODDIR = "$DATADIR/pod"; 107our $PODDIR = "$DATADIR/pod";
101our $MAPDIR = "$DATADIR/" . mapdir; 108our $MAPDIR = "$DATADIR/" . mapdir;
109
102our $LOCALDIR = localdir; 110our $LOCALDIR = localdir;
103our $TMPDIR = "$LOCALDIR/" . tmpdir; 111our $TMPDIR = "$LOCALDIR/" . tmpdir;
104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 112our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
105our $PLAYERDIR = "$LOCALDIR/" . playerdir; 113our $PLAYERDIR = "$LOCALDIR/" . playerdir;
106our $RANDOMDIR = "$LOCALDIR/random"; 114our $RANDOMDIR = "$LOCALDIR/random";
107our $BDBDIR = "$LOCALDIR/db"; 115our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid"; 116our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime"; 117our $RUNTIMEFILE = "$LOCALDIR/runtime";
110 118
111our %RESOURCE; 119#our %RESOURCE; # unused
112 120
113our $OUTPUT_RATE_MIN = 4000; 121our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 100000; 122our $OUTPUT_RATE_MAX = 1000000;
123
124our $MAX_LINKS = 32; # how many chained exits to follow
125our $VERBOSE_IO = 1;
115 126
116our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 127our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
117our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 128our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
118our $NEXT_TICK; 129our $NEXT_TICK;
119our $USE_FSYNC = 1; # use fsync to write maps - default on 130our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
121our $BDB_DEADLOCK_WATCHER; 132our $BDB_DEADLOCK_WATCHER;
122our $BDB_CHECKPOINT_WATCHER; 133our $BDB_CHECKPOINT_WATCHER;
123our $BDB_TRICKLE_WATCHER; 134our $BDB_TRICKLE_WATCHER;
124our $DB_ENV; 135our $DB_ENV;
125 136
126our @EXTRA_MODULES = qw(pod match mapscript); 137our @EXTRA_MODULES = qw(pod match mapscript incloader);
127 138
128our %CFG; 139our %CFG;
140our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
129 141
130our $UPTIME; $UPTIME ||= time; 142our $UPTIME; $UPTIME ||= time;
131our $RUNTIME; 143our $RUNTIME = 0;
144our $SERVER_TICK = 0;
132our $NOW; 145our $NOW;
133 146
134our (%PLAYER, %PLAYER_LOADING); # all users 147our (%PLAYER, %PLAYER_LOADING); # all users
135our (%MAP, %MAP_LOADING ); # all maps 148our (%MAP, %MAP_LOADING ); # all maps
136our $LINK_MAP; # the special {link} map, which is always available 149our $LINK_MAP; # the special {link} map, which is always available
… …
145 158
146our @POST_INIT; 159our @POST_INIT;
147 160
148our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) 161our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
149our $REALLY_UNLOOP; # never set to true, please :) 162our $REALLY_UNLOOP; # never set to true, please :)
163
164our $WAIT_FOR_TICK = new Coro::Signal;
165our @WAIT_FOR_TICK_BEGIN;
150 166
151binmode STDOUT; 167binmode STDOUT;
152binmode STDERR; 168binmode STDERR;
153 169
154# read virtual server time, if available 170# read virtual server time, if available
… …
165 181
166our $EMERGENCY_POSITION; 182our $EMERGENCY_POSITION;
167 183
168sub cf::map::normalise; 184sub cf::map::normalise;
169 185
186sub in_main() {
187 $Coro::current == $Coro::main
188}
189
170############################################################################# 190#############################################################################
171 191
172%REFLECT = (); 192%REFLECT = ();
173for (@REFLECT) { 193for (@REFLECT) {
174 my $reflect = JSON::XS::decode_json $_; 194 my $reflect = JSON::XS::decode_json $_;
… …
184 204
185=over 4 205=over 4
186 206
187=item $cf::UPTIME 207=item $cf::UPTIME
188 208
189The timestamp of the server start (so not actually an uptime). 209The timestamp of the server start (so not actually an "uptime").
210
211=item $cf::SERVER_TICK
212
213An unsigned integer that starts at zero when the server is started and is
214incremented on every tick.
215
216=item $cf::NOW
217
218The (real) time of the last (current) server tick - updated before and
219after tick processing, so this is useful only as a rough "what time is it
220now" estimate.
221
222=item $cf::TICK
223
224The interval between each server tick, in seconds.
190 225
191=item $cf::RUNTIME 226=item $cf::RUNTIME
192 227
193The time this server has run, starts at 0 and is increased by $cf::TICK on 228The time this server has run, starts at 0 and is increased by $cf::TICK on
194every server tick. 229every server tick.
195 230
196=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 231=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
197$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 232$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
198$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 233$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
199 234
200Various directories - "/etc", read-only install directory, perl-library 235Various directories - "/etc", read-only install directory, perl-library
201directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 236directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
202unique-items directory, player file directory, random maps directory and 237unique-items directory, player file directory, random maps directory and
203database environment. 238database environment.
204 239
205=item $cf::NOW
206
207The time of the last (current) server tick.
208
209=item $cf::TICK
210
211The interval between server ticks, in seconds.
212
213=item $cf::LOADAVG 240=item $cf::LOADAVG
214 241
215The current CPU load on the server (alpha-smoothed), as a value between 0 242The current CPU load on the server (alpha-smoothed), as a value between 0
216(none) and 1 (overloaded), indicating how much time is spent on processing 243(none) and 1 (overloaded), indicating how much time is spent on processing
217objects per tick. Healthy values are < 0.5. 244objects per tick. Healthy values are < 0.5.
… …
226from wherever your confdir points to. 253from wherever your confdir points to.
227 254
228=item cf::wait_for_tick, cf::wait_for_tick_begin 255=item cf::wait_for_tick, cf::wait_for_tick_begin
229 256
230These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 257These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
231returns directly I<after> the tick processing (and consequently, can only wake one process 258returns directly I<after> the tick processing (and consequently, can only wake one thread
232per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 259per tick), while cf::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();
233 277
234=item @cf::INVOKE_RESULTS 278=item @cf::INVOKE_RESULTS
235 279
236This array contains the results of the last C<invoke ()> call. When 280This array contains the results of the last C<invoke ()> call. When
237C<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
… …
245 289
246=back 290=back
247 291
248=cut 292=cut
249 293
294sub error(@) { LOG llevError, join "", @_ }
295sub warn (@) { LOG llevWarn , join "", @_ }
296sub info (@) { LOG llevInfo , join "", @_ }
297sub debug(@) { LOG llevDebug, join "", @_ }
298sub trace(@) { LOG llevTrace, join "", @_ }
299
250$Coro::State::WARNHOOK = sub { 300$Coro::State::WARNHOOK = sub {
251 my $msg = join "", @_; 301 my $msg = join "", @_;
252 302
253 $msg .= "\n" 303 $msg .= "\n"
254 unless $msg =~ /\n$/; 304 unless $msg =~ /\n$/;
255 305
256 $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;
257 307
258 LOG llevError, $msg; 308 LOG llevWarn, $msg;
259}; 309};
260 310
261$Coro::State::DIEHOOK = sub { 311$Coro::State::DIEHOOK = sub {
262 return unless $^S eq 0; # "eq", not "==" 312 return unless $^S eq 0; # "eq", not "=="
263 313
264 warn Carp::longmess $_[0]; 314 error Carp::longmess $_[0];
265 315
266 if ($Coro::current == $Coro::main) {#d# 316 if (in_main) {#d#
267 warn "DIEHOOK called in main context, Coro bug?\n";#d# 317 error "DIEHOOK called in main context, Coro bug?\n";#d#
268 return;#d# 318 return;#d#
269 }#d# 319 }#d#
270 320
271 # kill coroutine otherwise 321 # kill coroutine otherwise
272 Coro::terminate 322 Coro::terminate
… …
292)) { 342)) {
293 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 343 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
294} 344}
295 345
296$EV::DIED = sub { 346$EV::DIED = sub {
297 Carp::cluck "error in event callback: @_"; 347 warn "error in event callback: $@";
298}; 348};
349
350#############################################################################
351
352sub fork_call(&@);
353sub get_slot($;$$);
299 354
300############################################################################# 355#############################################################################
301 356
302=head2 UTILITY FUNCTIONS 357=head2 UTILITY FUNCTIONS
303 358
… …
324 $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;
325 $d 380 $d
326 } || "[unable to dump $_[0]: '$@']"; 381 } || "[unable to dump $_[0]: '$@']";
327} 382}
328 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
329=item $ref = cf::decode_json $json 436=item $ref = cf::decode_json $json
330 437
331Converts a JSON string into the corresponding perl data structure. 438Converts a JSON string into the corresponding perl data structure.
332 439
333=item $json = cf::encode_json $ref 440=item $json = cf::encode_json $ref
… …
339our $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
340 447
341sub encode_json($) { $json_coder->encode ($_[0]) } 448sub encode_json($) { $json_coder->encode ($_[0]) }
342sub decode_json($) { $json_coder->decode ($_[0]) } 449sub decode_json($) { $json_coder->decode ($_[0]) }
343 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
344=item cf::post_init { BLOCK } 482=item cf::post_init { BLOCK }
345 483
346Execute the given codeblock, I<after> all extensions have been (re-)loaded, 484Execute the given codeblock, I<after> all extensions have been (re-)loaded,
347but I<before> the server starts ticking again. 485but I<before> the server starts ticking again.
348 486
349The cdoeblock will have a single boolean argument to indicate whether this 487The codeblock will have a single boolean argument to indicate whether this
350is a reload or not. 488is a reload or not.
351 489
352=cut 490=cut
353 491
354sub post_init(&) { 492sub post_init(&) {
355 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 }
356} 511}
357 512
358=item cf::lock_wait $string 513=item cf::lock_wait $string
359 514
360Wait until the given lock is available. See cf::lock_acquire. 515Wait until the given lock is available. See cf::lock_acquire.
… …
399} 554}
400 555
401=item cf::periodic $interval, $cb 556=item cf::periodic $interval, $cb
402 557
403Like 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
404get spread over timer. 559get spread over time.
405 560
406=cut 561=cut
407 562
408sub periodic($$) { 563sub periodic($$) {
409 my ($interval, $cb) = @_; 564 my ($interval, $cb) = @_;
… …
413 EV::periodic $start, $interval, 0, $cb 568 EV::periodic $start, $interval, 0, $cb
414} 569}
415 570
416=item cf::get_slot $time[, $priority[, $name]] 571=item cf::get_slot $time[, $priority[, $name]]
417 572
418Allocate $time seconds of blocking CPU time at priority C<$priority>: 573Allocate $time seconds of blocking CPU time at priority C<$priority>
419This 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
420of 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 les than zero, interactive jobs
579should use 100 or more.
421 580
422The 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
423used for statistical purposes and should identify the same time-class. 582used for statistical purposes and should identify the same time-class.
424 583
425Useful for short background jobs. 584Useful for short background jobs.
… …
454 } 613 }
455 } 614 }
456 615
457 if (@SLOT_QUEUE) { 616 if (@SLOT_QUEUE) {
458 # 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
459 push @cf::WAIT_FOR_TICK, $signal; 618 $WAIT_FOR_TICK->wait;
460 $signal->wait;
461 } else { 619 } else {
462 $busy = 0; 620 $busy = 0;
463 Coro::schedule; 621 Coro::schedule;
464 } 622 }
465 } 623 }
… …
505=cut 663=cut
506 664
507sub sync_job(&) { 665sub sync_job(&) {
508 my ($job) = @_; 666 my ($job) = @_;
509 667
510 if ($Coro::current == $Coro::main) { 668 if (in_main) {
511 my $time = AE::time; 669 my $time = AE::time;
512 670
513 # this is the main coro, too bad, we have to block 671 # this is the main coro, too bad, we have to block
514 # till the operation succeeds, freezing the server :/ 672 # till the operation succeeds, freezing the server :/
515 673
516 LOG llevError, Carp::longmess "sync job";#d# 674 #LOG llevError, Carp::longmess "sync job";#d#
517 675
518 my $freeze_guard = freeze_mainloop; 676 my $freeze_guard = freeze_mainloop;
519 677
520 my $busy = 1; 678 my $busy = 1;
521 my @res; 679 my @res;
522 680
523 (async { 681 (async {
524 $Coro::current->desc ("sync job coro"); 682 $Coro::current->desc ("sync job coro");
525 @res = eval { $job->() }; 683 @res = eval { $job->() };
526 warn $@ if $@; 684 error $@ if $@;
527 undef $busy; 685 undef $busy;
528 })->prio (Coro::PRIO_MAX); 686 })->prio (Coro::PRIO_MAX);
529 687
530 while ($busy) { 688 while ($busy) {
531 if (Coro::nready) { 689 if (Coro::nready) {
… …
565 $EXT_CORO{$coro+0} = $coro; 723 $EXT_CORO{$coro+0} = $coro;
566 724
567 $coro 725 $coro
568} 726}
569 727
570=item fork_call { }, $args 728=item fork_call { }, @args
571 729
572Executes the given code block with the given arguments in a seperate 730Executes the given code block with the given arguments in a seperate
573process, returning the results. Everything must be serialisable with 731process, returning the results. Everything must be serialisable with
574Coro::Storable. May, of course, block. Note that the executed sub may 732Coro::Storable. May, of course, block. Note that the executed sub may
575never block itself or use any form of event handling. 733never block itself or use any form of event handling.
576 734
577=cut 735=cut
578 736
737sub post_fork {
738 reset_signals;
739}
740
579sub fork_call(&@) { 741sub fork_call(&@) {
580 my ($cb, @args) = @_; 742 my ($cb, @args) = @_;
581 743
582 # we seemingly have to make a local copy of the whole thing, 744 # we seemingly have to make a local copy of the whole thing,
583 # otherwise perl prematurely frees the stuff :/ 745 # otherwise perl prematurely frees the stuff :/
584 # TODO: investigate and fix (likely this will be rather laborious) 746 # TODO: investigate and fix (likely this will be rather laborious)
585 747
586 my @res = Coro::Util::fork_eval { 748 my @res = Coro::Util::fork_eval {
587 reset_signals; 749 cf::post_fork;
588 &$cb 750 &$cb
589 }, @args; 751 } @args;
590 752
591 wantarray ? @res : $res[-1] 753 wantarray ? @res : $res[-1]
754}
755
756sub objinfo {
757 (
758 "counter value" => cf::object::object_count,
759 "objects created" => cf::object::create_count,
760 "objects destroyed" => cf::object::destroy_count,
761 "freelist size" => cf::object::free_count,
762 "allocated objects" => cf::object::objects_size,
763 "active objects" => cf::object::actives_size,
764 )
592} 765}
593 766
594=item $coin = coin_from_name $name 767=item $coin = coin_from_name $name
595 768
596=cut 769=cut
… …
633within each server. 806within each server.
634 807
635=cut 808=cut
636 809
637sub db_table($) { 810sub db_table($) {
811 cf::error "db_get called from main context"
812 if $Coro::current == $Coro::main;
813
638 my ($name) = @_; 814 my ($name) = @_;
639 my $db = BDB::db_create $DB_ENV; 815 my $db = BDB::db_create $DB_ENV;
640 816
641 eval { 817 eval {
642 $db->set_flags (BDB::CHKSUM); 818 $db->set_flags (BDB::CHKSUM);
… …
652} 828}
653 829
654our $DB; 830our $DB;
655 831
656sub db_init { 832sub db_init {
657 cf::sync_job {
658 $DB ||= db_table "db"; 833 $DB ||= db_table "db";
659 };
660} 834}
661 835
662sub db_get($$) { 836sub db_get($$) {
663 my $key = "$_[0]/$_[1]"; 837 my $key = "$_[0]/$_[1]";
664 838
665 cf::sync_job { 839 cf::error "db_get called from main context"
840 if $Coro::current == $Coro::main;
841
666 BDB::db_get $DB, undef, $key, my $data; 842 BDB::db_get $DB, undef, $key, my $data;
667 843
668 $! ? () 844 $! ? ()
669 : $data 845 : $data
670 }
671} 846}
672 847
673sub db_put($$$) { 848sub db_put($$$) {
674 BDB::dbreq_pri 4; 849 BDB::dbreq_pri 4;
675 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 850 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
703 878
704 my @data; 879 my @data;
705 my $md5; 880 my $md5;
706 881
707 for (0 .. $#$src) { 882 for (0 .. $#$src) {
708 0 <= aio_load $src->[$_], $data[$_] 883 $data[$_] = load_file $src->[$_];
709 or Carp::croak "$src->[$_]: $!";
710 } 884 }
711 885
712 # if processing is expensive, check 886 # if processing is expensive, check
713 # checksum first 887 # checksum first
714 if (1) { 888 if (1) {
… …
731 905
732 my $t1 = Time::HiRes::time; 906 my $t1 = Time::HiRes::time;
733 my $data = $process->(\@data); 907 my $data = $process->(\@data);
734 my $t2 = Time::HiRes::time; 908 my $t2 = Time::HiRes::time;
735 909
736 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 910 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
737 911
738 db_put cache => "$id/data", $data; 912 db_put cache => "$id/data", $data;
739 db_put cache => "$id/md5" , $md5; 913 db_put cache => "$id/md5" , $md5;
740 db_put cache => "$id/meta", $meta; 914 db_put cache => "$id/meta", $meta;
741 915
… …
751 925
752=cut 926=cut
753 927
754sub datalog($@) { 928sub datalog($@) {
755 my ($type, %kv) = @_; 929 my ($type, %kv) = @_;
756 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 930 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
757} 931}
758 932
759=back 933=back
760 934
761=cut 935=cut
… …
956 1130
957 } elsif (exists $cb_id{$type}) { 1131 } elsif (exists $cb_id{$type}) {
958 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1132 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
959 1133
960 } elsif (ref $type) { 1134 } elsif (ref $type) {
961 warn "attaching objects not supported, ignoring.\n"; 1135 error "attaching objects not supported, ignoring.\n";
962 1136
963 } else { 1137 } else {
964 shift @arg; 1138 shift @arg;
965 warn "attach argument '$type' not supported, ignoring.\n"; 1139 error "attach argument '$type' not supported, ignoring.\n";
966 } 1140 }
967 } 1141 }
968} 1142}
969 1143
970sub _object_attach { 1144sub _object_attach {
… …
980 _attach $registry, $klass, @attach; 1154 _attach $registry, $klass, @attach;
981 } 1155 }
982 1156
983 $obj->{$name} = \%arg; 1157 $obj->{$name} = \%arg;
984 } else { 1158 } else {
985 warn "object uses attachment '$name' which is not available, postponing.\n"; 1159 info "object uses attachment '$name' which is not available, postponing.\n";
986 } 1160 }
987 1161
988 $obj->{_attachment}{$name} = undef; 1162 $obj->{_attachment}{$name} = undef;
989} 1163}
990 1164
… …
1049 1223
1050 for (@$callbacks) { 1224 for (@$callbacks) {
1051 eval { &{$_->[1]} }; 1225 eval { &{$_->[1]} };
1052 1226
1053 if ($@) { 1227 if ($@) {
1054 warn "$@";
1055 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1228 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1056 override; 1229 override;
1057 } 1230 }
1058 1231
1059 return 1 if $override; 1232 return 1 if $override;
1060 } 1233 }
… …
1139 for (@$attach) { 1312 for (@$attach) {
1140 my ($klass, @attach) = @$_; 1313 my ($klass, @attach) = @$_;
1141 _attach $registry, $klass, @attach; 1314 _attach $registry, $klass, @attach;
1142 } 1315 }
1143 } else { 1316 } else {
1144 warn "object uses attachment '$name' that is not available, postponing.\n"; 1317 info "object uses attachment '$name' that is not available, postponing.\n";
1145 } 1318 }
1146 } 1319 }
1147} 1320}
1148 1321
1149cf::attachable->attach ( 1322cf::attachable->attach (
… …
1176 my ($filename, $rdata, $objs) = @_; 1349 my ($filename, $rdata, $objs) = @_;
1177 1350
1178 sync_job { 1351 sync_job {
1179 if (length $$rdata) { 1352 if (length $$rdata) {
1180 utf8::decode (my $decname = $filename); 1353 utf8::decode (my $decname = $filename);
1181 warn sprintf "saving %s (%d,%d)\n", 1354 trace sprintf "saving %s (%d,%d)\n",
1182 $decname, length $$rdata, scalar @$objs; 1355 $decname, length $$rdata, scalar @$objs
1356 if $VERBOSE_IO;
1183 1357
1184 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1358 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1185 aio_chmod $fh, SAVE_MODE; 1359 aio_chmod $fh, SAVE_MODE;
1186 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1360 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1187 if ($cf::USE_FSYNC) { 1361 if ($cf::USE_FSYNC) {
… …
1209 aio_rename "$filename~", $filename; 1383 aio_rename "$filename~", $filename;
1210 1384
1211 $filename =~ s%/[^/]+$%%; 1385 $filename =~ s%/[^/]+$%%;
1212 aio_pathsync $filename if $cf::USE_FSYNC; 1386 aio_pathsync $filename if $cf::USE_FSYNC;
1213 } else { 1387 } else {
1214 warn "unable to save objects: $filename~: $!\n"; 1388 error "unable to save objects: $filename~: $!\n";
1215 } 1389 }
1216 } else { 1390 } else {
1217 aio_unlink $filename; 1391 aio_unlink $filename;
1218 aio_unlink "$filename.pst"; 1392 aio_unlink "$filename.pst";
1219 } 1393 }
… …
1243 my $st = eval { Coro::Storable::thaw $av }; 1417 my $st = eval { Coro::Storable::thaw $av };
1244 $av = $st->{objs}; 1418 $av = $st->{objs};
1245 } 1419 }
1246 1420
1247 utf8::decode (my $decname = $filename); 1421 utf8::decode (my $decname = $filename);
1248 warn sprintf "loading %s (%d,%d)\n", 1422 trace sprintf "loading %s (%d,%d)\n",
1249 $decname, length $data, scalar @{$av || []}; 1423 $decname, length $data, scalar @{$av || []}
1424 if $VERBOSE_IO;
1250 1425
1251 ($data, $av) 1426 ($data, $av)
1252} 1427}
1253 1428
1254=head2 COMMAND CALLBACKS 1429=head2 COMMAND CALLBACKS
… …
1258=cut 1433=cut
1259 1434
1260############################################################################# 1435#############################################################################
1261# command handling &c 1436# command handling &c
1262 1437
1263=item cf::register_command $name => \&callback($ob,$args); 1438=item cf::register_command $name => \&callback($ob,$args)
1264 1439
1265Register a callback for execution when the client sends the user command 1440Register a callback for execution when the client sends the user command
1266$name. 1441$name.
1267 1442
1268=cut 1443=cut
… …
1274 #warn "registering command '$name/$time' to '$caller'"; 1449 #warn "registering command '$name/$time' to '$caller'";
1275 1450
1276 push @{ $COMMAND{$name} }, [$caller, $cb]; 1451 push @{ $COMMAND{$name} }, [$caller, $cb];
1277} 1452}
1278 1453
1279=item cf::register_extcmd $name => \&callback($pl,$packet); 1454=item cf::register_extcmd $name => \&callback($pl,@args)
1280 1455
1281Register a callback for execution when the client sends an (synchronous) 1456Register a callback for execution when the client sends an (synchronous)
1282extcmd packet. Ext commands will be processed in the order they are 1457extcmd packet. Ext commands will be processed in the order they are
1283received by the server, like other user commands. The first argument is 1458received by the server, like other user commands. The first argument is
1284the logged-in player. Ext commands can only be processed after a player 1459the logged-in player. Ext commands can only be processed after a player
1285has logged in successfully. 1460has logged in successfully.
1286 1461
1287If the callback returns something, it is sent back as if reply was being 1462The values will be sent back to the client.
1288called.
1289 1463
1464=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
1465
1466Same as C<cf::register_extcmd>, but instead of returning values, the
1467callback needs to clal the C<$reply> function.
1468
1290=item cf::register_exticmd $name => \&callback($ns,$packet); 1469=item cf::register_exticmd $name => \&callback($ns,@args)
1291 1470
1292Register a callback for execution when the client sends an (asynchronous) 1471Register a callback for execution when the client sends an (asynchronous)
1293exticmd packet. Exti commands are processed by the server as soon as they 1472exticmd packet. Exti commands are processed by the server as soon as they
1294are received, i.e. out of order w.r.t. other commands. The first argument 1473are received, i.e. out of order w.r.t. other commands. The first argument
1295is a client socket. Exti commands can be received anytime, even before 1474is a client socket. Exti commands can be received anytime, even before
1296log-in. 1475log-in.
1297 1476
1298If the callback returns something, it is sent back as if reply was being 1477The values will be sent back to the client.
1299called.
1300 1478
1301=cut 1479=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1302 1480
1481Same as C<cf::register_extcmd>, but instead of returning values, the
1482callback needs to clal the C<$reply> function.
1483
1484=cut
1485
1303sub register_extcmd { 1486sub register_extcmd($$) {
1304 my ($name, $cb) = @_; 1487 my ($name, $cb) = @_;
1305 1488
1306 $EXTCMD{$name} = $cb; 1489 $EXTCMD{$name} = $cb;
1307} 1490}
1308 1491
1309sub register_exticmd { 1492sub register_async_extcmd($$) {
1310 my ($name, $cb) = @_; 1493 my ($name, $cb) = @_;
1311 1494
1495 $EXTACMD{$name} = $cb;
1496}
1497
1498sub register_exticmd($$) {
1499 my ($name, $cb) = @_;
1500
1312 $EXTICMD{$name} = $cb; 1501 $EXTICMD{$name} = $cb;
1502}
1503
1504sub register_async_exticmd($$) {
1505 my ($name, $cb) = @_;
1506
1507 $EXTIACMD{$name} = $cb;
1313} 1508}
1314 1509
1315use File::Glob (); 1510use File::Glob ();
1316 1511
1317cf::player->attach ( 1512cf::player->attach (
… …
1331 my ($pl, $buf) = @_; 1526 my ($pl, $buf) = @_;
1332 1527
1333 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1528 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1334 1529
1335 if (ref $msg) { 1530 if (ref $msg) {
1336 my ($type, $reply, @payload) = 1531 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1337 "ARRAY" eq ref $msg
1338 ? @$msg
1339 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1340 1532
1341 my @reply;
1342
1343 if (my $cb = $EXTCMD{$type}) { 1533 if (my $cb = $EXTACMD{$type}) {
1534 $cb->(
1535 $pl,
1536 sub {
1537 $pl->ext_msg ("reply-$reply", @_)
1538 if $reply;
1539 },
1540 @payload
1541 );
1542 } else {
1543 my @reply;
1544
1545 if (my $cb = $EXTCMD{$type}) {
1344 @reply = $cb->($pl, @payload); 1546 @reply = $cb->($pl, @payload);
1547 }
1548
1549 $pl->ext_msg ("reply-$reply", @reply)
1550 if $reply;
1345 } 1551 }
1346 1552
1347 $pl->ext_reply ($reply, @reply)
1348 if $reply;
1349
1350 } else { 1553 } else {
1351 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1554 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1352 } 1555 }
1353 1556
1354 cf::override; 1557 cf::override;
1355 }, 1558 },
1356); 1559);
… …
1366 }; 1569 };
1367 1570
1368 $grp 1571 $grp
1369} 1572}
1370 1573
1574sub _ext_cfg_reg($$$$) {
1575 my ($rvar, $varname, $cfgname, $default) = @_;
1576
1577 $cfgname = lc $varname
1578 unless length $cfgname;
1579
1580 $EXT_CFG{$cfgname} = [$rvar, $default];
1581
1582 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1583}
1584
1371sub load_extensions { 1585sub load_extensions {
1586 info "loading extensions...";
1587
1588 %EXT_CFG = ();
1589
1372 cf::sync_job { 1590 cf::sync_job {
1373 my %todo; 1591 my %todo;
1374 1592
1375 for my $path (<$LIBDIR/*.ext>) { 1593 for my $path (<$LIBDIR/*.ext>) {
1376 next unless -r $path; 1594 next unless -r $path;
… …
1394 1612
1395 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1613 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1396 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1614 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1397 1615
1398 $ext{source} = 1616 $ext{source} =
1399 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1617 "package $pkg; use common::sense;\n"
1400 . "#line 1 \"$path\"\n{\n" 1618 . "#line 1 \"$path\"\n{\n"
1401 . $source 1619 . $source
1402 . "\n};\n1"; 1620 . "\n};\n1";
1403 1621
1404 $todo{$base} = \%ext; 1622 $todo{$base} = \%ext;
… …
1416 for (split /,\s*/, $v->{meta}{depends}) { 1634 for (split /,\s*/, $v->{meta}{depends}) {
1417 next ext 1635 next ext
1418 unless exists $done{$_}; 1636 unless exists $done{$_};
1419 } 1637 }
1420 1638
1421 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1639 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1422 1640
1641 my $source = $v->{source};
1642
1643 # support "CONF varname :confname = default" pseudo-statements
1644 $source =~ s{
1645 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1646 }{
1647 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1648 }gmxe;
1649
1423 my $active = eval $v->{source}; 1650 my $active = eval $source;
1424 1651
1425 if (length $@) { 1652 if (length $@) {
1426 warn "$v->{path}: $@\n"; 1653 error "$v->{path}: $@\n";
1427 1654
1428 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1655 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1429 if exists $v->{meta}{mandatory}; 1656 if exists $v->{meta}{mandatory};
1657
1658 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1659 delete $todo{$k};
1430 } else { 1660 } else {
1431 $done{$k} = delete $todo{$k}; 1661 $done{$k} = delete $todo{$k};
1432 push @EXTS, $v->{pkg}; 1662 push @EXTS, $v->{pkg};
1433 $progress = 1; 1663 $progress = 1;
1434 1664
1435 warn "$v->{base}: extension inactive.\n" 1665 info "$v->{base}: extension inactive.\n"
1436 unless $active; 1666 unless $active;
1437 } 1667 }
1438 } 1668 }
1439 1669
1440 unless ($progress) { 1670 unless ($progress) {
… …
1442 1672
1443 while (my ($k, $v) = each %todo) { 1673 while (my ($k, $v) = each %todo) {
1444 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting." 1674 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1445 if exists $v->{meta}{mandatory}; 1675 if exists $v->{meta}{mandatory};
1446 } 1676 }
1677
1678 last;
1447 } 1679 }
1448 } 1680 }
1449 }; 1681 };
1450} 1682}
1451 1683
… …
1609 my $name = $pl->ob->name; 1841 my $name = $pl->ob->name;
1610 1842
1611 $pl->{deny_save} = 1; 1843 $pl->{deny_save} = 1;
1612 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1844 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1613 1845
1614 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1846 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1615 $pl->deactivate; 1847 $pl->deactivate;
1848
1616 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1849 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1617 $pl->ob->check_score;
1618 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1850 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1851 ext::highscore::check ($pl->ob);
1852
1619 $pl->ns->destroy if $pl->ns; 1853 $pl->ns->destroy if $pl->ns;
1620 1854
1621 my $path = playerdir $pl; 1855 my $path = playerdir $pl;
1622 my $temp = "$path~$cf::RUNTIME~deleting~"; 1856 my $temp = "$path~$cf::RUNTIME~deleting~";
1623 aio_rename $path, $temp; 1857 aio_rename $path, $temp;
… …
1677 \@logins 1911 \@logins
1678} 1912}
1679 1913
1680=item $player->maps 1914=item $player->maps
1681 1915
1916=item cf::player::maps $login
1917
1682Returns an arrayref of map paths that are private for this 1918Returns an arrayref of map paths that are private for this
1683player. May block. 1919player. May block.
1684 1920
1685=cut 1921=cut
1686 1922
… …
1707 1943
1708=item $protocol_xml = $player->expand_cfpod ($cfpod) 1944=item $protocol_xml = $player->expand_cfpod ($cfpod)
1709 1945
1710Expand deliantra pod fragments into protocol xml. 1946Expand deliantra pod fragments into protocol xml.
1711 1947
1712=item $player->ext_reply ($msgid, @msg)
1713
1714Sends an ext reply to the player.
1715
1716=cut
1717
1718sub ext_reply($$@) {
1719 my ($self, $id, @msg) = @_;
1720
1721 $self->ns->ext_reply ($id, @msg)
1722}
1723
1724=item $player->ext_msg ($type, @msg) 1948=item $player->ext_msg ($type, @msg)
1725 1949
1726Sends an ext event to the client. 1950Sends an ext event to the client.
1727 1951
1728=cut 1952=cut
… …
1747 1971
1748=cut 1972=cut
1749 1973
1750sub find_by_path($) { 1974sub find_by_path($) {
1751 my ($path) = @_; 1975 my ($path) = @_;
1976
1977 $path =~ s/^~[^\/]*//; # skip ~login
1752 1978
1753 my ($match, $specificity); 1979 my ($match, $specificity);
1754 1980
1755 for my $region (list) { 1981 for my $region (list) {
1756 if ($region->{match} && $path =~ $region->{match}) { 1982 if ($region->{match} && $path =~ $region->{match}) {
… …
1785sub generate_random_map { 2011sub generate_random_map {
1786 my ($self, $rmp) = @_; 2012 my ($self, $rmp) = @_;
1787 2013
1788 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 2014 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1789 2015
1790 # mit "rum" bekleckern, nicht
1791 $self->_create_random_map ( 2016 $self->_create_random_map ($rmp);
1792 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1793 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1794 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1795 $rmp->{exit_on_final_map},
1796 $rmp->{xsize}, $rmp->{ysize},
1797 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1798 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1799 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1800 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1801 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1802 (cf::region::find $rmp->{region}), $rmp->{custom}
1803 )
1804} 2017}
1805 2018
1806=item cf::map->register ($regex, $prio) 2019=item cf::map->register ($regex, $prio)
1807 2020
1808Register a handler for the map path matching the given regex at the 2021Register a handler for the map path matching the given regex at the
… …
1813 2026
1814sub register { 2027sub register {
1815 my (undef, $regex, $prio) = @_; 2028 my (undef, $regex, $prio) = @_;
1816 my $pkg = caller; 2029 my $pkg = caller;
1817 2030
1818 no strict;
1819 push @{"$pkg\::ISA"}, __PACKAGE__; 2031 push @{"$pkg\::ISA"}, __PACKAGE__;
1820 2032
1821 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 2033 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1822} 2034}
1823 2035
1824# also paths starting with '/' 2036# also paths starting with '/'
1825$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 2037$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1826 2038
1827sub thawer_merge { 2039sub thawer_merge {
1828 my ($self, $merge) = @_; 2040 my ($self, $merge) = @_;
1829 2041
1830 # we have to keep some variables in memory intact 2042 # we have to keep some variables in memory intact
… …
1835} 2047}
1836 2048
1837sub normalise { 2049sub normalise {
1838 my ($path, $base) = @_; 2050 my ($path, $base) = @_;
1839 2051
1840 $path = "$path"; # make sure its a string 2052 $path = "$path"; # make sure it's a string
1841 2053
1842 $path =~ s/\.map$//; 2054 $path =~ s/\.map$//;
1843 2055
1844 # map plan: 2056 # map plan:
1845 # 2057 #
… …
1860 $base =~ s{[^/]+/?$}{}; 2072 $base =~ s{[^/]+/?$}{};
1861 $path = "$base/$path"; 2073 $path = "$base/$path";
1862 } 2074 }
1863 2075
1864 for ($path) { 2076 for ($path) {
1865 redo if s{//}{/};
1866 redo if s{/\.?/}{/}; 2077 redo if s{/\.?/}{/};
1867 redo if s{/[^/]+/\.\./}{/}; 2078 redo if s{/[^/]+/\.\./}{/};
1868 } 2079 }
1869 2080
1870 $path 2081 $path
… …
1884 $self->init; # pass $1 etc. 2095 $self->init; # pass $1 etc.
1885 return $self; 2096 return $self;
1886 } 2097 }
1887 } 2098 }
1888 2099
1889 Carp::cluck "unable to resolve path '$path' (base '$base')."; 2100 Carp::cluck "unable to resolve path '$path' (base '$base')";
1890 () 2101 ()
1891} 2102}
1892 2103
2104# may re-bless or do other evil things
1893sub init { 2105sub init {
1894 my ($self) = @_; 2106 my ($self) = @_;
1895 2107
1896 $self 2108 $self
1897} 2109}
… …
1962 $self->{load_path} = $path; 2174 $self->{load_path} = $path;
1963 2175
1964 1 2176 1
1965} 2177}
1966 2178
2179# used to laod the header of an original map
1967sub load_header_orig { 2180sub load_header_orig {
1968 my ($self) = @_; 2181 my ($self) = @_;
1969 2182
1970 $self->load_header_from ($self->load_path) 2183 $self->load_header_from ($self->load_path)
1971} 2184}
1972 2185
2186# used to laod the header of an instantiated map
1973sub load_header_temp { 2187sub load_header_temp {
1974 my ($self) = @_; 2188 my ($self) = @_;
1975 2189
1976 $self->load_header_from ($self->save_path) 2190 $self->load_header_from ($self->save_path)
1977} 2191}
1978 2192
2193# called after loading the header from an instantiated map
1979sub prepare_temp { 2194sub prepare_temp {
1980 my ($self) = @_; 2195 my ($self) = @_;
1981 2196
1982 $self->last_access ((delete $self->{last_access}) 2197 $self->last_access ((delete $self->{last_access})
1983 || $cf::RUNTIME); #d# 2198 || $cf::RUNTIME); #d#
1984 # safety 2199 # safety
1985 $self->{instantiate_time} = $cf::RUNTIME 2200 $self->{instantiate_time} = $cf::RUNTIME
1986 if $self->{instantiate_time} > $cf::RUNTIME; 2201 if $self->{instantiate_time} > $cf::RUNTIME;
1987} 2202}
1988 2203
2204# called after loading the header from an original map
1989sub prepare_orig { 2205sub prepare_orig {
1990 my ($self) = @_; 2206 my ($self) = @_;
1991 2207
1992 $self->{load_original} = 1; 2208 $self->{load_original} = 1;
1993 $self->{instantiate_time} = $cf::RUNTIME; 2209 $self->{instantiate_time} = $cf::RUNTIME;
… …
2017 2233
2018sub find; 2234sub find;
2019sub find { 2235sub find {
2020 my ($path, $origin) = @_; 2236 my ($path, $origin) = @_;
2021 2237
2238 cf::cede_to_tick;
2239
2022 $path = normalise $path, $origin && $origin->path; 2240 $path = normalise $path, $origin;
2023 2241
2024 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2242 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2025 my $guard2 = cf::lock_acquire "map_find:$path"; 2243 my $guard2 = cf::lock_acquire "map_find:$path";
2026 2244
2027 $cf::MAP{$path} || do { 2245 $cf::MAP{$path} || do {
… …
2058 2276
2059 { 2277 {
2060 my $guard = cf::lock_acquire "map_data:$path"; 2278 my $guard = cf::lock_acquire "map_data:$path";
2061 2279
2062 return unless $self->valid; 2280 return unless $self->valid;
2063 return unless $self->in_memory == cf::MAP_SWAPPED; 2281 return unless $self->state == cf::MAP_SWAPPED;
2064
2065 $self->in_memory (cf::MAP_LOADING);
2066 2282
2067 $self->alloc; 2283 $self->alloc;
2068 2284
2069 $self->pre_load; 2285 $self->pre_load;
2070 cf::cede_to_tick; 2286 cf::cede_to_tick;
2071 2287
2288 if (exists $self->{load_path}) {
2072 my $f = new_from_file cf::object::thawer $self->{load_path}; 2289 my $f = new_from_file cf::object::thawer $self->{load_path};
2073 $f->skip_block; 2290 $f->skip_block;
2074 $self->_load_objects ($f) 2291 $self->_load_objects ($f)
2075 or return; 2292 or return;
2076 2293
2077 $self->post_load_original 2294 $self->post_load_original
2078 if delete $self->{load_original}; 2295 if delete $self->{load_original};
2079 2296
2080 if (my $uniq = $self->uniq_path) { 2297 if (my $uniq = $self->uniq_path) {
2081 utf8::encode $uniq; 2298 utf8::encode $uniq;
2082 unless (aio_stat $uniq) { 2299 unless (aio_stat $uniq) {
2083 if (my $f = new_from_file cf::object::thawer $uniq) { 2300 if (my $f = new_from_file cf::object::thawer $uniq) {
2084 $self->clear_unique_items; 2301 $self->clear_unique_items;
2085 $self->_load_objects ($f); 2302 $self->_load_objects ($f);
2086 $f->resolve_delayed_derefs; 2303 $f->resolve_delayed_derefs;
2304 }
2087 } 2305 }
2088 } 2306 }
2089 }
2090 2307
2091 $f->resolve_delayed_derefs; 2308 $f->resolve_delayed_derefs;
2309 } else {
2310 $self->post_load_original
2311 if delete $self->{load_original};
2312 }
2313
2314 $self->state (cf::MAP_INACTIVE);
2092 2315
2093 cf::cede_to_tick; 2316 cf::cede_to_tick;
2094 # now do the right thing for maps 2317 # now do the right thing for maps
2095 $self->link_multipart_objects; 2318 $self->link_multipart_objects;
2096 $self->difficulty ($self->estimate_difficulty) 2319 $self->difficulty ($self->estimate_difficulty)
… …
2100 unless ($self->{deny_activate}) { 2323 unless ($self->{deny_activate}) {
2101 $self->decay_objects; 2324 $self->decay_objects;
2102 $self->fix_auto_apply; 2325 $self->fix_auto_apply;
2103 $self->update_buttons; 2326 $self->update_buttons;
2104 cf::cede_to_tick; 2327 cf::cede_to_tick;
2105 $self->activate; 2328 #$self->activate; # no longer activate maps automatically
2106 } 2329 }
2107 2330
2108 $self->{last_save} = $cf::RUNTIME; 2331 $self->{last_save} = $cf::RUNTIME;
2109 $self->last_access ($cf::RUNTIME); 2332 $self->last_access ($cf::RUNTIME);
2110
2111 $self->in_memory (cf::MAP_ACTIVE);
2112 } 2333 }
2113 2334
2114 $self->post_load; 2335 $self->post_load;
2336
2337 1
2115} 2338}
2116 2339
2117# customize the map for a given player, i.e. 2340# customize the map for a given player, i.e.
2118# return the _real_ map. used by e.g. per-player 2341# return the _real_ map. used by e.g. per-player
2119# maps to change the path to ~playername/mappath 2342# maps to change the path to ~playername/mappath
… …
2127# if $self->per_party; 2350# if $self->per_party;
2128 2351
2129 $self 2352 $self
2130} 2353}
2131 2354
2132# find and load all maps in the 3x3 area around a map
2133sub load_neighbours {
2134 my ($map) = @_;
2135
2136 my @neigh; # diagonal neighbours
2137
2138 for (0 .. 3) {
2139 my $neigh = $map->tile_path ($_)
2140 or next;
2141 $neigh = find $neigh, $map
2142 or next;
2143 $neigh->load;
2144
2145 push @neigh,
2146 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2147 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2148 }
2149
2150 for (grep defined $_->[0], @neigh) {
2151 my ($path, $origin) = @$_;
2152 my $neigh = find $path, $origin
2153 or next;
2154 $neigh->load;
2155 }
2156}
2157
2158sub find_sync { 2355sub find_sync {
2159 my ($path, $origin) = @_; 2356 my ($path, $origin) = @_;
2160 2357
2161 cf::sync_job { find $path, $origin } 2358 # it's a bug to call this from the main context
2359 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2360 if $Coro::current == $Coro::main;
2361
2362 find $path, $origin
2162} 2363}
2163 2364
2164sub do_load_sync { 2365sub do_load_sync {
2165 my ($map) = @_; 2366 my ($map) = @_;
2166 2367
2368 # it's a bug to call this from the main context
2167 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2369 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2168 if $Coro::current == $Coro::main; 2370 if $Coro::current == $Coro::main;
2169 2371
2170 cf::sync_job { $map->load }; 2372 $map->load;
2171} 2373}
2172 2374
2173our %MAP_PREFETCH; 2375our %MAP_PREFETCH;
2174our $MAP_PREFETCHER = undef; 2376our $MAP_PREFETCHER = undef;
2175 2377
2176sub find_async { 2378sub find_async {
2177 my ($path, $origin, $load) = @_; 2379 my ($path, $origin, $load) = @_;
2178 2380
2179 $path = normalise $path, $origin && $origin->{path}; 2381 $path = normalise $path, $origin;
2180 2382
2181 if (my $map = $cf::MAP{$path}) { 2383 if (my $map = $cf::MAP{$path}) {
2182 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2384 return $map if !$load || $map->linkable;
2183 } 2385 }
2184 2386
2185 $MAP_PREFETCH{$path} |= $load; 2387 $MAP_PREFETCH{$path} |= $load;
2186 2388
2187 $MAP_PREFETCHER ||= cf::async { 2389 $MAP_PREFETCHER ||= cf::async {
… …
2201 $MAP_PREFETCHER->prio (6); 2403 $MAP_PREFETCHER->prio (6);
2202 2404
2203 () 2405 ()
2204} 2406}
2205 2407
2408# common code, used by both ->save and ->swapout
2206sub save { 2409sub _save {
2207 my ($self) = @_; 2410 my ($self) = @_;
2208
2209 my $lock = cf::lock_acquire "map_data:$self->{path}";
2210 2411
2211 $self->{last_save} = $cf::RUNTIME; 2412 $self->{last_save} = $cf::RUNTIME;
2212 2413
2213 return unless $self->dirty; 2414 return unless $self->dirty;
2214 2415
… …
2234 } else { 2435 } else {
2235 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2436 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2236 } 2437 }
2237} 2438}
2238 2439
2440sub save {
2441 my ($self) = @_;
2442
2443 my $lock = cf::lock_acquire "map_data:$self->{path}";
2444
2445 $self->_save;
2446}
2447
2239sub swap_out { 2448sub swap_out {
2240 my ($self) = @_; 2449 my ($self) = @_;
2241 2450
2242 # save first because save cedes
2243 $self->save;
2244
2245 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2451 my $lock = cf::lock_acquire "map_data:$self->{path}";
2246 2452
2453 return if !$self->linkable;
2454 return if $self->{deny_save};
2247 return if $self->players; 2455 return if $self->players;
2248 return if $self->in_memory != cf::MAP_ACTIVE; 2456
2457 # first deactivate the map and "unlink" it from the core
2458 $self->deactivate;
2459 $_->clear_links_to ($self) for values %cf::MAP;
2460 $self->state (cf::MAP_SWAPPED);
2461
2462 # then atomically save
2463 $self->_save;
2464
2465 # then free the map
2466 $self->clear;
2467}
2468
2469sub reset_at {
2470 my ($self) = @_;
2471
2472 # TODO: safety, remove and allow resettable per-player maps
2249 return if $self->{deny_save}; 2473 return 1e99 if $self->{deny_reset};
2250 2474
2475 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2476 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2477
2478 $time + $to
2479}
2480
2481sub should_reset {
2482 my ($self) = @_;
2483
2484 $self->reset_at <= $cf::RUNTIME
2485}
2486
2487sub reset {
2488 my ($self) = @_;
2489
2490 my $lock = cf::lock_acquire "map_data:$self->{path}";
2491
2492 return if $self->players;
2493
2494 cf::trace "resetting map ", $self->path, "\n";
2495
2251 $self->in_memory (cf::MAP_SWAPPED); 2496 $self->state (cf::MAP_SWAPPED);
2497
2498 # need to save uniques path
2499 unless ($self->{deny_save}) {
2500 my $uniq = $self->uniq_path; utf8::encode $uniq;
2501
2502 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2503 if $uniq;
2504 }
2505
2506 delete $cf::MAP{$self->path};
2252 2507
2253 $self->deactivate; 2508 $self->deactivate;
2254 $_->clear_links_to ($self) for values %cf::MAP; 2509 $_->clear_links_to ($self) for values %cf::MAP;
2255 $self->clear; 2510 $self->clear;
2256}
2257
2258sub reset_at {
2259 my ($self) = @_;
2260
2261 # TODO: safety, remove and allow resettable per-player maps
2262 return 1e99 if $self->{deny_reset};
2263
2264 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2265 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2266
2267 $time + $to
2268}
2269
2270sub should_reset {
2271 my ($self) = @_;
2272
2273 $self->reset_at <= $cf::RUNTIME
2274}
2275
2276sub reset {
2277 my ($self) = @_;
2278
2279 my $lock = cf::lock_acquire "map_data:$self->{path}";
2280
2281 return if $self->players;
2282
2283 warn "resetting map ", $self->path, "\n";
2284
2285 $self->in_memory (cf::MAP_SWAPPED);
2286
2287 # need to save uniques path
2288 unless ($self->{deny_save}) {
2289 my $uniq = $self->uniq_path; utf8::encode $uniq;
2290
2291 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2292 if $uniq;
2293 }
2294
2295 delete $cf::MAP{$self->path};
2296
2297 $self->deactivate;
2298 $_->clear_links_to ($self) for values %cf::MAP;
2299 $self->clear;
2300 2511
2301 $self->unlink_save; 2512 $self->unlink_save;
2302 $self->destroy; 2513 $self->destroy;
2303} 2514}
2304 2515
… …
2312 2523
2313 delete $cf::MAP{$self->path}; 2524 delete $cf::MAP{$self->path};
2314 2525
2315 $self->unlink_save; 2526 $self->unlink_save;
2316 2527
2317 bless $self, "cf::map"; 2528 bless $self, "cf::map::wrap";
2318 delete $self->{deny_reset}; 2529 delete $self->{deny_reset};
2319 $self->{deny_save} = 1; 2530 $self->{deny_save} = 1;
2320 $self->reset_timeout (1); 2531 $self->reset_timeout (1);
2321 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2532 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2322 2533
… …
2552 2763
2553Freezes the player and moves him/her to a special map (C<{link}>). 2764Freezes the player and moves him/her to a special map (C<{link}>).
2554 2765
2555The player should be reasonably safe there for short amounts of time (e.g. 2766The player should be reasonably safe there for short amounts of time (e.g.
2556for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2767for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2557though, as the palyer cannot control the character while it is on the link 2768though, as the player cannot control the character while it is on the link
2558map. 2769map.
2559 2770
2560Will never block. 2771Will never block.
2561 2772
2562=item $player_object->leave_link ($map, $x, $y) 2773=item $player_object->leave_link ($map, $x, $y)
… …
2583sub cf::object::player::enter_link { 2794sub cf::object::player::enter_link {
2584 my ($self) = @_; 2795 my ($self) = @_;
2585 2796
2586 $self->deactivate_recursive; 2797 $self->deactivate_recursive;
2587 2798
2799 ++$self->{_link_recursion};
2800
2588 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2801 return if UNIVERSAL::isa $self->map, "ext::map_link";
2589 2802
2590 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2803 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2591 if $self->map && $self->map->{path} ne "{link}"; 2804 if $self->map && $self->map->{path} ne "{link}";
2592 2805
2593 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2806 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2594} 2807}
2595 2808
2596sub cf::object::player::leave_link { 2809sub cf::object::player::leave_link {
2597 my ($self, $map, $x, $y) = @_; 2810 my ($self, $map, $x, $y) = @_;
2598 2811
… …
2618 # use -1 or undef as default coordinates, not 0, 0 2831 # use -1 or undef as default coordinates, not 0, 0
2619 ($x, $y) = ($map->enter_x, $map->enter_y) 2832 ($x, $y) = ($map->enter_x, $map->enter_y)
2620 if $x <= 0 && $y <= 0; 2833 if $x <= 0 && $y <= 0;
2621 2834
2622 $map->load; 2835 $map->load;
2623 $map->load_neighbours;
2624 2836
2625 return unless $self->contr->active; 2837 return unless $self->contr->active;
2626 2838
2627 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2839 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2628 $self->enter_map ($map, $x, $y); 2840 if ($self->enter_map ($map, $x, $y)) {
2629 2841 # entering was successful
2842 delete $self->{_link_recursion};
2630 # only activate afterwards, to support waiting in hooks 2843 # only activate afterwards, to support waiting in hooks
2631 $self->activate_recursive; 2844 $self->activate_recursive;
2632} 2845 }
2633 2846
2847}
2848
2634=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2849=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2635 2850
2636Moves the player to the given map-path and coordinates by first freezing 2851Moves the player to the given map-path and coordinates by first freezing
2637her, loading and preparing them map, calling the provided $check callback 2852her, loading and preparing them map, calling the provided $check callback
2638that has to return the map if sucecssful, and then unfreezes the player on 2853that has to return the map if sucecssful, and then unfreezes the player on
2639the new (success) or old (failed) map position. In either case, $done will 2854the new (success) or old (failed) map position. In either case, $done will
… …
2646 2861
2647our $GOTOGEN; 2862our $GOTOGEN;
2648 2863
2649sub cf::object::player::goto { 2864sub cf::object::player::goto {
2650 my ($self, $path, $x, $y, $check, $done) = @_; 2865 my ($self, $path, $x, $y, $check, $done) = @_;
2866
2867 if ($self->{_link_recursion} >= $MAX_LINKS) {
2868 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2869 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2870 ($path, $x, $y) = @$EMERGENCY_POSITION;
2871 }
2651 2872
2652 # do generation counting so two concurrent goto's will be executed in-order 2873 # do generation counting so two concurrent goto's will be executed in-order
2653 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2874 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2654 2875
2655 $self->enter_link; 2876 $self->enter_link;
… …
2675 ($path, $x, $y) = (undef, undef, undef); 2896 ($path, $x, $y) = (undef, undef, undef);
2676 } 2897 }
2677 } 2898 }
2678 2899
2679 my $map = eval { 2900 my $map = eval {
2680 my $map = defined $path ? cf::map::find $path : undef; 2901 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2681 2902
2682 if ($map) { 2903 if ($map) {
2683 $map = $map->customise_for ($self); 2904 $map = $map->customise_for ($self);
2684 $map = $check->($map) if $check && $map; 2905 $map = $check->($map, $x, $y, $self) if $check && $map;
2685 } else { 2906 } else {
2686 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2907 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2687 } 2908 }
2688 2909
2689 $map 2910 $map
… …
2697 if ($gen == $self->{_goto_generation}) { 2918 if ($gen == $self->{_goto_generation}) {
2698 delete $self->{_goto_generation}; 2919 delete $self->{_goto_generation};
2699 $self->leave_link ($map, $x, $y); 2920 $self->leave_link ($map, $x, $y);
2700 } 2921 }
2701 2922
2702 $done->() if $done; 2923 $done->($self) if $done;
2703 })->prio (1); 2924 })->prio (1);
2704} 2925}
2705 2926
2706=item $player_object->enter_exit ($exit_object) 2927=item $player_object->enter_exit ($exit_object)
2707 2928
… …
2775 $Coro::current->{desc} = "enter_exit"; 2996 $Coro::current->{desc} = "enter_exit";
2776 2997
2777 unless (eval { 2998 unless (eval {
2778 $self->deactivate_recursive; # just to be sure 2999 $self->deactivate_recursive; # just to be sure
2779 3000
2780 # random map handling
2781 {
2782 my $guard = cf::lock_acquire "exit_prepare:$exit";
2783
2784 prepare_random_map $exit
2785 if $exit->slaying eq "/!";
2786 }
2787
2788 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 3001 my $map = cf::map::normalise $exit->slaying, $exit->map;
2789 my $x = $exit->stats->hp; 3002 my $x = $exit->stats->hp;
2790 my $y = $exit->stats->sp; 3003 my $y = $exit->stats->sp;
3004
3005 # special map handling
3006 my $slaying = $exit->slaying;
3007
3008 # special map handling
3009 if ($slaying eq "/!") {
3010 my $guard = cf::lock_acquire "exit_prepare:$exit";
3011
3012 prepare_random_map $exit
3013 if $exit->slaying eq "/!"; # need to re-check after getting the lock
3014
3015 $map = $exit->slaying;
3016
3017 } elsif ($slaying eq '!up') {
3018 $map = $exit->map->tile_path (cf::TILE_UP);
3019 $x = $exit->x;
3020 $y = $exit->y;
3021
3022 } elsif ($slaying eq '!down') {
3023 $map = $exit->map->tile_path (cf::TILE_DOWN);
3024 $x = $exit->x;
3025 $y = $exit->y;
3026 }
2791 3027
2792 $self->goto ($map, $x, $y); 3028 $self->goto ($map, $x, $y);
2793 3029
2794 # if exit is damned, update players death & WoR home-position 3030 # if exit is damned, update players death & WoR home-position
2795 $self->contr->savebed ($map, $x, $y) 3031 $self->contr->savebed ($map, $x, $y)
… …
2800 $self->message ("Something went wrong deep within the deliantra server. " 3036 $self->message ("Something went wrong deep within the deliantra server. "
2801 . "I'll try to bring you back to the map you were before. " 3037 . "I'll try to bring you back to the map you were before. "
2802 . "Please report this to the dungeon master!", 3038 . "Please report this to the dungeon master!",
2803 cf::NDI_UNIQUE | cf::NDI_RED); 3039 cf::NDI_UNIQUE | cf::NDI_RED);
2804 3040
2805 warn "ERROR in enter_exit: $@"; 3041 error "ERROR in enter_exit: $@";
2806 $self->leave_link; 3042 $self->leave_link;
2807 } 3043 }
2808 })->prio (1); 3044 })->prio (1);
2809} 3045}
2810 3046
… …
3020=cut 3256=cut
3021 3257
3022sub cf::client::ext_msg($$@) { 3258sub cf::client::ext_msg($$@) {
3023 my ($self, $type, @msg) = @_; 3259 my ($self, $type, @msg) = @_;
3024 3260
3025 if ($self->extcmd == 2) {
3026 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3261 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3027 } elsif ($self->extcmd == 1) { # TODO: remove
3028 push @msg, msgtype => "event_$type";
3029 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3030 }
3031}
3032
3033=item $client->ext_reply ($msgid, @msg)
3034
3035Sends an ext reply to the client.
3036
3037=cut
3038
3039sub cf::client::ext_reply($$@) {
3040 my ($self, $id, @msg) = @_;
3041
3042 if ($self->extcmd == 2) {
3043 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3044 } elsif ($self->extcmd == 1) {
3045 #TODO: version 1, remove
3046 unshift @msg, msgtype => "reply", msgid => $id;
3047 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3048 }
3049} 3262}
3050 3263
3051=item $success = $client->query ($flags, "text", \&cb) 3264=item $success = $client->query ($flags, "text", \&cb)
3052 3265
3053Queues a query to the client, calling the given callback with 3266Queues a query to the client, calling the given callback with
… …
3108 my ($ns, $buf) = @_; 3321 my ($ns, $buf) = @_;
3109 3322
3110 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3323 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3111 3324
3112 if (ref $msg) { 3325 if (ref $msg) {
3113 my ($type, $reply, @payload) = 3326 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3114 "ARRAY" eq ref $msg
3115 ? @$msg
3116 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3117 3327
3118 my @reply;
3119
3120 if (my $cb = $EXTICMD{$type}) { 3328 if (my $cb = $EXTIACMD{$type}) {
3329 $cb->(
3330 $ns,
3331 sub {
3332 $ns->ext_msg ("reply-$reply", @_)
3333 if $reply;
3334 },
3335 @payload
3336 );
3337 } else {
3338 my @reply;
3339
3340 if (my $cb = $EXTICMD{$type}) {
3121 @reply = $cb->($ns, @payload); 3341 @reply = $cb->($ns, @payload);
3342 }
3343
3344 $ns->ext_msg ("reply-$reply", @reply)
3345 if $reply;
3122 } 3346 }
3123
3124 $ns->ext_reply ($reply, @reply)
3125 if $reply;
3126
3127 } else { 3347 } else {
3128 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3348 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3129 } 3349 }
3130 3350
3131 cf::override; 3351 cf::override;
3132 }, 3352 },
3133); 3353);
… …
3214 decrease split destroy change_exp value msg lore send_msg)], 3434 decrease split destroy change_exp value msg lore send_msg)],
3215 ["cf::object::player" => qw(player)], 3435 ["cf::object::player" => qw(player)],
3216 ["cf::player" => qw(peaceful send_msg)], 3436 ["cf::player" => qw(peaceful send_msg)],
3217 ["cf::map" => qw(trigger)], 3437 ["cf::map" => qw(trigger)],
3218) { 3438) {
3219 no strict 'refs';
3220 my ($pkg, @funs) = @$_; 3439 my ($pkg, @funs) = @$_;
3221 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3440 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3222 for @funs; 3441 for @funs;
3223} 3442}
3224 3443
… …
3263 local @cf::_safe_eval_args = values %vars; 3482 local @cf::_safe_eval_args = values %vars;
3264 @res = wantarray ? eval eval : scalar eval $eval; 3483 @res = wantarray ? eval eval : scalar eval $eval;
3265 } 3484 }
3266 3485
3267 if ($@) { 3486 if ($@) {
3268 warn "$@"; 3487 warn "$@",
3269 warn "while executing safe code '$code'\n"; 3488 "while executing safe code '$code'\n",
3270 warn "with arguments " . (join " ", %vars) . "\n"; 3489 "with arguments " . (join " ", %vars) . "\n";
3271 } 3490 }
3272 3491
3273 wantarray ? @res : $res[0] 3492 wantarray ? @res : $res[0]
3274} 3493}
3275 3494
… …
3300=cut 3519=cut
3301 3520
3302############################################################################# 3521#############################################################################
3303# the server's init and main functions 3522# the server's init and main functions
3304 3523
3524our %FACEHASH; # hash => idx, #d# HACK for http server
3525
3526# internal api, not fianlised
3527sub set_face {
3528 my ($name, $type, $data) = @_;
3529
3530 my $idx = cf::face::find $name;
3531
3532 if ($idx) {
3533 delete $FACEHASH{cf::face::get_chksum $idx};
3534 } else {
3535 $idx = cf::face::alloc $name;
3536 }
3537
3538 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
3539
3540 cf::face::set_type $idx, $type;
3541 cf::face::set_data $idx, 0, $data, $hash;
3542 cf::face::set_meta $idx, $type & 1 ? undef : undef;
3543 $FACEHASH{$hash} = $idx;#d#
3544
3545 $idx
3546}
3547
3305sub load_facedata($) { 3548sub load_facedata($) {
3306 my ($path) = @_; 3549 my ($path) = @_;
3307 3550
3308 # HACK to clear player env face cache, we need some signal framework 3551 # HACK to clear player env face cache, we need some signal framework
3309 # for this (global event?) 3552 # for this (global event?)
3310 %ext::player_env::MUSIC_FACE_CACHE = (); 3553 %ext::player_env::MUSIC_FACE_CACHE = ();
3311 3554
3312 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3555 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3313 3556
3314 warn "loading facedata from $path\n"; 3557 trace "loading facedata from $path\n";
3315 3558
3316 my $facedata; 3559 my $facedata = decode_storable load_file $path;
3317 0 < aio_load $path, $facedata
3318 or die "$path: $!";
3319
3320 $facedata = Coro::Storable::thaw $facedata;
3321 3560
3322 $facedata->{version} == 2 3561 $facedata->{version} == 2
3323 or cf::cleanup "$path: version mismatch, cannot proceed."; 3562 or cf::cleanup "$path: version mismatch, cannot proceed.";
3324 3563
3325 # patch in the exptable
3326 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3327 $facedata->{resource}{"res/exp_table"} = {
3328 type => FT_RSRC,
3329 data => $exp_table,
3330 hash => (Digest::MD5::md5 $exp_table),
3331 };
3332 cf::cede_to_tick; 3564 cf::cede_to_tick;
3333 3565
3334 { 3566 {
3335 my $faces = $facedata->{faceinfo}; 3567 my $faces = delete $facedata->{faceinfo};
3336 3568
3337 while (my ($face, $info) = each %$faces) { 3569 for my $face (sort keys %$faces) {
3570 my $info = $faces->{$face};
3338 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3571 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3339 3572
3340 cf::face::set_visibility $idx, $info->{visibility}; 3573 cf::face::set_visibility $idx, $info->{visibility};
3341 cf::face::set_magicmap $idx, $info->{magicmap}; 3574 cf::face::set_magicmap $idx, $info->{magicmap};
3342 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3575 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3343 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3576 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3344 3577 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3578 $FACEHASH{$info->{hash64}} = $idx;#d#
3579
3345 cf::cede_to_tick; 3580 cf::cede_to_tick;
3346 } 3581 }
3347 3582
3348 while (my ($face, $info) = each %$faces) { 3583 while (my ($face, $info) = each %$faces) {
3349 next unless $info->{smooth}; 3584 next unless $info->{smooth};
… …
3353 3588
3354 if (my $smooth = cf::face::find $info->{smooth}) { 3589 if (my $smooth = cf::face::find $info->{smooth}) {
3355 cf::face::set_smooth $idx, $smooth; 3590 cf::face::set_smooth $idx, $smooth;
3356 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3591 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3357 } else { 3592 } else {
3358 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3593 error "smooth face '$info->{smooth}' not found for face '$face'";
3359 } 3594 }
3360 3595
3361 cf::cede_to_tick; 3596 cf::cede_to_tick;
3362 } 3597 }
3363 } 3598 }
3364 3599
3365 { 3600 {
3366 my $anims = $facedata->{animinfo}; 3601 my $anims = delete $facedata->{animinfo};
3367 3602
3368 while (my ($anim, $info) = each %$anims) { 3603 while (my ($anim, $info) = each %$anims) {
3369 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3604 cf::anim::set $anim, $info->{frames}, $info->{facings};
3370 cf::cede_to_tick; 3605 cf::cede_to_tick;
3371 } 3606 }
3372 3607
3373 cf::anim::invalidate_all; # d'oh 3608 cf::anim::invalidate_all; # d'oh
3374 } 3609 }
3375 3610
3376 { 3611 {
3377 my $res = $facedata->{resource}; 3612 my $res = delete $facedata->{resource};
3378 3613
3379 while (my ($name, $info) = each %$res) { 3614 while (my ($name, $info) = each %$res) {
3380 if (defined $info->{type}) { 3615 if (defined (my $type = $info->{type})) {
3616 # TODO: different hash - must free and use new index, or cache ixface data queue
3381 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3617 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3382 3618
3619 cf::face::set_type $idx, $type;
3383 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3620 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3384 cf::face::set_type $idx, $info->{type}; 3621 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3622 $FACEHASH{$info->{hash}} = $idx;#d#
3385 } else { 3623 } else {
3386 $RESOURCE{$name} = $info; 3624# $RESOURCE{$name} = $info; # unused
3387 } 3625 }
3388 3626
3389 cf::cede_to_tick; 3627 cf::cede_to_tick;
3390 } 3628 }
3391 } 3629 }
3392 3630
3393 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3631 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3394 3632
3395 1 3633 1
3396} 3634}
3397
3398cf::global->attach (on_resource_update => sub {
3399 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3400 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3401
3402 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3403 my $sound = $soundconf->{compat}[$_]
3404 or next;
3405
3406 my $face = cf::face::find "sound/$sound->[1]";
3407 cf::sound::set $sound->[0] => $face;
3408 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3409 }
3410
3411 while (my ($k, $v) = each %{$soundconf->{event}}) {
3412 my $face = cf::face::find "sound/$v";
3413 cf::sound::set $k => $face;
3414 }
3415 }
3416});
3417 3635
3418register_exticmd fx_want => sub { 3636register_exticmd fx_want => sub {
3419 my ($ns, $want) = @_; 3637 my ($ns, $want) = @_;
3420 3638
3421 while (my ($k, $v) = each %$want) { 3639 while (my ($k, $v) = each %$want) {
… …
3429 my $status = load_resource_file_ $_[0]; 3647 my $status = load_resource_file_ $_[0];
3430 get_slot 0.1, 100; 3648 get_slot 0.1, 100;
3431 cf::arch::commit_load; 3649 cf::arch::commit_load;
3432 3650
3433 $status 3651 $status
3652}
3653
3654sub reload_exp_table {
3655 _reload_exp_table;
3656
3657 set_face "res/exp_table" => FT_RSRC,
3658 JSON::XS->new->utf8->canonical->encode (
3659 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3660 );
3661}
3662
3663sub reload_materials {
3664 _reload_materials;
3434} 3665}
3435 3666
3436sub reload_regions { 3667sub reload_regions {
3437 # HACK to clear player env face cache, we need some signal framework 3668 # HACK to clear player env face cache, we need some signal framework
3438 # for this (global event?) 3669 # for this (global event?)
… …
3453} 3684}
3454 3685
3455sub reload_archetypes { 3686sub reload_archetypes {
3456 load_resource_file "$DATADIR/archetypes" 3687 load_resource_file "$DATADIR/archetypes"
3457 or die "unable to load archetypes\n"; 3688 or die "unable to load archetypes\n";
3689
3690 set_face "res/skill_info" => FT_RSRC,
3691 JSON::XS->new->utf8->canonical->encode (
3692 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3693 );
3694 set_face "res/spell_paths" => FT_RSRC,
3695 JSON::XS->new->utf8->canonical->encode (
3696 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3697 );
3458} 3698}
3459 3699
3460sub reload_treasures { 3700sub reload_treasures {
3461 load_resource_file "$DATADIR/treasures" 3701 load_resource_file "$DATADIR/treasures"
3462 or die "unable to load treasurelists\n"; 3702 or die "unable to load treasurelists\n";
3463} 3703}
3464 3704
3705sub reload_sound {
3706 trace "loading sound config from $DATADIR/sound\n";
3707
3708 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3709
3710 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3711 my $sound = $soundconf->{compat}[$_]
3712 or next;
3713
3714 my $face = cf::face::find "sound/$sound->[1]";
3715 cf::sound::set $sound->[0] => $face;
3716 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3717 }
3718
3719 while (my ($k, $v) = each %{$soundconf->{event}}) {
3720 my $face = cf::face::find "sound/$v";
3721 cf::sound::set $k => $face;
3722 }
3723}
3724
3465sub reload_resources { 3725sub reload_resources {
3466 warn "reloading resource files...\n"; 3726 trace "reloading resource files...\n";
3467 3727
3728 reload_materials;
3468 reload_facedata; 3729 reload_facedata;
3730 reload_exp_table;
3731 reload_sound;
3469 reload_archetypes; 3732 reload_archetypes;
3470 reload_regions; 3733 reload_regions;
3471 reload_treasures; 3734 reload_treasures;
3472 3735
3473 warn "finished reloading resource files\n"; 3736 trace "finished reloading resource files\n";
3474} 3737}
3475 3738
3476sub reload_config { 3739sub reload_config {
3477 warn "reloading config file...\n"; 3740 trace "reloading config file...\n";
3478 3741
3479 open my $fh, "<:utf8", "$CONFDIR/config" 3742 my $config = load_file "$CONFDIR/config";
3480 or return; 3743 utf8::decode $config;
3744 *CFG = decode_yaml $config;
3481 3745
3482 local $/;
3483 *CFG = YAML::XS::Load scalar <$fh>;
3484
3485 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3746 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3486 3747
3487 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3748 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3488 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3749 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3489 3750
3490 if (exists $CFG{mlockall}) { 3751 if (exists $CFG{mlockall}) {
… …
3492 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3753 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3493 and die "WARNING: m(un)lockall failed: $!\n"; 3754 and die "WARNING: m(un)lockall failed: $!\n";
3494 }; 3755 };
3495 warn $@ if $@; 3756 warn $@ if $@;
3496 } 3757 }
3497
3498 warn "finished reloading resource files\n";
3499} 3758}
3500 3759
3501sub pidfile() { 3760sub pidfile() {
3502 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3761 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3503 or die "$PIDFILE: $!"; 3762 or die "$PIDFILE: $!";
… …
3516 seek $fh, 0, 0; 3775 seek $fh, 0, 0;
3517 print $fh $$; 3776 print $fh $$;
3518} 3777}
3519 3778
3520sub main_loop { 3779sub main_loop {
3521 warn "EV::loop starting\n"; 3780 trace "EV::loop starting\n";
3522 if (1) { 3781 if (1) {
3523 EV::loop; 3782 EV::loop;
3524 } 3783 }
3525 warn "EV::loop returned\n"; 3784 trace "EV::loop returned\n";
3526 goto &main_loop unless $REALLY_UNLOOP; 3785 goto &main_loop unless $REALLY_UNLOOP;
3527} 3786}
3528 3787
3529sub main { 3788sub main {
3530 cf::init_globals; # initialise logging 3789 cf::init_globals; # initialise logging
3531 3790
3532 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3791 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3533 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3792 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3534 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3793 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3535 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3794 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3536 3795
3537 cf::init_experience;
3538 cf::init_anim;
3539 cf::init_attackmess;
3540 cf::init_dynamic;
3541
3542 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3796 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3543 3797
3544 # we must not ever block the main coroutine 3798 # we must not ever block the main coroutine
3545 local $Coro::idle = sub { 3799 $Coro::idle = sub {
3546 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3800 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3547 (async { 3801 (async {
3548 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3802 $Coro::current->{desc} = "IDLE BUG HANDLER";
3549 EV::loop EV::LOOP_ONESHOT; 3803 EV::loop EV::LOOP_ONESHOT;
3550 })->prio (Coro::PRIO_MAX); 3804 })->prio (Coro::PRIO_MAX);
3551 }; 3805 };
3552 3806
3553 evthread_start IO::AIO::poll_fileno; 3807 evthread_start IO::AIO::poll_fileno;
3554 3808
3555 cf::sync_job { 3809 cf::sync_job {
3810 cf::incloader::init ();
3811
3812 db_init;
3813
3814 cf::init_anim;
3815 cf::init_attackmess;
3816 cf::init_dynamic;
3817
3556 cf::load_settings; 3818 cf::load_settings;
3557 cf::load_materials;
3558 3819
3559 reload_resources; 3820 reload_resources;
3560 reload_config; 3821 reload_config;
3561 db_init;
3562 3822
3563 cf::init_uuid; 3823 cf::init_uuid;
3564 cf::init_signals; 3824 cf::init_signals;
3565 cf::init_skills; 3825 cf::init_skills;
3566 3826
… …
3574 3834
3575 # no (long-running) fork's whatsoever before this point(!) 3835 # no (long-running) fork's whatsoever before this point(!)
3576 use POSIX (); 3836 use POSIX ();
3577 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3837 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3578 3838
3579 (pop @POST_INIT)->(0) while @POST_INIT; 3839 cf::_post_init 0;
3580 }; 3840 };
3581 3841
3842 cf::object::thawer::errors_are_fatal 0;
3843 info "parse errors in files are no longer fatal from this point on.\n";
3844
3845 AE::postpone {
3846 undef &main; # free gobs of memory :)
3847 };
3848
3582 main_loop; 3849 goto &main_loop;
3583} 3850}
3584 3851
3585############################################################################# 3852#############################################################################
3586# initialisation and cleanup 3853# initialisation and cleanup
3587 3854
… …
3626 or return; 3893 or return;
3627 3894
3628 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3895 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3629 and return; 3896 and return;
3630 3897
3631 warn sprintf "runtime file written (%gs).\n", AE::time - $t0; 3898 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3632 3899
3633 1 3900 1
3634} 3901}
3635 3902
3636our $uuid_lock; 3903our $uuid_lock;
… …
3648 or return; 3915 or return;
3649 3916
3650 my $value = uuid_seq uuid_cur; 3917 my $value = uuid_seq uuid_cur;
3651 3918
3652 unless ($value) { 3919 unless ($value) {
3653 warn "cowardly refusing to write zero uuid value!\n"; 3920 info "cowardly refusing to write zero uuid value!\n";
3654 return; 3921 return;
3655 } 3922 }
3656 3923
3657 my $value = uuid_str $value + $uuid_skip; 3924 my $value = uuid_str $value + $uuid_skip;
3658 $uuid_skip = 0; 3925 $uuid_skip = 0;
… …
3668 or return; 3935 or return;
3669 3936
3670 aio_rename "$uuid~", $uuid 3937 aio_rename "$uuid~", $uuid
3671 and return; 3938 and return;
3672 3939
3673 warn "uuid file written ($value).\n"; 3940 trace "uuid file written ($value).\n";
3674 3941
3675 1 3942 1
3676 3943
3677} 3944}
3678 3945
… …
3684} 3951}
3685 3952
3686sub emergency_save() { 3953sub emergency_save() {
3687 my $freeze_guard = cf::freeze_mainloop; 3954 my $freeze_guard = cf::freeze_mainloop;
3688 3955
3689 warn "emergency_perl_save: enter\n"; 3956 info "emergency_perl_save: enter\n";
3957
3958 # this is a trade-off: we want to be very quick here, so
3959 # save all maps without fsync, and later call a global sync
3960 # (which in turn might be very very slow)
3961 local $USE_FSYNC = 0;
3690 3962
3691 cf::sync_job { 3963 cf::sync_job {
3692 # this is a trade-off: we want to be very quick here, so 3964 cf::write_runtime_sync; # external watchdog should not bark
3693 # save all maps without fsync, and later call a global sync
3694 # (which in turn might be very very slow)
3695 local $USE_FSYNC = 0;
3696 3965
3697 # use a peculiar iteration method to avoid tripping on perl 3966 # use a peculiar iteration method to avoid tripping on perl
3698 # refcount bugs in for. also avoids problems with players 3967 # refcount bugs in for. also avoids problems with players
3699 # and maps saved/destroyed asynchronously. 3968 # and maps saved/destroyed asynchronously.
3700 warn "emergency_perl_save: begin player save\n"; 3969 info "emergency_perl_save: begin player save\n";
3701 for my $login (keys %cf::PLAYER) { 3970 for my $login (keys %cf::PLAYER) {
3702 my $pl = $cf::PLAYER{$login} or next; 3971 my $pl = $cf::PLAYER{$login} or next;
3703 $pl->valid or next; 3972 $pl->valid or next;
3704 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3973 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3705 $pl->save; 3974 $pl->save;
3706 } 3975 }
3707 warn "emergency_perl_save: end player save\n"; 3976 info "emergency_perl_save: end player save\n";
3708 3977
3978 cf::write_runtime_sync; # external watchdog should not bark
3979
3709 warn "emergency_perl_save: begin map save\n"; 3980 info "emergency_perl_save: begin map save\n";
3710 for my $path (keys %cf::MAP) { 3981 for my $path (keys %cf::MAP) {
3711 my $map = $cf::MAP{$path} or next; 3982 my $map = $cf::MAP{$path} or next;
3712 $map->valid or next; 3983 $map->valid or next;
3713 $map->save; 3984 $map->save;
3714 } 3985 }
3715 warn "emergency_perl_save: end map save\n"; 3986 info "emergency_perl_save: end map save\n";
3716 3987
3988 cf::write_runtime_sync; # external watchdog should not bark
3989
3717 warn "emergency_perl_save: begin database checkpoint\n"; 3990 info "emergency_perl_save: begin database checkpoint\n";
3718 BDB::db_env_txn_checkpoint $DB_ENV; 3991 BDB::db_env_txn_checkpoint $DB_ENV;
3719 warn "emergency_perl_save: end database checkpoint\n"; 3992 info "emergency_perl_save: end database checkpoint\n";
3720 3993
3721 warn "emergency_perl_save: begin write uuid\n"; 3994 info "emergency_perl_save: begin write uuid\n";
3722 write_uuid_sync 1; 3995 write_uuid_sync 1;
3723 warn "emergency_perl_save: end write uuid\n"; 3996 info "emergency_perl_save: end write uuid\n";
3997
3998 cf::write_runtime_sync; # external watchdog should not bark
3999
4000 trace "emergency_perl_save: syncing database to disk";
4001 BDB::db_env_txn_checkpoint $DB_ENV;
4002
4003 info "emergency_perl_save: starting sync\n";
4004 IO::AIO::aio_sync sub {
4005 info "emergency_perl_save: finished sync\n";
4006 };
4007
4008 cf::write_runtime_sync; # external watchdog should not bark
4009
4010 trace "emergency_perl_save: flushing outstanding aio requests";
4011 while (IO::AIO::nreqs || BDB::nreqs) {
4012 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
4013 }
4014
4015 cf::write_runtime_sync; # external watchdog should not bark
3724 }; 4016 };
3725 4017
3726 warn "emergency_perl_save: starting sync()\n";
3727 IO::AIO::aio_sync sub {
3728 warn "emergency_perl_save: finished sync()\n";
3729 };
3730
3731 warn "emergency_perl_save: leave\n"; 4018 info "emergency_perl_save: leave\n";
3732} 4019}
3733 4020
3734sub post_cleanup { 4021sub post_cleanup {
3735 my ($make_core) = @_; 4022 my ($make_core) = @_;
3736 4023
4024 IO::AIO::flush;
4025
3737 warn Carp::longmess "post_cleanup backtrace" 4026 error Carp::longmess "post_cleanup backtrace"
3738 if $make_core; 4027 if $make_core;
3739 4028
3740 my $fh = pidfile; 4029 my $fh = pidfile;
3741 unlink $PIDFILE if <$fh> == $$; 4030 unlink $PIDFILE if <$fh> == $$;
3742} 4031}
… …
3762 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 4051 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3763 for my $name (keys %$leaf_symtab) { 4052 for my $name (keys %$leaf_symtab) {
3764 _gv_clear *{"$pkg$name"}; 4053 _gv_clear *{"$pkg$name"};
3765# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 4054# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3766 } 4055 }
3767 warn "cleared package $pkg\n";#d#
3768} 4056}
3769 4057
3770sub do_reload_perl() { 4058sub do_reload_perl() {
3771 # can/must only be called in main 4059 # can/must only be called in main
3772 if ($Coro::current != $Coro::main) { 4060 unless (in_main) {
3773 warn "can only reload from main coroutine"; 4061 error "can only reload from main coroutine";
3774 return; 4062 return;
3775 } 4063 }
3776 4064
3777 return if $RELOAD++; 4065 return if $RELOAD++;
3778 4066
3779 my $t1 = AE::time; 4067 my $t1 = AE::time;
3780 4068
3781 while ($RELOAD) { 4069 while ($RELOAD) {
3782 warn "reloading..."; 4070 cf::get_slot 0.1, -1, "reload_perl";
4071 info "perl_reload: reloading...";
3783 4072
3784 warn "entering sync_job"; 4073 trace "perl_reload: entering sync_job";
3785 4074
3786 cf::sync_job { 4075 cf::sync_job {
3787 cf::write_runtime_sync; # external watchdog should not bark
3788 cf::emergency_save; 4076 #cf::emergency_save;
3789 cf::write_runtime_sync; # external watchdog should not bark
3790 4077
3791 warn "syncing database to disk";
3792 BDB::db_env_txn_checkpoint $DB_ENV;
3793
3794 # if anything goes wrong in here, we should simply crash as we already saved
3795
3796 warn "flushing outstanding aio requests";
3797 while (IO::AIO::nreqs || BDB::nreqs) {
3798 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3799 }
3800
3801 warn "cancelling all extension coros"; 4078 trace "perl_reload: cancelling all extension coros";
3802 $_->cancel for values %EXT_CORO; 4079 $_->cancel for values %EXT_CORO;
3803 %EXT_CORO = (); 4080 %EXT_CORO = ();
3804 4081
3805 warn "removing commands"; 4082 trace "perl_reload: removing commands";
3806 %COMMAND = (); 4083 %COMMAND = ();
3807 4084
3808 warn "removing ext/exti commands"; 4085 trace "perl_reload: removing ext/exti commands";
3809 %EXTCMD = (); 4086 %EXTCMD = ();
3810 %EXTICMD = (); 4087 %EXTICMD = ();
3811 4088
3812 warn "unloading/nuking all extensions"; 4089 trace "perl_reload: unloading/nuking all extensions";
3813 for my $pkg (@EXTS) { 4090 for my $pkg (@EXTS) {
3814 warn "... unloading $pkg"; 4091 trace "... unloading $pkg";
3815 4092
3816 if (my $cb = $pkg->can ("unload")) { 4093 if (my $cb = $pkg->can ("unload")) {
3817 eval { 4094 eval {
3818 $cb->($pkg); 4095 $cb->($pkg);
3819 1 4096 1
3820 } or warn "$pkg unloaded, but with errors: $@"; 4097 } or error "$pkg unloaded, but with errors: $@";
3821 } 4098 }
3822 4099
3823 warn "... clearing $pkg"; 4100 trace "... clearing $pkg";
3824 clear_package $pkg; 4101 clear_package $pkg;
3825 } 4102 }
3826 4103
3827 warn "unloading all perl modules loaded from $LIBDIR"; 4104 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3828 while (my ($k, $v) = each %INC) { 4105 while (my ($k, $v) = each %INC) {
3829 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4106 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3830 4107
3831 warn "... unloading $k"; 4108 trace "... unloading $k";
3832 delete $INC{$k}; 4109 delete $INC{$k};
3833 4110
3834 $k =~ s/\.pm$//; 4111 $k =~ s/\.pm$//;
3835 $k =~ s/\//::/g; 4112 $k =~ s/\//::/g;
3836 4113
… …
3839 } 4116 }
3840 4117
3841 clear_package $k; 4118 clear_package $k;
3842 } 4119 }
3843 4120
3844 warn "getting rid of safe::, as good as possible"; 4121 trace "perl_reload: getting rid of safe::, as good as possible";
3845 clear_package "safe::$_" 4122 clear_package "safe::$_"
3846 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4123 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3847 4124
3848 warn "unloading cf.pm \"a bit\""; 4125 trace "perl_reload: unloading cf.pm \"a bit\"";
3849 delete $INC{"cf.pm"}; 4126 delete $INC{"cf.pm"};
3850 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4127 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3851 4128
3852 # don't, removes xs symbols, too, 4129 # don't, removes xs symbols, too,
3853 # and global variables created in xs 4130 # and global variables created in xs
3854 #clear_package __PACKAGE__; 4131 #clear_package __PACKAGE__;
3855 4132
3856 warn "unload completed, starting to reload now"; 4133 info "perl_reload: unload completed, starting to reload now";
3857 4134
3858 warn "reloading cf.pm"; 4135 trace "perl_reload: reloading cf.pm";
3859 require cf; 4136 require cf;
3860 cf::_connect_to_perl_1; 4137 cf::_connect_to_perl_1;
3861 4138
3862 warn "loading config and database again"; 4139 trace "perl_reload: loading config and database again";
3863 cf::reload_config; 4140 cf::reload_config;
3864 4141
3865 warn "loading extensions"; 4142 trace "perl_reload: loading extensions";
3866 cf::load_extensions; 4143 cf::load_extensions;
3867 4144
3868 if ($REATTACH_ON_RELOAD) { 4145 if ($REATTACH_ON_RELOAD) {
3869 warn "reattaching attachments to objects/players"; 4146 trace "perl_reload: reattaching attachments to objects/players";
3870 _global_reattach; # objects, sockets 4147 _global_reattach; # objects, sockets
3871 warn "reattaching attachments to maps"; 4148 trace "perl_reload: reattaching attachments to maps";
3872 reattach $_ for values %MAP; 4149 reattach $_ for values %MAP;
3873 warn "reattaching attachments to players"; 4150 trace "perl_reload: reattaching attachments to players";
3874 reattach $_ for values %PLAYER; 4151 reattach $_ for values %PLAYER;
3875 } 4152 }
3876 4153
3877 warn "running post_init jobs"; 4154 cf::_post_init 1;
3878 (pop @POST_INIT)->(1) while @POST_INIT;
3879 4155
3880 warn "leaving sync_job"; 4156 trace "perl_reload: leaving sync_job";
3881 4157
3882 1 4158 1
3883 } or do { 4159 } or do {
3884 warn $@; 4160 error $@;
3885 cf::cleanup "error while reloading, exiting."; 4161 cf::cleanup "perl_reload: error, exiting.";
3886 }; 4162 };
3887 4163
3888 warn "reloaded";
3889 --$RELOAD; 4164 --$RELOAD;
3890 } 4165 }
3891 4166
3892 $t1 = AE::time - $t1; 4167 $t1 = AE::time - $t1;
3893 warn "reload completed in ${t1}s\n"; 4168 info "perl_reload: completed in ${t1}s\n";
3894}; 4169};
3895 4170
3896our $RELOAD_WATCHER; # used only during reload 4171our $RELOAD_WATCHER; # used only during reload
3897 4172
3898sub reload_perl() { 4173sub reload_perl() {
… …
3919 reload_perl; 4194 reload_perl;
3920 }; 4195 };
3921 } 4196 }
3922}; 4197};
3923 4198
3924unshift @INC, $LIBDIR; 4199#############################################################################
3925 4200
3926my $bug_warning = 0; 4201my $bug_warning = 0;
3927 4202
3928our @WAIT_FOR_TICK;
3929our @WAIT_FOR_TICK_BEGIN;
3930
3931sub wait_for_tick { 4203sub wait_for_tick() {
3932 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4204 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3933 4205
3934 my $signal = new Coro::Signal; 4206 $WAIT_FOR_TICK->wait;
3935 push @WAIT_FOR_TICK, $signal;
3936 $signal->wait;
3937} 4207}
3938 4208
3939sub wait_for_tick_begin { 4209sub wait_for_tick_begin() {
3940 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4210 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3941 4211
3942 my $signal = new Coro::Signal; 4212 my $signal = new Coro::Signal;
3943 push @WAIT_FOR_TICK_BEGIN, $signal; 4213 push @WAIT_FOR_TICK_BEGIN, $signal;
3944 $signal->wait; 4214 $signal->wait;
3945} 4215}
… …
3949 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4219 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3950 unless ++$bug_warning > 10; 4220 unless ++$bug_warning > 10;
3951 return; 4221 return;
3952 } 4222 }
3953 4223
3954 cf::server_tick; # one server iteration 4224 cf::one_tick; # one server iteration
3955 4225
3956 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d# 4226 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3957 4227
3958 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4228 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3959 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4229 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3960 Coro::async_pool { 4230 Coro::async_pool {
3961 $Coro::current->{desc} = "runtime saver"; 4231 $Coro::current->{desc} = "runtime saver";
3962 write_runtime_sync 4232 write_runtime_sync
3963 or warn "ERROR: unable to write runtime file: $!"; 4233 or error "ERROR: unable to write runtime file: $!";
3964 }; 4234 };
3965 } 4235 }
3966 4236
3967 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4237 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3968 $sig->send; 4238 $sig->send;
3969 } 4239 }
3970 while (my $sig = shift @WAIT_FOR_TICK) { 4240 $WAIT_FOR_TICK->broadcast;
3971 $sig->send;
3972 }
3973 4241
3974 $LOAD = ($NOW - $TICK_START) / $TICK; 4242 $LOAD = ($NOW - $TICK_START) / $TICK;
3975 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4243 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3976 4244
3977 if (0) { 4245 if (0) {
3978 if ($NEXT_TICK) { 4246 if ($NEXT_TICK) {
3979 my $jitter = $TICK_START - $NEXT_TICK; 4247 my $jitter = $TICK_START - $NEXT_TICK;
3980 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4248 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3981 warn "jitter $JITTER\n";#d# 4249 debug "jitter $JITTER\n";#d#
3982 } 4250 }
3983 } 4251 }
3984} 4252}
3985 4253
3986{ 4254{
3987 # configure BDB 4255 # configure BDB
4256 info "initialising database";
3988 4257
3989 BDB::min_parallel 16; 4258 BDB::min_parallel 16;
3990 BDB::max_poll_reqs $TICK * 0.1; 4259 BDB::max_poll_reqs $TICK * 0.1;
3991 $AnyEvent::BDB::WATCHER->priority (1); 4260 #$AnyEvent::BDB::WATCHER->priority (1);
3992 4261
3993 unless ($DB_ENV) { 4262 unless ($DB_ENV) {
3994 $DB_ENV = BDB::db_env_create; 4263 $DB_ENV = BDB::db_env_create;
3995 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4264 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3996 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4265 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
4021 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4290 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4022 }; 4291 };
4023 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4292 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4024 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4293 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4025 }; 4294 };
4295
4296 info "database initialised";
4026} 4297}
4027 4298
4028{ 4299{
4029 # configure IO::AIO 4300 # configure IO::AIO
4030 4301
4302 info "initialising aio";
4031 IO::AIO::min_parallel 8; 4303 IO::AIO::min_parallel 8;
4032 IO::AIO::max_poll_time $TICK * 0.1; 4304 IO::AIO::max_poll_time $TICK * 0.1;
4033 undef $AnyEvent::AIO::WATCHER; 4305 undef $AnyEvent::AIO::WATCHER;
4306 info "aio initialised";
4034} 4307}
4035 4308
4036my $_log_backtrace; 4309our $_log_backtrace;
4310our $_log_backtrace_last;
4037 4311
4038sub _log_backtrace { 4312sub _log_backtrace {
4039 my ($msg, @addr) = @_; 4313 my ($msg, @addr) = @_;
4040 4314
4041 $msg =~ s/\n//; 4315 $msg =~ s/\n$//;
4042 4316
4317 if ($_log_backtrace_last eq $msg) {
4318 LOG llevInfo, "[ABT] $msg\n";
4319 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4043 # limit the # of concurrent backtraces 4320 # limit the # of concurrent backtraces
4044 if ($_log_backtrace < 2) { 4321 } elsif ($_log_backtrace < 2) {
4322 $_log_backtrace_last = $msg;
4045 ++$_log_backtrace; 4323 ++$_log_backtrace;
4046 my $perl_bt = Carp::longmess $msg; 4324 my $perl_bt = Carp::longmess $msg;
4047 async { 4325 async {
4048 $Coro::current->{desc} = "abt $msg"; 4326 $Coro::current->{desc} = "abt $msg";
4049 4327
… …
4069 LOG llevInfo, "[ABT] $_\n" for @bt; 4347 LOG llevInfo, "[ABT] $_\n" for @bt;
4070 --$_log_backtrace; 4348 --$_log_backtrace;
4071 }; 4349 };
4072 } else { 4350 } else {
4073 LOG llevInfo, "[ABT] $msg\n"; 4351 LOG llevInfo, "[ABT] $msg\n";
4074 LOG llevInfo, "[ABT] [suppressed]\n"; 4352 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4075 } 4353 }
4076} 4354}
4077 4355
4078# load additional modules 4356# load additional modules
4079require "cf/$_.pm" for @EXTRA_MODULES; 4357require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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