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.519 by root, Fri Apr 16 02:32:25 2010 UTC vs.
Revision 1.596 by root, Fri Nov 9 20:37:57 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 {
… …
2257sub swap_out { 2448sub swap_out {
2258 my ($self) = @_; 2449 my ($self) = @_;
2259 2450
2260 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2451 my $lock = cf::lock_acquire "map_data:$self->{path}";
2261 2452
2262 return if $self->in_memory != cf::MAP_ACTIVE; 2453 return if !$self->linkable;
2263 return if $self->{deny_save}; 2454 return if $self->{deny_save};
2264 return if $self->players; 2455 return if $self->players;
2265 2456
2266 # first deactivate the map and "unlink" it from the core 2457 # first deactivate the map and "unlink" it from the core
2267 $self->deactivate; 2458 $self->deactivate;
2268 $_->clear_links_to ($self) for values %cf::MAP; 2459 $_->clear_links_to ($self) for values %cf::MAP;
2269 $self->in_memory (cf::MAP_SWAPPED); 2460 $self->state (cf::MAP_SWAPPED);
2270 2461
2271 # then atomically save 2462 # then atomically save
2272 $self->_save; 2463 $self->_save;
2273 2464
2274 # then free the map 2465 # then free the map
… …
2298 2489
2299 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2490 my $lock = cf::lock_acquire "map_data:$self->{path}";
2300 2491
2301 return if $self->players; 2492 return if $self->players;
2302 2493
2303 warn "resetting map ", $self->path, "\n"; 2494 cf::trace "resetting map ", $self->path, "\n";
2304 2495
2305 $self->in_memory (cf::MAP_SWAPPED); 2496 $self->state (cf::MAP_SWAPPED);
2306 2497
2307 # need to save uniques path 2498 # need to save uniques path
2308 unless ($self->{deny_save}) { 2499 unless ($self->{deny_save}) {
2309 my $uniq = $self->uniq_path; utf8::encode $uniq; 2500 my $uniq = $self->uniq_path; utf8::encode $uniq;
2310 2501
… …
2332 2523
2333 delete $cf::MAP{$self->path}; 2524 delete $cf::MAP{$self->path};
2334 2525
2335 $self->unlink_save; 2526 $self->unlink_save;
2336 2527
2337 bless $self, "cf::map"; 2528 bless $self, "cf::map::wrap";
2338 delete $self->{deny_reset}; 2529 delete $self->{deny_reset};
2339 $self->{deny_save} = 1; 2530 $self->{deny_save} = 1;
2340 $self->reset_timeout (1); 2531 $self->reset_timeout (1);
2341 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2532 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2342 2533
… …
2572 2763
2573Freezes 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}>).
2574 2765
2575The 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.
2576for 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,
2577though, 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
2578map. 2769map.
2579 2770
2580Will never block. 2771Will never block.
2581 2772
2582=item $player_object->leave_link ($map, $x, $y) 2773=item $player_object->leave_link ($map, $x, $y)
… …
2603sub cf::object::player::enter_link { 2794sub cf::object::player::enter_link {
2604 my ($self) = @_; 2795 my ($self) = @_;
2605 2796
2606 $self->deactivate_recursive; 2797 $self->deactivate_recursive;
2607 2798
2799 ++$self->{_link_recursion};
2800
2608 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2801 return if UNIVERSAL::isa $self->map, "ext::map_link";
2609 2802
2610 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2803 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2611 if $self->map && $self->map->{path} ne "{link}"; 2804 if $self->map && $self->map->{path} ne "{link}";
2612 2805
… …
2638 # use -1 or undef as default coordinates, not 0, 0 2831 # use -1 or undef as default coordinates, not 0, 0
2639 ($x, $y) = ($map->enter_x, $map->enter_y) 2832 ($x, $y) = ($map->enter_x, $map->enter_y)
2640 if $x <= 0 && $y <= 0; 2833 if $x <= 0 && $y <= 0;
2641 2834
2642 $map->load; 2835 $map->load;
2643 $map->load_neighbours;
2644 2836
2645 return unless $self->contr->active; 2837 return unless $self->contr->active;
2646 2838
2647 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2839 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2648 $self->enter_map ($map, $x, $y); 2840 if ($self->enter_map ($map, $x, $y)) {
2649 2841 # entering was successful
2842 delete $self->{_link_recursion};
2650 # only activate afterwards, to support waiting in hooks 2843 # only activate afterwards, to support waiting in hooks
2651 $self->activate_recursive; 2844 $self->activate_recursive;
2652} 2845 }
2653 2846
2847}
2848
2654=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)]])
2655 2850
2656Moves 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
2657her, loading and preparing them map, calling the provided $check callback 2852her, loading and preparing them map, calling the provided $check callback
2658that 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
2659the 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
… …
2666 2861
2667our $GOTOGEN; 2862our $GOTOGEN;
2668 2863
2669sub cf::object::player::goto { 2864sub cf::object::player::goto {
2670 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 }
2671 2872
2672 # 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
2673 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2874 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2674 2875
2675 $self->enter_link; 2876 $self->enter_link;
… …
2695 ($path, $x, $y) = (undef, undef, undef); 2896 ($path, $x, $y) = (undef, undef, undef);
2696 } 2897 }
2697 } 2898 }
2698 2899
2699 my $map = eval { 2900 my $map = eval {
2700 my $map = defined $path ? cf::map::find $path : undef; 2901 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2701 2902
2702 if ($map) { 2903 if ($map) {
2703 $map = $map->customise_for ($self); 2904 $map = $map->customise_for ($self);
2704 $map = $check->($map) if $check && $map; 2905 $map = $check->($map, $x, $y, $self) if $check && $map;
2705 } else { 2906 } else {
2706 $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);
2707 } 2908 }
2708 2909
2709 $map 2910 $map
… …
2717 if ($gen == $self->{_goto_generation}) { 2918 if ($gen == $self->{_goto_generation}) {
2718 delete $self->{_goto_generation}; 2919 delete $self->{_goto_generation};
2719 $self->leave_link ($map, $x, $y); 2920 $self->leave_link ($map, $x, $y);
2720 } 2921 }
2721 2922
2722 $done->() if $done; 2923 $done->($self) if $done;
2723 })->prio (1); 2924 })->prio (1);
2724} 2925}
2725 2926
2726=item $player_object->enter_exit ($exit_object) 2927=item $player_object->enter_exit ($exit_object)
2727 2928
… …
2795 $Coro::current->{desc} = "enter_exit"; 2996 $Coro::current->{desc} = "enter_exit";
2796 2997
2797 unless (eval { 2998 unless (eval {
2798 $self->deactivate_recursive; # just to be sure 2999 $self->deactivate_recursive; # just to be sure
2799 3000
2800 # random map handling
2801 {
2802 my $guard = cf::lock_acquire "exit_prepare:$exit";
2803
2804 prepare_random_map $exit
2805 if $exit->slaying eq "/!";
2806 }
2807
2808 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 3001 my $map = cf::map::normalise $exit->slaying, $exit->map;
2809 my $x = $exit->stats->hp; 3002 my $x = $exit->stats->hp;
2810 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 }
2811 3027
2812 $self->goto ($map, $x, $y); 3028 $self->goto ($map, $x, $y);
2813 3029
2814 # if exit is damned, update players death & WoR home-position 3030 # if exit is damned, update players death & WoR home-position
2815 $self->contr->savebed ($map, $x, $y) 3031 $self->contr->savebed ($map, $x, $y)
… …
2820 $self->message ("Something went wrong deep within the deliantra server. " 3036 $self->message ("Something went wrong deep within the deliantra server. "
2821 . "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. "
2822 . "Please report this to the dungeon master!", 3038 . "Please report this to the dungeon master!",
2823 cf::NDI_UNIQUE | cf::NDI_RED); 3039 cf::NDI_UNIQUE | cf::NDI_RED);
2824 3040
2825 warn "ERROR in enter_exit: $@"; 3041 error "ERROR in enter_exit: $@";
2826 $self->leave_link; 3042 $self->leave_link;
2827 } 3043 }
2828 })->prio (1); 3044 })->prio (1);
2829} 3045}
2830 3046
… …
3040=cut 3256=cut
3041 3257
3042sub cf::client::ext_msg($$@) { 3258sub cf::client::ext_msg($$@) {
3043 my ($self, $type, @msg) = @_; 3259 my ($self, $type, @msg) = @_;
3044 3260
3045 if ($self->extcmd == 2) {
3046 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3261 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3047 } elsif ($self->extcmd == 1) { # TODO: remove
3048 push @msg, msgtype => "event_$type";
3049 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3050 }
3051}
3052
3053=item $client->ext_reply ($msgid, @msg)
3054
3055Sends an ext reply to the client.
3056
3057=cut
3058
3059sub cf::client::ext_reply($$@) {
3060 my ($self, $id, @msg) = @_;
3061
3062 if ($self->extcmd == 2) {
3063 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3064 } elsif ($self->extcmd == 1) {
3065 #TODO: version 1, remove
3066 unshift @msg, msgtype => "reply", msgid => $id;
3067 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3068 }
3069} 3262}
3070 3263
3071=item $success = $client->query ($flags, "text", \&cb) 3264=item $success = $client->query ($flags, "text", \&cb)
3072 3265
3073Queues a query to the client, calling the given callback with 3266Queues a query to the client, calling the given callback with
… …
3128 my ($ns, $buf) = @_; 3321 my ($ns, $buf) = @_;
3129 3322
3130 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3323 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3131 3324
3132 if (ref $msg) { 3325 if (ref $msg) {
3133 my ($type, $reply, @payload) = 3326 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3134 "ARRAY" eq ref $msg
3135 ? @$msg
3136 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3137 3327
3138 my @reply;
3139
3140 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}) {
3141 @reply = $cb->($ns, @payload); 3341 @reply = $cb->($ns, @payload);
3342 }
3343
3344 $ns->ext_msg ("reply-$reply", @reply)
3345 if $reply;
3142 } 3346 }
3143
3144 $ns->ext_reply ($reply, @reply)
3145 if $reply;
3146
3147 } else { 3347 } else {
3148 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";
3149 } 3349 }
3150 3350
3151 cf::override; 3351 cf::override;
3152 }, 3352 },
3153); 3353);
… …
3234 decrease split destroy change_exp value msg lore send_msg)], 3434 decrease split destroy change_exp value msg lore send_msg)],
3235 ["cf::object::player" => qw(player)], 3435 ["cf::object::player" => qw(player)],
3236 ["cf::player" => qw(peaceful send_msg)], 3436 ["cf::player" => qw(peaceful send_msg)],
3237 ["cf::map" => qw(trigger)], 3437 ["cf::map" => qw(trigger)],
3238) { 3438) {
3239 no strict 'refs';
3240 my ($pkg, @funs) = @$_; 3439 my ($pkg, @funs) = @$_;
3241 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3440 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3242 for @funs; 3441 for @funs;
3243} 3442}
3244 3443
… …
3283 local @cf::_safe_eval_args = values %vars; 3482 local @cf::_safe_eval_args = values %vars;
3284 @res = wantarray ? eval eval : scalar eval $eval; 3483 @res = wantarray ? eval eval : scalar eval $eval;
3285 } 3484 }
3286 3485
3287 if ($@) { 3486 if ($@) {
3288 warn "$@"; 3487 warn "$@",
3289 warn "while executing safe code '$code'\n"; 3488 "while executing safe code '$code'\n",
3290 warn "with arguments " . (join " ", %vars) . "\n"; 3489 "with arguments " . (join " ", %vars) . "\n";
3291 } 3490 }
3292 3491
3293 wantarray ? @res : $res[0] 3492 wantarray ? @res : $res[0]
3294} 3493}
3295 3494
… …
3320=cut 3519=cut
3321 3520
3322############################################################################# 3521#############################################################################
3323# the server's init and main functions 3522# the server's init and main functions
3324 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
3325sub load_facedata($) { 3548sub load_facedata($) {
3326 my ($path) = @_; 3549 my ($path) = @_;
3327 3550
3328 # 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
3329 # for this (global event?) 3552 # for this (global event?)
3330 %ext::player_env::MUSIC_FACE_CACHE = (); 3553 %ext::player_env::MUSIC_FACE_CACHE = ();
3331 3554
3332 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3555 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3333 3556
3334 warn "loading facedata from $path\n"; 3557 trace "loading facedata from $path\n";
3335 3558
3336 my $facedata; 3559 my $facedata = decode_storable load_file $path;
3337 0 < aio_load $path, $facedata
3338 or die "$path: $!";
3339
3340 $facedata = Coro::Storable::thaw $facedata;
3341 3560
3342 $facedata->{version} == 2 3561 $facedata->{version} == 2
3343 or cf::cleanup "$path: version mismatch, cannot proceed."; 3562 or cf::cleanup "$path: version mismatch, cannot proceed.";
3344 3563
3345 # patch in the exptable
3346 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3347 $facedata->{resource}{"res/exp_table"} = {
3348 type => FT_RSRC,
3349 data => $exp_table,
3350 hash => (Digest::MD5::md5 $exp_table),
3351 };
3352 cf::cede_to_tick; 3564 cf::cede_to_tick;
3353 3565
3354 { 3566 {
3355 my $faces = $facedata->{faceinfo}; 3567 my $faces = $facedata->{faceinfo};
3356 3568
3357 while (my ($face, $info) = each %$faces) { 3569 for my $face (sort keys %$faces) {
3570 my $info = $faces->{$face};
3358 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3571 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3359 3572
3360 cf::face::set_visibility $idx, $info->{visibility}; 3573 cf::face::set_visibility $idx, $info->{visibility};
3361 cf::face::set_magicmap $idx, $info->{magicmap}; 3574 cf::face::set_magicmap $idx, $info->{magicmap};
3362 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3575 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3363 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3576 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3577 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3578 $FACEHASH{$info->{hash64}} = $idx;#d#
3364 3579
3365 cf::cede_to_tick; 3580 cf::cede_to_tick;
3366 } 3581 }
3367 3582
3368 while (my ($face, $info) = each %$faces) { 3583 while (my ($face, $info) = each %$faces) {
… …
3373 3588
3374 if (my $smooth = cf::face::find $info->{smooth}) { 3589 if (my $smooth = cf::face::find $info->{smooth}) {
3375 cf::face::set_smooth $idx, $smooth; 3590 cf::face::set_smooth $idx, $smooth;
3376 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3591 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3377 } else { 3592 } else {
3378 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3593 error "smooth face '$info->{smooth}' not found for face '$face'";
3379 } 3594 }
3380 3595
3381 cf::cede_to_tick; 3596 cf::cede_to_tick;
3382 } 3597 }
3383 } 3598 }
… …
3395 3610
3396 { 3611 {
3397 my $res = $facedata->{resource}; 3612 my $res = $facedata->{resource};
3398 3613
3399 while (my ($name, $info) = each %$res) { 3614 while (my ($name, $info) = each %$res) {
3400 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
3401 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3617 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3402 3618
3619 cf::face::set_type $idx, $type;
3403 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3620 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3404 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#
3405 } else { 3623 } else {
3406 $RESOURCE{$name} = $info; 3624# $RESOURCE{$name} = $info; # unused
3407 } 3625 }
3408 3626
3409 cf::cede_to_tick; 3627 cf::cede_to_tick;
3410 } 3628 }
3411 } 3629 }
3412 3630
3413 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3631 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3414 3632
3415 1 3633 1
3416} 3634}
3417
3418cf::global->attach (on_resource_update => sub {
3419 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3420 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3421
3422 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3423 my $sound = $soundconf->{compat}[$_]
3424 or next;
3425
3426 my $face = cf::face::find "sound/$sound->[1]";
3427 cf::sound::set $sound->[0] => $face;
3428 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3429 }
3430
3431 while (my ($k, $v) = each %{$soundconf->{event}}) {
3432 my $face = cf::face::find "sound/$v";
3433 cf::sound::set $k => $face;
3434 }
3435 }
3436});
3437 3635
3438register_exticmd fx_want => sub { 3636register_exticmd fx_want => sub {
3439 my ($ns, $want) = @_; 3637 my ($ns, $want) = @_;
3440 3638
3441 while (my ($k, $v) = each %$want) { 3639 while (my ($k, $v) = each %$want) {
… …
3449 my $status = load_resource_file_ $_[0]; 3647 my $status = load_resource_file_ $_[0];
3450 get_slot 0.1, 100; 3648 get_slot 0.1, 100;
3451 cf::arch::commit_load; 3649 cf::arch::commit_load;
3452 3650
3453 $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;
3454} 3665}
3455 3666
3456sub reload_regions { 3667sub reload_regions {
3457 # 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
3458 # for this (global event?) 3669 # for this (global event?)
… …
3473} 3684}
3474 3685
3475sub reload_archetypes { 3686sub reload_archetypes {
3476 load_resource_file "$DATADIR/archetypes" 3687 load_resource_file "$DATADIR/archetypes"
3477 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 );
3478} 3698}
3479 3699
3480sub reload_treasures { 3700sub reload_treasures {
3481 load_resource_file "$DATADIR/treasures" 3701 load_resource_file "$DATADIR/treasures"
3482 or die "unable to load treasurelists\n"; 3702 or die "unable to load treasurelists\n";
3483} 3703}
3484 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
3485sub reload_resources { 3725sub reload_resources {
3486 warn "reloading resource files...\n"; 3726 trace "reloading resource files...\n";
3487 3727
3728 reload_materials;
3488 reload_facedata; 3729 reload_facedata;
3730 reload_exp_table;
3731 reload_sound;
3489 reload_archetypes; 3732 reload_archetypes;
3490 reload_regions; 3733 reload_regions;
3491 reload_treasures; 3734 reload_treasures;
3492 3735
3493 warn "finished reloading resource files\n"; 3736 trace "finished reloading resource files\n";
3494} 3737}
3495 3738
3496sub reload_config { 3739sub reload_config {
3497 warn "reloading config file...\n"; 3740 trace "reloading config file...\n";
3498 3741
3499 open my $fh, "<:utf8", "$CONFDIR/config" 3742 my $config = load_file "$CONFDIR/config";
3500 or return; 3743 utf8::decode $config;
3744 *CFG = decode_yaml $config;
3501 3745
3502 local $/;
3503 *CFG = YAML::XS::Load scalar <$fh>;
3504
3505 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3746 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3506 3747
3507 $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};
3508 $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};
3509 3750
3510 if (exists $CFG{mlockall}) { 3751 if (exists $CFG{mlockall}) {
… …
3512 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3753 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3513 and die "WARNING: m(un)lockall failed: $!\n"; 3754 and die "WARNING: m(un)lockall failed: $!\n";
3514 }; 3755 };
3515 warn $@ if $@; 3756 warn $@ if $@;
3516 } 3757 }
3517
3518 warn "finished reloading resource files\n";
3519} 3758}
3520 3759
3521sub pidfile() { 3760sub pidfile() {
3522 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3761 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3523 or die "$PIDFILE: $!"; 3762 or die "$PIDFILE: $!";
… …
3536 seek $fh, 0, 0; 3775 seek $fh, 0, 0;
3537 print $fh $$; 3776 print $fh $$;
3538} 3777}
3539 3778
3540sub main_loop { 3779sub main_loop {
3541 warn "EV::loop starting\n"; 3780 trace "EV::loop starting\n";
3542 if (1) { 3781 if (1) {
3543 EV::loop; 3782 EV::loop;
3544 } 3783 }
3545 warn "EV::loop returned\n"; 3784 trace "EV::loop returned\n";
3546 goto &main_loop unless $REALLY_UNLOOP; 3785 goto &main_loop unless $REALLY_UNLOOP;
3547} 3786}
3548 3787
3549sub main { 3788sub main {
3550 cf::init_globals; # initialise logging 3789 cf::init_globals; # initialise logging
3551 3790
3552 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3791 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3553 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.";
3554 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3793 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3555 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3794 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3556 3795
3557 $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
3558 3797
3559 # we must not ever block the main coroutine 3798 # we must not ever block the main coroutine
3560 local $Coro::idle = sub { 3799 $Coro::idle = sub {
3561 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#
3562 (async { 3801 (async {
3563 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3802 $Coro::current->{desc} = "IDLE BUG HANDLER";
3564 EV::loop EV::LOOP_ONESHOT; 3803 EV::loop EV::LOOP_ONESHOT;
3565 })->prio (Coro::PRIO_MAX); 3804 })->prio (Coro::PRIO_MAX);
3566 }; 3805 };
3567 3806
3568 evthread_start IO::AIO::poll_fileno; 3807 evthread_start IO::AIO::poll_fileno;
3569 3808
3570 cf::sync_job { 3809 cf::sync_job {
3571 cf::init_experience; 3810 cf::incloader::init ();
3811
3812 db_init;
3813
3572 cf::init_anim; 3814 cf::init_anim;
3573 cf::init_attackmess; 3815 cf::init_attackmess;
3574 cf::init_dynamic; 3816 cf::init_dynamic;
3575 3817
3576 cf::load_settings; 3818 cf::load_settings;
3577 cf::load_materials;
3578 3819
3579 reload_resources; 3820 reload_resources;
3580 reload_config; 3821 reload_config;
3581 db_init;
3582 3822
3583 cf::init_uuid; 3823 cf::init_uuid;
3584 cf::init_signals; 3824 cf::init_signals;
3585 cf::init_skills; 3825 cf::init_skills;
3586 3826
… …
3594 3834
3595 # no (long-running) fork's whatsoever before this point(!) 3835 # no (long-running) fork's whatsoever before this point(!)
3596 use POSIX (); 3836 use POSIX ();
3597 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};
3598 3838
3599 (pop @POST_INIT)->(0) while @POST_INIT; 3839 cf::_post_init 0;
3600 }; 3840 };
3601 3841
3602 cf::object::thawer::errors_are_fatal 0; 3842 cf::object::thawer::errors_are_fatal 0;
3603 warn "parse errors in files are no longer fatal from this point on.\n"; 3843 info "parse errors in files are no longer fatal from this point on.\n";
3604 3844
3845 AE::postpone {
3846 undef &main; # free gobs of memory :)
3847 };
3848
3605 main_loop; 3849 goto &main_loop;
3606} 3850}
3607 3851
3608############################################################################# 3852#############################################################################
3609# initialisation and cleanup 3853# initialisation and cleanup
3610 3854
… …
3649 or return; 3893 or return;
3650 3894
3651 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3895 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3652 and return; 3896 and return;
3653 3897
3654 warn sprintf "runtime file written (%gs).\n", AE::time - $t0; 3898 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3655 3899
3656 1 3900 1
3657} 3901}
3658 3902
3659our $uuid_lock; 3903our $uuid_lock;
… …
3671 or return; 3915 or return;
3672 3916
3673 my $value = uuid_seq uuid_cur; 3917 my $value = uuid_seq uuid_cur;
3674 3918
3675 unless ($value) { 3919 unless ($value) {
3676 warn "cowardly refusing to write zero uuid value!\n"; 3920 info "cowardly refusing to write zero uuid value!\n";
3677 return; 3921 return;
3678 } 3922 }
3679 3923
3680 my $value = uuid_str $value + $uuid_skip; 3924 my $value = uuid_str $value + $uuid_skip;
3681 $uuid_skip = 0; 3925 $uuid_skip = 0;
… …
3691 or return; 3935 or return;
3692 3936
3693 aio_rename "$uuid~", $uuid 3937 aio_rename "$uuid~", $uuid
3694 and return; 3938 and return;
3695 3939
3696 warn "uuid file written ($value).\n"; 3940 trace "uuid file written ($value).\n";
3697 3941
3698 1 3942 1
3699 3943
3700} 3944}
3701 3945
… …
3707} 3951}
3708 3952
3709sub emergency_save() { 3953sub emergency_save() {
3710 my $freeze_guard = cf::freeze_mainloop; 3954 my $freeze_guard = cf::freeze_mainloop;
3711 3955
3712 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;
3713 3962
3714 cf::sync_job { 3963 cf::sync_job {
3715 # this is a trade-off: we want to be very quick here, so 3964 cf::write_runtime_sync; # external watchdog should not bark
3716 # save all maps without fsync, and later call a global sync
3717 # (which in turn might be very very slow)
3718 local $USE_FSYNC = 0;
3719 3965
3720 # use a peculiar iteration method to avoid tripping on perl 3966 # use a peculiar iteration method to avoid tripping on perl
3721 # refcount bugs in for. also avoids problems with players 3967 # refcount bugs in for. also avoids problems with players
3722 # and maps saved/destroyed asynchronously. 3968 # and maps saved/destroyed asynchronously.
3723 warn "emergency_perl_save: begin player save\n"; 3969 info "emergency_perl_save: begin player save\n";
3724 for my $login (keys %cf::PLAYER) { 3970 for my $login (keys %cf::PLAYER) {
3725 my $pl = $cf::PLAYER{$login} or next; 3971 my $pl = $cf::PLAYER{$login} or next;
3726 $pl->valid or next; 3972 $pl->valid or next;
3727 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3973 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3728 $pl->save; 3974 $pl->save;
3729 } 3975 }
3730 warn "emergency_perl_save: end player save\n"; 3976 info "emergency_perl_save: end player save\n";
3731 3977
3978 cf::write_runtime_sync; # external watchdog should not bark
3979
3732 warn "emergency_perl_save: begin map save\n"; 3980 info "emergency_perl_save: begin map save\n";
3733 for my $path (keys %cf::MAP) { 3981 for my $path (keys %cf::MAP) {
3734 my $map = $cf::MAP{$path} or next; 3982 my $map = $cf::MAP{$path} or next;
3735 $map->valid or next; 3983 $map->valid or next;
3736 $map->save; 3984 $map->save;
3737 } 3985 }
3738 warn "emergency_perl_save: end map save\n"; 3986 info "emergency_perl_save: end map save\n";
3739 3987
3988 cf::write_runtime_sync; # external watchdog should not bark
3989
3740 warn "emergency_perl_save: begin database checkpoint\n"; 3990 info "emergency_perl_save: begin database checkpoint\n";
3741 BDB::db_env_txn_checkpoint $DB_ENV; 3991 BDB::db_env_txn_checkpoint $DB_ENV;
3742 warn "emergency_perl_save: end database checkpoint\n"; 3992 info "emergency_perl_save: end database checkpoint\n";
3743 3993
3744 warn "emergency_perl_save: begin write uuid\n"; 3994 info "emergency_perl_save: begin write uuid\n";
3745 write_uuid_sync 1; 3995 write_uuid_sync 1;
3746 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
3747 }; 4016 };
3748 4017
3749 warn "emergency_perl_save: starting sync()\n";
3750 IO::AIO::aio_sync sub {
3751 warn "emergency_perl_save: finished sync()\n";
3752 };
3753
3754 warn "emergency_perl_save: leave\n"; 4018 info "emergency_perl_save: leave\n";
3755} 4019}
3756 4020
3757sub post_cleanup { 4021sub post_cleanup {
3758 my ($make_core) = @_; 4022 my ($make_core) = @_;
3759 4023
4024 IO::AIO::flush;
4025
3760 warn Carp::longmess "post_cleanup backtrace" 4026 error Carp::longmess "post_cleanup backtrace"
3761 if $make_core; 4027 if $make_core;
3762 4028
3763 my $fh = pidfile; 4029 my $fh = pidfile;
3764 unlink $PIDFILE if <$fh> == $$; 4030 unlink $PIDFILE if <$fh> == $$;
3765} 4031}
… …
3785 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 4051 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3786 for my $name (keys %$leaf_symtab) { 4052 for my $name (keys %$leaf_symtab) {
3787 _gv_clear *{"$pkg$name"}; 4053 _gv_clear *{"$pkg$name"};
3788# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 4054# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3789 } 4055 }
3790 warn "cleared package $pkg\n";#d#
3791} 4056}
3792 4057
3793sub do_reload_perl() { 4058sub do_reload_perl() {
3794 # can/must only be called in main 4059 # can/must only be called in main
3795 if ($Coro::current != $Coro::main) { 4060 unless (in_main) {
3796 warn "can only reload from main coroutine"; 4061 error "can only reload from main coroutine";
3797 return; 4062 return;
3798 } 4063 }
3799 4064
3800 return if $RELOAD++; 4065 return if $RELOAD++;
3801 4066
3802 my $t1 = AE::time; 4067 my $t1 = AE::time;
3803 4068
3804 while ($RELOAD) { 4069 while ($RELOAD) {
3805 warn "reloading..."; 4070 cf::get_slot 0.1, -1, "reload_perl";
4071 info "perl_reload: reloading...";
3806 4072
3807 warn "entering sync_job"; 4073 trace "perl_reload: entering sync_job";
3808 4074
3809 cf::sync_job { 4075 cf::sync_job {
3810 cf::write_runtime_sync; # external watchdog should not bark
3811 cf::emergency_save; 4076 #cf::emergency_save;
3812 cf::write_runtime_sync; # external watchdog should not bark
3813 4077
3814 warn "syncing database to disk";
3815 BDB::db_env_txn_checkpoint $DB_ENV;
3816
3817 # if anything goes wrong in here, we should simply crash as we already saved
3818
3819 warn "flushing outstanding aio requests";
3820 while (IO::AIO::nreqs || BDB::nreqs) {
3821 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3822 }
3823
3824 warn "cancelling all extension coros"; 4078 trace "perl_reload: cancelling all extension coros";
3825 $_->cancel for values %EXT_CORO; 4079 $_->cancel for values %EXT_CORO;
3826 %EXT_CORO = (); 4080 %EXT_CORO = ();
3827 4081
3828 warn "removing commands"; 4082 trace "perl_reload: removing commands";
3829 %COMMAND = (); 4083 %COMMAND = ();
3830 4084
3831 warn "removing ext/exti commands"; 4085 trace "perl_reload: removing ext/exti commands";
3832 %EXTCMD = (); 4086 %EXTCMD = ();
3833 %EXTICMD = (); 4087 %EXTICMD = ();
3834 4088
3835 warn "unloading/nuking all extensions"; 4089 trace "perl_reload: unloading/nuking all extensions";
3836 for my $pkg (@EXTS) { 4090 for my $pkg (@EXTS) {
3837 warn "... unloading $pkg"; 4091 trace "... unloading $pkg";
3838 4092
3839 if (my $cb = $pkg->can ("unload")) { 4093 if (my $cb = $pkg->can ("unload")) {
3840 eval { 4094 eval {
3841 $cb->($pkg); 4095 $cb->($pkg);
3842 1 4096 1
3843 } or warn "$pkg unloaded, but with errors: $@"; 4097 } or error "$pkg unloaded, but with errors: $@";
3844 } 4098 }
3845 4099
3846 warn "... clearing $pkg"; 4100 trace "... clearing $pkg";
3847 clear_package $pkg; 4101 clear_package $pkg;
3848 } 4102 }
3849 4103
3850 warn "unloading all perl modules loaded from $LIBDIR"; 4104 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3851 while (my ($k, $v) = each %INC) { 4105 while (my ($k, $v) = each %INC) {
3852 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4106 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3853 4107
3854 warn "... unloading $k"; 4108 trace "... unloading $k";
3855 delete $INC{$k}; 4109 delete $INC{$k};
3856 4110
3857 $k =~ s/\.pm$//; 4111 $k =~ s/\.pm$//;
3858 $k =~ s/\//::/g; 4112 $k =~ s/\//::/g;
3859 4113
… …
3862 } 4116 }
3863 4117
3864 clear_package $k; 4118 clear_package $k;
3865 } 4119 }
3866 4120
3867 warn "getting rid of safe::, as good as possible"; 4121 trace "perl_reload: getting rid of safe::, as good as possible";
3868 clear_package "safe::$_" 4122 clear_package "safe::$_"
3869 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);
3870 4124
3871 warn "unloading cf.pm \"a bit\""; 4125 trace "perl_reload: unloading cf.pm \"a bit\"";
3872 delete $INC{"cf.pm"}; 4126 delete $INC{"cf.pm"};
3873 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4127 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3874 4128
3875 # don't, removes xs symbols, too, 4129 # don't, removes xs symbols, too,
3876 # and global variables created in xs 4130 # and global variables created in xs
3877 #clear_package __PACKAGE__; 4131 #clear_package __PACKAGE__;
3878 4132
3879 warn "unload completed, starting to reload now"; 4133 info "perl_reload: unload completed, starting to reload now";
3880 4134
3881 warn "reloading cf.pm"; 4135 trace "perl_reload: reloading cf.pm";
3882 require cf; 4136 require cf;
3883 cf::_connect_to_perl_1; 4137 cf::_connect_to_perl_1;
3884 4138
3885 warn "loading config and database again"; 4139 trace "perl_reload: loading config and database again";
3886 cf::reload_config; 4140 cf::reload_config;
3887 4141
3888 warn "loading extensions"; 4142 trace "perl_reload: loading extensions";
3889 cf::load_extensions; 4143 cf::load_extensions;
3890 4144
3891 if ($REATTACH_ON_RELOAD) { 4145 if ($REATTACH_ON_RELOAD) {
3892 warn "reattaching attachments to objects/players"; 4146 trace "perl_reload: reattaching attachments to objects/players";
3893 _global_reattach; # objects, sockets 4147 _global_reattach; # objects, sockets
3894 warn "reattaching attachments to maps"; 4148 trace "perl_reload: reattaching attachments to maps";
3895 reattach $_ for values %MAP; 4149 reattach $_ for values %MAP;
3896 warn "reattaching attachments to players"; 4150 trace "perl_reload: reattaching attachments to players";
3897 reattach $_ for values %PLAYER; 4151 reattach $_ for values %PLAYER;
3898 } 4152 }
3899 4153
3900 warn "running post_init jobs"; 4154 cf::_post_init 1;
3901 (pop @POST_INIT)->(1) while @POST_INIT;
3902 4155
3903 warn "leaving sync_job"; 4156 trace "perl_reload: leaving sync_job";
3904 4157
3905 1 4158 1
3906 } or do { 4159 } or do {
3907 warn $@; 4160 error $@;
3908 cf::cleanup "error while reloading, exiting."; 4161 cf::cleanup "perl_reload: error, exiting.";
3909 }; 4162 };
3910 4163
3911 warn "reloaded";
3912 --$RELOAD; 4164 --$RELOAD;
3913 } 4165 }
3914 4166
3915 $t1 = AE::time - $t1; 4167 $t1 = AE::time - $t1;
3916 warn "reload completed in ${t1}s\n"; 4168 info "perl_reload: completed in ${t1}s\n";
3917}; 4169};
3918 4170
3919our $RELOAD_WATCHER; # used only during reload 4171our $RELOAD_WATCHER; # used only during reload
3920 4172
3921sub reload_perl() { 4173sub reload_perl() {
… …
3942 reload_perl; 4194 reload_perl;
3943 }; 4195 };
3944 } 4196 }
3945}; 4197};
3946 4198
3947unshift @INC, $LIBDIR; 4199#############################################################################
3948 4200
3949my $bug_warning = 0; 4201my $bug_warning = 0;
3950 4202
3951our @WAIT_FOR_TICK;
3952our @WAIT_FOR_TICK_BEGIN;
3953
3954sub wait_for_tick { 4203sub wait_for_tick() {
3955 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4204 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3956 4205
3957 my $signal = new Coro::Signal; 4206 $WAIT_FOR_TICK->wait;
3958 push @WAIT_FOR_TICK, $signal;
3959 $signal->wait;
3960} 4207}
3961 4208
3962sub wait_for_tick_begin { 4209sub wait_for_tick_begin() {
3963 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4210 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3964 4211
3965 my $signal = new Coro::Signal; 4212 my $signal = new Coro::Signal;
3966 push @WAIT_FOR_TICK_BEGIN, $signal; 4213 push @WAIT_FOR_TICK_BEGIN, $signal;
3967 $signal->wait; 4214 $signal->wait;
3968} 4215}
… …
3972 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"
3973 unless ++$bug_warning > 10; 4220 unless ++$bug_warning > 10;
3974 return; 4221 return;
3975 } 4222 }
3976 4223
3977 cf::server_tick; # one server iteration 4224 cf::one_tick; # one server iteration
3978 4225
3979 #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#
3980 4227
3981 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4228 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3982 $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.;
3983 Coro::async_pool { 4230 Coro::async_pool {
3984 $Coro::current->{desc} = "runtime saver"; 4231 $Coro::current->{desc} = "runtime saver";
3985 write_runtime_sync 4232 write_runtime_sync
3986 or warn "ERROR: unable to write runtime file: $!"; 4233 or error "ERROR: unable to write runtime file: $!";
3987 }; 4234 };
3988 } 4235 }
3989 4236
3990 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4237 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3991 $sig->send; 4238 $sig->send;
3992 } 4239 }
3993 while (my $sig = shift @WAIT_FOR_TICK) { 4240 $WAIT_FOR_TICK->broadcast;
3994 $sig->send;
3995 }
3996 4241
3997 $LOAD = ($NOW - $TICK_START) / $TICK; 4242 $LOAD = ($NOW - $TICK_START) / $TICK;
3998 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4243 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3999 4244
4000 if (0) { 4245 if (0) {
4001 if ($NEXT_TICK) { 4246 if ($NEXT_TICK) {
4002 my $jitter = $TICK_START - $NEXT_TICK; 4247 my $jitter = $TICK_START - $NEXT_TICK;
4003 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4248 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4004 warn "jitter $JITTER\n";#d# 4249 debug "jitter $JITTER\n";#d#
4005 } 4250 }
4006 } 4251 }
4007} 4252}
4008 4253
4009{ 4254{
4010 # configure BDB 4255 # configure BDB
4256 info "initialising database";
4011 4257
4012 BDB::min_parallel 16; 4258 BDB::min_parallel 16;
4013 BDB::max_poll_reqs $TICK * 0.1; 4259 BDB::max_poll_reqs $TICK * 0.1;
4014 $AnyEvent::BDB::WATCHER->priority (1); 4260 #$AnyEvent::BDB::WATCHER->priority (1);
4015 4261
4016 unless ($DB_ENV) { 4262 unless ($DB_ENV) {
4017 $DB_ENV = BDB::db_env_create; 4263 $DB_ENV = BDB::db_env_create;
4018 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4264 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4019 $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;
… …
4044 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4290 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4045 }; 4291 };
4046 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4292 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4047 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4293 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4048 }; 4294 };
4295
4296 info "database initialised";
4049} 4297}
4050 4298
4051{ 4299{
4052 # configure IO::AIO 4300 # configure IO::AIO
4053 4301
4302 info "initialising aio";
4054 IO::AIO::min_parallel 8; 4303 IO::AIO::min_parallel 8;
4055 IO::AIO::max_poll_time $TICK * 0.1; 4304 IO::AIO::max_poll_time $TICK * 0.1;
4056 undef $AnyEvent::AIO::WATCHER; 4305 undef $AnyEvent::AIO::WATCHER;
4306 info "aio initialised";
4057} 4307}
4058 4308
4059my $_log_backtrace; 4309our $_log_backtrace;
4310our $_log_backtrace_last;
4060 4311
4061sub _log_backtrace { 4312sub _log_backtrace {
4062 my ($msg, @addr) = @_; 4313 my ($msg, @addr) = @_;
4063 4314
4064 $msg =~ s/\n//; 4315 $msg =~ s/\n$//;
4065 4316
4317 if ($_log_backtrace_last eq $msg) {
4318 LOG llevInfo, "[ABT] $msg\n";
4319 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4066 # limit the # of concurrent backtraces 4320 # limit the # of concurrent backtraces
4067 if ($_log_backtrace < 2) { 4321 } elsif ($_log_backtrace < 2) {
4322 $_log_backtrace_last = $msg;
4068 ++$_log_backtrace; 4323 ++$_log_backtrace;
4069 my $perl_bt = Carp::longmess $msg; 4324 my $perl_bt = Carp::longmess $msg;
4070 async { 4325 async {
4071 $Coro::current->{desc} = "abt $msg"; 4326 $Coro::current->{desc} = "abt $msg";
4072 4327
… …
4092 LOG llevInfo, "[ABT] $_\n" for @bt; 4347 LOG llevInfo, "[ABT] $_\n" for @bt;
4093 --$_log_backtrace; 4348 --$_log_backtrace;
4094 }; 4349 };
4095 } else { 4350 } else {
4096 LOG llevInfo, "[ABT] $msg\n"; 4351 LOG llevInfo, "[ABT] $msg\n";
4097 LOG llevInfo, "[ABT] [suppressed]\n"; 4352 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4098 } 4353 }
4099} 4354}
4100 4355
4101# load additional modules 4356# load additional modules
4102require "cf/$_.pm" for @EXTRA_MODULES; 4357require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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