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.485 by root, Mon Oct 12 14:12:54 2009 UTC vs.
Revision 1.571 by root, Wed May 4 19:04:45 2011 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010,2011 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.
… …
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;
33use Opcode; 31use Opcode;
34use Safe; 32use Safe;
35use Safe::Hole; 33use Safe::Hole;
36use Storable (); 34use Storable ();
35use Carp ();
37 36
38use Guard (); 37use Guard ();
39use Coro (); 38use Coro ();
40use Coro::State; 39use Coro::State;
41use Coro::Handle; 40use Coro::Handle;
… …
52use Coro::Util (); 51use Coro::Util ();
53 52
54use JSON::XS 2.01 (); 53use JSON::XS 2.01 ();
55use BDB (); 54use BDB ();
56use Data::Dumper; 55use Data::Dumper;
57use Digest::MD5;
58use Fcntl; 56use Fcntl;
59use YAML::XS (); 57use YAML::XS ();
60use IO::AIO (); 58use IO::AIO ();
61use Time::HiRes; 59use Time::HiRes;
62use Compress::LZF; 60use Compress::LZF;
… …
78# strictly for debugging 76# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; 77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
80 78
81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
82 80
81our @ORIG_INC;
82
83our %COMMAND = (); 83our %COMMAND = ();
84our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
85 85
86our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
87our %EXTCMD = (); 87our %EXTCMD = ();
… …
93our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS 94our @REFLECT; # set by XS
95our %REFLECT; # set by us 95our %REFLECT; # set by us
96 96
97our $CONFDIR = confdir; 97our $CONFDIR = confdir;
98
98our $DATADIR = datadir; 99our $DATADIR = datadir;
99our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
100our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
101our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
103
102our $LOCALDIR = localdir; 104our $LOCALDIR = localdir;
103our $TMPDIR = "$LOCALDIR/" . tmpdir; 105our $TMPDIR = "$LOCALDIR/" . tmpdir;
104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 106our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
105our $PLAYERDIR = "$LOCALDIR/" . playerdir; 107our $PLAYERDIR = "$LOCALDIR/" . playerdir;
106our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
107our $BDBDIR = "$LOCALDIR/db"; 109our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid"; 110our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime"; 111our $RUNTIMEFILE = "$LOCALDIR/runtime";
110 112
111our %RESOURCE; 113our %RESOURCE; # unused
114
115our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000;
117
118our $MAX_LINKS = 32; # how many chained exits to follow
119our $VERBOSE_IO = 1;
112 120
113our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 121our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
114our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 122our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
115our $NEXT_TICK; 123our $NEXT_TICK;
116our $USE_FSYNC = 1; # use fsync to write maps - default on 124our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
118our $BDB_DEADLOCK_WATCHER; 126our $BDB_DEADLOCK_WATCHER;
119our $BDB_CHECKPOINT_WATCHER; 127our $BDB_CHECKPOINT_WATCHER;
120our $BDB_TRICKLE_WATCHER; 128our $BDB_TRICKLE_WATCHER;
121our $DB_ENV; 129our $DB_ENV;
122 130
123our @EXTRA_MODULES = qw(pod match mapscript); 131our @EXTRA_MODULES = qw(pod match mapscript incloader);
124 132
125our %CFG; 133our %CFG;
126 134
127our $UPTIME; $UPTIME ||= time; 135our $UPTIME; $UPTIME ||= time;
128our $RUNTIME; 136our $RUNTIME = 0;
137our $SERVER_TICK = 0;
129our $NOW; 138our $NOW;
130 139
131our (%PLAYER, %PLAYER_LOADING); # all users 140our (%PLAYER, %PLAYER_LOADING); # all users
132our (%MAP, %MAP_LOADING ); # all maps 141our (%MAP, %MAP_LOADING ); # all maps
133our $LINK_MAP; # the special {link} map, which is always available 142our $LINK_MAP; # the special {link} map, which is always available
… …
142 151
143our @POST_INIT; 152our @POST_INIT;
144 153
145our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) 154our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
146our $REALLY_UNLOOP; # never set to true, please :) 155our $REALLY_UNLOOP; # never set to true, please :)
156
157our $WAIT_FOR_TICK = new Coro::Signal;
158our @WAIT_FOR_TICK_BEGIN;
147 159
148binmode STDOUT; 160binmode STDOUT;
149binmode STDERR; 161binmode STDERR;
150 162
151# read virtual server time, if available 163# read virtual server time, if available
… …
162 174
163our $EMERGENCY_POSITION; 175our $EMERGENCY_POSITION;
164 176
165sub cf::map::normalise; 177sub cf::map::normalise;
166 178
179sub in_main() {
180 $Coro::current == $Coro::main
181}
182
167############################################################################# 183#############################################################################
168 184
169%REFLECT = (); 185%REFLECT = ();
170for (@REFLECT) { 186for (@REFLECT) {
171 my $reflect = JSON::XS::decode_json $_; 187 my $reflect = JSON::XS::decode_json $_;
… …
181 197
182=over 4 198=over 4
183 199
184=item $cf::UPTIME 200=item $cf::UPTIME
185 201
186The timestamp of the server start (so not actually an uptime). 202The timestamp of the server start (so not actually an "uptime").
203
204=item $cf::SERVER_TICK
205
206An unsigned integer that starts at zero when the server is started and is
207incremented on every tick.
208
209=item $cf::NOW
210
211The (real) time of the last (current) server tick - updated before and
212after tick processing, so this is useful only as a rough "what time is it
213now" estimate.
214
215=item $cf::TICK
216
217The interval between each server tick, in seconds.
187 218
188=item $cf::RUNTIME 219=item $cf::RUNTIME
189 220
190The time this server has run, starts at 0 and is increased by $cf::TICK on 221The time this server has run, starts at 0 and is increased by $cf::TICK on
191every server tick. 222every server tick.
… …
197Various directories - "/etc", read-only install directory, perl-library 228Various directories - "/etc", read-only install directory, perl-library
198directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 229directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
199unique-items directory, player file directory, random maps directory and 230unique-items directory, player file directory, random maps directory and
200database environment. 231database environment.
201 232
202=item $cf::NOW
203
204The time of the last (current) server tick.
205
206=item $cf::TICK
207
208The interval between server ticks, in seconds.
209
210=item $cf::LOADAVG 233=item $cf::LOADAVG
211 234
212The current CPU load on the server (alpha-smoothed), as a value between 0 235The current CPU load on the server (alpha-smoothed), as a value between 0
213(none) and 1 (overloaded), indicating how much time is spent on processing 236(none) and 1 (overloaded), indicating how much time is spent on processing
214objects per tick. Healthy values are < 0.5. 237objects per tick. Healthy values are < 0.5.
… …
223from wherever your confdir points to. 246from wherever your confdir points to.
224 247
225=item cf::wait_for_tick, cf::wait_for_tick_begin 248=item cf::wait_for_tick, cf::wait_for_tick_begin
226 249
227These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 250These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
228returns directly I<after> the tick processing (and consequently, can only wake one process 251returns directly I<after> the tick processing (and consequently, can only wake one thread
229per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 252per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
230 253
254Note that cf::Wait_for_tick will immediately return when the server is not
255ticking, making it suitable for small pauses in threads that need to run
256when the server is paused. If that is not applicable (i.e. you I<really>
257want to wait, use C<$cf::WAIT_FOR_TICK>).
258
259=item $cf::WAIT_FOR_TICK
260
261Note that C<cf::wait_for_tick> is probably the correct thing to use. This
262variable contains a L<Coro::Signal> that is broadcats after every server
263tick. Calling C<< ->wait >> on it will suspend the caller until after the
264next server tick.
265
266=cut
267
268sub wait_for_tick();
269sub wait_for_tick_begin();
270
231=item @cf::INVOKE_RESULTS 271=item @cf::INVOKE_RESULTS
232 272
233This array contains the results of the last C<invoke ()> call. When 273This array contains the results of the last C<invoke ()> call. When
234C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 274C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
235that call. 275that call.
236 276
237=item %cf::REFLECT 277=item %cf::REFLECT
238 278
… …
242 282
243=back 283=back
244 284
245=cut 285=cut
246 286
287sub error(@) { LOG llevError, join "", @_ }
288sub warn (@) { LOG llevWarn , join "", @_ }
289sub info (@) { LOG llevInfo , join "", @_ }
290sub debug(@) { LOG llevDebug, join "", @_ }
291sub trace(@) { LOG llevTrace, join "", @_ }
292
247$Coro::State::WARNHOOK = sub { 293$Coro::State::WARNHOOK = sub {
248 my $msg = join "", @_; 294 my $msg = join "", @_;
249 295
250 $msg .= "\n" 296 $msg .= "\n"
251 unless $msg =~ /\n$/; 297 unless $msg =~ /\n$/;
252 298
253 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 299 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
254 300
255 LOG llevError, $msg; 301 LOG llevWarn, $msg;
256}; 302};
257 303
258$Coro::State::DIEHOOK = sub { 304$Coro::State::DIEHOOK = sub {
259 return unless $^S eq 0; # "eq", not "==" 305 return unless $^S eq 0; # "eq", not "=="
260 306
261 warn Carp::longmess $_[0]; 307 error Carp::longmess $_[0];
262 308
263 if ($Coro::current == $Coro::main) {#d# 309 if (in_main) {#d#
264 warn "DIEHOOK called in main context, Coro bug?\n";#d# 310 error "DIEHOOK called in main context, Coro bug?\n";#d#
265 return;#d# 311 return;#d#
266 }#d# 312 }#d#
267 313
268 # kill coroutine otherwise 314 # kill coroutine otherwise
269 Coro::terminate 315 Coro::terminate
… …
289)) { 335)) {
290 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 336 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
291} 337}
292 338
293$EV::DIED = sub { 339$EV::DIED = sub {
294 warn "error in event callback: @_"; 340 Carp::cluck "error in event callback: @_";
295}; 341};
342
343#############################################################################
344
345sub fork_call(&@);
346sub get_slot($;$$);
296 347
297############################################################################# 348#############################################################################
298 349
299=head2 UTILITY FUNCTIONS 350=head2 UTILITY FUNCTIONS
300 351
… …
321 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 372 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
322 $d 373 $d
323 } || "[unable to dump $_[0]: '$@']"; 374 } || "[unable to dump $_[0]: '$@']";
324} 375}
325 376
377=item $scalar = load_file $path
378
379Loads the given file from path and returns its contents. Croaks on error
380and can block.
381
382=cut
383
384sub load_file($) {
385 0 <= aio_load $_[0], my $data
386 or Carp::croak "$_[0]: $!";
387
388 $data
389}
390
326=item $ref = cf::decode_json $json 391=item $ref = cf::decode_json $json
327 392
328Converts a JSON string into the corresponding perl data structure. 393Converts a JSON string into the corresponding perl data structure.
329 394
330=item $json = cf::encode_json $ref 395=item $json = cf::encode_json $ref
… …
336our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 401our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
337 402
338sub encode_json($) { $json_coder->encode ($_[0]) } 403sub encode_json($) { $json_coder->encode ($_[0]) }
339sub decode_json($) { $json_coder->decode ($_[0]) } 404sub decode_json($) { $json_coder->decode ($_[0]) }
340 405
406=item $ref = cf::decode_storable $scalar
407
408Same as Coro::Storable::thaw, so blocks.
409
410=cut
411
412BEGIN { *decode_storable = \&Coro::Storable::thaw }
413
414=item $ref = cf::decode_yaml $scalar
415
416Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
417
418=cut
419
420sub decode_yaml($) {
421 fork_call { YAML::XS::Load $_[0] } @_
422}
423
424=item $scalar = cf::unlzf $scalar
425
426Same as Compress::LZF::compress, but takes server ticks into account, so
427blocks.
428
429=cut
430
431sub unlzf($) {
432 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
433 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
434 Compress::LZF::decompress $_[0]
435}
436
341=item cf::post_init { BLOCK } 437=item cf::post_init { BLOCK }
342 438
343Execute the given codeblock, I<after> all extensions have been (re-)loaded, 439Execute the given codeblock, I<after> all extensions have been (re-)loaded,
344but I<before> the server starts ticking again. 440but I<before> the server starts ticking again.
345 441
346The cdoeblock will have a single boolean argument to indicate whether this 442The codeblock will have a single boolean argument to indicate whether this
347is a reload or not. 443is a reload or not.
348 444
349=cut 445=cut
350 446
351sub post_init(&) { 447sub post_init(&) {
352 push @POST_INIT, shift; 448 push @POST_INIT, shift;
449}
450
451sub _post_init {
452 trace "running post_init jobs";
453
454 # run them in parallel...
455
456 my @join;
457
458 while () {
459 push @join, map &Coro::async ($_, 0), @POST_INIT;
460 @POST_INIT = ();
461
462 @join or last;
463
464 (pop @join)->join;
465 }
353} 466}
354 467
355=item cf::lock_wait $string 468=item cf::lock_wait $string
356 469
357Wait until the given lock is available. See cf::lock_acquire. 470Wait until the given lock is available. See cf::lock_acquire.
… …
396} 509}
397 510
398=item cf::periodic $interval, $cb 511=item cf::periodic $interval, $cb
399 512
400Like EV::periodic, but randomly selects a starting point so that the actions 513Like EV::periodic, but randomly selects a starting point so that the actions
401get spread over timer. 514get spread over time.
402 515
403=cut 516=cut
404 517
405sub periodic($$) { 518sub periodic($$) {
406 my ($interval, $cb) = @_; 519 my ($interval, $cb) = @_;
… …
410 EV::periodic $start, $interval, 0, $cb 523 EV::periodic $start, $interval, 0, $cb
411} 524}
412 525
413=item cf::get_slot $time[, $priority[, $name]] 526=item cf::get_slot $time[, $priority[, $name]]
414 527
415Allocate $time seconds of blocking CPU time at priority C<$priority>: 528Allocate $time seconds of blocking CPU time at priority C<$priority>
416This call blocks and returns only when you have at least C<$time> seconds 529(default: 0): This call blocks and returns only when you have at least
417of cpu time till the next tick. The slot is only valid till the next cede. 530C<$time> seconds of cpu time till the next tick. The slot is only valid
531till the next cede.
532
533Background jobs should use a priority les than zero, interactive jobs
534should use 100 or more.
418 535
419The optional C<$name> can be used to identify the job to run. It might be 536The optional C<$name> can be used to identify the job to run. It might be
420used for statistical purposes and should identify the same time-class. 537used for statistical purposes and should identify the same time-class.
421 538
422Useful for short background jobs. 539Useful for short background jobs.
423 540
424=cut 541=cut
425 542
426our @SLOT_QUEUE; 543our @SLOT_QUEUE;
427our $SLOT_QUEUE; 544our $SLOT_QUEUE;
545our $SLOT_DECAY = 0.9;
428 546
429$SLOT_QUEUE->cancel if $SLOT_QUEUE; 547$SLOT_QUEUE->cancel if $SLOT_QUEUE;
430$SLOT_QUEUE = Coro::async { 548$SLOT_QUEUE = Coro::async {
431 $Coro::current->desc ("timeslot manager"); 549 $Coro::current->desc ("timeslot manager");
432 550
433 my $signal = new Coro::Signal; 551 my $signal = new Coro::Signal;
552 my $busy;
434 553
435 while () { 554 while () {
436 next_job: 555 next_job:
556
437 my $avail = cf::till_tick; 557 my $avail = cf::till_tick;
438 if ($avail > 0.01) { 558
439 for (0 .. $#SLOT_QUEUE) { 559 for (0 .. $#SLOT_QUEUE) {
440 if ($SLOT_QUEUE[$_][0] < $avail) { 560 if ($SLOT_QUEUE[$_][0] <= $avail) {
561 $busy = 0;
441 my $job = splice @SLOT_QUEUE, $_, 1, (); 562 my $job = splice @SLOT_QUEUE, $_, 1, ();
442 $job->[2]->send; 563 $job->[2]->send;
443 Coro::cede; 564 Coro::cede;
444 goto next_job; 565 goto next_job;
445 } 566 } else {
567 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
446 } 568 }
447 } 569 }
448 570
449 if (@SLOT_QUEUE) { 571 if (@SLOT_QUEUE) {
450 # we do not use wait_for_tick() as it returns immediately when tick is inactive 572 # we do not use wait_for_tick() as it returns immediately when tick is inactive
451 push @cf::WAIT_FOR_TICK, $signal; 573 $WAIT_FOR_TICK->wait;
452 $signal->wait;
453 } else { 574 } else {
575 $busy = 0;
454 Coro::schedule; 576 Coro::schedule;
455 } 577 }
456 } 578 }
457}; 579};
458 580
459sub get_slot($;$$) { 581sub get_slot($;$$) {
460 return if tick_inhibit || $Coro::current == $Coro::main; 582 return if tick_inhibit || $Coro::current == $Coro::main;
461 583
462 my ($time, $pri, $name) = @_; 584 my ($time, $pri, $name) = @_;
463 585
464 $time = $TICK * .6 if $time > $TICK * .6; 586 $time = clamp $time, 0.01, $TICK * .6;
587
465 my $sig = new Coro::Signal; 588 my $sig = new Coro::Signal;
466 589
467 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 590 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
468 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 591 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
469 $SLOT_QUEUE->ready; 592 $SLOT_QUEUE->ready;
… …
495=cut 618=cut
496 619
497sub sync_job(&) { 620sub sync_job(&) {
498 my ($job) = @_; 621 my ($job) = @_;
499 622
500 if ($Coro::current == $Coro::main) { 623 if (in_main) {
501 my $time = EV::time; 624 my $time = AE::time;
502 625
503 # this is the main coro, too bad, we have to block 626 # this is the main coro, too bad, we have to block
504 # till the operation succeeds, freezing the server :/ 627 # till the operation succeeds, freezing the server :/
505 628
506 LOG llevError, Carp::longmess "sync job";#d# 629 #LOG llevError, Carp::longmess "sync job";#d#
507 630
508 my $freeze_guard = freeze_mainloop; 631 my $freeze_guard = freeze_mainloop;
509 632
510 my $busy = 1; 633 my $busy = 1;
511 my @res; 634 my @res;
512 635
513 (async { 636 (async {
514 $Coro::current->desc ("sync job coro"); 637 $Coro::current->desc ("sync job coro");
515 @res = eval { $job->() }; 638 @res = eval { $job->() };
516 warn $@ if $@; 639 error $@ if $@;
517 undef $busy; 640 undef $busy;
518 })->prio (Coro::PRIO_MAX); 641 })->prio (Coro::PRIO_MAX);
519 642
520 while ($busy) { 643 while ($busy) {
521 if (Coro::nready) { 644 if (Coro::nready) {
… …
523 } else { 646 } else {
524 EV::loop EV::LOOP_ONESHOT; 647 EV::loop EV::LOOP_ONESHOT;
525 } 648 }
526 } 649 }
527 650
528 my $time = EV::time - $time; 651 my $time = AE::time - $time;
529 652
530 $TICK_START += $time; # do not account sync jobs to server load 653 $TICK_START += $time; # do not account sync jobs to server load
531 654
532 wantarray ? @res : $res[0] 655 wantarray ? @res : $res[0]
533 } else { 656 } else {
… …
555 $EXT_CORO{$coro+0} = $coro; 678 $EXT_CORO{$coro+0} = $coro;
556 679
557 $coro 680 $coro
558} 681}
559 682
560=item fork_call { }, $args 683=item fork_call { }, @args
561 684
562Executes the given code block with the given arguments in a seperate 685Executes the given code block with the given arguments in a seperate
563process, returning the results. Everything must be serialisable with 686process, returning the results. Everything must be serialisable with
564Coro::Storable. May, of course, block. Note that the executed sub may 687Coro::Storable. May, of course, block. Note that the executed sub may
565never block itself or use any form of event handling. 688never block itself or use any form of event handling.
566 689
567=cut 690=cut
568 691
692sub post_fork {
693 reset_signals;
694}
695
569sub fork_call(&@) { 696sub fork_call(&@) {
570 my ($cb, @args) = @_; 697 my ($cb, @args) = @_;
571 698
572 # we seemingly have to make a local copy of the whole thing, 699 # we seemingly have to make a local copy of the whole thing,
573 # otherwise perl prematurely frees the stuff :/ 700 # otherwise perl prematurely frees the stuff :/
574 # TODO: investigate and fix (likely this will be rather laborious) 701 # TODO: investigate and fix (likely this will be rather laborious)
575 702
576 my @res = Coro::Util::fork_eval { 703 my @res = Coro::Util::fork_eval {
577 reset_signals; 704 cf::post_fork;
578 &$cb 705 &$cb
579 }, @args; 706 } @args;
580 707
581 wantarray ? @res : $res[-1] 708 wantarray ? @res : $res[-1]
709}
710
711sub objinfo {
712 (
713 "counter value" => cf::object::object_count,
714 "objects created" => cf::object::create_count,
715 "objects destroyed" => cf::object::destroy_count,
716 "freelist size" => cf::object::free_count,
717 "allocated objects" => cf::object::objects_size,
718 "active objects" => cf::object::actives_size,
719 )
582} 720}
583 721
584=item $coin = coin_from_name $name 722=item $coin = coin_from_name $name
585 723
586=cut 724=cut
… …
623within each server. 761within each server.
624 762
625=cut 763=cut
626 764
627sub db_table($) { 765sub db_table($) {
766 cf::error "db_get called from main context"
767 if $Coro::current == $Coro::main;
768
628 my ($name) = @_; 769 my ($name) = @_;
629 my $db = BDB::db_create $DB_ENV; 770 my $db = BDB::db_create $DB_ENV;
630 771
631 eval { 772 eval {
632 $db->set_flags (BDB::CHKSUM); 773 $db->set_flags (BDB::CHKSUM);
… …
642} 783}
643 784
644our $DB; 785our $DB;
645 786
646sub db_init { 787sub db_init {
647 cf::sync_job {
648 $DB ||= db_table "db"; 788 $DB ||= db_table "db";
649 };
650} 789}
651 790
652sub db_get($$) { 791sub db_get($$) {
653 my $key = "$_[0]/$_[1]"; 792 my $key = "$_[0]/$_[1]";
654 793
655 cf::sync_job { 794 cf::error "db_get called from main context"
795 if $Coro::current == $Coro::main;
796
656 BDB::db_get $DB, undef, $key, my $data; 797 BDB::db_get $DB, undef, $key, my $data;
657 798
658 $! ? () 799 $! ? ()
659 : $data 800 : $data
660 }
661} 801}
662 802
663sub db_put($$$) { 803sub db_put($$$) {
664 BDB::dbreq_pri 4; 804 BDB::dbreq_pri 4;
665 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 805 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
693 833
694 my @data; 834 my @data;
695 my $md5; 835 my $md5;
696 836
697 for (0 .. $#$src) { 837 for (0 .. $#$src) {
698 0 <= aio_load $src->[$_], $data[$_] 838 $data[$_] = load_file $src->[$_];
699 or Carp::croak "$src->[$_]: $!";
700 } 839 }
701 840
702 # if processing is expensive, check 841 # if processing is expensive, check
703 # checksum first 842 # checksum first
704 if (1) { 843 if (1) {
… …
721 860
722 my $t1 = Time::HiRes::time; 861 my $t1 = Time::HiRes::time;
723 my $data = $process->(\@data); 862 my $data = $process->(\@data);
724 my $t2 = Time::HiRes::time; 863 my $t2 = Time::HiRes::time;
725 864
726 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 865 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
727 866
728 db_put cache => "$id/data", $data; 867 db_put cache => "$id/data", $data;
729 db_put cache => "$id/md5" , $md5; 868 db_put cache => "$id/md5" , $md5;
730 db_put cache => "$id/meta", $meta; 869 db_put cache => "$id/meta", $meta;
731 870
… …
741 880
742=cut 881=cut
743 882
744sub datalog($@) { 883sub datalog($@) {
745 my ($type, %kv) = @_; 884 my ($type, %kv) = @_;
746 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 885 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
747} 886}
748 887
749=back 888=back
750 889
751=cut 890=cut
… …
946 1085
947 } elsif (exists $cb_id{$type}) { 1086 } elsif (exists $cb_id{$type}) {
948 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1087 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
949 1088
950 } elsif (ref $type) { 1089 } elsif (ref $type) {
951 warn "attaching objects not supported, ignoring.\n"; 1090 error "attaching objects not supported, ignoring.\n";
952 1091
953 } else { 1092 } else {
954 shift @arg; 1093 shift @arg;
955 warn "attach argument '$type' not supported, ignoring.\n"; 1094 error "attach argument '$type' not supported, ignoring.\n";
956 } 1095 }
957 } 1096 }
958} 1097}
959 1098
960sub _object_attach { 1099sub _object_attach {
… …
970 _attach $registry, $klass, @attach; 1109 _attach $registry, $klass, @attach;
971 } 1110 }
972 1111
973 $obj->{$name} = \%arg; 1112 $obj->{$name} = \%arg;
974 } else { 1113 } else {
975 warn "object uses attachment '$name' which is not available, postponing.\n"; 1114 info "object uses attachment '$name' which is not available, postponing.\n";
976 } 1115 }
977 1116
978 $obj->{_attachment}{$name} = undef; 1117 $obj->{_attachment}{$name} = undef;
979} 1118}
980 1119
… …
1039 1178
1040 for (@$callbacks) { 1179 for (@$callbacks) {
1041 eval { &{$_->[1]} }; 1180 eval { &{$_->[1]} };
1042 1181
1043 if ($@) { 1182 if ($@) {
1044 warn "$@";
1045 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1183 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1046 override; 1184 override;
1047 } 1185 }
1048 1186
1049 return 1 if $override; 1187 return 1 if $override;
1050 } 1188 }
… …
1129 for (@$attach) { 1267 for (@$attach) {
1130 my ($klass, @attach) = @$_; 1268 my ($klass, @attach) = @$_;
1131 _attach $registry, $klass, @attach; 1269 _attach $registry, $klass, @attach;
1132 } 1270 }
1133 } else { 1271 } else {
1134 warn "object uses attachment '$name' that is not available, postponing.\n"; 1272 info "object uses attachment '$name' that is not available, postponing.\n";
1135 } 1273 }
1136 } 1274 }
1137} 1275}
1138 1276
1139cf::attachable->attach ( 1277cf::attachable->attach (
… …
1166 my ($filename, $rdata, $objs) = @_; 1304 my ($filename, $rdata, $objs) = @_;
1167 1305
1168 sync_job { 1306 sync_job {
1169 if (length $$rdata) { 1307 if (length $$rdata) {
1170 utf8::decode (my $decname = $filename); 1308 utf8::decode (my $decname = $filename);
1171 warn sprintf "saving %s (%d,%d)\n", 1309 trace sprintf "saving %s (%d,%d)\n",
1172 $decname, length $$rdata, scalar @$objs; 1310 $decname, length $$rdata, scalar @$objs
1311 if $VERBOSE_IO;
1173 1312
1174 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1313 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1175 aio_chmod $fh, SAVE_MODE; 1314 aio_chmod $fh, SAVE_MODE;
1176 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1315 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1177 if ($cf::USE_FSYNC) { 1316 if ($cf::USE_FSYNC) {
… …
1199 aio_rename "$filename~", $filename; 1338 aio_rename "$filename~", $filename;
1200 1339
1201 $filename =~ s%/[^/]+$%%; 1340 $filename =~ s%/[^/]+$%%;
1202 aio_pathsync $filename if $cf::USE_FSYNC; 1341 aio_pathsync $filename if $cf::USE_FSYNC;
1203 } else { 1342 } else {
1204 warn "unable to save objects: $filename~: $!\n"; 1343 error "unable to save objects: $filename~: $!\n";
1205 } 1344 }
1206 } else { 1345 } else {
1207 aio_unlink $filename; 1346 aio_unlink $filename;
1208 aio_unlink "$filename.pst"; 1347 aio_unlink "$filename.pst";
1209 } 1348 }
… …
1233 my $st = eval { Coro::Storable::thaw $av }; 1372 my $st = eval { Coro::Storable::thaw $av };
1234 $av = $st->{objs}; 1373 $av = $st->{objs};
1235 } 1374 }
1236 1375
1237 utf8::decode (my $decname = $filename); 1376 utf8::decode (my $decname = $filename);
1238 warn sprintf "loading %s (%d,%d)\n", 1377 trace sprintf "loading %s (%d,%d)\n",
1239 $decname, length $data, scalar @{$av || []}; 1378 $decname, length $data, scalar @{$av || []}
1379 if $VERBOSE_IO;
1240 1380
1241 ($data, $av) 1381 ($data, $av)
1242} 1382}
1243 1383
1244=head2 COMMAND CALLBACKS 1384=head2 COMMAND CALLBACKS
… …
1303} 1443}
1304 1444
1305use File::Glob (); 1445use File::Glob ();
1306 1446
1307cf::player->attach ( 1447cf::player->attach (
1308 on_command => sub { 1448 on_unknown_command => sub {
1309 my ($pl, $name, $params) = @_; 1449 my ($pl, $name, $params) = @_;
1310 1450
1311 my $cb = $COMMAND{$name} 1451 my $cb = $COMMAND{$name}
1312 or return; 1452 or return;
1313 1453
… …
1336 1476
1337 $pl->ext_reply ($reply, @reply) 1477 $pl->ext_reply ($reply, @reply)
1338 if $reply; 1478 if $reply;
1339 1479
1340 } else { 1480 } else {
1341 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1481 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1342 } 1482 }
1343 1483
1344 cf::override; 1484 cf::override;
1345 }, 1485 },
1346); 1486);
… …
1357 1497
1358 $grp 1498 $grp
1359} 1499}
1360 1500
1361sub load_extensions { 1501sub load_extensions {
1502 info "loading extensions...";
1503
1362 cf::sync_job { 1504 cf::sync_job {
1363 my %todo; 1505 my %todo;
1364 1506
1365 for my $path (<$LIBDIR/*.ext>) { 1507 for my $path (<$LIBDIR/*.ext>) {
1366 next unless -r $path; 1508 next unless -r $path;
… …
1384 1526
1385 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1527 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1386 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1528 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1387 1529
1388 $ext{source} = 1530 $ext{source} =
1389 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1531 "package $pkg; use common::sense;\n"
1390 . "#line 1 \"$path\"\n{\n" 1532 . "#line 1 \"$path\"\n{\n"
1391 . $source 1533 . $source
1392 . "\n};\n1"; 1534 . "\n};\n1";
1393 1535
1394 $todo{$base} = \%ext; 1536 $todo{$base} = \%ext;
1395 } 1537 }
1396 1538
1539 my $pass = 0;
1397 my %done; 1540 my %done;
1398 while (%todo) { 1541 while (%todo) {
1399 my $progress; 1542 my $progress;
1400 1543
1544 ++$pass;
1545
1546 ext:
1401 while (my ($k, $v) = each %todo) { 1547 while (my ($k, $v) = each %todo) {
1402 for (split /,\s*/, $v->{meta}{depends}) { 1548 for (split /,\s*/, $v->{meta}{depends}) {
1403 goto skip 1549 next ext
1404 unless exists $done{$_}; 1550 unless exists $done{$_};
1405 } 1551 }
1406 1552
1407 warn "... loading '$k' into '$v->{pkg}'\n"; 1553 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1408 1554
1409 unless (eval $v->{source}) { 1555 my $active = eval $v->{source};
1556
1557 if (length $@) {
1410 my $msg = $@ ? "$v->{path}: $@\n" 1558 error "$v->{path}: $@\n";
1411 : "$v->{base}: extension inactive.\n";
1412 1559
1413 if (exists $v->{meta}{mandatory}) {
1414 warn $msg;
1415 cf::cleanup "mandatory extension failed to load, exiting."; 1560 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1416 } 1561 if exists $v->{meta}{mandatory};
1417 1562
1418 warn $msg; 1563 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1564 delete $todo{$k};
1565 } else {
1566 $done{$k} = delete $todo{$k};
1567 push @EXTS, $v->{pkg};
1568 $progress = 1;
1569
1570 info "$v->{base}: extension inactive.\n"
1571 unless $active;
1419 } 1572 }
1420
1421 $done{$k} = delete $todo{$k};
1422 push @EXTS, $v->{pkg};
1423 $progress = 1;
1424 } 1573 }
1425 1574
1426 skip: 1575 unless ($progress) {
1427 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1576 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1428 unless $progress; 1577
1578 while (my ($k, $v) = each %todo) {
1579 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1580 if exists $v->{meta}{mandatory};
1581 }
1582
1583 last;
1584 }
1429 } 1585 }
1430 }; 1586 };
1431} 1587}
1432 1588
1433############################################################################# 1589#############################################################################
… …
1517 $cf::PLAYER{$login} = $pl 1673 $cf::PLAYER{$login} = $pl
1518 } 1674 }
1519 } 1675 }
1520} 1676}
1521 1677
1678cf::player->attach (
1679 on_load => sub {
1680 my ($pl, $path) = @_;
1681
1682 # restore slots saved in save, below
1683 my $slots = delete $pl->{_slots};
1684
1685 $pl->ob->current_weapon ($slots->[0]);
1686 $pl->combat_ob ($slots->[1]);
1687 $pl->ranged_ob ($slots->[2]);
1688 },
1689);
1690
1522sub save($) { 1691sub save($) {
1523 my ($pl) = @_; 1692 my ($pl) = @_;
1524 1693
1525 return if $pl->{deny_save}; 1694 return if $pl->{deny_save};
1526 1695
… …
1531 1700
1532 aio_mkdir playerdir $pl, 0770; 1701 aio_mkdir playerdir $pl, 0770;
1533 $pl->{last_save} = $cf::RUNTIME; 1702 $pl->{last_save} = $cf::RUNTIME;
1534 1703
1535 cf::get_slot 0.01; 1704 cf::get_slot 0.01;
1705
1706 # save slots, to be restored later
1707 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1536 1708
1537 $pl->save_pl ($path); 1709 $pl->save_pl ($path);
1538 cf::cede_to_tick; 1710 cf::cede_to_tick;
1539} 1711}
1540 1712
… …
1574 my $name = $pl->ob->name; 1746 my $name = $pl->ob->name;
1575 1747
1576 $pl->{deny_save} = 1; 1748 $pl->{deny_save} = 1;
1577 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1749 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1578 1750
1579 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1751 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1580 $pl->deactivate; 1752 $pl->deactivate;
1753
1581 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1754 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1582 $pl->ob->check_score;
1583 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1755 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1756 ext::highscore::check ($pl->ob);
1757
1584 $pl->ns->destroy if $pl->ns; 1758 $pl->ns->destroy if $pl->ns;
1585 1759
1586 my $path = playerdir $pl; 1760 my $path = playerdir $pl;
1587 my $temp = "$path~$cf::RUNTIME~deleting~"; 1761 my $temp = "$path~$cf::RUNTIME~deleting~";
1588 aio_rename $path, $temp; 1762 aio_rename $path, $temp;
… …
1642 \@logins 1816 \@logins
1643} 1817}
1644 1818
1645=item $player->maps 1819=item $player->maps
1646 1820
1821=item cf::player::maps $login
1822
1647Returns an arrayref of map paths that are private for this 1823Returns an arrayref of map paths that are private for this
1648player. May block. 1824player. May block.
1649 1825
1650=cut 1826=cut
1651 1827
… …
1713=cut 1889=cut
1714 1890
1715sub find_by_path($) { 1891sub find_by_path($) {
1716 my ($path) = @_; 1892 my ($path) = @_;
1717 1893
1894 $path =~ s/^~[^\/]*//; # skip ~login
1895
1718 my ($match, $specificity); 1896 my ($match, $specificity);
1719 1897
1720 for my $region (list) { 1898 for my $region (list) {
1721 if ($region->{match} && $path =~ $region->{match}) { 1899 if ($region->{match} && $path =~ $region->{match}) {
1722 ($match, $specificity) = ($region, $region->specificity) 1900 ($match, $specificity) = ($region, $region->specificity)
… …
1750sub generate_random_map { 1928sub generate_random_map {
1751 my ($self, $rmp) = @_; 1929 my ($self, $rmp) = @_;
1752 1930
1753 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1931 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1754 1932
1755 # mit "rum" bekleckern, nicht
1756 $self->_create_random_map ( 1933 $self->_create_random_map ($rmp);
1757 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1758 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1759 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1760 $rmp->{exit_on_final_map},
1761 $rmp->{xsize}, $rmp->{ysize},
1762 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1763 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1764 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1765 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1766 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1767 (cf::region::find $rmp->{region}), $rmp->{custom}
1768 )
1769} 1934}
1770 1935
1771=item cf::map->register ($regex, $prio) 1936=item cf::map->register ($regex, $prio)
1772 1937
1773Register a handler for the map path matching the given regex at the 1938Register a handler for the map path matching the given regex at the
… …
1778 1943
1779sub register { 1944sub register {
1780 my (undef, $regex, $prio) = @_; 1945 my (undef, $regex, $prio) = @_;
1781 my $pkg = caller; 1946 my $pkg = caller;
1782 1947
1783 no strict;
1784 push @{"$pkg\::ISA"}, __PACKAGE__; 1948 push @{"$pkg\::ISA"}, __PACKAGE__;
1785 1949
1786 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1950 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1787} 1951}
1788 1952
1789# also paths starting with '/' 1953# also paths starting with '/'
1790$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1954$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1791 1955
1792sub thawer_merge { 1956sub thawer_merge {
1793 my ($self, $merge) = @_; 1957 my ($self, $merge) = @_;
1794 1958
1795 # we have to keep some variables in memory intact 1959 # we have to keep some variables in memory intact
… …
1800} 1964}
1801 1965
1802sub normalise { 1966sub normalise {
1803 my ($path, $base) = @_; 1967 my ($path, $base) = @_;
1804 1968
1805 $path = "$path"; # make sure its a string 1969 $path = "$path"; # make sure it's a string
1806 1970
1807 $path =~ s/\.map$//; 1971 $path =~ s/\.map$//;
1808 1972
1809 # map plan: 1973 # map plan:
1810 # 1974 #
… …
1825 $base =~ s{[^/]+/?$}{}; 1989 $base =~ s{[^/]+/?$}{};
1826 $path = "$base/$path"; 1990 $path = "$base/$path";
1827 } 1991 }
1828 1992
1829 for ($path) { 1993 for ($path) {
1830 redo if s{//}{/};
1831 redo if s{/\.?/}{/}; 1994 redo if s{/\.?/}{/};
1832 redo if s{/[^/]+/\.\./}{/}; 1995 redo if s{/[^/]+/\.\./}{/};
1833 } 1996 }
1834 1997
1835 $path 1998 $path
… …
1849 $self->init; # pass $1 etc. 2012 $self->init; # pass $1 etc.
1850 return $self; 2013 return $self;
1851 } 2014 }
1852 } 2015 }
1853 2016
1854 Carp::cluck "unable to resolve path '$path' (base '$base')."; 2017 Carp::cluck "unable to resolve path '$path' (base '$base')";
1855 () 2018 ()
1856} 2019}
1857 2020
2021# may re-bless or do other evil things
1858sub init { 2022sub init {
1859 my ($self) = @_; 2023 my ($self) = @_;
1860 2024
1861 $self 2025 $self
1862} 2026}
… …
1927 $self->{load_path} = $path; 2091 $self->{load_path} = $path;
1928 2092
1929 1 2093 1
1930} 2094}
1931 2095
2096# used to laod the header of an original map
1932sub load_header_orig { 2097sub load_header_orig {
1933 my ($self) = @_; 2098 my ($self) = @_;
1934 2099
1935 $self->load_header_from ($self->load_path) 2100 $self->load_header_from ($self->load_path)
1936} 2101}
1937 2102
2103# used to laod the header of an instantiated map
1938sub load_header_temp { 2104sub load_header_temp {
1939 my ($self) = @_; 2105 my ($self) = @_;
1940 2106
1941 $self->load_header_from ($self->save_path) 2107 $self->load_header_from ($self->save_path)
1942} 2108}
1943 2109
2110# called after loading the header from an instantiated map
1944sub prepare_temp { 2111sub prepare_temp {
1945 my ($self) = @_; 2112 my ($self) = @_;
1946 2113
1947 $self->last_access ((delete $self->{last_access}) 2114 $self->last_access ((delete $self->{last_access})
1948 || $cf::RUNTIME); #d# 2115 || $cf::RUNTIME); #d#
1949 # safety 2116 # safety
1950 $self->{instantiate_time} = $cf::RUNTIME 2117 $self->{instantiate_time} = $cf::RUNTIME
1951 if $self->{instantiate_time} > $cf::RUNTIME; 2118 if $self->{instantiate_time} > $cf::RUNTIME;
1952} 2119}
1953 2120
2121# called after loading the header from an original map
1954sub prepare_orig { 2122sub prepare_orig {
1955 my ($self) = @_; 2123 my ($self) = @_;
1956 2124
1957 $self->{load_original} = 1; 2125 $self->{load_original} = 1;
1958 $self->{instantiate_time} = $cf::RUNTIME; 2126 $self->{instantiate_time} = $cf::RUNTIME;
… …
1982 2150
1983sub find; 2151sub find;
1984sub find { 2152sub find {
1985 my ($path, $origin) = @_; 2153 my ($path, $origin) = @_;
1986 2154
2155 cf::cede_to_tick;
2156
1987 $path = normalise $path, $origin && $origin->path; 2157 $path = normalise $path, $origin;
1988 2158
1989 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2159 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1990 my $guard2 = cf::lock_acquire "map_find:$path"; 2160 my $guard2 = cf::lock_acquire "map_find:$path";
1991 2161
1992 $cf::MAP{$path} || do { 2162 $cf::MAP{$path} || do {
… …
2009 2179
2010 $cf::MAP{$path} = $map 2180 $cf::MAP{$path} = $map
2011 } 2181 }
2012} 2182}
2013 2183
2014sub pre_load { } 2184sub pre_load { }
2015sub post_load { } 2185#sub post_load { } # XS
2016 2186
2017sub load { 2187sub load {
2018 my ($self) = @_; 2188 my ($self) = @_;
2019 2189
2020 local $self->{deny_reset} = 1; # loading can take a long time 2190 local $self->{deny_reset} = 1; # loading can take a long time
… …
2023 2193
2024 { 2194 {
2025 my $guard = cf::lock_acquire "map_data:$path"; 2195 my $guard = cf::lock_acquire "map_data:$path";
2026 2196
2027 return unless $self->valid; 2197 return unless $self->valid;
2028 return unless $self->in_memory == cf::MAP_SWAPPED; 2198 return unless $self->state == cf::MAP_SWAPPED;
2029
2030 $self->in_memory (cf::MAP_LOADING);
2031 2199
2032 $self->alloc; 2200 $self->alloc;
2033 2201
2034 $self->pre_load; 2202 $self->pre_load;
2035 cf::cede_to_tick; 2203 cf::cede_to_tick;
2036 2204
2205 if (exists $self->{load_path}) {
2037 my $f = new_from_file cf::object::thawer $self->{load_path}; 2206 my $f = new_from_file cf::object::thawer $self->{load_path};
2038 $f->skip_block; 2207 $f->skip_block;
2039 $self->_load_objects ($f) 2208 $self->_load_objects ($f)
2040 or return; 2209 or return;
2041 2210
2042 $self->post_load_original 2211 $self->post_load_original
2043 if delete $self->{load_original}; 2212 if delete $self->{load_original};
2044 2213
2045 if (my $uniq = $self->uniq_path) { 2214 if (my $uniq = $self->uniq_path) {
2046 utf8::encode $uniq; 2215 utf8::encode $uniq;
2047 unless (aio_stat $uniq) { 2216 unless (aio_stat $uniq) {
2048 if (my $f = new_from_file cf::object::thawer $uniq) { 2217 if (my $f = new_from_file cf::object::thawer $uniq) {
2049 $self->clear_unique_items; 2218 $self->clear_unique_items;
2050 $self->_load_objects ($f); 2219 $self->_load_objects ($f);
2051 $f->resolve_delayed_derefs; 2220 $f->resolve_delayed_derefs;
2221 }
2052 } 2222 }
2053 } 2223 }
2054 }
2055 2224
2056 $f->resolve_delayed_derefs; 2225 $f->resolve_delayed_derefs;
2226 } else {
2227 $self->post_load_original
2228 if delete $self->{load_original};
2229 }
2230
2231 $self->state (cf::MAP_INACTIVE);
2057 2232
2058 cf::cede_to_tick; 2233 cf::cede_to_tick;
2059 # now do the right thing for maps 2234 # now do the right thing for maps
2060 $self->link_multipart_objects; 2235 $self->link_multipart_objects;
2061 $self->difficulty ($self->estimate_difficulty) 2236 $self->difficulty ($self->estimate_difficulty)
… …
2064 2239
2065 unless ($self->{deny_activate}) { 2240 unless ($self->{deny_activate}) {
2066 $self->decay_objects; 2241 $self->decay_objects;
2067 $self->fix_auto_apply; 2242 $self->fix_auto_apply;
2068 $self->update_buttons; 2243 $self->update_buttons;
2244 $self->post_load_physics;
2069 cf::cede_to_tick; 2245 cf::cede_to_tick;
2070 $self->activate; 2246 #$self->activate; # no longer activate maps automatically
2071 } 2247 }
2072 2248
2073 $self->{last_save} = $cf::RUNTIME; 2249 $self->{last_save} = $cf::RUNTIME;
2074 $self->last_access ($cf::RUNTIME); 2250 $self->last_access ($cf::RUNTIME);
2075
2076 $self->in_memory (cf::MAP_ACTIVE);
2077 } 2251 }
2078 2252
2079 $self->post_load; 2253 $self->post_load;
2080}
2081 2254
2255 1
2256}
2257
2258# customize the map for a given player, i.e.
2259# return the _real_ map. used by e.g. per-player
2260# maps to change the path to ~playername/mappath
2082sub customise_for { 2261sub customise_for {
2083 my ($self, $ob) = @_; 2262 my ($self, $ob) = @_;
2084 2263
2085 return find "~" . $ob->name . "/" . $self->{path} 2264 return find "~" . $ob->name . "/" . $self->{path}
2086 if $self->per_player; 2265 if $self->per_player;
… …
2102 or next; 2281 or next;
2103 $neigh = find $neigh, $map 2282 $neigh = find $neigh, $map
2104 or next; 2283 or next;
2105 $neigh->load; 2284 $neigh->load;
2106 2285
2286 # now find the diagonal neighbours
2107 push @neigh, 2287 push @neigh,
2108 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2288 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2109 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2289 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2110 } 2290 }
2111 2291
… …
2118} 2298}
2119 2299
2120sub find_sync { 2300sub find_sync {
2121 my ($path, $origin) = @_; 2301 my ($path, $origin) = @_;
2122 2302
2123 cf::sync_job { find $path, $origin } 2303 # it's a bug to call this from the main context
2304 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2305 if $Coro::current == $Coro::main;
2306
2307 find $path, $origin
2124} 2308}
2125 2309
2126sub do_load_sync { 2310sub do_load_sync {
2127 my ($map) = @_; 2311 my ($map) = @_;
2128 2312
2313 # it's a bug to call this from the main context
2129 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2314 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2130 if $Coro::current == $Coro::main; 2315 if $Coro::current == $Coro::main;
2131 2316
2132 cf::sync_job { $map->load }; 2317 $map->load;
2133} 2318}
2134 2319
2135our %MAP_PREFETCH; 2320our %MAP_PREFETCH;
2136our $MAP_PREFETCHER = undef; 2321our $MAP_PREFETCHER = undef;
2137 2322
2138sub find_async { 2323sub find_async {
2139 my ($path, $origin, $load) = @_; 2324 my ($path, $origin, $load) = @_;
2140 2325
2141 $path = normalise $path, $origin && $origin->{path}; 2326 $path = normalise $path, $origin;
2142 2327
2143 if (my $map = $cf::MAP{$path}) { 2328 if (my $map = $cf::MAP{$path}) {
2144 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2329 return $map if !$load || $map->linkable;
2145 } 2330 }
2146 2331
2147 $MAP_PREFETCH{$path} |= $load; 2332 $MAP_PREFETCH{$path} |= $load;
2148 2333
2149 $MAP_PREFETCHER ||= cf::async { 2334 $MAP_PREFETCHER ||= cf::async {
… …
2163 $MAP_PREFETCHER->prio (6); 2348 $MAP_PREFETCHER->prio (6);
2164 2349
2165 () 2350 ()
2166} 2351}
2167 2352
2353# common code, used by both ->save and ->swapout
2168sub save { 2354sub _save {
2169 my ($self) = @_; 2355 my ($self) = @_;
2170
2171 my $lock = cf::lock_acquire "map_data:$self->{path}";
2172 2356
2173 $self->{last_save} = $cf::RUNTIME; 2357 $self->{last_save} = $cf::RUNTIME;
2174 2358
2175 return unless $self->dirty; 2359 return unless $self->dirty;
2176 2360
… …
2196 } else { 2380 } else {
2197 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2381 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2198 } 2382 }
2199} 2383}
2200 2384
2385sub save {
2386 my ($self) = @_;
2387
2388 my $lock = cf::lock_acquire "map_data:$self->{path}";
2389
2390 $self->_save;
2391}
2392
2201sub swap_out { 2393sub swap_out {
2202 my ($self) = @_; 2394 my ($self) = @_;
2203 2395
2204 # save first because save cedes
2205 $self->save;
2206
2207 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2396 my $lock = cf::lock_acquire "map_data:$self->{path}";
2208 2397
2398 return if !$self->linkable;
2399 return if $self->{deny_save};
2209 return if $self->players; 2400 return if $self->players;
2210 return if $self->in_memory != cf::MAP_ACTIVE; 2401
2402 # first deactivate the map and "unlink" it from the core
2403 $self->deactivate;
2404 $_->clear_links_to ($self) for values %cf::MAP;
2405 $self->state (cf::MAP_SWAPPED);
2406
2407 # then atomically save
2408 $self->_save;
2409
2410 # then free the map
2411 $self->clear;
2412}
2413
2414sub reset_at {
2415 my ($self) = @_;
2416
2417 # TODO: safety, remove and allow resettable per-player maps
2211 return if $self->{deny_save}; 2418 return 1e99 if $self->{deny_reset};
2212 2419
2420 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2421 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2422
2423 $time + $to
2424}
2425
2426sub should_reset {
2427 my ($self) = @_;
2428
2429 $self->reset_at <= $cf::RUNTIME
2430}
2431
2432sub reset {
2433 my ($self) = @_;
2434
2435 my $lock = cf::lock_acquire "map_data:$self->{path}";
2436
2437 return if $self->players;
2438
2439 cf::trace "resetting map ", $self->path, "\n";
2440
2213 $self->in_memory (cf::MAP_SWAPPED); 2441 $self->state (cf::MAP_SWAPPED);
2442
2443 # need to save uniques path
2444 unless ($self->{deny_save}) {
2445 my $uniq = $self->uniq_path; utf8::encode $uniq;
2446
2447 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2448 if $uniq;
2449 }
2450
2451 delete $cf::MAP{$self->path};
2214 2452
2215 $self->deactivate; 2453 $self->deactivate;
2216 $_->clear_links_to ($self) for values %cf::MAP; 2454 $_->clear_links_to ($self) for values %cf::MAP;
2217 $self->clear; 2455 $self->clear;
2218}
2219
2220sub reset_at {
2221 my ($self) = @_;
2222
2223 # TODO: safety, remove and allow resettable per-player maps
2224 return 1e99 if $self->{deny_reset};
2225
2226 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2227 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2228
2229 $time + $to
2230}
2231
2232sub should_reset {
2233 my ($self) = @_;
2234
2235 $self->reset_at <= $cf::RUNTIME
2236}
2237
2238sub reset {
2239 my ($self) = @_;
2240
2241 my $lock = cf::lock_acquire "map_data:$self->{path}";
2242
2243 return if $self->players;
2244
2245 warn "resetting map ", $self->path, "\n";
2246
2247 $self->in_memory (cf::MAP_SWAPPED);
2248
2249 # need to save uniques path
2250 unless ($self->{deny_save}) {
2251 my $uniq = $self->uniq_path; utf8::encode $uniq;
2252
2253 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2254 if $uniq;
2255 }
2256
2257 delete $cf::MAP{$self->path};
2258
2259 $self->deactivate;
2260 $_->clear_links_to ($self) for values %cf::MAP;
2261 $self->clear;
2262 2456
2263 $self->unlink_save; 2457 $self->unlink_save;
2264 $self->destroy; 2458 $self->destroy;
2265} 2459}
2266 2460
… …
2274 2468
2275 delete $cf::MAP{$self->path}; 2469 delete $cf::MAP{$self->path};
2276 2470
2277 $self->unlink_save; 2471 $self->unlink_save;
2278 2472
2279 bless $self, "cf::map"; 2473 bless $self, "cf::map::wrap";
2280 delete $self->{deny_reset}; 2474 delete $self->{deny_reset};
2281 $self->{deny_save} = 1; 2475 $self->{deny_save} = 1;
2282 $self->reset_timeout (1); 2476 $self->reset_timeout (1);
2283 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2477 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2284 2478
… …
2341 : normalise $_ 2535 : normalise $_
2342 } @{ aio_readdir $UNIQUEDIR or [] } 2536 } @{ aio_readdir $UNIQUEDIR or [] }
2343 ] 2537 ]
2344} 2538}
2345 2539
2540=item cf::map::static_maps
2541
2542Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2543file in the shared directory excluding F</styles> and F</editor>). May
2544block.
2545
2546=cut
2547
2548sub static_maps() {
2549 my @dirs = "";
2550 my @maps;
2551
2552 while (@dirs) {
2553 my $dir = shift @dirs;
2554
2555 next if $dir eq "/styles" || $dir eq "/editor";
2556
2557 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2558 or return;
2559
2560 for (@$files) {
2561 s/\.map$// or next;
2562 utf8::decode $_;
2563 push @maps, "$dir/$_";
2564 }
2565
2566 push @dirs, map "$dir/$_", @$dirs;
2567 }
2568
2569 \@maps
2570}
2571
2346=back 2572=back
2347 2573
2348=head3 cf::object 2574=head3 cf::object
2349 2575
2350=cut 2576=cut
… …
2482 2708
2483Freezes the player and moves him/her to a special map (C<{link}>). 2709Freezes the player and moves him/her to a special map (C<{link}>).
2484 2710
2485The player should be reasonably safe there for short amounts of time (e.g. 2711The player should be reasonably safe there for short amounts of time (e.g.
2486for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2712for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2487though, as the palyer cannot control the character while it is on the link 2713though, as the player cannot control the character while it is on the link
2488map. 2714map.
2489 2715
2490Will never block. 2716Will never block.
2491 2717
2492=item $player_object->leave_link ($map, $x, $y) 2718=item $player_object->leave_link ($map, $x, $y)
… …
2513sub cf::object::player::enter_link { 2739sub cf::object::player::enter_link {
2514 my ($self) = @_; 2740 my ($self) = @_;
2515 2741
2516 $self->deactivate_recursive; 2742 $self->deactivate_recursive;
2517 2743
2744 ++$self->{_link_recursion};
2745
2518 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2746 return if UNIVERSAL::isa $self->map, "ext::map_link";
2519 2747
2520 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2748 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2521 if $self->map && $self->map->{path} ne "{link}"; 2749 if $self->map && $self->map->{path} ne "{link}";
2522 2750
2523 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2751 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2524} 2752}
2525 2753
2526sub cf::object::player::leave_link { 2754sub cf::object::player::leave_link {
2527 my ($self, $map, $x, $y) = @_; 2755 my ($self, $map, $x, $y) = @_;
2528 2756
… …
2545 ($x, $y) = (-1, -1) 2773 ($x, $y) = (-1, -1)
2546 unless (defined $x) && (defined $y); 2774 unless (defined $x) && (defined $y);
2547 2775
2548 # use -1 or undef as default coordinates, not 0, 0 2776 # use -1 or undef as default coordinates, not 0, 0
2549 ($x, $y) = ($map->enter_x, $map->enter_y) 2777 ($x, $y) = ($map->enter_x, $map->enter_y)
2550 if $x <=0 && $y <= 0; 2778 if $x <= 0 && $y <= 0;
2551 2779
2552 $map->load; 2780 $map->load;
2553 $map->load_neighbours; 2781 $map->load_neighbours;
2554 2782
2555 return unless $self->contr->active; 2783 return unless $self->contr->active;
2556 2784
2557 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2785 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2558 $self->enter_map ($map, $x, $y); 2786 if ($self->enter_map ($map, $x, $y)) {
2559 2787 # entering was successful
2788 delete $self->{_link_recursion};
2560 # only activate afterwards, to support waiting in hooks 2789 # only activate afterwards, to support waiting in hooks
2561 $self->activate_recursive; 2790 $self->activate_recursive;
2562} 2791 }
2563 2792
2793}
2794
2564=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2795=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2565 2796
2566Moves the player to the given map-path and coordinates by first freezing 2797Moves the player to the given map-path and coordinates by first freezing
2567her, loading and preparing them map, calling the provided $check callback 2798her, loading and preparing them map, calling the provided $check callback
2568that has to return the map if sucecssful, and then unfreezes the player on 2799that has to return the map if sucecssful, and then unfreezes the player on
2569the new (success) or old (failed) map position. In either case, $done will 2800the new (success) or old (failed) map position. In either case, $done will
… …
2576 2807
2577our $GOTOGEN; 2808our $GOTOGEN;
2578 2809
2579sub cf::object::player::goto { 2810sub cf::object::player::goto {
2580 my ($self, $path, $x, $y, $check, $done) = @_; 2811 my ($self, $path, $x, $y, $check, $done) = @_;
2812
2813 if ($self->{_link_recursion} >= $MAX_LINKS) {
2814 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2815 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2816 ($path, $x, $y) = @$EMERGENCY_POSITION;
2817 }
2581 2818
2582 # do generation counting so two concurrent goto's will be executed in-order 2819 # do generation counting so two concurrent goto's will be executed in-order
2583 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2820 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2584 2821
2585 $self->enter_link; 2822 $self->enter_link;
… …
2605 ($path, $x, $y) = (undef, undef, undef); 2842 ($path, $x, $y) = (undef, undef, undef);
2606 } 2843 }
2607 } 2844 }
2608 2845
2609 my $map = eval { 2846 my $map = eval {
2610 my $map = defined $path ? cf::map::find $path : undef; 2847 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2611 2848
2612 if ($map) { 2849 if ($map) {
2613 $map = $map->customise_for ($self); 2850 $map = $map->customise_for ($self);
2614 $map = $check->($map) if $check && $map; 2851 $map = $check->($map, $x, $y, $self) if $check && $map;
2615 } else { 2852 } else {
2616 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2853 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2617 } 2854 }
2618 2855
2619 $map 2856 $map
… …
2627 if ($gen == $self->{_goto_generation}) { 2864 if ($gen == $self->{_goto_generation}) {
2628 delete $self->{_goto_generation}; 2865 delete $self->{_goto_generation};
2629 $self->leave_link ($map, $x, $y); 2866 $self->leave_link ($map, $x, $y);
2630 } 2867 }
2631 2868
2632 $done->() if $done; 2869 $done->($self) if $done;
2633 })->prio (1); 2870 })->prio (1);
2634} 2871}
2635 2872
2636=item $player_object->enter_exit ($exit_object) 2873=item $player_object->enter_exit ($exit_object)
2637 2874
… …
2705 $Coro::current->{desc} = "enter_exit"; 2942 $Coro::current->{desc} = "enter_exit";
2706 2943
2707 unless (eval { 2944 unless (eval {
2708 $self->deactivate_recursive; # just to be sure 2945 $self->deactivate_recursive; # just to be sure
2709 2946
2710 # random map handling
2711 {
2712 my $guard = cf::lock_acquire "exit_prepare:$exit";
2713
2714 prepare_random_map $exit
2715 if $exit->slaying eq "/!";
2716 }
2717
2718 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2947 my $map = cf::map::normalise $exit->slaying, $exit->map;
2719 my $x = $exit->stats->hp; 2948 my $x = $exit->stats->hp;
2720 my $y = $exit->stats->sp; 2949 my $y = $exit->stats->sp;
2950
2951 # special map handling
2952 my $slaying = $exit->slaying;
2953
2954 # special map handling
2955 if ($slaying eq "/!") {
2956 my $guard = cf::lock_acquire "exit_prepare:$exit";
2957
2958 prepare_random_map $exit
2959 if $exit->slaying eq "/!"; # need to re-check after getting the lock
2960
2961 $map = $exit->slaying;
2962
2963 } elsif ($slaying eq '!up') {
2964 $map = $exit->map->tile_path (cf::TILE_UP);
2965 $x = $exit->x;
2966 $y = $exit->y;
2967
2968 } elsif ($slaying eq '!down') {
2969 $map = $exit->map->tile_path (cf::TILE_DOWN);
2970 $x = $exit->x;
2971 $y = $exit->y;
2972 }
2721 2973
2722 $self->goto ($map, $x, $y); 2974 $self->goto ($map, $x, $y);
2723 2975
2724 # if exit is damned, update players death & WoR home-position 2976 # if exit is damned, update players death & WoR home-position
2725 $self->contr->savebed ($map, $x, $y) 2977 $self->contr->savebed ($map, $x, $y)
… …
2730 $self->message ("Something went wrong deep within the deliantra server. " 2982 $self->message ("Something went wrong deep within the deliantra server. "
2731 . "I'll try to bring you back to the map you were before. " 2983 . "I'll try to bring you back to the map you were before. "
2732 . "Please report this to the dungeon master!", 2984 . "Please report this to the dungeon master!",
2733 cf::NDI_UNIQUE | cf::NDI_RED); 2985 cf::NDI_UNIQUE | cf::NDI_RED);
2734 2986
2735 warn "ERROR in enter_exit: $@"; 2987 error "ERROR in enter_exit: $@";
2736 $self->leave_link; 2988 $self->leave_link;
2737 } 2989 }
2738 })->prio (1); 2990 })->prio (1);
2739} 2991}
2740 2992
… …
2752sub cf::client::send_drawinfo { 3004sub cf::client::send_drawinfo {
2753 my ($self, $text, $flags) = @_; 3005 my ($self, $text, $flags) = @_;
2754 3006
2755 utf8::encode $text; 3007 utf8::encode $text;
2756 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 3008 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
3009}
3010
3011=item $client->send_big_packet ($pkt)
3012
3013Like C<send_packet>, but tries to compress large packets, and fragments
3014them as required.
3015
3016=cut
3017
3018our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
3019
3020sub cf::client::send_big_packet {
3021 my ($self, $pkt) = @_;
3022
3023 # try lzf for large packets
3024 $pkt = "lzf " . Compress::LZF::compress $pkt
3025 if 1024 <= length $pkt and $self->{can_lzf};
3026
3027 # split very large packets
3028 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3029 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3030 $pkt = "frag";
3031 }
3032
3033 $self->send_packet ($pkt);
2757} 3034}
2758 3035
2759=item $client->send_msg ($channel, $msg, $color, [extra...]) 3036=item $client->send_msg ($channel, $msg, $color, [extra...])
2760 3037
2761Send a drawinfo or msg packet to the client, formatting the msg for the 3038Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2765 3042
2766=cut 3043=cut
2767 3044
2768# non-persistent channels (usually the info channel) 3045# non-persistent channels (usually the info channel)
2769our %CHANNEL = ( 3046our %CHANNEL = (
3047 "c/motd" => {
3048 id => "infobox",
3049 title => "MOTD",
3050 reply => undef,
3051 tooltip => "The message of the day",
3052 },
2770 "c/identify" => { 3053 "c/identify" => {
2771 id => "infobox", 3054 id => "infobox",
2772 title => "Identify", 3055 title => "Identify",
2773 reply => undef, 3056 reply => undef,
2774 tooltip => "Items recently identified", 3057 tooltip => "Items recently identified",
… …
2776 "c/examine" => { 3059 "c/examine" => {
2777 id => "infobox", 3060 id => "infobox",
2778 title => "Examine", 3061 title => "Examine",
2779 reply => undef, 3062 reply => undef,
2780 tooltip => "Signs and other items you examined", 3063 tooltip => "Signs and other items you examined",
3064 },
3065 "c/shopinfo" => {
3066 id => "infobox",
3067 title => "Shop Info",
3068 reply => undef,
3069 tooltip => "What your bargaining skill tells you about the shop",
2781 }, 3070 },
2782 "c/book" => { 3071 "c/book" => {
2783 id => "infobox", 3072 id => "infobox",
2784 title => "Book", 3073 title => "Book",
2785 reply => undef, 3074 reply => undef,
… …
2901 my $pkt = "msg " 3190 my $pkt = "msg "
2902 . $self->{json_coder}->encode ( 3191 . $self->{json_coder}->encode (
2903 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3192 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2904 ); 3193 );
2905 3194
2906 # try lzf for large packets
2907 $pkt = "lzf " . Compress::LZF::compress $pkt
2908 if 1024 <= length $pkt and $self->{can_lzf};
2909
2910 # split very large packets
2911 if (8192 < length $pkt and $self->{can_lzf}) {
2912 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2913 $pkt = "frag";
2914 }
2915
2916 $self->send_packet ($pkt); 3195 $self->send_big_packet ($pkt);
2917} 3196}
2918 3197
2919=item $client->ext_msg ($type, @msg) 3198=item $client->ext_msg ($type, @msg)
2920 3199
2921Sends an ext event to the client. 3200Sends an ext event to the client.
… …
2924 3203
2925sub cf::client::ext_msg($$@) { 3204sub cf::client::ext_msg($$@) {
2926 my ($self, $type, @msg) = @_; 3205 my ($self, $type, @msg) = @_;
2927 3206
2928 if ($self->extcmd == 2) { 3207 if ($self->extcmd == 2) {
2929 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3208 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2930 } elsif ($self->extcmd == 1) { # TODO: remove 3209 } elsif ($self->extcmd == 1) { # TODO: remove
2931 push @msg, msgtype => "event_$type"; 3210 push @msg, msgtype => "event_$type";
2932 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3211 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2933 } 3212 }
2934} 3213}
2935 3214
2936=item $client->ext_reply ($msgid, @msg) 3215=item $client->ext_reply ($msgid, @msg)
2937 3216
… …
2941 3220
2942sub cf::client::ext_reply($$@) { 3221sub cf::client::ext_reply($$@) {
2943 my ($self, $id, @msg) = @_; 3222 my ($self, $id, @msg) = @_;
2944 3223
2945 if ($self->extcmd == 2) { 3224 if ($self->extcmd == 2) {
2946 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3225 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2947 } elsif ($self->extcmd == 1) { 3226 } elsif ($self->extcmd == 1) {
2948 #TODO: version 1, remove 3227 #TODO: version 1, remove
2949 unshift @msg, msgtype => "reply", msgid => $id; 3228 unshift @msg, msgtype => "reply", msgid => $id;
2950 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3229 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2951 } 3230 }
2952} 3231}
2953 3232
2954=item $success = $client->query ($flags, "text", \&cb) 3233=item $success = $client->query ($flags, "text", \&cb)
2955 3234
… …
3026 3305
3027 $ns->ext_reply ($reply, @reply) 3306 $ns->ext_reply ($reply, @reply)
3028 if $reply; 3307 if $reply;
3029 3308
3030 } else { 3309 } else {
3031 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3310 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3032 } 3311 }
3033 3312
3034 cf::override; 3313 cf::override;
3035 }, 3314 },
3036); 3315);
… …
3056 3335
3057 $coro 3336 $coro
3058} 3337}
3059 3338
3060cf::client->attach ( 3339cf::client->attach (
3061 on_destroy => sub { 3340 on_client_destroy => sub {
3062 my ($ns) = @_; 3341 my ($ns) = @_;
3063 3342
3064 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3343 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3065 }, 3344 },
3066); 3345);
… …
3082our $safe_hole = new Safe::Hole; 3361our $safe_hole = new Safe::Hole;
3083 3362
3084$SIG{FPE} = 'IGNORE'; 3363$SIG{FPE} = 'IGNORE';
3085 3364
3086$safe->permit_only (Opcode::opset qw( 3365$safe->permit_only (Opcode::opset qw(
3087 :base_core :base_mem :base_orig :base_math 3366 :base_core :base_mem :base_orig :base_math :base_loop
3088 grepstart grepwhile mapstart mapwhile 3367 grepstart grepwhile mapstart mapwhile
3089 sort time 3368 sort time
3090)); 3369));
3091 3370
3092# here we export the classes and methods available to script code 3371# here we export the classes and methods available to script code
… …
3117 decrease split destroy change_exp value msg lore send_msg)], 3396 decrease split destroy change_exp value msg lore send_msg)],
3118 ["cf::object::player" => qw(player)], 3397 ["cf::object::player" => qw(player)],
3119 ["cf::player" => qw(peaceful send_msg)], 3398 ["cf::player" => qw(peaceful send_msg)],
3120 ["cf::map" => qw(trigger)], 3399 ["cf::map" => qw(trigger)],
3121) { 3400) {
3122 no strict 'refs';
3123 my ($pkg, @funs) = @$_; 3401 my ($pkg, @funs) = @$_;
3124 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3402 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3125 for @funs; 3403 for @funs;
3126} 3404}
3127 3405
… …
3144 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3422 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3145 $qcode =~ s/\n/\\n/g; 3423 $qcode =~ s/\n/\\n/g;
3146 3424
3147 %vars = (_dummy => 0) unless %vars; 3425 %vars = (_dummy => 0) unless %vars;
3148 3426
3427 my @res;
3149 local $_; 3428 local $_;
3150 local @safe::cf::_safe_eval_args = values %vars;
3151 3429
3152 my $eval = 3430 my $eval =
3153 "do {\n" 3431 "do {\n"
3154 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3432 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3155 . "#line 0 \"{$qcode}\"\n" 3433 . "#line 0 \"{$qcode}\"\n"
3156 . $code 3434 . $code
3157 . "\n}" 3435 . "\n}"
3158 ; 3436 ;
3159 3437
3438 if ($CFG{safe_eval}) {
3160 sub_generation_inc; 3439 sub_generation_inc;
3440 local @safe::cf::_safe_eval_args = values %vars;
3161 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3441 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3162 sub_generation_inc; 3442 sub_generation_inc;
3443 } else {
3444 local @cf::_safe_eval_args = values %vars;
3445 @res = wantarray ? eval eval : scalar eval $eval;
3446 }
3163 3447
3164 if ($@) { 3448 if ($@) {
3165 warn "$@"; 3449 warn "$@",
3166 warn "while executing safe code '$code'\n"; 3450 "while executing safe code '$code'\n",
3167 warn "with arguments " . (join " ", %vars) . "\n"; 3451 "with arguments " . (join " ", %vars) . "\n";
3168 } 3452 }
3169 3453
3170 wantarray ? @res : $res[0] 3454 wantarray ? @res : $res[0]
3171} 3455}
3172 3456
… …
3186=cut 3470=cut
3187 3471
3188sub register_script_function { 3472sub register_script_function {
3189 my ($fun, $cb) = @_; 3473 my ($fun, $cb) = @_;
3190 3474
3191 no strict 'refs'; 3475 $fun = "safe::$fun" if $CFG{safe_eval};
3192 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3476 *$fun = $safe_hole->wrap ($cb);
3193} 3477}
3194 3478
3195=back 3479=back
3196 3480
3197=cut 3481=cut
… …
3206 # for this (global event?) 3490 # for this (global event?)
3207 %ext::player_env::MUSIC_FACE_CACHE = (); 3491 %ext::player_env::MUSIC_FACE_CACHE = ();
3208 3492
3209 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3493 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3210 3494
3211 warn "loading facedata from $path\n"; 3495 trace "loading facedata from $path\n";
3212 3496
3213 my $facedata; 3497 my $facedata = decode_storable load_file $path;
3214 0 < aio_load $path, $facedata
3215 or die "$path: $!";
3216
3217 $facedata = Coro::Storable::thaw $facedata;
3218 3498
3219 $facedata->{version} == 2 3499 $facedata->{version} == 2
3220 or cf::cleanup "$path: version mismatch, cannot proceed."; 3500 or cf::cleanup "$path: version mismatch, cannot proceed.";
3221 3501
3222 # patch in the exptable 3502 # patch in the exptable
3503 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3223 $facedata->{resource}{"res/exp_table"} = { 3504 $facedata->{resource}{"res/exp_table"} = {
3224 type => FT_RSRC, 3505 type => FT_RSRC,
3225 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3506 data => $exp_table,
3507 hash => (Digest::MD5::md5 $exp_table),
3226 }; 3508 };
3227 cf::cede_to_tick; 3509 cf::cede_to_tick;
3228 3510
3229 { 3511 {
3230 my $faces = $facedata->{faceinfo}; 3512 my $faces = $facedata->{faceinfo};
… …
3232 while (my ($face, $info) = each %$faces) { 3514 while (my ($face, $info) = each %$faces) {
3233 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3515 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3234 3516
3235 cf::face::set_visibility $idx, $info->{visibility}; 3517 cf::face::set_visibility $idx, $info->{visibility};
3236 cf::face::set_magicmap $idx, $info->{magicmap}; 3518 cf::face::set_magicmap $idx, $info->{magicmap};
3237 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3519 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3238 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3520 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3521 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3239 3522
3240 cf::cede_to_tick; 3523 cf::cede_to_tick;
3241 } 3524 }
3242 3525
3243 while (my ($face, $info) = each %$faces) { 3526 while (my ($face, $info) = each %$faces) {
… …
3248 3531
3249 if (my $smooth = cf::face::find $info->{smooth}) { 3532 if (my $smooth = cf::face::find $info->{smooth}) {
3250 cf::face::set_smooth $idx, $smooth; 3533 cf::face::set_smooth $idx, $smooth;
3251 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3534 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3252 } else { 3535 } else {
3253 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3536 error "smooth face '$info->{smooth}' not found for face '$face'";
3254 } 3537 }
3255 3538
3256 cf::cede_to_tick; 3539 cf::cede_to_tick;
3257 } 3540 }
3258 } 3541 }
… …
3267 3550
3268 cf::anim::invalidate_all; # d'oh 3551 cf::anim::invalidate_all; # d'oh
3269 } 3552 }
3270 3553
3271 { 3554 {
3272 # TODO: for gcfclient pleasure, we should give resources
3273 # that gcfclient doesn't grok a >10000 face index.
3274 my $res = $facedata->{resource}; 3555 my $res = $facedata->{resource};
3275 3556
3276 while (my ($name, $info) = each %$res) { 3557 while (my ($name, $info) = each %$res) {
3277 if (defined $info->{type}) { 3558 if (defined $info->{type}) {
3278 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3559 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3279 my $data;
3280 3560
3281 if ($info->{type} & 1) { 3561 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3282 # prepend meta info
3283
3284 my $meta = $enc->encode ({
3285 name => $name,
3286 %{ $info->{meta} || {} },
3287 });
3288
3289 $data = pack "(w/a*)*", $meta, $info->{data};
3290 } else {
3291 $data = $info->{data};
3292 }
3293
3294 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3295 cf::face::set_type $idx, $info->{type}; 3562 cf::face::set_type $idx, $info->{type};
3296 } else { 3563 } else {
3297 $RESOURCE{$name} = $info; 3564 $RESOURCE{$name} = $info; # unused
3298 } 3565 }
3299 3566
3300 cf::cede_to_tick; 3567 cf::cede_to_tick;
3301 } 3568 }
3302 } 3569 }
3303 3570
3304 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3571 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3305 3572
3306 1 3573 1
3307} 3574}
3308
3309cf::global->attach (on_resource_update => sub {
3310 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3311 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3312
3313 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3314 my $sound = $soundconf->{compat}[$_]
3315 or next;
3316
3317 my $face = cf::face::find "sound/$sound->[1]";
3318 cf::sound::set $sound->[0] => $face;
3319 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3320 }
3321
3322 while (my ($k, $v) = each %{$soundconf->{event}}) {
3323 my $face = cf::face::find "sound/$v";
3324 cf::sound::set $k => $face;
3325 }
3326 }
3327});
3328 3575
3329register_exticmd fx_want => sub { 3576register_exticmd fx_want => sub {
3330 my ($ns, $want) = @_; 3577 my ($ns, $want) = @_;
3331 3578
3332 while (my ($k, $v) = each %$want) { 3579 while (my ($k, $v) = each %$want) {
… …
3371sub reload_treasures { 3618sub reload_treasures {
3372 load_resource_file "$DATADIR/treasures" 3619 load_resource_file "$DATADIR/treasures"
3373 or die "unable to load treasurelists\n"; 3620 or die "unable to load treasurelists\n";
3374} 3621}
3375 3622
3623sub reload_sound {
3624 trace "loading sound config from $DATADIR/sound\n";
3625
3626 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3627
3628 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3629 my $sound = $soundconf->{compat}[$_]
3630 or next;
3631
3632 my $face = cf::face::find "sound/$sound->[1]";
3633 cf::sound::set $sound->[0] => $face;
3634 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3635 }
3636
3637 while (my ($k, $v) = each %{$soundconf->{event}}) {
3638 my $face = cf::face::find "sound/$v";
3639 cf::sound::set $k => $face;
3640 }
3641}
3642
3376sub reload_resources { 3643sub reload_resources {
3377 warn "reloading resource files...\n"; 3644 trace "reloading resource files...\n";
3378 3645
3646 reload_exp_table;
3647 reload_materials;
3379 reload_facedata; 3648 reload_facedata;
3649 reload_sound;
3380 reload_archetypes; 3650 reload_archetypes;
3381 reload_regions; 3651 reload_regions;
3382 reload_treasures; 3652 reload_treasures;
3383 3653
3384 warn "finished reloading resource files\n"; 3654 trace "finished reloading resource files\n";
3385} 3655}
3386 3656
3387sub reload_config { 3657sub reload_config {
3388 warn "reloading config file...\n"; 3658 trace "reloading config file...\n";
3389 3659
3390 open my $fh, "<:utf8", "$CONFDIR/config" 3660 my $config = load_file "$CONFDIR/config";
3391 or return; 3661 utf8::decode $config;
3662 *CFG = decode_yaml $config;
3392 3663
3393 local $/;
3394 *CFG = YAML::XS::Load scalar <$fh>;
3395
3396 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3664 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3397 3665
3398 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3666 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3399 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3667 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3400 3668
3401 if (exists $CFG{mlockall}) { 3669 if (exists $CFG{mlockall}) {
… …
3403 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3671 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3404 and die "WARNING: m(un)lockall failed: $!\n"; 3672 and die "WARNING: m(un)lockall failed: $!\n";
3405 }; 3673 };
3406 warn $@ if $@; 3674 warn $@ if $@;
3407 } 3675 }
3408
3409 warn "finished reloading resource files\n";
3410} 3676}
3411 3677
3412sub pidfile() { 3678sub pidfile() {
3413 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3679 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3414 or die "$PIDFILE: $!"; 3680 or die "$PIDFILE: $!";
… …
3427 seek $fh, 0, 0; 3693 seek $fh, 0, 0;
3428 print $fh $$; 3694 print $fh $$;
3429} 3695}
3430 3696
3431sub main_loop { 3697sub main_loop {
3432 warn "EV::loop starting\n"; 3698 trace "EV::loop starting\n";
3433 if (1) { 3699 if (1) {
3434 EV::loop; 3700 EV::loop;
3435 } 3701 }
3436 warn "EV::loop returned\n"; 3702 trace "EV::loop returned\n";
3437 goto &main_loop unless $REALLY_UNLOOP; 3703 goto &main_loop unless $REALLY_UNLOOP;
3438} 3704}
3439 3705
3440sub main { 3706sub main {
3441 cf::init_globals; # initialise logging 3707 cf::init_globals; # initialise logging
3442 3708
3443 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3709 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3444 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3710 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3445 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3711 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3446 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3712 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3447
3448 cf::init_experience;
3449 cf::init_anim;
3450 cf::init_attackmess;
3451 cf::init_dynamic;
3452 3713
3453 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3714 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3454 3715
3455 # we must not ever block the main coroutine 3716 # we must not ever block the main coroutine
3456 local $Coro::idle = sub { 3717 local $Coro::idle = sub {
… …
3462 }; 3723 };
3463 3724
3464 evthread_start IO::AIO::poll_fileno; 3725 evthread_start IO::AIO::poll_fileno;
3465 3726
3466 cf::sync_job { 3727 cf::sync_job {
3728 cf::incloader::init ();
3729
3730 cf::init_anim;
3731 cf::init_attackmess;
3732 cf::init_dynamic;
3733
3734 cf::load_settings;
3735
3467 reload_resources; 3736 reload_resources;
3468 reload_config; 3737 reload_config;
3469 db_init; 3738 db_init;
3470 3739
3471 cf::load_settings;
3472 cf::load_materials;
3473 cf::init_uuid; 3740 cf::init_uuid;
3474 cf::init_signals; 3741 cf::init_signals;
3475 cf::init_commands;
3476 cf::init_skills; 3742 cf::init_skills;
3477 3743
3478 cf::init_beforeplay; 3744 cf::init_beforeplay;
3479 3745
3480 atomic; 3746 atomic;
… …
3485 3751
3486 # no (long-running) fork's whatsoever before this point(!) 3752 # no (long-running) fork's whatsoever before this point(!)
3487 use POSIX (); 3753 use POSIX ();
3488 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3754 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3489 3755
3490 (pop @POST_INIT)->(0) while @POST_INIT; 3756 cf::_post_init 0;
3491 }; 3757 };
3492 3758
3759 cf::object::thawer::errors_are_fatal 0;
3760 info "parse errors in files are no longer fatal from this point on.\n";
3761
3762 my $free_main; $free_main = EV::idle sub {
3763 undef $free_main;
3764 undef &main; # free gobs of memory :)
3765 };
3766
3493 main_loop; 3767 goto &main_loop;
3494} 3768}
3495 3769
3496############################################################################# 3770#############################################################################
3497# initialisation and cleanup 3771# initialisation and cleanup
3498 3772
3499# install some emergency cleanup handlers 3773# install some emergency cleanup handlers
3500BEGIN { 3774BEGIN {
3501 our %SIGWATCHER = (); 3775 our %SIGWATCHER = ();
3502 for my $signal (qw(INT HUP TERM)) { 3776 for my $signal (qw(INT HUP TERM)) {
3503 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3777 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3504 cf::cleanup "SIG$signal"; 3778 cf::cleanup "SIG$signal";
3505 }; 3779 };
3506 } 3780 }
3507} 3781}
3508 3782
3509sub write_runtime_sync { 3783sub write_runtime_sync {
3784 my $t0 = AE::time;
3785
3510 # first touch the runtime file to show we are still running: 3786 # first touch the runtime file to show we are still running:
3511 # the fsync below can take a very very long time. 3787 # the fsync below can take a very very long time.
3512 3788
3513 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3789 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3514 3790
3515 my $guard = cf::lock_acquire "write_runtime"; 3791 my $guard = cf::lock_acquire "write_runtime";
3516 3792
3517 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3793 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3518 or return; 3794 or return;
3519 3795
3520 my $value = $cf::RUNTIME + 90 + 10; 3796 my $value = $cf::RUNTIME + 90 + 10;
3521 # 10 is the runtime save interval, for a monotonic clock 3797 # 10 is the runtime save interval, for a monotonic clock
3522 # 60 allows for the watchdog to kill the server. 3798 # 60 allows for the watchdog to kill the server.
… …
3535 or return; 3811 or return;
3536 3812
3537 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3813 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3538 and return; 3814 and return;
3539 3815
3540 warn "runtime file written.\n"; 3816 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3541 3817
3542 1 3818 1
3543} 3819}
3544 3820
3545our $uuid_lock; 3821our $uuid_lock;
… …
3557 or return; 3833 or return;
3558 3834
3559 my $value = uuid_seq uuid_cur; 3835 my $value = uuid_seq uuid_cur;
3560 3836
3561 unless ($value) { 3837 unless ($value) {
3562 warn "cowardly refusing to write zero uuid value!\n"; 3838 info "cowardly refusing to write zero uuid value!\n";
3563 return; 3839 return;
3564 } 3840 }
3565 3841
3566 my $value = uuid_str $value + $uuid_skip; 3842 my $value = uuid_str $value + $uuid_skip;
3567 $uuid_skip = 0; 3843 $uuid_skip = 0;
… …
3577 or return; 3853 or return;
3578 3854
3579 aio_rename "$uuid~", $uuid 3855 aio_rename "$uuid~", $uuid
3580 and return; 3856 and return;
3581 3857
3582 warn "uuid file written ($value).\n"; 3858 trace "uuid file written ($value).\n";
3583 3859
3584 1 3860 1
3585 3861
3586} 3862}
3587 3863
… …
3593} 3869}
3594 3870
3595sub emergency_save() { 3871sub emergency_save() {
3596 my $freeze_guard = cf::freeze_mainloop; 3872 my $freeze_guard = cf::freeze_mainloop;
3597 3873
3598 warn "emergency_perl_save: enter\n"; 3874 info "emergency_perl_save: enter\n";
3875
3876 # this is a trade-off: we want to be very quick here, so
3877 # save all maps without fsync, and later call a global sync
3878 # (which in turn might be very very slow)
3879 local $USE_FSYNC = 0;
3599 3880
3600 cf::sync_job { 3881 cf::sync_job {
3601 # this is a trade-off: we want to be very quick here, so 3882 cf::write_runtime_sync; # external watchdog should not bark
3602 # save all maps without fsync, and later call a global sync
3603 # (which in turn might be very very slow)
3604 local $USE_FSYNC = 0;
3605 3883
3606 # use a peculiar iteration method to avoid tripping on perl 3884 # use a peculiar iteration method to avoid tripping on perl
3607 # refcount bugs in for. also avoids problems with players 3885 # refcount bugs in for. also avoids problems with players
3608 # and maps saved/destroyed asynchronously. 3886 # and maps saved/destroyed asynchronously.
3609 warn "emergency_perl_save: begin player save\n"; 3887 info "emergency_perl_save: begin player save\n";
3610 for my $login (keys %cf::PLAYER) { 3888 for my $login (keys %cf::PLAYER) {
3611 my $pl = $cf::PLAYER{$login} or next; 3889 my $pl = $cf::PLAYER{$login} or next;
3612 $pl->valid or next; 3890 $pl->valid or next;
3613 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3891 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3614 $pl->save; 3892 $pl->save;
3615 } 3893 }
3616 warn "emergency_perl_save: end player save\n"; 3894 info "emergency_perl_save: end player save\n";
3617 3895
3896 cf::write_runtime_sync; # external watchdog should not bark
3897
3618 warn "emergency_perl_save: begin map save\n"; 3898 info "emergency_perl_save: begin map save\n";
3619 for my $path (keys %cf::MAP) { 3899 for my $path (keys %cf::MAP) {
3620 my $map = $cf::MAP{$path} or next; 3900 my $map = $cf::MAP{$path} or next;
3621 $map->valid or next; 3901 $map->valid or next;
3622 $map->save; 3902 $map->save;
3623 } 3903 }
3624 warn "emergency_perl_save: end map save\n"; 3904 info "emergency_perl_save: end map save\n";
3625 3905
3906 cf::write_runtime_sync; # external watchdog should not bark
3907
3626 warn "emergency_perl_save: begin database checkpoint\n"; 3908 info "emergency_perl_save: begin database checkpoint\n";
3627 BDB::db_env_txn_checkpoint $DB_ENV; 3909 BDB::db_env_txn_checkpoint $DB_ENV;
3628 warn "emergency_perl_save: end database checkpoint\n"; 3910 info "emergency_perl_save: end database checkpoint\n";
3629 3911
3630 warn "emergency_perl_save: begin write uuid\n"; 3912 info "emergency_perl_save: begin write uuid\n";
3631 write_uuid_sync 1; 3913 write_uuid_sync 1;
3632 warn "emergency_perl_save: end write uuid\n"; 3914 info "emergency_perl_save: end write uuid\n";
3915
3916 cf::write_runtime_sync; # external watchdog should not bark
3917
3918 trace "emergency_perl_save: syncing database to disk";
3919 BDB::db_env_txn_checkpoint $DB_ENV;
3920
3921 info "emergency_perl_save: starting sync\n";
3922 IO::AIO::aio_sync sub {
3923 info "emergency_perl_save: finished sync\n";
3924 };
3925
3926 cf::write_runtime_sync; # external watchdog should not bark
3927
3928 trace "emergency_perl_save: flushing outstanding aio requests";
3929 while (IO::AIO::nreqs || BDB::nreqs) {
3930 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3931 }
3932
3933 cf::write_runtime_sync; # external watchdog should not bark
3633 }; 3934 };
3634 3935
3635 warn "emergency_perl_save: starting sync()\n";
3636 IO::AIO::aio_sync sub {
3637 warn "emergency_perl_save: finished sync()\n";
3638 };
3639
3640 warn "emergency_perl_save: leave\n"; 3936 info "emergency_perl_save: leave\n";
3641} 3937}
3642 3938
3643sub post_cleanup { 3939sub post_cleanup {
3644 my ($make_core) = @_; 3940 my ($make_core) = @_;
3645 3941
3942 IO::AIO::flush;
3943
3646 warn Carp::longmess "post_cleanup backtrace" 3944 error Carp::longmess "post_cleanup backtrace"
3647 if $make_core; 3945 if $make_core;
3648 3946
3649 my $fh = pidfile; 3947 my $fh = pidfile;
3650 unlink $PIDFILE if <$fh> == $$; 3948 unlink $PIDFILE if <$fh> == $$;
3651} 3949}
… …
3671 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3969 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3672 for my $name (keys %$leaf_symtab) { 3970 for my $name (keys %$leaf_symtab) {
3673 _gv_clear *{"$pkg$name"}; 3971 _gv_clear *{"$pkg$name"};
3674# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3972# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3675 } 3973 }
3676 warn "cleared package $pkg\n";#d#
3677} 3974}
3678 3975
3679sub do_reload_perl() { 3976sub do_reload_perl() {
3680 # can/must only be called in main 3977 # can/must only be called in main
3681 if ($Coro::current != $Coro::main) { 3978 unless (in_main) {
3682 warn "can only reload from main coroutine"; 3979 error "can only reload from main coroutine";
3683 return; 3980 return;
3684 } 3981 }
3685 3982
3686 return if $RELOAD++; 3983 return if $RELOAD++;
3687 3984
3688 my $t1 = EV::time; 3985 my $t1 = AE::time;
3689 3986
3690 while ($RELOAD) { 3987 while ($RELOAD) {
3691 warn "reloading..."; 3988 cf::get_slot 0.1, -1, "reload_perl";
3989 info "perl_reload: reloading...";
3692 3990
3693 warn "entering sync_job"; 3991 trace "perl_reload: entering sync_job";
3694 3992
3695 cf::sync_job { 3993 cf::sync_job {
3696 cf::write_runtime_sync; # external watchdog should not bark
3697 cf::emergency_save; 3994 #cf::emergency_save;
3698 cf::write_runtime_sync; # external watchdog should not bark
3699 3995
3700 warn "syncing database to disk";
3701 BDB::db_env_txn_checkpoint $DB_ENV;
3702
3703 # if anything goes wrong in here, we should simply crash as we already saved
3704
3705 warn "flushing outstanding aio requests";
3706 while (IO::AIO::nreqs || BDB::nreqs) {
3707 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3708 }
3709
3710 warn "cancelling all extension coros"; 3996 trace "perl_reload: cancelling all extension coros";
3711 $_->cancel for values %EXT_CORO; 3997 $_->cancel for values %EXT_CORO;
3712 %EXT_CORO = (); 3998 %EXT_CORO = ();
3713 3999
3714 warn "removing commands"; 4000 trace "perl_reload: removing commands";
3715 %COMMAND = (); 4001 %COMMAND = ();
3716 4002
3717 warn "removing ext/exti commands"; 4003 trace "perl_reload: removing ext/exti commands";
3718 %EXTCMD = (); 4004 %EXTCMD = ();
3719 %EXTICMD = (); 4005 %EXTICMD = ();
3720 4006
3721 warn "unloading/nuking all extensions"; 4007 trace "perl_reload: unloading/nuking all extensions";
3722 for my $pkg (@EXTS) { 4008 for my $pkg (@EXTS) {
3723 warn "... unloading $pkg"; 4009 trace "... unloading $pkg";
3724 4010
3725 if (my $cb = $pkg->can ("unload")) { 4011 if (my $cb = $pkg->can ("unload")) {
3726 eval { 4012 eval {
3727 $cb->($pkg); 4013 $cb->($pkg);
3728 1 4014 1
3729 } or warn "$pkg unloaded, but with errors: $@"; 4015 } or error "$pkg unloaded, but with errors: $@";
3730 } 4016 }
3731 4017
3732 warn "... clearing $pkg"; 4018 trace "... clearing $pkg";
3733 clear_package $pkg; 4019 clear_package $pkg;
3734 } 4020 }
3735 4021
3736 warn "unloading all perl modules loaded from $LIBDIR"; 4022 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3737 while (my ($k, $v) = each %INC) { 4023 while (my ($k, $v) = each %INC) {
3738 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4024 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3739 4025
3740 warn "... unloading $k"; 4026 trace "... unloading $k";
3741 delete $INC{$k}; 4027 delete $INC{$k};
3742 4028
3743 $k =~ s/\.pm$//; 4029 $k =~ s/\.pm$//;
3744 $k =~ s/\//::/g; 4030 $k =~ s/\//::/g;
3745 4031
… …
3748 } 4034 }
3749 4035
3750 clear_package $k; 4036 clear_package $k;
3751 } 4037 }
3752 4038
3753 warn "getting rid of safe::, as good as possible"; 4039 trace "perl_reload: getting rid of safe::, as good as possible";
3754 clear_package "safe::$_" 4040 clear_package "safe::$_"
3755 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4041 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3756 4042
3757 warn "unloading cf.pm \"a bit\""; 4043 trace "perl_reload: unloading cf.pm \"a bit\"";
3758 delete $INC{"cf.pm"}; 4044 delete $INC{"cf.pm"};
3759 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4045 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3760 4046
3761 # don't, removes xs symbols, too, 4047 # don't, removes xs symbols, too,
3762 # and global variables created in xs 4048 # and global variables created in xs
3763 #clear_package __PACKAGE__; 4049 #clear_package __PACKAGE__;
3764 4050
3765 warn "unload completed, starting to reload now"; 4051 info "perl_reload: unload completed, starting to reload now";
3766 4052
3767 warn "reloading cf.pm"; 4053 trace "perl_reload: reloading cf.pm";
3768 require cf; 4054 require cf;
3769 cf::_connect_to_perl_1; 4055 cf::_connect_to_perl_1;
3770 4056
3771 warn "loading config and database again"; 4057 trace "perl_reload: loading config and database again";
3772 cf::reload_config; 4058 cf::reload_config;
3773 4059
3774 warn "loading extensions"; 4060 trace "perl_reload: loading extensions";
3775 cf::load_extensions; 4061 cf::load_extensions;
3776 4062
3777 if ($REATTACH_ON_RELOAD) { 4063 if ($REATTACH_ON_RELOAD) {
3778 warn "reattaching attachments to objects/players"; 4064 trace "perl_reload: reattaching attachments to objects/players";
3779 _global_reattach; # objects, sockets 4065 _global_reattach; # objects, sockets
3780 warn "reattaching attachments to maps"; 4066 trace "perl_reload: reattaching attachments to maps";
3781 reattach $_ for values %MAP; 4067 reattach $_ for values %MAP;
3782 warn "reattaching attachments to players"; 4068 trace "perl_reload: reattaching attachments to players";
3783 reattach $_ for values %PLAYER; 4069 reattach $_ for values %PLAYER;
3784 } 4070 }
3785 4071
3786 warn "running post_init jobs"; 4072 cf::_post_init 1;
3787 (pop @POST_INIT)->(1) while @POST_INIT;
3788 4073
3789 warn "leaving sync_job"; 4074 trace "perl_reload: leaving sync_job";
3790 4075
3791 1 4076 1
3792 } or do { 4077 } or do {
3793 warn $@; 4078 error $@;
3794 cf::cleanup "error while reloading, exiting."; 4079 cf::cleanup "perl_reload: error, exiting.";
3795 }; 4080 };
3796 4081
3797 warn "reloaded";
3798 --$RELOAD; 4082 --$RELOAD;
3799 } 4083 }
3800 4084
3801 $t1 = EV::time - $t1; 4085 $t1 = AE::time - $t1;
3802 warn "reload completed in ${t1}s\n"; 4086 info "perl_reload: completed in ${t1}s\n";
3803}; 4087};
3804 4088
3805our $RELOAD_WATCHER; # used only during reload 4089our $RELOAD_WATCHER; # used only during reload
3806 4090
3807sub reload_perl() { 4091sub reload_perl() {
… …
3809 # coro crashes during coro_state_free->destroy here. 4093 # coro crashes during coro_state_free->destroy here.
3810 4094
3811 $RELOAD_WATCHER ||= cf::async { 4095 $RELOAD_WATCHER ||= cf::async {
3812 Coro::AIO::aio_wait cache_extensions; 4096 Coro::AIO::aio_wait cache_extensions;
3813 4097
3814 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 4098 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3815 do_reload_perl; 4099 do_reload_perl;
3816 undef $RELOAD_WATCHER; 4100 undef $RELOAD_WATCHER;
3817 }; 4101 };
3818 }; 4102 };
3819} 4103}
… …
3828 reload_perl; 4112 reload_perl;
3829 }; 4113 };
3830 } 4114 }
3831}; 4115};
3832 4116
3833unshift @INC, $LIBDIR; 4117#############################################################################
3834 4118
3835my $bug_warning = 0; 4119my $bug_warning = 0;
3836 4120
3837our @WAIT_FOR_TICK;
3838our @WAIT_FOR_TICK_BEGIN;
3839
3840sub wait_for_tick { 4121sub wait_for_tick() {
3841 return if tick_inhibit || $Coro::current == $Coro::main; 4122 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3842 4123
3843 my $signal = new Coro::Signal; 4124 $WAIT_FOR_TICK->wait;
3844 push @WAIT_FOR_TICK, $signal;
3845 $signal->wait;
3846} 4125}
3847 4126
3848sub wait_for_tick_begin { 4127sub wait_for_tick_begin() {
3849 return if tick_inhibit || $Coro::current == $Coro::main; 4128 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3850 4129
3851 my $signal = new Coro::Signal; 4130 my $signal = new Coro::Signal;
3852 push @WAIT_FOR_TICK_BEGIN, $signal; 4131 push @WAIT_FOR_TICK_BEGIN, $signal;
3853 $signal->wait; 4132 $signal->wait;
3854} 4133}
… …
3858 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4137 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3859 unless ++$bug_warning > 10; 4138 unless ++$bug_warning > 10;
3860 return; 4139 return;
3861 } 4140 }
3862 4141
3863 cf::server_tick; # one server iteration 4142 cf::one_tick; # one server iteration
4143
4144 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3864 4145
3865 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4146 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3866 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4147 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3867 Coro::async_pool { 4148 Coro::async_pool {
3868 $Coro::current->{desc} = "runtime saver"; 4149 $Coro::current->{desc} = "runtime saver";
3869 write_runtime_sync 4150 write_runtime_sync
3870 or warn "ERROR: unable to write runtime file: $!"; 4151 or error "ERROR: unable to write runtime file: $!";
3871 }; 4152 };
3872 } 4153 }
3873 4154
3874 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4155 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3875 $sig->send; 4156 $sig->send;
3876 } 4157 }
3877 while (my $sig = shift @WAIT_FOR_TICK) { 4158 $WAIT_FOR_TICK->broadcast;
3878 $sig->send;
3879 }
3880 4159
3881 $LOAD = ($NOW - $TICK_START) / $TICK; 4160 $LOAD = ($NOW - $TICK_START) / $TICK;
3882 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4161 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3883 4162
3884 if (0) { 4163 if (0) {
3885 if ($NEXT_TICK) { 4164 if ($NEXT_TICK) {
3886 my $jitter = $TICK_START - $NEXT_TICK; 4165 my $jitter = $TICK_START - $NEXT_TICK;
3887 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4166 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3888 warn "jitter $JITTER\n";#d# 4167 debug "jitter $JITTER\n";#d#
3889 } 4168 }
3890 } 4169 }
3891} 4170}
3892 4171
3893{ 4172{
3894 # configure BDB 4173 # configure BDB
3895 4174
3896 BDB::min_parallel 8; 4175 BDB::min_parallel 16;
3897 BDB::max_poll_reqs $TICK * 0.1; 4176 BDB::max_poll_reqs $TICK * 0.1;
3898 $AnyEvent::BDB::WATCHER->priority (1); 4177 $AnyEvent::BDB::WATCHER->priority (1);
3899 4178
3900 unless ($DB_ENV) { 4179 unless ($DB_ENV) {
3901 $DB_ENV = BDB::db_env_create; 4180 $DB_ENV = BDB::db_env_create;
… …
3938 IO::AIO::min_parallel 8; 4217 IO::AIO::min_parallel 8;
3939 IO::AIO::max_poll_time $TICK * 0.1; 4218 IO::AIO::max_poll_time $TICK * 0.1;
3940 undef $AnyEvent::AIO::WATCHER; 4219 undef $AnyEvent::AIO::WATCHER;
3941} 4220}
3942 4221
3943my $_log_backtrace; 4222our $_log_backtrace;
4223our $_log_backtrace_last;
3944 4224
3945sub _log_backtrace { 4225sub _log_backtrace {
3946 my ($msg, @addr) = @_; 4226 my ($msg, @addr) = @_;
3947 4227
3948 $msg =~ s/\n//; 4228 $msg =~ s/\n$//;
3949 4229
4230 if ($_log_backtrace_last eq $msg) {
4231 LOG llevInfo, "[ABT] $msg\n";
4232 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3950 # limit the # of concurrent backtraces 4233 # limit the # of concurrent backtraces
3951 if ($_log_backtrace < 2) { 4234 } elsif ($_log_backtrace < 2) {
4235 $_log_backtrace_last = $msg;
3952 ++$_log_backtrace; 4236 ++$_log_backtrace;
3953 my $perl_bt = Carp::longmess $msg; 4237 my $perl_bt = Carp::longmess $msg;
3954 async { 4238 async {
3955 $Coro::current->{desc} = "abt $msg"; 4239 $Coro::current->{desc} = "abt $msg";
3956 4240
… …
3976 LOG llevInfo, "[ABT] $_\n" for @bt; 4260 LOG llevInfo, "[ABT] $_\n" for @bt;
3977 --$_log_backtrace; 4261 --$_log_backtrace;
3978 }; 4262 };
3979 } else { 4263 } else {
3980 LOG llevInfo, "[ABT] $msg\n"; 4264 LOG llevInfo, "[ABT] $msg\n";
3981 LOG llevInfo, "[ABT] [suppressed]\n"; 4265 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3982 } 4266 }
3983} 4267}
3984 4268
3985# load additional modules 4269# load additional modules
3986require "cf/$_.pm" for @EXTRA_MODULES; 4270require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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