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.484 by root, Mon Oct 12 14:00:58 2009 UTC vs.
Revision 1.590 by root, Sun Nov 4 02:20:11 2012 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify it under 6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the 7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your 8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the Affero GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>. 18# <http://www.gnu.org/licenses/>.
19# 19#
20# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
21# 21#
22 22
23package cf; 23package cf;
24 24
25use 5.10.0; 25use common::sense;
26use utf8;
27use strict qw(vars subs);
28 26
29use Symbol; 27use Symbol;
30use List::Util; 28use List::Util;
31use Socket; 29use Socket;
32use EV; 30use EV;
33use Opcode; 31use Opcode;
34use Safe; 32use Safe;
35use Safe::Hole; 33use Safe::Hole;
36use Storable (); 34use Storable ();
37
38use Guard (); 35use Carp ();
36
37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
40
39use Coro (); 41use Coro ();
40use Coro::State; 42use Coro::State;
41use Coro::Handle; 43use Coro::Handle;
42use Coro::EV; 44use Coro::EV;
43use Coro::AnyEvent; 45use Coro::AnyEvent;
… …
49use Coro::AIO; 51use Coro::AIO;
50use Coro::BDB 1.6; 52use Coro::BDB 1.6;
51use Coro::Storable; 53use Coro::Storable;
52use Coro::Util (); 54use Coro::Util ();
53 55
56use Guard ();
54use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
55use BDB (); 58use BDB ();
56use Data::Dumper; 59use Data::Dumper;
57use Digest::MD5;
58use Fcntl; 60use Fcntl;
59use YAML::XS (); 61use YAML::XS ();
60use IO::AIO (); 62use IO::AIO ();
61use Time::HiRes; 63use Time::HiRes;
62use Compress::LZF; 64use Compress::LZF;
… …
78# strictly for debugging 80# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; 81$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
80 82
81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 83sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
82 84
85our @ORIG_INC;
86
83our %COMMAND = (); 87our %COMMAND = ();
84our %COMMAND_TIME = (); 88our %COMMAND_TIME = ();
85 89
86our @EXTS = (); # list of extension package names 90our @EXTS = (); # list of extension package names
87our %EXTCMD = (); 91our %EXTCMD = ();
… …
93our @EVENT; 97our @EVENT;
94our @REFLECT; # set by XS 98our @REFLECT; # set by XS
95our %REFLECT; # set by us 99our %REFLECT; # set by us
96 100
97our $CONFDIR = confdir; 101our $CONFDIR = confdir;
102
98our $DATADIR = datadir; 103our $DATADIR = datadir;
99our $LIBDIR = "$DATADIR/ext"; 104our $LIBDIR = "$DATADIR/ext";
100our $PODDIR = "$DATADIR/pod"; 105our $PODDIR = "$DATADIR/pod";
101our $MAPDIR = "$DATADIR/" . mapdir; 106our $MAPDIR = "$DATADIR/" . mapdir;
107
102our $LOCALDIR = localdir; 108our $LOCALDIR = localdir;
103our $TMPDIR = "$LOCALDIR/" . tmpdir; 109our $TMPDIR = "$LOCALDIR/" . tmpdir;
104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 110our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
105our $PLAYERDIR = "$LOCALDIR/" . playerdir; 111our $PLAYERDIR = "$LOCALDIR/" . playerdir;
106our $RANDOMDIR = "$LOCALDIR/random"; 112our $RANDOMDIR = "$LOCALDIR/random";
107our $BDBDIR = "$LOCALDIR/db"; 113our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid"; 114our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime"; 115our $RUNTIMEFILE = "$LOCALDIR/runtime";
110 116
111our %RESOURCE; 117#our %RESOURCE; # unused
118
119our $OUTPUT_RATE_MIN = 3000;
120our $OUTPUT_RATE_MAX = 1000000;
121
122our $MAX_LINKS = 32; # how many chained exits to follow
123our $VERBOSE_IO = 1;
112 124
113our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 125our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
114our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 126our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
115our $NEXT_TICK; 127our $NEXT_TICK;
116our $USE_FSYNC = 1; # use fsync to write maps - default on 128our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
118our $BDB_DEADLOCK_WATCHER; 130our $BDB_DEADLOCK_WATCHER;
119our $BDB_CHECKPOINT_WATCHER; 131our $BDB_CHECKPOINT_WATCHER;
120our $BDB_TRICKLE_WATCHER; 132our $BDB_TRICKLE_WATCHER;
121our $DB_ENV; 133our $DB_ENV;
122 134
123our @EXTRA_MODULES = qw(pod match mapscript); 135our @EXTRA_MODULES = qw(pod match mapscript incloader);
124 136
125our %CFG; 137our %CFG;
138our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
126 139
127our $UPTIME; $UPTIME ||= time; 140our $UPTIME; $UPTIME ||= time;
128our $RUNTIME; 141our $RUNTIME = 0;
142our $SERVER_TICK = 0;
129our $NOW; 143our $NOW;
130 144
131our (%PLAYER, %PLAYER_LOADING); # all users 145our (%PLAYER, %PLAYER_LOADING); # all users
132our (%MAP, %MAP_LOADING ); # all maps 146our (%MAP, %MAP_LOADING ); # all maps
133our $LINK_MAP; # the special {link} map, which is always available 147our $LINK_MAP; # the special {link} map, which is always available
… …
142 156
143our @POST_INIT; 157our @POST_INIT;
144 158
145our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) 159our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
146our $REALLY_UNLOOP; # never set to true, please :) 160our $REALLY_UNLOOP; # never set to true, please :)
161
162our $WAIT_FOR_TICK = new Coro::Signal;
163our @WAIT_FOR_TICK_BEGIN;
147 164
148binmode STDOUT; 165binmode STDOUT;
149binmode STDERR; 166binmode STDERR;
150 167
151# read virtual server time, if available 168# read virtual server time, if available
… …
162 179
163our $EMERGENCY_POSITION; 180our $EMERGENCY_POSITION;
164 181
165sub cf::map::normalise; 182sub cf::map::normalise;
166 183
184sub in_main() {
185 $Coro::current == $Coro::main
186}
187
167############################################################################# 188#############################################################################
168 189
169%REFLECT = (); 190%REFLECT = ();
170for (@REFLECT) { 191for (@REFLECT) {
171 my $reflect = JSON::XS::decode_json $_; 192 my $reflect = JSON::XS::decode_json $_;
… …
181 202
182=over 4 203=over 4
183 204
184=item $cf::UPTIME 205=item $cf::UPTIME
185 206
186The timestamp of the server start (so not actually an uptime). 207The timestamp of the server start (so not actually an "uptime").
208
209=item $cf::SERVER_TICK
210
211An unsigned integer that starts at zero when the server is started and is
212incremented on every tick.
213
214=item $cf::NOW
215
216The (real) time of the last (current) server tick - updated before and
217after tick processing, so this is useful only as a rough "what time is it
218now" estimate.
219
220=item $cf::TICK
221
222The interval between each server tick, in seconds.
187 223
188=item $cf::RUNTIME 224=item $cf::RUNTIME
189 225
190The time this server has run, starts at 0 and is increased by $cf::TICK on 226The time this server has run, starts at 0 and is increased by $cf::TICK on
191every server tick. 227every server tick.
… …
197Various directories - "/etc", read-only install directory, perl-library 233Various directories - "/etc", read-only install directory, perl-library
198directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 234directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
199unique-items directory, player file directory, random maps directory and 235unique-items directory, player file directory, random maps directory and
200database environment. 236database environment.
201 237
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 238=item $cf::LOADAVG
211 239
212The current CPU load on the server (alpha-smoothed), as a value between 0 240The 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 241(none) and 1 (overloaded), indicating how much time is spent on processing
214objects per tick. Healthy values are < 0.5. 242objects per tick. Healthy values are < 0.5.
… …
223from wherever your confdir points to. 251from wherever your confdir points to.
224 252
225=item cf::wait_for_tick, cf::wait_for_tick_begin 253=item cf::wait_for_tick, cf::wait_for_tick_begin
226 254
227These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 255These 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 256returns 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. 257per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
230 258
259Note that cf::Wait_for_tick will immediately return when the server is not
260ticking, making it suitable for small pauses in threads that need to run
261when the server is paused. If that is not applicable (i.e. you I<really>
262want to wait, use C<$cf::WAIT_FOR_TICK>).
263
264=item $cf::WAIT_FOR_TICK
265
266Note that C<cf::wait_for_tick> is probably the correct thing to use. This
267variable contains a L<Coro::Signal> that is broadcats after every server
268tick. Calling C<< ->wait >> on it will suspend the caller until after the
269next server tick.
270
271=cut
272
273sub wait_for_tick();
274sub wait_for_tick_begin();
275
231=item @cf::INVOKE_RESULTS 276=item @cf::INVOKE_RESULTS
232 277
233This array contains the results of the last C<invoke ()> call. When 278This 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 279C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
235that call. 280that call.
236 281
237=item %cf::REFLECT 282=item %cf::REFLECT
238 283
… …
242 287
243=back 288=back
244 289
245=cut 290=cut
246 291
292sub error(@) { LOG llevError, join "", @_ }
293sub warn (@) { LOG llevWarn , join "", @_ }
294sub info (@) { LOG llevInfo , join "", @_ }
295sub debug(@) { LOG llevDebug, join "", @_ }
296sub trace(@) { LOG llevTrace, join "", @_ }
297
247$Coro::State::WARNHOOK = sub { 298$Coro::State::WARNHOOK = sub {
248 my $msg = join "", @_; 299 my $msg = join "", @_;
249 300
250 $msg .= "\n" 301 $msg .= "\n"
251 unless $msg =~ /\n$/; 302 unless $msg =~ /\n$/;
252 303
253 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 304 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
254 305
255 LOG llevError, $msg; 306 LOG llevWarn, $msg;
256}; 307};
257 308
258$Coro::State::DIEHOOK = sub { 309$Coro::State::DIEHOOK = sub {
259 return unless $^S eq 0; # "eq", not "==" 310 return unless $^S eq 0; # "eq", not "=="
260 311
261 warn Carp::longmess $_[0]; 312 error Carp::longmess $_[0];
262 313
263 if ($Coro::current == $Coro::main) {#d# 314 if (in_main) {#d#
264 warn "DIEHOOK called in main context, Coro bug?\n";#d# 315 error "DIEHOOK called in main context, Coro bug?\n";#d#
265 return;#d# 316 return;#d#
266 }#d# 317 }#d#
267 318
268 # kill coroutine otherwise 319 # kill coroutine otherwise
269 Coro::terminate 320 Coro::terminate
… …
289)) { 340)) {
290 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 341 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
291} 342}
292 343
293$EV::DIED = sub { 344$EV::DIED = sub {
294 warn "error in event callback: @_"; 345 warn "error in event callback: $@";
295}; 346};
347
348#############################################################################
349
350sub fork_call(&@);
351sub get_slot($;$$);
296 352
297############################################################################# 353#############################################################################
298 354
299=head2 UTILITY FUNCTIONS 355=head2 UTILITY FUNCTIONS
300 356
… …
321 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 377 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
322 $d 378 $d
323 } || "[unable to dump $_[0]: '$@']"; 379 } || "[unable to dump $_[0]: '$@']";
324} 380}
325 381
382=item $scalar = cf::load_file $path
383
384Loads the given file from path and returns its contents. Croaks on error
385and can block.
386
387=cut
388
389sub load_file($) {
390 0 <= aio_load $_[0], my $data
391 or Carp::croak "$_[0]: $!";
392
393 $data
394}
395
396=item $success = cf::replace_file $path, $data, $sync
397
398Atomically replaces the file at the given $path with new $data, and
399optionally $sync the data to disk before replacing the file.
400
401=cut
402
403sub replace_file($$;$) {
404 my ($path, $data, $sync) = @_;
405
406 my $lock = cf::lock_acquire ("replace_file:$path");
407
408 my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
409 or return;
410
411 $data = $data->() if ref $data;
412
413 length $data == aio_write $fh, 0, (length $data), $data, 0
414 or return;
415
416 !$sync
417 or !aio_fsync $fh
418 or return;
419
420 aio_close $fh
421 and return;
422
423 aio_rename "$path~", $path
424 and return;
425
426 if ($sync) {
427 $path =~ s%/[^/]*$%%;
428 aio_pathsync $path;
429 }
430
431 1
432}
433
326=item $ref = cf::decode_json $json 434=item $ref = cf::decode_json $json
327 435
328Converts a JSON string into the corresponding perl data structure. 436Converts a JSON string into the corresponding perl data structure.
329 437
330=item $json = cf::encode_json $ref 438=item $json = cf::encode_json $ref
… …
336our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 444our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
337 445
338sub encode_json($) { $json_coder->encode ($_[0]) } 446sub encode_json($) { $json_coder->encode ($_[0]) }
339sub decode_json($) { $json_coder->decode ($_[0]) } 447sub decode_json($) { $json_coder->decode ($_[0]) }
340 448
449=item $ref = cf::decode_storable $scalar
450
451Same as Coro::Storable::thaw, so blocks.
452
453=cut
454
455BEGIN { *decode_storable = \&Coro::Storable::thaw }
456
457=item $ref = cf::decode_yaml $scalar
458
459Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
460
461=cut
462
463sub decode_yaml($) {
464 fork_call { YAML::XS::Load $_[0] } @_
465}
466
467=item $scalar = cf::unlzf $scalar
468
469Same as Compress::LZF::compress, but takes server ticks into account, so
470blocks.
471
472=cut
473
474sub unlzf($) {
475 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
476 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
477 Compress::LZF::decompress $_[0]
478}
479
341=item cf::post_init { BLOCK } 480=item cf::post_init { BLOCK }
342 481
343Execute the given codeblock, I<after> all extensions have been (re-)loaded, 482Execute the given codeblock, I<after> all extensions have been (re-)loaded,
344but I<before> the server starts ticking again. 483but I<before> the server starts ticking again.
345 484
346The cdoeblock will have a single boolean argument to indicate whether this 485The codeblock will have a single boolean argument to indicate whether this
347is a reload or not. 486is a reload or not.
348 487
349=cut 488=cut
350 489
351sub post_init(&) { 490sub post_init(&) {
352 push @POST_INIT, shift; 491 push @POST_INIT, shift;
492}
493
494sub _post_init {
495 trace "running post_init jobs";
496
497 # run them in parallel...
498
499 my @join;
500
501 while () {
502 push @join, map &Coro::async ($_, 0), @POST_INIT;
503 @POST_INIT = ();
504
505 @join or last;
506
507 (pop @join)->join;
508 }
353} 509}
354 510
355=item cf::lock_wait $string 511=item cf::lock_wait $string
356 512
357Wait until the given lock is available. See cf::lock_acquire. 513Wait until the given lock is available. See cf::lock_acquire.
… …
396} 552}
397 553
398=item cf::periodic $interval, $cb 554=item cf::periodic $interval, $cb
399 555
400Like EV::periodic, but randomly selects a starting point so that the actions 556Like EV::periodic, but randomly selects a starting point so that the actions
401get spread over timer. 557get spread over time.
402 558
403=cut 559=cut
404 560
405sub periodic($$) { 561sub periodic($$) {
406 my ($interval, $cb) = @_; 562 my ($interval, $cb) = @_;
… …
410 EV::periodic $start, $interval, 0, $cb 566 EV::periodic $start, $interval, 0, $cb
411} 567}
412 568
413=item cf::get_slot $time[, $priority[, $name]] 569=item cf::get_slot $time[, $priority[, $name]]
414 570
415Allocate $time seconds of blocking CPU time at priority C<$priority>: 571Allocate $time seconds of blocking CPU time at priority C<$priority>
416This call blocks and returns only when you have at least C<$time> seconds 572(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. 573C<$time> seconds of cpu time till the next tick. The slot is only valid
574till the next cede.
575
576Background jobs should use a priority les than zero, interactive jobs
577should use 100 or more.
418 578
419The optional C<$name> can be used to identify the job to run. It might be 579The 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. 580used for statistical purposes and should identify the same time-class.
421 581
422Useful for short background jobs. 582Useful for short background jobs.
423 583
424=cut 584=cut
425 585
426our @SLOT_QUEUE; 586our @SLOT_QUEUE;
427our $SLOT_QUEUE; 587our $SLOT_QUEUE;
588our $SLOT_DECAY = 0.9;
428 589
429$SLOT_QUEUE->cancel if $SLOT_QUEUE; 590$SLOT_QUEUE->cancel if $SLOT_QUEUE;
430$SLOT_QUEUE = Coro::async { 591$SLOT_QUEUE = Coro::async {
431 $Coro::current->desc ("timeslot manager"); 592 $Coro::current->desc ("timeslot manager");
432 593
433 my $signal = new Coro::Signal; 594 my $signal = new Coro::Signal;
595 my $busy;
434 596
435 while () { 597 while () {
436 next_job: 598 next_job:
599
437 my $avail = cf::till_tick; 600 my $avail = cf::till_tick;
438 if ($avail > 0.01) { 601
439 for (0 .. $#SLOT_QUEUE) { 602 for (0 .. $#SLOT_QUEUE) {
440 if ($SLOT_QUEUE[$_][0] < $avail) { 603 if ($SLOT_QUEUE[$_][0] <= $avail) {
604 $busy = 0;
441 my $job = splice @SLOT_QUEUE, $_, 1, (); 605 my $job = splice @SLOT_QUEUE, $_, 1, ();
442 $job->[2]->send; 606 $job->[2]->send;
443 Coro::cede; 607 Coro::cede;
444 goto next_job; 608 goto next_job;
445 } 609 } else {
610 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
446 } 611 }
447 } 612 }
448 613
449 if (@SLOT_QUEUE) { 614 if (@SLOT_QUEUE) {
450 # we do not use wait_for_tick() as it returns immediately when tick is inactive 615 # we do not use wait_for_tick() as it returns immediately when tick is inactive
451 push @cf::WAIT_FOR_TICK, $signal; 616 $WAIT_FOR_TICK->wait;
452 $signal->wait;
453 } else { 617 } else {
618 $busy = 0;
454 Coro::schedule; 619 Coro::schedule;
455 } 620 }
456 } 621 }
457}; 622};
458 623
459sub get_slot($;$$) { 624sub get_slot($;$$) {
460 return if tick_inhibit || $Coro::current == $Coro::main; 625 return if tick_inhibit || $Coro::current == $Coro::main;
461 626
462 my ($time, $pri, $name) = @_; 627 my ($time, $pri, $name) = @_;
463 628
464 $time = $TICK * .6 if $time > $TICK * .6; 629 $time = clamp $time, 0.01, $TICK * .6;
630
465 my $sig = new Coro::Signal; 631 my $sig = new Coro::Signal;
466 632
467 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 633 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
468 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 634 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
469 $SLOT_QUEUE->ready; 635 $SLOT_QUEUE->ready;
… …
495=cut 661=cut
496 662
497sub sync_job(&) { 663sub sync_job(&) {
498 my ($job) = @_; 664 my ($job) = @_;
499 665
500 if ($Coro::current == $Coro::main) { 666 if (in_main) {
501 my $time = EV::time; 667 my $time = AE::time;
502 668
503 # this is the main coro, too bad, we have to block 669 # this is the main coro, too bad, we have to block
504 # till the operation succeeds, freezing the server :/ 670 # till the operation succeeds, freezing the server :/
505 671
506 LOG llevError, Carp::longmess "sync job";#d# 672 #LOG llevError, Carp::longmess "sync job";#d#
507 673
508 my $freeze_guard = freeze_mainloop; 674 my $freeze_guard = freeze_mainloop;
509 675
510 my $busy = 1; 676 my $busy = 1;
511 my @res; 677 my @res;
512 678
513 (async { 679 (async {
514 $Coro::current->desc ("sync job coro"); 680 $Coro::current->desc ("sync job coro");
515 @res = eval { $job->() }; 681 @res = eval { $job->() };
516 warn $@ if $@; 682 error $@ if $@;
517 undef $busy; 683 undef $busy;
518 })->prio (Coro::PRIO_MAX); 684 })->prio (Coro::PRIO_MAX);
519 685
520 while ($busy) { 686 while ($busy) {
521 if (Coro::nready) { 687 if (Coro::nready) {
… …
523 } else { 689 } else {
524 EV::loop EV::LOOP_ONESHOT; 690 EV::loop EV::LOOP_ONESHOT;
525 } 691 }
526 } 692 }
527 693
528 my $time = EV::time - $time; 694 my $time = AE::time - $time;
529 695
530 $TICK_START += $time; # do not account sync jobs to server load 696 $TICK_START += $time; # do not account sync jobs to server load
531 697
532 wantarray ? @res : $res[0] 698 wantarray ? @res : $res[0]
533 } else { 699 } else {
… …
555 $EXT_CORO{$coro+0} = $coro; 721 $EXT_CORO{$coro+0} = $coro;
556 722
557 $coro 723 $coro
558} 724}
559 725
560=item fork_call { }, $args 726=item fork_call { }, @args
561 727
562Executes the given code block with the given arguments in a seperate 728Executes the given code block with the given arguments in a seperate
563process, returning the results. Everything must be serialisable with 729process, returning the results. Everything must be serialisable with
564Coro::Storable. May, of course, block. Note that the executed sub may 730Coro::Storable. May, of course, block. Note that the executed sub may
565never block itself or use any form of event handling. 731never block itself or use any form of event handling.
566 732
567=cut 733=cut
568 734
735sub post_fork {
736 reset_signals;
737}
738
569sub fork_call(&@) { 739sub fork_call(&@) {
570 my ($cb, @args) = @_; 740 my ($cb, @args) = @_;
571 741
572 # we seemingly have to make a local copy of the whole thing, 742 # we seemingly have to make a local copy of the whole thing,
573 # otherwise perl prematurely frees the stuff :/ 743 # otherwise perl prematurely frees the stuff :/
574 # TODO: investigate and fix (likely this will be rather laborious) 744 # TODO: investigate and fix (likely this will be rather laborious)
575 745
576 my @res = Coro::Util::fork_eval { 746 my @res = Coro::Util::fork_eval {
577 reset_signals; 747 cf::post_fork;
578 &$cb 748 &$cb
579 }, @args; 749 } @args;
580 750
581 wantarray ? @res : $res[-1] 751 wantarray ? @res : $res[-1]
752}
753
754sub objinfo {
755 (
756 "counter value" => cf::object::object_count,
757 "objects created" => cf::object::create_count,
758 "objects destroyed" => cf::object::destroy_count,
759 "freelist size" => cf::object::free_count,
760 "allocated objects" => cf::object::objects_size,
761 "active objects" => cf::object::actives_size,
762 )
582} 763}
583 764
584=item $coin = coin_from_name $name 765=item $coin = coin_from_name $name
585 766
586=cut 767=cut
… …
623within each server. 804within each server.
624 805
625=cut 806=cut
626 807
627sub db_table($) { 808sub db_table($) {
809 cf::error "db_get called from main context"
810 if $Coro::current == $Coro::main;
811
628 my ($name) = @_; 812 my ($name) = @_;
629 my $db = BDB::db_create $DB_ENV; 813 my $db = BDB::db_create $DB_ENV;
630 814
631 eval { 815 eval {
632 $db->set_flags (BDB::CHKSUM); 816 $db->set_flags (BDB::CHKSUM);
… …
642} 826}
643 827
644our $DB; 828our $DB;
645 829
646sub db_init { 830sub db_init {
647 cf::sync_job {
648 $DB ||= db_table "db"; 831 $DB ||= db_table "db";
649 };
650} 832}
651 833
652sub db_get($$) { 834sub db_get($$) {
653 my $key = "$_[0]/$_[1]"; 835 my $key = "$_[0]/$_[1]";
654 836
655 cf::sync_job { 837 cf::error "db_get called from main context"
838 if $Coro::current == $Coro::main;
839
656 BDB::db_get $DB, undef, $key, my $data; 840 BDB::db_get $DB, undef, $key, my $data;
657 841
658 $! ? () 842 $! ? ()
659 : $data 843 : $data
660 }
661} 844}
662 845
663sub db_put($$$) { 846sub db_put($$$) {
664 BDB::dbreq_pri 4; 847 BDB::dbreq_pri 4;
665 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 848 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
693 876
694 my @data; 877 my @data;
695 my $md5; 878 my $md5;
696 879
697 for (0 .. $#$src) { 880 for (0 .. $#$src) {
698 0 <= aio_load $src->[$_], $data[$_] 881 $data[$_] = load_file $src->[$_];
699 or Carp::croak "$src->[$_]: $!";
700 } 882 }
701 883
702 # if processing is expensive, check 884 # if processing is expensive, check
703 # checksum first 885 # checksum first
704 if (1) { 886 if (1) {
… …
721 903
722 my $t1 = Time::HiRes::time; 904 my $t1 = Time::HiRes::time;
723 my $data = $process->(\@data); 905 my $data = $process->(\@data);
724 my $t2 = Time::HiRes::time; 906 my $t2 = Time::HiRes::time;
725 907
726 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 908 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
727 909
728 db_put cache => "$id/data", $data; 910 db_put cache => "$id/data", $data;
729 db_put cache => "$id/md5" , $md5; 911 db_put cache => "$id/md5" , $md5;
730 db_put cache => "$id/meta", $meta; 912 db_put cache => "$id/meta", $meta;
731 913
… …
741 923
742=cut 924=cut
743 925
744sub datalog($@) { 926sub datalog($@) {
745 my ($type, %kv) = @_; 927 my ($type, %kv) = @_;
746 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 928 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
747} 929}
748 930
749=back 931=back
750 932
751=cut 933=cut
… …
946 1128
947 } elsif (exists $cb_id{$type}) { 1129 } elsif (exists $cb_id{$type}) {
948 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1130 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
949 1131
950 } elsif (ref $type) { 1132 } elsif (ref $type) {
951 warn "attaching objects not supported, ignoring.\n"; 1133 error "attaching objects not supported, ignoring.\n";
952 1134
953 } else { 1135 } else {
954 shift @arg; 1136 shift @arg;
955 warn "attach argument '$type' not supported, ignoring.\n"; 1137 error "attach argument '$type' not supported, ignoring.\n";
956 } 1138 }
957 } 1139 }
958} 1140}
959 1141
960sub _object_attach { 1142sub _object_attach {
… …
970 _attach $registry, $klass, @attach; 1152 _attach $registry, $klass, @attach;
971 } 1153 }
972 1154
973 $obj->{$name} = \%arg; 1155 $obj->{$name} = \%arg;
974 } else { 1156 } else {
975 warn "object uses attachment '$name' which is not available, postponing.\n"; 1157 info "object uses attachment '$name' which is not available, postponing.\n";
976 } 1158 }
977 1159
978 $obj->{_attachment}{$name} = undef; 1160 $obj->{_attachment}{$name} = undef;
979} 1161}
980 1162
… …
1039 1221
1040 for (@$callbacks) { 1222 for (@$callbacks) {
1041 eval { &{$_->[1]} }; 1223 eval { &{$_->[1]} };
1042 1224
1043 if ($@) { 1225 if ($@) {
1044 warn "$@";
1045 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1226 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1046 override; 1227 override;
1047 } 1228 }
1048 1229
1049 return 1 if $override; 1230 return 1 if $override;
1050 } 1231 }
… …
1129 for (@$attach) { 1310 for (@$attach) {
1130 my ($klass, @attach) = @$_; 1311 my ($klass, @attach) = @$_;
1131 _attach $registry, $klass, @attach; 1312 _attach $registry, $klass, @attach;
1132 } 1313 }
1133 } else { 1314 } else {
1134 warn "object uses attachment '$name' that is not available, postponing.\n"; 1315 info "object uses attachment '$name' that is not available, postponing.\n";
1135 } 1316 }
1136 } 1317 }
1137} 1318}
1138 1319
1139cf::attachable->attach ( 1320cf::attachable->attach (
… …
1166 my ($filename, $rdata, $objs) = @_; 1347 my ($filename, $rdata, $objs) = @_;
1167 1348
1168 sync_job { 1349 sync_job {
1169 if (length $$rdata) { 1350 if (length $$rdata) {
1170 utf8::decode (my $decname = $filename); 1351 utf8::decode (my $decname = $filename);
1171 warn sprintf "saving %s (%d,%d)\n", 1352 trace sprintf "saving %s (%d,%d)\n",
1172 $decname, length $$rdata, scalar @$objs; 1353 $decname, length $$rdata, scalar @$objs
1354 if $VERBOSE_IO;
1173 1355
1174 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1356 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1175 aio_chmod $fh, SAVE_MODE; 1357 aio_chmod $fh, SAVE_MODE;
1176 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1358 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1177 if ($cf::USE_FSYNC) { 1359 if ($cf::USE_FSYNC) {
… …
1199 aio_rename "$filename~", $filename; 1381 aio_rename "$filename~", $filename;
1200 1382
1201 $filename =~ s%/[^/]+$%%; 1383 $filename =~ s%/[^/]+$%%;
1202 aio_pathsync $filename if $cf::USE_FSYNC; 1384 aio_pathsync $filename if $cf::USE_FSYNC;
1203 } else { 1385 } else {
1204 warn "unable to save objects: $filename~: $!\n"; 1386 error "unable to save objects: $filename~: $!\n";
1205 } 1387 }
1206 } else { 1388 } else {
1207 aio_unlink $filename; 1389 aio_unlink $filename;
1208 aio_unlink "$filename.pst"; 1390 aio_unlink "$filename.pst";
1209 } 1391 }
… …
1233 my $st = eval { Coro::Storable::thaw $av }; 1415 my $st = eval { Coro::Storable::thaw $av };
1234 $av = $st->{objs}; 1416 $av = $st->{objs};
1235 } 1417 }
1236 1418
1237 utf8::decode (my $decname = $filename); 1419 utf8::decode (my $decname = $filename);
1238 warn sprintf "loading %s (%d,%d)\n", 1420 trace sprintf "loading %s (%d,%d)\n",
1239 $decname, length $data, scalar @{$av || []}; 1421 $decname, length $data, scalar @{$av || []}
1422 if $VERBOSE_IO;
1240 1423
1241 ($data, $av) 1424 ($data, $av)
1242} 1425}
1243 1426
1244=head2 COMMAND CALLBACKS 1427=head2 COMMAND CALLBACKS
… …
1303} 1486}
1304 1487
1305use File::Glob (); 1488use File::Glob ();
1306 1489
1307cf::player->attach ( 1490cf::player->attach (
1308 on_command => sub { 1491 on_unknown_command => sub {
1309 my ($pl, $name, $params) = @_; 1492 my ($pl, $name, $params) = @_;
1310 1493
1311 my $cb = $COMMAND{$name} 1494 my $cb = $COMMAND{$name}
1312 or return; 1495 or return;
1313 1496
… …
1321 my ($pl, $buf) = @_; 1504 my ($pl, $buf) = @_;
1322 1505
1323 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1506 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1324 1507
1325 if (ref $msg) { 1508 if (ref $msg) {
1326 my ($type, $reply, @payload) = 1509 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1327 "ARRAY" eq ref $msg
1328 ? @$msg
1329 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1330 1510
1331 my @reply; 1511 my @reply;
1332 1512
1333 if (my $cb = $EXTCMD{$type}) { 1513 if (my $cb = $EXTCMD{$type}) {
1334 @reply = $cb->($pl, @payload); 1514 @reply = $cb->($pl, @payload);
… …
1336 1516
1337 $pl->ext_reply ($reply, @reply) 1517 $pl->ext_reply ($reply, @reply)
1338 if $reply; 1518 if $reply;
1339 1519
1340 } else { 1520 } else {
1341 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1521 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1342 } 1522 }
1343 1523
1344 cf::override; 1524 cf::override;
1345 }, 1525 },
1346); 1526);
… …
1356 }; 1536 };
1357 1537
1358 $grp 1538 $grp
1359} 1539}
1360 1540
1541sub _ext_cfg_reg($$$$) {
1542 my ($rvar, $varname, $cfgname, $default) = @_;
1543
1544 $cfgname = lc $varname
1545 unless length $cfgname;
1546
1547 $EXT_CFG{$cfgname} = [$rvar, $default];
1548
1549 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1550}
1551
1361sub load_extensions { 1552sub load_extensions {
1553 info "loading extensions...";
1554
1555 %EXT_CFG = ();
1556
1362 cf::sync_job { 1557 cf::sync_job {
1363 my %todo; 1558 my %todo;
1364 1559
1365 for my $path (<$LIBDIR/*.ext>) { 1560 for my $path (<$LIBDIR/*.ext>) {
1366 next unless -r $path; 1561 next unless -r $path;
… …
1384 1579
1385 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1580 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1386 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1581 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1387 1582
1388 $ext{source} = 1583 $ext{source} =
1389 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1584 "package $pkg; use common::sense;\n"
1390 . "#line 1 \"$path\"\n{\n" 1585 . "#line 1 \"$path\"\n{\n"
1391 . $source 1586 . $source
1392 . "\n};\n1"; 1587 . "\n};\n1";
1393 1588
1394 $todo{$base} = \%ext; 1589 $todo{$base} = \%ext;
1395 } 1590 }
1396 1591
1592 my $pass = 0;
1397 my %done; 1593 my %done;
1398 while (%todo) { 1594 while (%todo) {
1399 my $progress; 1595 my $progress;
1400 1596
1597 ++$pass;
1598
1599 ext:
1401 while (my ($k, $v) = each %todo) { 1600 while (my ($k, $v) = each %todo) {
1402 for (split /,\s*/, $v->{meta}{depends}) { 1601 for (split /,\s*/, $v->{meta}{depends}) {
1403 goto skip 1602 next ext
1404 unless exists $done{$_}; 1603 unless exists $done{$_};
1405 } 1604 }
1406 1605
1407 warn "... loading '$k' into '$v->{pkg}'\n"; 1606 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1408 1607
1409 unless (eval $v->{source}) { 1608 my $source = $v->{source};
1609
1610 # support "CONF varname :confname = default" pseudo-statements
1611 $source =~ s{
1612 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1613 }{
1614 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1615 }gmxe;
1616
1617 my $active = eval $source;
1618
1619 if (length $@) {
1410 my $msg = $@ ? "$v->{path}: $@\n" 1620 error "$v->{path}: $@\n";
1411 : "$v->{base}: extension inactive.\n";
1412 1621
1413 if (exists $v->{meta}{mandatory}) {
1414 warn $msg;
1415 cf::cleanup "mandatory extension failed to load, exiting."; 1622 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1416 } 1623 if exists $v->{meta}{mandatory};
1417 1624
1418 warn $msg; 1625 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1626 delete $todo{$k};
1627 } else {
1628 $done{$k} = delete $todo{$k};
1629 push @EXTS, $v->{pkg};
1630 $progress = 1;
1631
1632 info "$v->{base}: extension inactive.\n"
1633 unless $active;
1419 } 1634 }
1420
1421 $done{$k} = delete $todo{$k};
1422 push @EXTS, $v->{pkg};
1423 $progress = 1;
1424 } 1635 }
1425 1636
1426 skip: 1637 unless ($progress) {
1427 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1638 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1428 unless $progress; 1639
1640 while (my ($k, $v) = each %todo) {
1641 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1642 if exists $v->{meta}{mandatory};
1643 }
1644
1645 last;
1646 }
1429 } 1647 }
1430 }; 1648 };
1431} 1649}
1432 1650
1433############################################################################# 1651#############################################################################
… …
1517 $cf::PLAYER{$login} = $pl 1735 $cf::PLAYER{$login} = $pl
1518 } 1736 }
1519 } 1737 }
1520} 1738}
1521 1739
1740cf::player->attach (
1741 on_load => sub {
1742 my ($pl, $path) = @_;
1743
1744 # restore slots saved in save, below
1745 my $slots = delete $pl->{_slots};
1746
1747 $pl->ob->current_weapon ($slots->[0]);
1748 $pl->combat_ob ($slots->[1]);
1749 $pl->ranged_ob ($slots->[2]);
1750 },
1751);
1752
1522sub save($) { 1753sub save($) {
1523 my ($pl) = @_; 1754 my ($pl) = @_;
1524 1755
1525 return if $pl->{deny_save}; 1756 return if $pl->{deny_save};
1526 1757
… …
1531 1762
1532 aio_mkdir playerdir $pl, 0770; 1763 aio_mkdir playerdir $pl, 0770;
1533 $pl->{last_save} = $cf::RUNTIME; 1764 $pl->{last_save} = $cf::RUNTIME;
1534 1765
1535 cf::get_slot 0.01; 1766 cf::get_slot 0.01;
1767
1768 # save slots, to be restored later
1769 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1536 1770
1537 $pl->save_pl ($path); 1771 $pl->save_pl ($path);
1538 cf::cede_to_tick; 1772 cf::cede_to_tick;
1539} 1773}
1540 1774
… …
1574 my $name = $pl->ob->name; 1808 my $name = $pl->ob->name;
1575 1809
1576 $pl->{deny_save} = 1; 1810 $pl->{deny_save} = 1;
1577 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1811 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1578 1812
1579 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1813 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1580 $pl->deactivate; 1814 $pl->deactivate;
1815
1581 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1816 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1582 $pl->ob->check_score;
1583 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1817 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1818 ext::highscore::check ($pl->ob);
1819
1584 $pl->ns->destroy if $pl->ns; 1820 $pl->ns->destroy if $pl->ns;
1585 1821
1586 my $path = playerdir $pl; 1822 my $path = playerdir $pl;
1587 my $temp = "$path~$cf::RUNTIME~deleting~"; 1823 my $temp = "$path~$cf::RUNTIME~deleting~";
1588 aio_rename $path, $temp; 1824 aio_rename $path, $temp;
… …
1642 \@logins 1878 \@logins
1643} 1879}
1644 1880
1645=item $player->maps 1881=item $player->maps
1646 1882
1883=item cf::player::maps $login
1884
1647Returns an arrayref of map paths that are private for this 1885Returns an arrayref of map paths that are private for this
1648player. May block. 1886player. May block.
1649 1887
1650=cut 1888=cut
1651 1889
… …
1713=cut 1951=cut
1714 1952
1715sub find_by_path($) { 1953sub find_by_path($) {
1716 my ($path) = @_; 1954 my ($path) = @_;
1717 1955
1956 $path =~ s/^~[^\/]*//; # skip ~login
1957
1718 my ($match, $specificity); 1958 my ($match, $specificity);
1719 1959
1720 for my $region (list) { 1960 for my $region (list) {
1721 if ($region->{match} && $path =~ $region->{match}) { 1961 if ($region->{match} && $path =~ $region->{match}) {
1722 ($match, $specificity) = ($region, $region->specificity) 1962 ($match, $specificity) = ($region, $region->specificity)
… …
1750sub generate_random_map { 1990sub generate_random_map {
1751 my ($self, $rmp) = @_; 1991 my ($self, $rmp) = @_;
1752 1992
1753 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1993 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1754 1994
1755 # mit "rum" bekleckern, nicht
1756 $self->_create_random_map ( 1995 $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} 1996}
1770 1997
1771=item cf::map->register ($regex, $prio) 1998=item cf::map->register ($regex, $prio)
1772 1999
1773Register a handler for the map path matching the given regex at the 2000Register a handler for the map path matching the given regex at the
… …
1778 2005
1779sub register { 2006sub register {
1780 my (undef, $regex, $prio) = @_; 2007 my (undef, $regex, $prio) = @_;
1781 my $pkg = caller; 2008 my $pkg = caller;
1782 2009
1783 no strict;
1784 push @{"$pkg\::ISA"}, __PACKAGE__; 2010 push @{"$pkg\::ISA"}, __PACKAGE__;
1785 2011
1786 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 2012 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1787} 2013}
1788 2014
1789# also paths starting with '/' 2015# also paths starting with '/'
1790$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 2016$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1791 2017
1792sub thawer_merge { 2018sub thawer_merge {
1793 my ($self, $merge) = @_; 2019 my ($self, $merge) = @_;
1794 2020
1795 # we have to keep some variables in memory intact 2021 # we have to keep some variables in memory intact
… …
1800} 2026}
1801 2027
1802sub normalise { 2028sub normalise {
1803 my ($path, $base) = @_; 2029 my ($path, $base) = @_;
1804 2030
1805 $path = "$path"; # make sure its a string 2031 $path = "$path"; # make sure it's a string
1806 2032
1807 $path =~ s/\.map$//; 2033 $path =~ s/\.map$//;
1808 2034
1809 # map plan: 2035 # map plan:
1810 # 2036 #
… …
1825 $base =~ s{[^/]+/?$}{}; 2051 $base =~ s{[^/]+/?$}{};
1826 $path = "$base/$path"; 2052 $path = "$base/$path";
1827 } 2053 }
1828 2054
1829 for ($path) { 2055 for ($path) {
1830 redo if s{//}{/};
1831 redo if s{/\.?/}{/}; 2056 redo if s{/\.?/}{/};
1832 redo if s{/[^/]+/\.\./}{/}; 2057 redo if s{/[^/]+/\.\./}{/};
1833 } 2058 }
1834 2059
1835 $path 2060 $path
… …
1849 $self->init; # pass $1 etc. 2074 $self->init; # pass $1 etc.
1850 return $self; 2075 return $self;
1851 } 2076 }
1852 } 2077 }
1853 2078
1854 Carp::cluck "unable to resolve path '$path' (base '$base')."; 2079 Carp::cluck "unable to resolve path '$path' (base '$base')";
1855 () 2080 ()
1856} 2081}
1857 2082
2083# may re-bless or do other evil things
1858sub init { 2084sub init {
1859 my ($self) = @_; 2085 my ($self) = @_;
1860 2086
1861 $self 2087 $self
1862} 2088}
… …
1927 $self->{load_path} = $path; 2153 $self->{load_path} = $path;
1928 2154
1929 1 2155 1
1930} 2156}
1931 2157
2158# used to laod the header of an original map
1932sub load_header_orig { 2159sub load_header_orig {
1933 my ($self) = @_; 2160 my ($self) = @_;
1934 2161
1935 $self->load_header_from ($self->load_path) 2162 $self->load_header_from ($self->load_path)
1936} 2163}
1937 2164
2165# used to laod the header of an instantiated map
1938sub load_header_temp { 2166sub load_header_temp {
1939 my ($self) = @_; 2167 my ($self) = @_;
1940 2168
1941 $self->load_header_from ($self->save_path) 2169 $self->load_header_from ($self->save_path)
1942} 2170}
1943 2171
2172# called after loading the header from an instantiated map
1944sub prepare_temp { 2173sub prepare_temp {
1945 my ($self) = @_; 2174 my ($self) = @_;
1946 2175
1947 $self->last_access ((delete $self->{last_access}) 2176 $self->last_access ((delete $self->{last_access})
1948 || $cf::RUNTIME); #d# 2177 || $cf::RUNTIME); #d#
1949 # safety 2178 # safety
1950 $self->{instantiate_time} = $cf::RUNTIME 2179 $self->{instantiate_time} = $cf::RUNTIME
1951 if $self->{instantiate_time} > $cf::RUNTIME; 2180 if $self->{instantiate_time} > $cf::RUNTIME;
1952} 2181}
1953 2182
2183# called after loading the header from an original map
1954sub prepare_orig { 2184sub prepare_orig {
1955 my ($self) = @_; 2185 my ($self) = @_;
1956 2186
1957 $self->{load_original} = 1; 2187 $self->{load_original} = 1;
1958 $self->{instantiate_time} = $cf::RUNTIME; 2188 $self->{instantiate_time} = $cf::RUNTIME;
… …
1982 2212
1983sub find; 2213sub find;
1984sub find { 2214sub find {
1985 my ($path, $origin) = @_; 2215 my ($path, $origin) = @_;
1986 2216
2217 cf::cede_to_tick;
2218
1987 $path = normalise $path, $origin && $origin->path; 2219 $path = normalise $path, $origin;
1988 2220
1989 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2221 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1990 my $guard2 = cf::lock_acquire "map_find:$path"; 2222 my $guard2 = cf::lock_acquire "map_find:$path";
1991 2223
1992 $cf::MAP{$path} || do { 2224 $cf::MAP{$path} || do {
… …
2009 2241
2010 $cf::MAP{$path} = $map 2242 $cf::MAP{$path} = $map
2011 } 2243 }
2012} 2244}
2013 2245
2014sub pre_load { } 2246sub pre_load { }
2015sub post_load { } 2247#sub post_load { } # XS
2016 2248
2017sub load { 2249sub load {
2018 my ($self) = @_; 2250 my ($self) = @_;
2019 2251
2020 local $self->{deny_reset} = 1; # loading can take a long time 2252 local $self->{deny_reset} = 1; # loading can take a long time
… …
2023 2255
2024 { 2256 {
2025 my $guard = cf::lock_acquire "map_data:$path"; 2257 my $guard = cf::lock_acquire "map_data:$path";
2026 2258
2027 return unless $self->valid; 2259 return unless $self->valid;
2028 return unless $self->in_memory == cf::MAP_SWAPPED; 2260 return unless $self->state == cf::MAP_SWAPPED;
2029
2030 $self->in_memory (cf::MAP_LOADING);
2031 2261
2032 $self->alloc; 2262 $self->alloc;
2033 2263
2034 $self->pre_load; 2264 $self->pre_load;
2035 cf::cede_to_tick; 2265 cf::cede_to_tick;
2036 2266
2267 if (exists $self->{load_path}) {
2037 my $f = new_from_file cf::object::thawer $self->{load_path}; 2268 my $f = new_from_file cf::object::thawer $self->{load_path};
2038 $f->skip_block; 2269 $f->skip_block;
2039 $self->_load_objects ($f) 2270 $self->_load_objects ($f)
2040 or return; 2271 or return;
2041 2272
2042 $self->post_load_original 2273 $self->post_load_original
2043 if delete $self->{load_original}; 2274 if delete $self->{load_original};
2044 2275
2045 if (my $uniq = $self->uniq_path) { 2276 if (my $uniq = $self->uniq_path) {
2046 utf8::encode $uniq; 2277 utf8::encode $uniq;
2047 unless (aio_stat $uniq) { 2278 unless (aio_stat $uniq) {
2048 if (my $f = new_from_file cf::object::thawer $uniq) { 2279 if (my $f = new_from_file cf::object::thawer $uniq) {
2049 $self->clear_unique_items; 2280 $self->clear_unique_items;
2050 $self->_load_objects ($f); 2281 $self->_load_objects ($f);
2051 $f->resolve_delayed_derefs; 2282 $f->resolve_delayed_derefs;
2283 }
2052 } 2284 }
2053 } 2285 }
2054 }
2055 2286
2056 $f->resolve_delayed_derefs; 2287 $f->resolve_delayed_derefs;
2288 } else {
2289 $self->post_load_original
2290 if delete $self->{load_original};
2291 }
2292
2293 $self->state (cf::MAP_INACTIVE);
2057 2294
2058 cf::cede_to_tick; 2295 cf::cede_to_tick;
2059 # now do the right thing for maps 2296 # now do the right thing for maps
2060 $self->link_multipart_objects; 2297 $self->link_multipart_objects;
2061 $self->difficulty ($self->estimate_difficulty) 2298 $self->difficulty ($self->estimate_difficulty)
… …
2065 unless ($self->{deny_activate}) { 2302 unless ($self->{deny_activate}) {
2066 $self->decay_objects; 2303 $self->decay_objects;
2067 $self->fix_auto_apply; 2304 $self->fix_auto_apply;
2068 $self->update_buttons; 2305 $self->update_buttons;
2069 cf::cede_to_tick; 2306 cf::cede_to_tick;
2070 $self->activate; 2307 #$self->activate; # no longer activate maps automatically
2071 } 2308 }
2072 2309
2073 $self->{last_save} = $cf::RUNTIME; 2310 $self->{last_save} = $cf::RUNTIME;
2074 $self->last_access ($cf::RUNTIME); 2311 $self->last_access ($cf::RUNTIME);
2075
2076 $self->in_memory (cf::MAP_ACTIVE);
2077 } 2312 }
2078 2313
2079 $self->post_load; 2314 $self->post_load;
2080}
2081 2315
2316 1
2317}
2318
2319# customize the map for a given player, i.e.
2320# return the _real_ map. used by e.g. per-player
2321# maps to change the path to ~playername/mappath
2082sub customise_for { 2322sub customise_for {
2083 my ($self, $ob) = @_; 2323 my ($self, $ob) = @_;
2084 2324
2085 return find "~" . $ob->name . "/" . $self->{path} 2325 return find "~" . $ob->name . "/" . $self->{path}
2086 if $self->per_player; 2326 if $self->per_player;
… …
2089# if $self->per_party; 2329# if $self->per_party;
2090 2330
2091 $self 2331 $self
2092} 2332}
2093 2333
2094# find and load all maps in the 3x3 area around a map
2095sub load_neighbours {
2096 my ($map) = @_;
2097
2098 my @neigh; # diagonal neighbours
2099
2100 for (0 .. 3) {
2101 my $neigh = $map->tile_path ($_)
2102 or next;
2103 $neigh = find $neigh, $map
2104 or next;
2105 $neigh->load;
2106
2107 push @neigh,
2108 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2109 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2110 }
2111
2112 for (grep defined $_->[0], @neigh) {
2113 my ($path, $origin) = @$_;
2114 my $neigh = find $path, $origin
2115 or next;
2116 $neigh->load;
2117 }
2118}
2119
2120sub find_sync { 2334sub find_sync {
2121 my ($path, $origin) = @_; 2335 my ($path, $origin) = @_;
2122 2336
2123 cf::sync_job { find $path, $origin } 2337 # it's a bug to call this from the main context
2338 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2339 if $Coro::current == $Coro::main;
2340
2341 find $path, $origin
2124} 2342}
2125 2343
2126sub do_load_sync { 2344sub do_load_sync {
2127 my ($map) = @_; 2345 my ($map) = @_;
2128 2346
2347 # it's a bug to call this from the main context
2129 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2348 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2130 if $Coro::current == $Coro::main; 2349 if $Coro::current == $Coro::main;
2131 2350
2132 cf::sync_job { $map->load }; 2351 $map->load;
2133} 2352}
2134 2353
2135our %MAP_PREFETCH; 2354our %MAP_PREFETCH;
2136our $MAP_PREFETCHER = undef; 2355our $MAP_PREFETCHER = undef;
2137 2356
2138sub find_async { 2357sub find_async {
2139 my ($path, $origin, $load) = @_; 2358 my ($path, $origin, $load) = @_;
2140 2359
2141 $path = normalise $path, $origin && $origin->{path}; 2360 $path = normalise $path, $origin;
2142 2361
2143 if (my $map = $cf::MAP{$path}) { 2362 if (my $map = $cf::MAP{$path}) {
2144 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2363 return $map if !$load || $map->linkable;
2145 } 2364 }
2146 2365
2147 $MAP_PREFETCH{$path} |= $load; 2366 $MAP_PREFETCH{$path} |= $load;
2148 2367
2149 $MAP_PREFETCHER ||= cf::async { 2368 $MAP_PREFETCHER ||= cf::async {
… …
2163 $MAP_PREFETCHER->prio (6); 2382 $MAP_PREFETCHER->prio (6);
2164 2383
2165 () 2384 ()
2166} 2385}
2167 2386
2387# common code, used by both ->save and ->swapout
2168sub save { 2388sub _save {
2169 my ($self) = @_; 2389 my ($self) = @_;
2170
2171 my $lock = cf::lock_acquire "map_data:$self->{path}";
2172 2390
2173 $self->{last_save} = $cf::RUNTIME; 2391 $self->{last_save} = $cf::RUNTIME;
2174 2392
2175 return unless $self->dirty; 2393 return unless $self->dirty;
2176 2394
… …
2196 } else { 2414 } else {
2197 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2415 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2198 } 2416 }
2199} 2417}
2200 2418
2419sub save {
2420 my ($self) = @_;
2421
2422 my $lock = cf::lock_acquire "map_data:$self->{path}";
2423
2424 $self->_save;
2425}
2426
2201sub swap_out { 2427sub swap_out {
2202 my ($self) = @_; 2428 my ($self) = @_;
2203 2429
2204 # save first because save cedes
2205 $self->save;
2206
2207 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2430 my $lock = cf::lock_acquire "map_data:$self->{path}";
2208 2431
2432 return if !$self->linkable;
2433 return if $self->{deny_save};
2209 return if $self->players; 2434 return if $self->players;
2210 return if $self->in_memory != cf::MAP_ACTIVE; 2435
2436 # first deactivate the map and "unlink" it from the core
2437 $self->deactivate;
2438 $_->clear_links_to ($self) for values %cf::MAP;
2439 $self->state (cf::MAP_SWAPPED);
2440
2441 # then atomically save
2442 $self->_save;
2443
2444 # then free the map
2445 $self->clear;
2446}
2447
2448sub reset_at {
2449 my ($self) = @_;
2450
2451 # TODO: safety, remove and allow resettable per-player maps
2211 return if $self->{deny_save}; 2452 return 1e99 if $self->{deny_reset};
2212 2453
2454 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2455 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2456
2457 $time + $to
2458}
2459
2460sub should_reset {
2461 my ($self) = @_;
2462
2463 $self->reset_at <= $cf::RUNTIME
2464}
2465
2466sub reset {
2467 my ($self) = @_;
2468
2469 my $lock = cf::lock_acquire "map_data:$self->{path}";
2470
2471 return if $self->players;
2472
2473 cf::trace "resetting map ", $self->path, "\n";
2474
2213 $self->in_memory (cf::MAP_SWAPPED); 2475 $self->state (cf::MAP_SWAPPED);
2476
2477 # need to save uniques path
2478 unless ($self->{deny_save}) {
2479 my $uniq = $self->uniq_path; utf8::encode $uniq;
2480
2481 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2482 if $uniq;
2483 }
2484
2485 delete $cf::MAP{$self->path};
2214 2486
2215 $self->deactivate; 2487 $self->deactivate;
2216 $_->clear_links_to ($self) for values %cf::MAP; 2488 $_->clear_links_to ($self) for values %cf::MAP;
2217 $self->clear; 2489 $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 2490
2263 $self->unlink_save; 2491 $self->unlink_save;
2264 $self->destroy; 2492 $self->destroy;
2265} 2493}
2266 2494
… …
2274 2502
2275 delete $cf::MAP{$self->path}; 2503 delete $cf::MAP{$self->path};
2276 2504
2277 $self->unlink_save; 2505 $self->unlink_save;
2278 2506
2279 bless $self, "cf::map"; 2507 bless $self, "cf::map::wrap";
2280 delete $self->{deny_reset}; 2508 delete $self->{deny_reset};
2281 $self->{deny_save} = 1; 2509 $self->{deny_save} = 1;
2282 $self->reset_timeout (1); 2510 $self->reset_timeout (1);
2283 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2511 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2284 2512
… …
2341 : normalise $_ 2569 : normalise $_
2342 } @{ aio_readdir $UNIQUEDIR or [] } 2570 } @{ aio_readdir $UNIQUEDIR or [] }
2343 ] 2571 ]
2344} 2572}
2345 2573
2574=item cf::map::static_maps
2575
2576Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2577file in the shared directory excluding F</styles> and F</editor>). May
2578block.
2579
2580=cut
2581
2582sub static_maps() {
2583 my @dirs = "";
2584 my @maps;
2585
2586 while (@dirs) {
2587 my $dir = shift @dirs;
2588
2589 next if $dir eq "/styles" || $dir eq "/editor";
2590
2591 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2592 or return;
2593
2594 for (@$files) {
2595 s/\.map$// or next;
2596 utf8::decode $_;
2597 push @maps, "$dir/$_";
2598 }
2599
2600 push @dirs, map "$dir/$_", @$dirs;
2601 }
2602
2603 \@maps
2604}
2605
2346=back 2606=back
2347 2607
2348=head3 cf::object 2608=head3 cf::object
2349 2609
2350=cut 2610=cut
… …
2482 2742
2483Freezes the player and moves him/her to a special map (C<{link}>). 2743Freezes the player and moves him/her to a special map (C<{link}>).
2484 2744
2485The player should be reasonably safe there for short amounts of time (e.g. 2745The 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, 2746for 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 2747though, as the player cannot control the character while it is on the link
2488map. 2748map.
2489 2749
2490Will never block. 2750Will never block.
2491 2751
2492=item $player_object->leave_link ($map, $x, $y) 2752=item $player_object->leave_link ($map, $x, $y)
… …
2513sub cf::object::player::enter_link { 2773sub cf::object::player::enter_link {
2514 my ($self) = @_; 2774 my ($self) = @_;
2515 2775
2516 $self->deactivate_recursive; 2776 $self->deactivate_recursive;
2517 2777
2778 ++$self->{_link_recursion};
2779
2518 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2780 return if UNIVERSAL::isa $self->map, "ext::map_link";
2519 2781
2520 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2782 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2521 if $self->map && $self->map->{path} ne "{link}"; 2783 if $self->map && $self->map->{path} ne "{link}";
2522 2784
2523 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2785 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2524} 2786}
2525 2787
2526sub cf::object::player::leave_link { 2788sub cf::object::player::leave_link {
2527 my ($self, $map, $x, $y) = @_; 2789 my ($self, $map, $x, $y) = @_;
2528 2790
… …
2545 ($x, $y) = (-1, -1) 2807 ($x, $y) = (-1, -1)
2546 unless (defined $x) && (defined $y); 2808 unless (defined $x) && (defined $y);
2547 2809
2548 # use -1 or undef as default coordinates, not 0, 0 2810 # use -1 or undef as default coordinates, not 0, 0
2549 ($x, $y) = ($map->enter_x, $map->enter_y) 2811 ($x, $y) = ($map->enter_x, $map->enter_y)
2550 if $x <=0 && $y <= 0; 2812 if $x <= 0 && $y <= 0;
2551 2813
2552 $map->load; 2814 $map->load;
2553 $map->load_neighbours;
2554 2815
2555 return unless $self->contr->active; 2816 return unless $self->contr->active;
2556 2817
2557 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2818 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2558 $self->enter_map ($map, $x, $y); 2819 if ($self->enter_map ($map, $x, $y)) {
2559 2820 # entering was successful
2821 delete $self->{_link_recursion};
2560 # only activate afterwards, to support waiting in hooks 2822 # only activate afterwards, to support waiting in hooks
2561 $self->activate_recursive; 2823 $self->activate_recursive;
2562} 2824 }
2563 2825
2826}
2827
2564=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2828=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2565 2829
2566Moves the player to the given map-path and coordinates by first freezing 2830Moves the player to the given map-path and coordinates by first freezing
2567her, loading and preparing them map, calling the provided $check callback 2831her, loading and preparing them map, calling the provided $check callback
2568that has to return the map if sucecssful, and then unfreezes the player on 2832that 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 2833the new (success) or old (failed) map position. In either case, $done will
… …
2576 2840
2577our $GOTOGEN; 2841our $GOTOGEN;
2578 2842
2579sub cf::object::player::goto { 2843sub cf::object::player::goto {
2580 my ($self, $path, $x, $y, $check, $done) = @_; 2844 my ($self, $path, $x, $y, $check, $done) = @_;
2845
2846 if ($self->{_link_recursion} >= $MAX_LINKS) {
2847 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2848 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2849 ($path, $x, $y) = @$EMERGENCY_POSITION;
2850 }
2581 2851
2582 # do generation counting so two concurrent goto's will be executed in-order 2852 # do generation counting so two concurrent goto's will be executed in-order
2583 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2853 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2584 2854
2585 $self->enter_link; 2855 $self->enter_link;
… …
2605 ($path, $x, $y) = (undef, undef, undef); 2875 ($path, $x, $y) = (undef, undef, undef);
2606 } 2876 }
2607 } 2877 }
2608 2878
2609 my $map = eval { 2879 my $map = eval {
2610 my $map = defined $path ? cf::map::find $path : undef; 2880 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2611 2881
2612 if ($map) { 2882 if ($map) {
2613 $map = $map->customise_for ($self); 2883 $map = $map->customise_for ($self);
2614 $map = $check->($map) if $check && $map; 2884 $map = $check->($map, $x, $y, $self) if $check && $map;
2615 } else { 2885 } else {
2616 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2886 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2617 } 2887 }
2618 2888
2619 $map 2889 $map
… …
2627 if ($gen == $self->{_goto_generation}) { 2897 if ($gen == $self->{_goto_generation}) {
2628 delete $self->{_goto_generation}; 2898 delete $self->{_goto_generation};
2629 $self->leave_link ($map, $x, $y); 2899 $self->leave_link ($map, $x, $y);
2630 } 2900 }
2631 2901
2632 $done->() if $done; 2902 $done->($self) if $done;
2633 })->prio (1); 2903 })->prio (1);
2634} 2904}
2635 2905
2636=item $player_object->enter_exit ($exit_object) 2906=item $player_object->enter_exit ($exit_object)
2637 2907
… …
2705 $Coro::current->{desc} = "enter_exit"; 2975 $Coro::current->{desc} = "enter_exit";
2706 2976
2707 unless (eval { 2977 unless (eval {
2708 $self->deactivate_recursive; # just to be sure 2978 $self->deactivate_recursive; # just to be sure
2709 2979
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; 2980 my $map = cf::map::normalise $exit->slaying, $exit->map;
2719 my $x = $exit->stats->hp; 2981 my $x = $exit->stats->hp;
2720 my $y = $exit->stats->sp; 2982 my $y = $exit->stats->sp;
2983
2984 # special map handling
2985 my $slaying = $exit->slaying;
2986
2987 # special map handling
2988 if ($slaying eq "/!") {
2989 my $guard = cf::lock_acquire "exit_prepare:$exit";
2990
2991 prepare_random_map $exit
2992 if $exit->slaying eq "/!"; # need to re-check after getting the lock
2993
2994 $map = $exit->slaying;
2995
2996 } elsif ($slaying eq '!up') {
2997 $map = $exit->map->tile_path (cf::TILE_UP);
2998 $x = $exit->x;
2999 $y = $exit->y;
3000
3001 } elsif ($slaying eq '!down') {
3002 $map = $exit->map->tile_path (cf::TILE_DOWN);
3003 $x = $exit->x;
3004 $y = $exit->y;
3005 }
2721 3006
2722 $self->goto ($map, $x, $y); 3007 $self->goto ($map, $x, $y);
2723 3008
2724 # if exit is damned, update players death & WoR home-position 3009 # if exit is damned, update players death & WoR home-position
2725 $self->contr->savebed ($map, $x, $y) 3010 $self->contr->savebed ($map, $x, $y)
… …
2730 $self->message ("Something went wrong deep within the deliantra server. " 3015 $self->message ("Something went wrong deep within the deliantra server. "
2731 . "I'll try to bring you back to the map you were before. " 3016 . "I'll try to bring you back to the map you were before. "
2732 . "Please report this to the dungeon master!", 3017 . "Please report this to the dungeon master!",
2733 cf::NDI_UNIQUE | cf::NDI_RED); 3018 cf::NDI_UNIQUE | cf::NDI_RED);
2734 3019
2735 warn "ERROR in enter_exit: $@"; 3020 error "ERROR in enter_exit: $@";
2736 $self->leave_link; 3021 $self->leave_link;
2737 } 3022 }
2738 })->prio (1); 3023 })->prio (1);
2739} 3024}
2740 3025
… …
2752sub cf::client::send_drawinfo { 3037sub cf::client::send_drawinfo {
2753 my ($self, $text, $flags) = @_; 3038 my ($self, $text, $flags) = @_;
2754 3039
2755 utf8::encode $text; 3040 utf8::encode $text;
2756 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 3041 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
3042}
3043
3044=item $client->send_big_packet ($pkt)
3045
3046Like C<send_packet>, but tries to compress large packets, and fragments
3047them as required.
3048
3049=cut
3050
3051our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
3052
3053sub cf::client::send_big_packet {
3054 my ($self, $pkt) = @_;
3055
3056 # try lzf for large packets
3057 $pkt = "lzf " . Compress::LZF::compress $pkt
3058 if 1024 <= length $pkt and $self->{can_lzf};
3059
3060 # split very large packets
3061 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3062 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3063 $pkt = "frag";
3064 }
3065
3066 $self->send_packet ($pkt);
2757} 3067}
2758 3068
2759=item $client->send_msg ($channel, $msg, $color, [extra...]) 3069=item $client->send_msg ($channel, $msg, $color, [extra...])
2760 3070
2761Send a drawinfo or msg packet to the client, formatting the msg for the 3071Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2765 3075
2766=cut 3076=cut
2767 3077
2768# non-persistent channels (usually the info channel) 3078# non-persistent channels (usually the info channel)
2769our %CHANNEL = ( 3079our %CHANNEL = (
3080 "c/motd" => {
3081 id => "infobox",
3082 title => "MOTD",
3083 reply => undef,
3084 tooltip => "The message of the day",
3085 },
2770 "c/identify" => { 3086 "c/identify" => {
2771 id => "infobox", 3087 id => "infobox",
2772 title => "Identify", 3088 title => "Identify",
2773 reply => undef, 3089 reply => undef,
2774 tooltip => "Items recently identified", 3090 tooltip => "Items recently identified",
… …
2776 "c/examine" => { 3092 "c/examine" => {
2777 id => "infobox", 3093 id => "infobox",
2778 title => "Examine", 3094 title => "Examine",
2779 reply => undef, 3095 reply => undef,
2780 tooltip => "Signs and other items you examined", 3096 tooltip => "Signs and other items you examined",
3097 },
3098 "c/shopinfo" => {
3099 id => "infobox",
3100 title => "Shop Info",
3101 reply => undef,
3102 tooltip => "What your bargaining skill tells you about the shop",
2781 }, 3103 },
2782 "c/book" => { 3104 "c/book" => {
2783 id => "infobox", 3105 id => "infobox",
2784 title => "Book", 3106 title => "Book",
2785 reply => undef, 3107 reply => undef,
… …
2901 my $pkt = "msg " 3223 my $pkt = "msg "
2902 . $self->{json_coder}->encode ( 3224 . $self->{json_coder}->encode (
2903 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3225 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2904 ); 3226 );
2905 3227
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); 3228 $self->send_big_packet ($pkt);
2917} 3229}
2918 3230
2919=item $client->ext_msg ($type, @msg) 3231=item $client->ext_msg ($type, @msg)
2920 3232
2921Sends an ext event to the client. 3233Sends an ext event to the client.
… …
2923=cut 3235=cut
2924 3236
2925sub cf::client::ext_msg($$@) { 3237sub cf::client::ext_msg($$@) {
2926 my ($self, $type, @msg) = @_; 3238 my ($self, $type, @msg) = @_;
2927 3239
2928 if ($self->extcmd == 2) {
2929 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3240 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2930 } elsif ($self->extcmd == 1) { # TODO: remove
2931 push @msg, msgtype => "event_$type";
2932 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2933 }
2934} 3241}
2935 3242
2936=item $client->ext_reply ($msgid, @msg) 3243=item $client->ext_reply ($msgid, @msg)
2937 3244
2938Sends an ext reply to the client. 3245Sends an ext reply to the client.
… …
2940=cut 3247=cut
2941 3248
2942sub cf::client::ext_reply($$@) { 3249sub cf::client::ext_reply($$@) {
2943 my ($self, $id, @msg) = @_; 3250 my ($self, $id, @msg) = @_;
2944 3251
2945 if ($self->extcmd == 2) {
2946 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3252 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2947 } elsif ($self->extcmd == 1) {
2948 #TODO: version 1, remove
2949 unshift @msg, msgtype => "reply", msgid => $id;
2950 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2951 }
2952} 3253}
2953 3254
2954=item $success = $client->query ($flags, "text", \&cb) 3255=item $success = $client->query ($flags, "text", \&cb)
2955 3256
2956Queues a query to the client, calling the given callback with 3257Queues a query to the client, calling the given callback with
… …
3011 my ($ns, $buf) = @_; 3312 my ($ns, $buf) = @_;
3012 3313
3013 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3314 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3014 3315
3015 if (ref $msg) { 3316 if (ref $msg) {
3016 my ($type, $reply, @payload) = 3317 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3017 "ARRAY" eq ref $msg
3018 ? @$msg
3019 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3020 3318
3021 my @reply; 3319 my @reply;
3022 3320
3023 if (my $cb = $EXTICMD{$type}) { 3321 if (my $cb = $EXTICMD{$type}) {
3024 @reply = $cb->($ns, @payload); 3322 @reply = $cb->($ns, @payload);
… …
3026 3324
3027 $ns->ext_reply ($reply, @reply) 3325 $ns->ext_reply ($reply, @reply)
3028 if $reply; 3326 if $reply;
3029 3327
3030 } else { 3328 } else {
3031 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3329 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3032 } 3330 }
3033 3331
3034 cf::override; 3332 cf::override;
3035 }, 3333 },
3036); 3334);
… …
3056 3354
3057 $coro 3355 $coro
3058} 3356}
3059 3357
3060cf::client->attach ( 3358cf::client->attach (
3061 on_destroy => sub { 3359 on_client_destroy => sub {
3062 my ($ns) = @_; 3360 my ($ns) = @_;
3063 3361
3064 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3362 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3065 }, 3363 },
3066); 3364);
… …
3082our $safe_hole = new Safe::Hole; 3380our $safe_hole = new Safe::Hole;
3083 3381
3084$SIG{FPE} = 'IGNORE'; 3382$SIG{FPE} = 'IGNORE';
3085 3383
3086$safe->permit_only (Opcode::opset qw( 3384$safe->permit_only (Opcode::opset qw(
3087 :base_core :base_mem :base_orig :base_math 3385 :base_core :base_mem :base_orig :base_math :base_loop
3088 grepstart grepwhile mapstart mapwhile 3386 grepstart grepwhile mapstart mapwhile
3089 sort time 3387 sort time
3090)); 3388));
3091 3389
3092# here we export the classes and methods available to script code 3390# here we export the classes and methods available to script code
… …
3117 decrease split destroy change_exp value msg lore send_msg)], 3415 decrease split destroy change_exp value msg lore send_msg)],
3118 ["cf::object::player" => qw(player)], 3416 ["cf::object::player" => qw(player)],
3119 ["cf::player" => qw(peaceful send_msg)], 3417 ["cf::player" => qw(peaceful send_msg)],
3120 ["cf::map" => qw(trigger)], 3418 ["cf::map" => qw(trigger)],
3121) { 3419) {
3122 no strict 'refs';
3123 my ($pkg, @funs) = @$_; 3420 my ($pkg, @funs) = @$_;
3124 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3421 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3125 for @funs; 3422 for @funs;
3126} 3423}
3127 3424
… …
3144 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3441 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3145 $qcode =~ s/\n/\\n/g; 3442 $qcode =~ s/\n/\\n/g;
3146 3443
3147 %vars = (_dummy => 0) unless %vars; 3444 %vars = (_dummy => 0) unless %vars;
3148 3445
3446 my @res;
3149 local $_; 3447 local $_;
3150 local @safe::cf::_safe_eval_args = values %vars;
3151 3448
3152 my $eval = 3449 my $eval =
3153 "do {\n" 3450 "do {\n"
3154 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3451 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3155 . "#line 0 \"{$qcode}\"\n" 3452 . "#line 0 \"{$qcode}\"\n"
3156 . $code 3453 . $code
3157 . "\n}" 3454 . "\n}"
3158 ; 3455 ;
3159 3456
3457 if ($CFG{safe_eval}) {
3160 sub_generation_inc; 3458 sub_generation_inc;
3459 local @safe::cf::_safe_eval_args = values %vars;
3161 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3460 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3162 sub_generation_inc; 3461 sub_generation_inc;
3462 } else {
3463 local @cf::_safe_eval_args = values %vars;
3464 @res = wantarray ? eval eval : scalar eval $eval;
3465 }
3163 3466
3164 if ($@) { 3467 if ($@) {
3165 warn "$@"; 3468 warn "$@",
3166 warn "while executing safe code '$code'\n"; 3469 "while executing safe code '$code'\n",
3167 warn "with arguments " . (join " ", %vars) . "\n"; 3470 "with arguments " . (join " ", %vars) . "\n";
3168 } 3471 }
3169 3472
3170 wantarray ? @res : $res[0] 3473 wantarray ? @res : $res[0]
3171} 3474}
3172 3475
… …
3186=cut 3489=cut
3187 3490
3188sub register_script_function { 3491sub register_script_function {
3189 my ($fun, $cb) = @_; 3492 my ($fun, $cb) = @_;
3190 3493
3191 no strict 'refs'; 3494 $fun = "safe::$fun" if $CFG{safe_eval};
3192 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3495 *$fun = $safe_hole->wrap ($cb);
3193} 3496}
3194 3497
3195=back 3498=back
3196 3499
3197=cut 3500=cut
3198 3501
3199############################################################################# 3502#############################################################################
3200# the server's init and main functions 3503# the server's init and main functions
3504
3505our %FACEHASH; # hash => idx, #d# HACK for http server
3506
3507# internal api, not fianlised
3508sub add_face {
3509 my ($name, $type, $data) = @_;
3510
3511 my $idx = cf::face::find $name;
3512
3513 if ($idx) {
3514 delete $FACEHASH{cf::face::get_chksum $idx};
3515 } else {
3516 $idx = cf::face::alloc $name;
3517 }
3518
3519 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
3520
3521 cf::face::set_type $idx, $type;
3522 cf::face::set_data $idx, 0, $data, $hash;
3523 cf::face::set_meta $idx, $type & 1 ? undef : undef;
3524 $FACEHASH{$hash} = $idx;#d#
3525
3526 $idx
3527}
3201 3528
3202sub load_facedata($) { 3529sub load_facedata($) {
3203 my ($path) = @_; 3530 my ($path) = @_;
3204 3531
3205 # HACK to clear player env face cache, we need some signal framework 3532 # HACK to clear player env face cache, we need some signal framework
3206 # for this (global event?) 3533 # for this (global event?)
3207 %ext::player_env::MUSIC_FACE_CACHE = (); 3534 %ext::player_env::MUSIC_FACE_CACHE = ();
3208 3535
3209 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3536 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3210 3537
3211 warn "loading facedata from $path\n"; 3538 trace "loading facedata from $path\n";
3212 3539
3213 my $facedata; 3540 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 3541
3219 $facedata->{version} == 2 3542 $facedata->{version} == 2
3220 or cf::cleanup "$path: version mismatch, cannot proceed."; 3543 or cf::cleanup "$path: version mismatch, cannot proceed.";
3221 3544
3222 # patch in the exptable
3223 $facedata->{resource}{"res/exp_table"} = {
3224 type => FT_RSRC,
3225 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3226 };
3227 cf::cede_to_tick; 3545 cf::cede_to_tick;
3228 3546
3229 { 3547 {
3230 my $faces = $facedata->{faceinfo}; 3548 my $faces = $facedata->{faceinfo};
3231 3549
3232 while (my ($face, $info) = each %$faces) { 3550 for my $face (sort keys %$faces) {
3551 my $info = $faces->{$face};
3233 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3552 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3234 3553
3235 cf::face::set_visibility $idx, $info->{visibility}; 3554 cf::face::set_visibility $idx, $info->{visibility};
3236 cf::face::set_magicmap $idx, $info->{magicmap}; 3555 cf::face::set_magicmap $idx, $info->{magicmap};
3237 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3556 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3238 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3557 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3558 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3559 $FACEHASH{$info->{hash64}} = $idx;#d#
3239 3560
3240 cf::cede_to_tick; 3561 cf::cede_to_tick;
3241 } 3562 }
3242 3563
3243 while (my ($face, $info) = each %$faces) { 3564 while (my ($face, $info) = each %$faces) {
… …
3248 3569
3249 if (my $smooth = cf::face::find $info->{smooth}) { 3570 if (my $smooth = cf::face::find $info->{smooth}) {
3250 cf::face::set_smooth $idx, $smooth; 3571 cf::face::set_smooth $idx, $smooth;
3251 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3572 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3252 } else { 3573 } else {
3253 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3574 error "smooth face '$info->{smooth}' not found for face '$face'";
3254 } 3575 }
3255 3576
3256 cf::cede_to_tick; 3577 cf::cede_to_tick;
3257 } 3578 }
3258 } 3579 }
… …
3267 3588
3268 cf::anim::invalidate_all; # d'oh 3589 cf::anim::invalidate_all; # d'oh
3269 } 3590 }
3270 3591
3271 { 3592 {
3272 # TODO: for gcfclient pleasure, we should give resources
3273 # that gcfclient doesn't grok a >10000 face index.
3274 my $res = $facedata->{resource}; 3593 my $res = $facedata->{resource};
3275 3594
3276 while (my ($name, $info) = each %$res) { 3595 while (my ($name, $info) = each %$res) {
3277 if (defined $info->{type}) { 3596 if (defined (my $type = $info->{type})) {
3597 # TODO: different hash - must free and use new index, or cache ixface data queue
3278 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3598 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3279 my $data;
3280 3599
3281 if ($info->{type} & 1) {
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}; 3600 cf::face::set_type $idx, $type;
3601 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3602 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3603 $FACEHASH{$info->{hash}} = $idx;#d#
3296 } else { 3604 } else {
3297 $RESOURCE{$name} = $info; 3605# $RESOURCE{$name} = $info; # unused
3298 } 3606 }
3299 3607
3300 cf::cede_to_tick; 3608 cf::cede_to_tick;
3301 } 3609 }
3302 } 3610 }
3303 3611
3304 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3612 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3305 3613
3306 1 3614 1
3307} 3615}
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 3616
3329register_exticmd fx_want => sub { 3617register_exticmd fx_want => sub {
3330 my ($ns, $want) = @_; 3618 my ($ns, $want) = @_;
3331 3619
3332 while (my ($k, $v) = each %$want) { 3620 while (my ($k, $v) = each %$want) {
… …
3340 my $status = load_resource_file_ $_[0]; 3628 my $status = load_resource_file_ $_[0];
3341 get_slot 0.1, 100; 3629 get_slot 0.1, 100;
3342 cf::arch::commit_load; 3630 cf::arch::commit_load;
3343 3631
3344 $status 3632 $status
3633}
3634
3635sub reload_exp_table {
3636 _reload_exp_table;
3637
3638 add_face "res/exp_table" => FT_RSRC,
3639 JSON::XS->new->utf8->canonical->encode (
3640 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3641 );
3642}
3643
3644sub reload_materials {
3645 _reload_materials;
3345} 3646}
3346 3647
3347sub reload_regions { 3648sub reload_regions {
3348 # HACK to clear player env face cache, we need some signal framework 3649 # HACK to clear player env face cache, we need some signal framework
3349 # for this (global event?) 3650 # for this (global event?)
… …
3364} 3665}
3365 3666
3366sub reload_archetypes { 3667sub reload_archetypes {
3367 load_resource_file "$DATADIR/archetypes" 3668 load_resource_file "$DATADIR/archetypes"
3368 or die "unable to load archetypes\n"; 3669 or die "unable to load archetypes\n";
3670
3671 add_face "res/skill_info" => FT_RSRC,
3672 JSON::XS->new->utf8->canonical->encode (
3673 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3674 );
3675 add_face "res/spell_paths" => FT_RSRC,
3676 JSON::XS->new->utf8->canonical->encode (
3677 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3678 );
3369} 3679}
3370 3680
3371sub reload_treasures { 3681sub reload_treasures {
3372 load_resource_file "$DATADIR/treasures" 3682 load_resource_file "$DATADIR/treasures"
3373 or die "unable to load treasurelists\n"; 3683 or die "unable to load treasurelists\n";
3374} 3684}
3375 3685
3686sub reload_sound {
3687 trace "loading sound config from $DATADIR/sound\n";
3688
3689 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3690
3691 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3692 my $sound = $soundconf->{compat}[$_]
3693 or next;
3694
3695 my $face = cf::face::find "sound/$sound->[1]";
3696 cf::sound::set $sound->[0] => $face;
3697 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3698 }
3699
3700 while (my ($k, $v) = each %{$soundconf->{event}}) {
3701 my $face = cf::face::find "sound/$v";
3702 cf::sound::set $k => $face;
3703 }
3704}
3705
3376sub reload_resources { 3706sub reload_resources {
3377 warn "reloading resource files...\n"; 3707 trace "reloading resource files...\n";
3378 3708
3709 reload_materials;
3379 reload_facedata; 3710 reload_facedata;
3711 reload_exp_table;
3712 reload_sound;
3380 reload_archetypes; 3713 reload_archetypes;
3381 reload_regions; 3714 reload_regions;
3382 reload_treasures; 3715 reload_treasures;
3383 3716
3384 warn "finished reloading resource files\n"; 3717 trace "finished reloading resource files\n";
3385} 3718}
3386 3719
3387sub reload_config { 3720sub reload_config {
3388 open my $fh, "<:utf8", "$CONFDIR/config" 3721 trace "reloading config file...\n";
3389 or return;
3390 3722
3391 local $/; 3723 my $config = load_file "$CONFDIR/config";
3392 *CFG = YAML::XS::Load <$fh>; 3724 utf8::decode $config;
3725 *CFG = decode_yaml $config;
3393 3726
3394 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3727 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3395 3728
3396 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3729 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3397 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3730 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3398 3731
3399 if (exists $CFG{mlockall}) { 3732 if (exists $CFG{mlockall}) {
… …
3423 seek $fh, 0, 0; 3756 seek $fh, 0, 0;
3424 print $fh $$; 3757 print $fh $$;
3425} 3758}
3426 3759
3427sub main_loop { 3760sub main_loop {
3428 warn "EV::loop starting\n"; 3761 trace "EV::loop starting\n";
3429 if (1) { 3762 if (1) {
3430 EV::loop; 3763 EV::loop;
3431 } 3764 }
3432 warn "EV::loop returned\n"; 3765 trace "EV::loop returned\n";
3433 goto &main_loop unless $REALLY_UNLOOP; 3766 goto &main_loop unless $REALLY_UNLOOP;
3434} 3767}
3435 3768
3436sub main { 3769sub main {
3437 cf::init_globals; # initialise logging 3770 cf::init_globals; # initialise logging
3438 3771
3439 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3772 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3440 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3773 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3441 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3774 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3442 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3775 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3443 3776
3444 cf::init_experience;
3445 cf::init_anim;
3446 cf::init_attackmess;
3447 cf::init_dynamic;
3448
3449 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3777 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3450 3778
3451 # we must not ever block the main coroutine 3779 # we must not ever block the main coroutine
3452 local $Coro::idle = sub { 3780 $Coro::idle = sub {
3453 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3781 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3454 (async { 3782 (async {
3455 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3783 $Coro::current->{desc} = "IDLE BUG HANDLER";
3456 EV::loop EV::LOOP_ONESHOT; 3784 EV::loop EV::LOOP_ONESHOT;
3457 })->prio (Coro::PRIO_MAX); 3785 })->prio (Coro::PRIO_MAX);
3458 }; 3786 };
3459 3787
3460 evthread_start IO::AIO::poll_fileno; 3788 evthread_start IO::AIO::poll_fileno;
3461 3789
3462 cf::sync_job { 3790 cf::sync_job {
3791 cf::incloader::init ();
3792
3793 cf::init_anim;
3794 cf::init_attackmess;
3795 cf::init_dynamic;
3796
3797 cf::load_settings;
3798
3463 reload_resources; 3799 reload_resources;
3464 reload_config; 3800 reload_config;
3465 db_init; 3801 db_init;
3466 3802
3467 cf::load_settings;
3468 cf::load_materials;
3469 cf::init_uuid; 3803 cf::init_uuid;
3470 cf::init_signals; 3804 cf::init_signals;
3471 cf::init_commands;
3472 cf::init_skills; 3805 cf::init_skills;
3473 3806
3474 cf::init_beforeplay; 3807 cf::init_beforeplay;
3475 3808
3476 atomic; 3809 atomic;
… …
3481 3814
3482 # no (long-running) fork's whatsoever before this point(!) 3815 # no (long-running) fork's whatsoever before this point(!)
3483 use POSIX (); 3816 use POSIX ();
3484 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3817 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3485 3818
3486 (pop @POST_INIT)->(0) while @POST_INIT; 3819 cf::_post_init 0;
3487 }; 3820 };
3488 3821
3822 cf::object::thawer::errors_are_fatal 0;
3823 info "parse errors in files are no longer fatal from this point on.\n";
3824
3825 AE::postpone {
3826 undef &main; # free gobs of memory :)
3827 };
3828
3489 main_loop; 3829 goto &main_loop;
3490} 3830}
3491 3831
3492############################################################################# 3832#############################################################################
3493# initialisation and cleanup 3833# initialisation and cleanup
3494 3834
3495# install some emergency cleanup handlers 3835# install some emergency cleanup handlers
3496BEGIN { 3836BEGIN {
3497 our %SIGWATCHER = (); 3837 our %SIGWATCHER = ();
3498 for my $signal (qw(INT HUP TERM)) { 3838 for my $signal (qw(INT HUP TERM)) {
3499 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3839 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3500 cf::cleanup "SIG$signal"; 3840 cf::cleanup "SIG$signal";
3501 }; 3841 };
3502 } 3842 }
3503} 3843}
3504 3844
3505sub write_runtime_sync { 3845sub write_runtime_sync {
3846 my $t0 = AE::time;
3847
3506 # first touch the runtime file to show we are still running: 3848 # first touch the runtime file to show we are still running:
3507 # the fsync below can take a very very long time. 3849 # the fsync below can take a very very long time.
3508 3850
3509 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3851 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3510 3852
3511 my $guard = cf::lock_acquire "write_runtime"; 3853 my $guard = cf::lock_acquire "write_runtime";
3512 3854
3513 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3855 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3514 or return; 3856 or return;
3515 3857
3516 my $value = $cf::RUNTIME + 90 + 10; 3858 my $value = $cf::RUNTIME + 90 + 10;
3517 # 10 is the runtime save interval, for a monotonic clock 3859 # 10 is the runtime save interval, for a monotonic clock
3518 # 60 allows for the watchdog to kill the server. 3860 # 60 allows for the watchdog to kill the server.
… …
3531 or return; 3873 or return;
3532 3874
3533 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3875 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3534 and return; 3876 and return;
3535 3877
3536 warn "runtime file written.\n"; 3878 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3537 3879
3538 1 3880 1
3539} 3881}
3540 3882
3541our $uuid_lock; 3883our $uuid_lock;
… …
3553 or return; 3895 or return;
3554 3896
3555 my $value = uuid_seq uuid_cur; 3897 my $value = uuid_seq uuid_cur;
3556 3898
3557 unless ($value) { 3899 unless ($value) {
3558 warn "cowardly refusing to write zero uuid value!\n"; 3900 info "cowardly refusing to write zero uuid value!\n";
3559 return; 3901 return;
3560 } 3902 }
3561 3903
3562 my $value = uuid_str $value + $uuid_skip; 3904 my $value = uuid_str $value + $uuid_skip;
3563 $uuid_skip = 0; 3905 $uuid_skip = 0;
… …
3573 or return; 3915 or return;
3574 3916
3575 aio_rename "$uuid~", $uuid 3917 aio_rename "$uuid~", $uuid
3576 and return; 3918 and return;
3577 3919
3578 warn "uuid file written ($value).\n"; 3920 trace "uuid file written ($value).\n";
3579 3921
3580 1 3922 1
3581 3923
3582} 3924}
3583 3925
… …
3589} 3931}
3590 3932
3591sub emergency_save() { 3933sub emergency_save() {
3592 my $freeze_guard = cf::freeze_mainloop; 3934 my $freeze_guard = cf::freeze_mainloop;
3593 3935
3594 warn "emergency_perl_save: enter\n"; 3936 info "emergency_perl_save: enter\n";
3937
3938 # this is a trade-off: we want to be very quick here, so
3939 # save all maps without fsync, and later call a global sync
3940 # (which in turn might be very very slow)
3941 local $USE_FSYNC = 0;
3595 3942
3596 cf::sync_job { 3943 cf::sync_job {
3597 # this is a trade-off: we want to be very quick here, so 3944 cf::write_runtime_sync; # external watchdog should not bark
3598 # save all maps without fsync, and later call a global sync
3599 # (which in turn might be very very slow)
3600 local $USE_FSYNC = 0;
3601 3945
3602 # use a peculiar iteration method to avoid tripping on perl 3946 # use a peculiar iteration method to avoid tripping on perl
3603 # refcount bugs in for. also avoids problems with players 3947 # refcount bugs in for. also avoids problems with players
3604 # and maps saved/destroyed asynchronously. 3948 # and maps saved/destroyed asynchronously.
3605 warn "emergency_perl_save: begin player save\n"; 3949 info "emergency_perl_save: begin player save\n";
3606 for my $login (keys %cf::PLAYER) { 3950 for my $login (keys %cf::PLAYER) {
3607 my $pl = $cf::PLAYER{$login} or next; 3951 my $pl = $cf::PLAYER{$login} or next;
3608 $pl->valid or next; 3952 $pl->valid or next;
3609 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3953 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3610 $pl->save; 3954 $pl->save;
3611 } 3955 }
3612 warn "emergency_perl_save: end player save\n"; 3956 info "emergency_perl_save: end player save\n";
3613 3957
3958 cf::write_runtime_sync; # external watchdog should not bark
3959
3614 warn "emergency_perl_save: begin map save\n"; 3960 info "emergency_perl_save: begin map save\n";
3615 for my $path (keys %cf::MAP) { 3961 for my $path (keys %cf::MAP) {
3616 my $map = $cf::MAP{$path} or next; 3962 my $map = $cf::MAP{$path} or next;
3617 $map->valid or next; 3963 $map->valid or next;
3618 $map->save; 3964 $map->save;
3619 } 3965 }
3620 warn "emergency_perl_save: end map save\n"; 3966 info "emergency_perl_save: end map save\n";
3621 3967
3968 cf::write_runtime_sync; # external watchdog should not bark
3969
3622 warn "emergency_perl_save: begin database checkpoint\n"; 3970 info "emergency_perl_save: begin database checkpoint\n";
3623 BDB::db_env_txn_checkpoint $DB_ENV; 3971 BDB::db_env_txn_checkpoint $DB_ENV;
3624 warn "emergency_perl_save: end database checkpoint\n"; 3972 info "emergency_perl_save: end database checkpoint\n";
3625 3973
3626 warn "emergency_perl_save: begin write uuid\n"; 3974 info "emergency_perl_save: begin write uuid\n";
3627 write_uuid_sync 1; 3975 write_uuid_sync 1;
3628 warn "emergency_perl_save: end write uuid\n"; 3976 info "emergency_perl_save: end write uuid\n";
3977
3978 cf::write_runtime_sync; # external watchdog should not bark
3979
3980 trace "emergency_perl_save: syncing database to disk";
3981 BDB::db_env_txn_checkpoint $DB_ENV;
3982
3983 info "emergency_perl_save: starting sync\n";
3984 IO::AIO::aio_sync sub {
3985 info "emergency_perl_save: finished sync\n";
3986 };
3987
3988 cf::write_runtime_sync; # external watchdog should not bark
3989
3990 trace "emergency_perl_save: flushing outstanding aio requests";
3991 while (IO::AIO::nreqs || BDB::nreqs) {
3992 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3993 }
3994
3995 cf::write_runtime_sync; # external watchdog should not bark
3629 }; 3996 };
3630 3997
3631 warn "emergency_perl_save: starting sync()\n";
3632 IO::AIO::aio_sync sub {
3633 warn "emergency_perl_save: finished sync()\n";
3634 };
3635
3636 warn "emergency_perl_save: leave\n"; 3998 info "emergency_perl_save: leave\n";
3637} 3999}
3638 4000
3639sub post_cleanup { 4001sub post_cleanup {
3640 my ($make_core) = @_; 4002 my ($make_core) = @_;
3641 4003
4004 IO::AIO::flush;
4005
3642 warn Carp::longmess "post_cleanup backtrace" 4006 error Carp::longmess "post_cleanup backtrace"
3643 if $make_core; 4007 if $make_core;
3644 4008
3645 my $fh = pidfile; 4009 my $fh = pidfile;
3646 unlink $PIDFILE if <$fh> == $$; 4010 unlink $PIDFILE if <$fh> == $$;
3647} 4011}
… …
3667 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 4031 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3668 for my $name (keys %$leaf_symtab) { 4032 for my $name (keys %$leaf_symtab) {
3669 _gv_clear *{"$pkg$name"}; 4033 _gv_clear *{"$pkg$name"};
3670# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 4034# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3671 } 4035 }
3672 warn "cleared package $pkg\n";#d#
3673} 4036}
3674 4037
3675sub do_reload_perl() { 4038sub do_reload_perl() {
3676 # can/must only be called in main 4039 # can/must only be called in main
3677 if ($Coro::current != $Coro::main) { 4040 unless (in_main) {
3678 warn "can only reload from main coroutine"; 4041 error "can only reload from main coroutine";
3679 return; 4042 return;
3680 } 4043 }
3681 4044
3682 return if $RELOAD++; 4045 return if $RELOAD++;
3683 4046
3684 my $t1 = EV::time; 4047 my $t1 = AE::time;
3685 4048
3686 while ($RELOAD) { 4049 while ($RELOAD) {
3687 warn "reloading..."; 4050 cf::get_slot 0.1, -1, "reload_perl";
4051 info "perl_reload: reloading...";
3688 4052
3689 warn "entering sync_job"; 4053 trace "perl_reload: entering sync_job";
3690 4054
3691 cf::sync_job { 4055 cf::sync_job {
3692 cf::write_runtime_sync; # external watchdog should not bark
3693 cf::emergency_save; 4056 #cf::emergency_save;
3694 cf::write_runtime_sync; # external watchdog should not bark
3695 4057
3696 warn "syncing database to disk";
3697 BDB::db_env_txn_checkpoint $DB_ENV;
3698
3699 # if anything goes wrong in here, we should simply crash as we already saved
3700
3701 warn "flushing outstanding aio requests";
3702 while (IO::AIO::nreqs || BDB::nreqs) {
3703 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3704 }
3705
3706 warn "cancelling all extension coros"; 4058 trace "perl_reload: cancelling all extension coros";
3707 $_->cancel for values %EXT_CORO; 4059 $_->cancel for values %EXT_CORO;
3708 %EXT_CORO = (); 4060 %EXT_CORO = ();
3709 4061
3710 warn "removing commands"; 4062 trace "perl_reload: removing commands";
3711 %COMMAND = (); 4063 %COMMAND = ();
3712 4064
3713 warn "removing ext/exti commands"; 4065 trace "perl_reload: removing ext/exti commands";
3714 %EXTCMD = (); 4066 %EXTCMD = ();
3715 %EXTICMD = (); 4067 %EXTICMD = ();
3716 4068
3717 warn "unloading/nuking all extensions"; 4069 trace "perl_reload: unloading/nuking all extensions";
3718 for my $pkg (@EXTS) { 4070 for my $pkg (@EXTS) {
3719 warn "... unloading $pkg"; 4071 trace "... unloading $pkg";
3720 4072
3721 if (my $cb = $pkg->can ("unload")) { 4073 if (my $cb = $pkg->can ("unload")) {
3722 eval { 4074 eval {
3723 $cb->($pkg); 4075 $cb->($pkg);
3724 1 4076 1
3725 } or warn "$pkg unloaded, but with errors: $@"; 4077 } or error "$pkg unloaded, but with errors: $@";
3726 } 4078 }
3727 4079
3728 warn "... clearing $pkg"; 4080 trace "... clearing $pkg";
3729 clear_package $pkg; 4081 clear_package $pkg;
3730 } 4082 }
3731 4083
3732 warn "unloading all perl modules loaded from $LIBDIR"; 4084 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3733 while (my ($k, $v) = each %INC) { 4085 while (my ($k, $v) = each %INC) {
3734 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4086 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3735 4087
3736 warn "... unloading $k"; 4088 trace "... unloading $k";
3737 delete $INC{$k}; 4089 delete $INC{$k};
3738 4090
3739 $k =~ s/\.pm$//; 4091 $k =~ s/\.pm$//;
3740 $k =~ s/\//::/g; 4092 $k =~ s/\//::/g;
3741 4093
… …
3744 } 4096 }
3745 4097
3746 clear_package $k; 4098 clear_package $k;
3747 } 4099 }
3748 4100
3749 warn "getting rid of safe::, as good as possible"; 4101 trace "perl_reload: getting rid of safe::, as good as possible";
3750 clear_package "safe::$_" 4102 clear_package "safe::$_"
3751 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4103 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3752 4104
3753 warn "unloading cf.pm \"a bit\""; 4105 trace "perl_reload: unloading cf.pm \"a bit\"";
3754 delete $INC{"cf.pm"}; 4106 delete $INC{"cf.pm"};
3755 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4107 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3756 4108
3757 # don't, removes xs symbols, too, 4109 # don't, removes xs symbols, too,
3758 # and global variables created in xs 4110 # and global variables created in xs
3759 #clear_package __PACKAGE__; 4111 #clear_package __PACKAGE__;
3760 4112
3761 warn "unload completed, starting to reload now"; 4113 info "perl_reload: unload completed, starting to reload now";
3762 4114
3763 warn "reloading cf.pm"; 4115 trace "perl_reload: reloading cf.pm";
3764 require cf; 4116 require cf;
3765 cf::_connect_to_perl_1; 4117 cf::_connect_to_perl_1;
3766 4118
3767 warn "loading config and database again"; 4119 trace "perl_reload: loading config and database again";
3768 cf::reload_config; 4120 cf::reload_config;
3769 4121
3770 warn "loading extensions"; 4122 trace "perl_reload: loading extensions";
3771 cf::load_extensions; 4123 cf::load_extensions;
3772 4124
3773 if ($REATTACH_ON_RELOAD) { 4125 if ($REATTACH_ON_RELOAD) {
3774 warn "reattaching attachments to objects/players"; 4126 trace "perl_reload: reattaching attachments to objects/players";
3775 _global_reattach; # objects, sockets 4127 _global_reattach; # objects, sockets
3776 warn "reattaching attachments to maps"; 4128 trace "perl_reload: reattaching attachments to maps";
3777 reattach $_ for values %MAP; 4129 reattach $_ for values %MAP;
3778 warn "reattaching attachments to players"; 4130 trace "perl_reload: reattaching attachments to players";
3779 reattach $_ for values %PLAYER; 4131 reattach $_ for values %PLAYER;
3780 } 4132 }
3781 4133
3782 warn "running post_init jobs"; 4134 cf::_post_init 1;
3783 (pop @POST_INIT)->(1) while @POST_INIT;
3784 4135
3785 warn "leaving sync_job"; 4136 trace "perl_reload: leaving sync_job";
3786 4137
3787 1 4138 1
3788 } or do { 4139 } or do {
3789 warn $@; 4140 error $@;
3790 cf::cleanup "error while reloading, exiting."; 4141 cf::cleanup "perl_reload: error, exiting.";
3791 }; 4142 };
3792 4143
3793 warn "reloaded";
3794 --$RELOAD; 4144 --$RELOAD;
3795 } 4145 }
3796 4146
3797 $t1 = EV::time - $t1; 4147 $t1 = AE::time - $t1;
3798 warn "reload completed in ${t1}s\n"; 4148 info "perl_reload: completed in ${t1}s\n";
3799}; 4149};
3800 4150
3801our $RELOAD_WATCHER; # used only during reload 4151our $RELOAD_WATCHER; # used only during reload
3802 4152
3803sub reload_perl() { 4153sub reload_perl() {
… …
3805 # coro crashes during coro_state_free->destroy here. 4155 # coro crashes during coro_state_free->destroy here.
3806 4156
3807 $RELOAD_WATCHER ||= cf::async { 4157 $RELOAD_WATCHER ||= cf::async {
3808 Coro::AIO::aio_wait cache_extensions; 4158 Coro::AIO::aio_wait cache_extensions;
3809 4159
3810 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 4160 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3811 do_reload_perl; 4161 do_reload_perl;
3812 undef $RELOAD_WATCHER; 4162 undef $RELOAD_WATCHER;
3813 }; 4163 };
3814 }; 4164 };
3815} 4165}
… …
3824 reload_perl; 4174 reload_perl;
3825 }; 4175 };
3826 } 4176 }
3827}; 4177};
3828 4178
3829unshift @INC, $LIBDIR; 4179#############################################################################
3830 4180
3831my $bug_warning = 0; 4181my $bug_warning = 0;
3832 4182
3833our @WAIT_FOR_TICK;
3834our @WAIT_FOR_TICK_BEGIN;
3835
3836sub wait_for_tick { 4183sub wait_for_tick() {
3837 return if tick_inhibit || $Coro::current == $Coro::main; 4184 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3838 4185
3839 my $signal = new Coro::Signal; 4186 $WAIT_FOR_TICK->wait;
3840 push @WAIT_FOR_TICK, $signal;
3841 $signal->wait;
3842} 4187}
3843 4188
3844sub wait_for_tick_begin { 4189sub wait_for_tick_begin() {
3845 return if tick_inhibit || $Coro::current == $Coro::main; 4190 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3846 4191
3847 my $signal = new Coro::Signal; 4192 my $signal = new Coro::Signal;
3848 push @WAIT_FOR_TICK_BEGIN, $signal; 4193 push @WAIT_FOR_TICK_BEGIN, $signal;
3849 $signal->wait; 4194 $signal->wait;
3850} 4195}
… …
3854 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4199 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3855 unless ++$bug_warning > 10; 4200 unless ++$bug_warning > 10;
3856 return; 4201 return;
3857 } 4202 }
3858 4203
3859 cf::server_tick; # one server iteration 4204 cf::one_tick; # one server iteration
4205
4206 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3860 4207
3861 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4208 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3862 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4209 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3863 Coro::async_pool { 4210 Coro::async_pool {
3864 $Coro::current->{desc} = "runtime saver"; 4211 $Coro::current->{desc} = "runtime saver";
3865 write_runtime_sync 4212 write_runtime_sync
3866 or warn "ERROR: unable to write runtime file: $!"; 4213 or error "ERROR: unable to write runtime file: $!";
3867 }; 4214 };
3868 } 4215 }
3869 4216
3870 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4217 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3871 $sig->send; 4218 $sig->send;
3872 } 4219 }
3873 while (my $sig = shift @WAIT_FOR_TICK) { 4220 $WAIT_FOR_TICK->broadcast;
3874 $sig->send;
3875 }
3876 4221
3877 $LOAD = ($NOW - $TICK_START) / $TICK; 4222 $LOAD = ($NOW - $TICK_START) / $TICK;
3878 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4223 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3879 4224
3880 if (0) { 4225 if (0) {
3881 if ($NEXT_TICK) { 4226 if ($NEXT_TICK) {
3882 my $jitter = $TICK_START - $NEXT_TICK; 4227 my $jitter = $TICK_START - $NEXT_TICK;
3883 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4228 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3884 warn "jitter $JITTER\n";#d# 4229 debug "jitter $JITTER\n";#d#
3885 } 4230 }
3886 } 4231 }
3887} 4232}
3888 4233
3889{ 4234{
3890 # configure BDB 4235 # configure BDB
3891 4236
3892 BDB::min_parallel 8; 4237 BDB::min_parallel 16;
3893 BDB::max_poll_reqs $TICK * 0.1; 4238 BDB::max_poll_reqs $TICK * 0.1;
3894 $AnyEvent::BDB::WATCHER->priority (1); 4239 #$AnyEvent::BDB::WATCHER->priority (1);
3895 4240
3896 unless ($DB_ENV) { 4241 unless ($DB_ENV) {
3897 $DB_ENV = BDB::db_env_create; 4242 $DB_ENV = BDB::db_env_create;
3898 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4243 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3899 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4244 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
3934 IO::AIO::min_parallel 8; 4279 IO::AIO::min_parallel 8;
3935 IO::AIO::max_poll_time $TICK * 0.1; 4280 IO::AIO::max_poll_time $TICK * 0.1;
3936 undef $AnyEvent::AIO::WATCHER; 4281 undef $AnyEvent::AIO::WATCHER;
3937} 4282}
3938 4283
3939my $_log_backtrace; 4284our $_log_backtrace;
4285our $_log_backtrace_last;
3940 4286
3941sub _log_backtrace { 4287sub _log_backtrace {
3942 my ($msg, @addr) = @_; 4288 my ($msg, @addr) = @_;
3943 4289
3944 $msg =~ s/\n//; 4290 $msg =~ s/\n$//;
3945 4291
4292 if ($_log_backtrace_last eq $msg) {
4293 LOG llevInfo, "[ABT] $msg\n";
4294 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3946 # limit the # of concurrent backtraces 4295 # limit the # of concurrent backtraces
3947 if ($_log_backtrace < 2) { 4296 } elsif ($_log_backtrace < 2) {
4297 $_log_backtrace_last = $msg;
3948 ++$_log_backtrace; 4298 ++$_log_backtrace;
3949 my $perl_bt = Carp::longmess $msg; 4299 my $perl_bt = Carp::longmess $msg;
3950 async { 4300 async {
3951 $Coro::current->{desc} = "abt $msg"; 4301 $Coro::current->{desc} = "abt $msg";
3952 4302
… …
3972 LOG llevInfo, "[ABT] $_\n" for @bt; 4322 LOG llevInfo, "[ABT] $_\n" for @bt;
3973 --$_log_backtrace; 4323 --$_log_backtrace;
3974 }; 4324 };
3975 } else { 4325 } else {
3976 LOG llevInfo, "[ABT] $msg\n"; 4326 LOG llevInfo, "[ABT] $msg\n";
3977 LOG llevInfo, "[ABT] [suppressed]\n"; 4327 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3978 } 4328 }
3979} 4329}
3980 4330
3981# load additional modules 4331# load additional modules
3982require "cf/$_.pm" for @EXTRA_MODULES; 4332require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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