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.514 by root, Mon Apr 12 17:13:36 2010 UTC vs.
Revision 1.597 by root, Sun Nov 11 02:14:37 2012 UTC

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

Diff Legend

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