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.483 by root, Mon Oct 12 04:02:17 2009 UTC vs.
Revision 1.607 by root, Sun Nov 18 09:29:25 2012 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your 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 GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# 18# <http://www.gnu.org/licenses/>.
19#
19# 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>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use 5.10.0; 25use common::sense;
25use utf8;
26use strict qw(vars subs);
27 26
28use Symbol; 27use Symbol;
29use List::Util; 28use List::Util;
30use Socket; 29use Socket;
31use EV; 30use EV;
32use Opcode; 31use Opcode;
33use Safe; 32use Safe;
34use Safe::Hole; 33use Safe::Hole;
35use Storable (); 34use Storable ();
36
37use Guard (); 35use Carp ();
36
37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
40
38use Coro (); 41use Coro ();
39use Coro::State; 42use Coro::State;
40use Coro::Handle; 43use Coro::Handle;
41use Coro::EV; 44use Coro::EV;
42use Coro::AnyEvent; 45use Coro::AnyEvent;
… …
48use Coro::AIO; 51use Coro::AIO;
49use Coro::BDB 1.6; 52use Coro::BDB 1.6;
50use Coro::Storable; 53use Coro::Storable;
51use Coro::Util (); 54use Coro::Util ();
52 55
56use Guard ();
53use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
54use BDB (); 58use BDB ();
55use Data::Dumper; 59use Data::Dumper;
56use Digest::MD5;
57use Fcntl; 60use Fcntl;
58use YAML (); 61use YAML::XS ();
59use IO::AIO (); 62use IO::AIO ();
60use Time::HiRes;
61use Compress::LZF; 63use Compress::LZF;
62use Digest::MD5 (); 64use Digest::MD5 ();
63 65
64AnyEvent::detect; 66AnyEvent::detect;
65 67
… …
77# strictly for debugging 79# strictly for debugging
78$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; 80$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
79 81
80sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 82sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
81 83
84our @ORIG_INC;
85
82our %COMMAND = (); 86our %COMMAND = ();
83our %COMMAND_TIME = (); 87our %COMMAND_TIME = ();
84 88
85our @EXTS = (); # list of extension package names 89our @EXTS = (); # list of extension package names
86our %EXTCMD = (); 90our %EXTCMD = ();
91our %EXTACMD = ();
87our %EXTICMD = (); 92our %EXTICMD = ();
93our %EXTIACMD = ();
88our %EXT_CORO = (); # coroutines bound to extensions 94our %EXT_CORO = (); # coroutines bound to extensions
89our %EXT_MAP = (); # pluggable maps 95our %EXT_MAP = (); # pluggable maps
90 96
91our $RELOAD; # number of reloads so far, non-zero while in reload 97our $RELOAD; # number of reloads so far, non-zero while in reload
92our @EVENT; 98our @EVENT;
93our @REFLECT; # set by XS 99our @REFLECT; # set by XS
94our %REFLECT; # set by us 100our %REFLECT; # set by us
95 101
96our $CONFDIR = confdir; 102our $CONFDIR = confdir;
103
97our $DATADIR = datadir; 104our $DATADIR = datadir;
98our $LIBDIR = "$DATADIR/ext"; 105our $LIBDIR = "$DATADIR/ext";
99our $PODDIR = "$DATADIR/pod"; 106our $PODDIR = "$DATADIR/pod";
100our $MAPDIR = "$DATADIR/" . mapdir; 107our $MAPDIR = "$DATADIR/" . mapdir;
108
101our $LOCALDIR = localdir; 109our $LOCALDIR = localdir;
102our $TMPDIR = "$LOCALDIR/" . tmpdir; 110our $TMPDIR = "$LOCALDIR/" . tmpdir;
103our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 111our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
104our $PLAYERDIR = "$LOCALDIR/" . playerdir; 112our $PLAYERDIR = "$LOCALDIR/" . playerdir;
105our $RANDOMDIR = "$LOCALDIR/random"; 113our $RANDOMDIR = "$LOCALDIR/random";
106our $BDBDIR = "$LOCALDIR/db"; 114our $BDBDIR = "$LOCALDIR/db";
107our $PIDFILE = "$LOCALDIR/pid"; 115our $PIDFILE = "$LOCALDIR/pid";
108our $RUNTIMEFILE = "$LOCALDIR/runtime"; 116our $RUNTIMEFILE = "$LOCALDIR/runtime";
109 117
110our %RESOURCE; 118#our %RESOURCE; # unused
119
120our $OUTPUT_RATE_MIN = 3000;
121our $OUTPUT_RATE_MAX = 1000000;
122
123our $MAX_LINKS = 32; # how many chained exits to follow
124our $VERBOSE_IO = 1;
111 125
112our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 126our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
113our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 127our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
114our $NEXT_TICK; 128our $NEXT_TICK;
115our $USE_FSYNC = 1; # use fsync to write maps - default on 129our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
117our $BDB_DEADLOCK_WATCHER; 131our $BDB_DEADLOCK_WATCHER;
118our $BDB_CHECKPOINT_WATCHER; 132our $BDB_CHECKPOINT_WATCHER;
119our $BDB_TRICKLE_WATCHER; 133our $BDB_TRICKLE_WATCHER;
120our $DB_ENV; 134our $DB_ENV;
121 135
122our @EXTRA_MODULES = qw(pod match mapscript); 136our @EXTRA_MODULES = qw(pod match mapscript incloader);
123 137
124our %CFG; 138our %CFG;
139our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
125 140
126our $UPTIME; $UPTIME ||= time; 141our $UPTIME; $UPTIME ||= time;
127our $RUNTIME; 142our $RUNTIME = 0;
143our $SERVER_TICK = 0;
128our $NOW; 144our $NOW;
129 145
130our (%PLAYER, %PLAYER_LOADING); # all users 146our (%PLAYER, %PLAYER_LOADING); # all users
131our (%MAP, %MAP_LOADING ); # all maps 147our (%MAP, %MAP_LOADING ); # all maps
132our $LINK_MAP; # the special {link} map, which is always available 148our $LINK_MAP; # the special {link} map, which is always available
… …
141 157
142our @POST_INIT; 158our @POST_INIT;
143 159
144our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) 160our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
145our $REALLY_UNLOOP; # never set to true, please :) 161our $REALLY_UNLOOP; # never set to true, please :)
162
163our $WAIT_FOR_TICK = new Coro::Signal;
164our @WAIT_FOR_TICK_BEGIN;
146 165
147binmode STDOUT; 166binmode STDOUT;
148binmode STDERR; 167binmode STDERR;
149 168
150# read virtual server time, if available 169# read virtual server time, if available
… …
161 180
162our $EMERGENCY_POSITION; 181our $EMERGENCY_POSITION;
163 182
164sub cf::map::normalise; 183sub cf::map::normalise;
165 184
185sub in_main() {
186 $Coro::current == $Coro::main
187}
188
166############################################################################# 189#############################################################################
167 190
168%REFLECT = (); 191%REFLECT = ();
169for (@REFLECT) { 192for (@REFLECT) {
170 my $reflect = JSON::XS::decode_json $_; 193 my $reflect = JSON::XS::decode_json $_;
… …
180 203
181=over 4 204=over 4
182 205
183=item $cf::UPTIME 206=item $cf::UPTIME
184 207
185The timestamp of the server start (so not actually an uptime). 208The timestamp of the server start (so not actually an "uptime").
209
210=item $cf::SERVER_TICK
211
212An unsigned integer that starts at zero when the server is started and is
213incremented on every tick.
214
215=item $cf::NOW
216
217The (real) time of the last (current) server tick - updated before and
218after tick processing, so this is useful only as a rough "what time is it
219now" estimate.
220
221=item $cf::TICK
222
223The interval between each server tick, in seconds.
186 224
187=item $cf::RUNTIME 225=item $cf::RUNTIME
188 226
189The time this server has run, starts at 0 and is increased by $cf::TICK on 227The time this server has run, starts at 0 and is increased by $cf::TICK on
190every server tick. 228every server tick.
191 229
192=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 230=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
193$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 231$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
194$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 232$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
195 233
196Various directories - "/etc", read-only install directory, perl-library 234Various directories - "/etc", read-only install directory, perl-library
197directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 235directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
198unique-items directory, player file directory, random maps directory and 236unique-items directory, player file directory, random maps directory and
199database environment. 237database environment.
200 238
201=item $cf::NOW
202
203The time of the last (current) server tick.
204
205=item $cf::TICK
206
207The interval between server ticks, in seconds.
208
209=item $cf::LOADAVG 239=item $cf::LOADAVG
210 240
211The current CPU load on the server (alpha-smoothed), as a value between 0 241The current CPU load on the server (alpha-smoothed), as a value between 0
212(none) and 1 (overloaded), indicating how much time is spent on processing 242(none) and 1 (overloaded), indicating how much time is spent on processing
213objects per tick. Healthy values are < 0.5. 243objects per tick. Healthy values are < 0.5.
… …
221Configuration for the server, loaded from C</etc/deliantra-server/config>, or 251Configuration for the server, loaded from C</etc/deliantra-server/config>, or
222from wherever your confdir points to. 252from wherever your confdir points to.
223 253
224=item cf::wait_for_tick, cf::wait_for_tick_begin 254=item cf::wait_for_tick, cf::wait_for_tick_begin
225 255
226These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 256These are functions that inhibit the current coroutine one tick.
227returns directly I<after> the tick processing (and consequently, can only wake one process 257cf::wait_for_tick_begin only returns directly I<after> the tick
258processing (and consequently, can only wake one thread per tick), while
228per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 259cf::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();
229 277
230=item @cf::INVOKE_RESULTS 278=item @cf::INVOKE_RESULTS
231 279
232This array contains the results of the last C<invoke ()> call. When 280This array contains the results of the last C<invoke ()> call. When
233C<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
234that call. 282that call.
235 283
236=item %cf::REFLECT 284=item %cf::REFLECT
237 285
… …
241 289
242=back 290=back
243 291
244=cut 292=cut
245 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
246$Coro::State::WARNHOOK = sub { 300$Coro::State::WARNHOOK = sub {
247 my $msg = join "", @_; 301 my $msg = join "", @_;
248 302
249 $msg .= "\n" 303 $msg .= "\n"
250 unless $msg =~ /\n$/; 304 unless $msg =~ /\n$/;
251 305
252 $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;
253 307
254 LOG llevError, $msg; 308 LOG llevWarn, $msg;
255}; 309};
256 310
257$Coro::State::DIEHOOK = sub { 311$Coro::State::DIEHOOK = sub {
258 return unless $^S eq 0; # "eq", not "==" 312 return unless $^S eq 0; # "eq", not "=="
259 313
260 warn Carp::longmess $_[0]; 314 error Carp::longmess $_[0];
261 315
262 if ($Coro::current == $Coro::main) {#d# 316 if (in_main) {#d#
263 warn "DIEHOOK called in main context, Coro bug?\n";#d# 317 error "DIEHOOK called in main context, Coro bug?\n";#d#
264 return;#d# 318 return;#d#
265 }#d# 319 }#d#
266 320
267 # kill coroutine otherwise 321 # kill coroutine otherwise
268 Coro::terminate 322 Coro::terminate
… …
288)) { 342)) {
289 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 343 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
290} 344}
291 345
292$EV::DIED = sub { 346$EV::DIED = sub {
293 warn "error in event callback: @_"; 347 warn "error in event callback: $@";
294}; 348};
349
350#############################################################################
351
352sub fork_call(&@);
353sub get_slot($;$$);
295 354
296############################################################################# 355#############################################################################
297 356
298=head2 UTILITY FUNCTIONS 357=head2 UTILITY FUNCTIONS
299 358
… …
320 $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;
321 $d 380 $d
322 } || "[unable to dump $_[0]: '$@']"; 381 } || "[unable to dump $_[0]: '$@']";
323} 382}
324 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
325=item $ref = cf::decode_json $json 436=item $ref = cf::decode_json $json
326 437
327Converts a JSON string into the corresponding perl data structure. 438Converts a JSON string into the corresponding perl data structure.
328 439
329=item $json = cf::encode_json $ref 440=item $json = cf::encode_json $ref
… …
335our $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
336 447
337sub encode_json($) { $json_coder->encode ($_[0]) } 448sub encode_json($) { $json_coder->encode ($_[0]) }
338sub decode_json($) { $json_coder->decode ($_[0]) } 449sub decode_json($) { $json_coder->decode ($_[0]) }
339 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
340=item cf::post_init { BLOCK } 482=item cf::post_init { BLOCK }
341 483
342Execute the given codeblock, I<after> all extensions have been (re-)loaded, 484Execute the given codeblock, I<after> all extensions have been (re-)loaded,
343but I<before> the server starts ticking again. 485but I<before> the server starts ticking again.
344 486
345The cdoeblock will have a single boolean argument to indicate whether this 487The codeblock will have a single boolean argument to indicate whether this
346is a reload or not. 488is a reload or not.
347 489
348=cut 490=cut
349 491
350sub post_init(&) { 492sub post_init(&) {
351 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 }
352} 511}
353 512
354=item cf::lock_wait $string 513=item cf::lock_wait $string
355 514
356Wait until the given lock is available. See cf::lock_acquire. 515Wait until the given lock is available. See cf::lock_acquire.
… …
395} 554}
396 555
397=item cf::periodic $interval, $cb 556=item cf::periodic $interval, $cb
398 557
399Like EV::periodic, but randomly selects a starting point so that the actions 558Like EV::periodic, but randomly selects a starting point so that the actions
400get spread over timer. 559get spread over time.
401 560
402=cut 561=cut
403 562
404sub periodic($$) { 563sub periodic($$) {
405 my ($interval, $cb) = @_; 564 my ($interval, $cb) = @_;
… …
409 EV::periodic $start, $interval, 0, $cb 568 EV::periodic $start, $interval, 0, $cb
410} 569}
411 570
412=item cf::get_slot $time[, $priority[, $name]] 571=item cf::get_slot $time[, $priority[, $name]]
413 572
414Allocate $time seconds of blocking CPU time at priority C<$priority>: 573Allocate $time seconds of blocking CPU time at priority C<$priority>
415This 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
416of 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 less than zero, interactive jobs
579should use 100 or more.
417 580
418The 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
419used for statistical purposes and should identify the same time-class. 582used for statistical purposes and should identify the same time-class.
420 583
421Useful for short background jobs. 584Useful for short background jobs.
422 585
423=cut 586=cut
424 587
425our @SLOT_QUEUE; 588our @SLOT_QUEUE;
426our $SLOT_QUEUE; 589our $SLOT_QUEUE;
590our $SLOT_DECAY = 0.9;
427 591
428$SLOT_QUEUE->cancel if $SLOT_QUEUE; 592$SLOT_QUEUE->cancel if $SLOT_QUEUE;
429$SLOT_QUEUE = Coro::async { 593$SLOT_QUEUE = Coro::async {
430 $Coro::current->desc ("timeslot manager"); 594 $Coro::current->desc ("timeslot manager");
431 595
432 my $signal = new Coro::Signal; 596 my $signal = new Coro::Signal;
597 my $busy;
433 598
434 while () { 599 while () {
435 next_job: 600 next_job:
601
436 my $avail = cf::till_tick; 602 my $avail = cf::till_tick;
437 if ($avail > 0.01) { 603
438 for (0 .. $#SLOT_QUEUE) { 604 for (0 .. $#SLOT_QUEUE) {
439 if ($SLOT_QUEUE[$_][0] < $avail) { 605 if ($SLOT_QUEUE[$_][0] <= $avail) {
606 $busy = 0;
440 my $job = splice @SLOT_QUEUE, $_, 1, (); 607 my $job = splice @SLOT_QUEUE, $_, 1, ();
441 $job->[2]->send; 608 $job->[2]->send;
442 Coro::cede; 609 Coro::cede;
443 goto next_job; 610 goto next_job;
444 } 611 } else {
612 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
445 } 613 }
446 } 614 }
447 615
448 if (@SLOT_QUEUE) { 616 if (@SLOT_QUEUE) {
449 # 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
450 push @cf::WAIT_FOR_TICK, $signal; 618 $WAIT_FOR_TICK->wait;
451 $signal->wait;
452 } else { 619 } else {
620 $busy = 0;
453 Coro::schedule; 621 Coro::schedule;
454 } 622 }
455 } 623 }
456}; 624};
457 625
458sub get_slot($;$$) { 626sub get_slot($;$$) {
459 return if tick_inhibit || $Coro::current == $Coro::main; 627 return if tick_inhibit || $Coro::current == $Coro::main;
460 628
461 my ($time, $pri, $name) = @_; 629 my ($time, $pri, $name) = @_;
462 630
463 $time = $TICK * .6 if $time > $TICK * .6; 631 $time = clamp $time, 0.01, $TICK * .6;
632
464 my $sig = new Coro::Signal; 633 my $sig = new Coro::Signal;
465 634
466 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 635 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
467 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 636 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
468 $SLOT_QUEUE->ready; 637 $SLOT_QUEUE->ready;
… …
494=cut 663=cut
495 664
496sub sync_job(&) { 665sub sync_job(&) {
497 my ($job) = @_; 666 my ($job) = @_;
498 667
499 if ($Coro::current == $Coro::main) { 668 if (in_main) {
500 my $time = EV::time; 669 my $time = AE::time;
501 670
502 # this is the main coro, too bad, we have to block 671 # this is the main coro, too bad, we have to block
503 # till the operation succeeds, freezing the server :/ 672 # till the operation succeeds, freezing the server :/
504 673
505 LOG llevError, Carp::longmess "sync job";#d# 674 #LOG llevError, Carp::longmess "sync job";#d#
506 675
507 my $freeze_guard = freeze_mainloop; 676 my $freeze_guard = freeze_mainloop;
508 677
509 my $busy = 1; 678 my $busy = 1;
510 my @res; 679 my @res;
511 680
512 (async { 681 (async {
513 $Coro::current->desc ("sync job coro"); 682 $Coro::current->desc ("sync job coro");
514 @res = eval { $job->() }; 683 @res = eval { $job->() };
515 warn $@ if $@; 684 error $@ if $@;
516 undef $busy; 685 undef $busy;
517 })->prio (Coro::PRIO_MAX); 686 })->prio (Coro::PRIO_MAX);
518 687
519 while ($busy) { 688 while ($busy) {
520 if (Coro::nready) { 689 if (Coro::nready) {
… …
522 } else { 691 } else {
523 EV::loop EV::LOOP_ONESHOT; 692 EV::loop EV::LOOP_ONESHOT;
524 } 693 }
525 } 694 }
526 695
527 my $time = EV::time - $time; 696 my $time = AE::time - $time;
528 697
529 $TICK_START += $time; # do not account sync jobs to server load 698 $TICK_START += $time; # do not account sync jobs to server load
530 699
531 wantarray ? @res : $res[0] 700 wantarray ? @res : $res[0]
532 } else { 701 } else {
… …
554 $EXT_CORO{$coro+0} = $coro; 723 $EXT_CORO{$coro+0} = $coro;
555 724
556 $coro 725 $coro
557} 726}
558 727
559=item fork_call { }, $args 728=item fork_call { }, @args
560 729
561Executes the given code block with the given arguments in a seperate 730Executes the given code block with the given arguments in a seperate
562process, returning the results. Everything must be serialisable with 731process, returning the results. Everything must be serialisable with
563Coro::Storable. May, of course, block. Note that the executed sub may 732Coro::Storable. May, of course, block. Note that the executed sub may
564never block itself or use any form of event handling. 733never block itself or use any form of event handling.
565 734
566=cut 735=cut
567 736
737sub post_fork {
738 reset_signals;
739}
740
568sub fork_call(&@) { 741sub fork_call(&@) {
569 my ($cb, @args) = @_; 742 my ($cb, @args) = @_;
570 743
571 # we seemingly have to make a local copy of the whole thing,
572 # otherwise perl prematurely frees the stuff :/
573 # TODO: investigate and fix (likely this will be rather laborious)
574
575 my @res = Coro::Util::fork_eval { 744 my @res = Coro::Util::fork_eval {
576 reset_signals; 745 cf::post_fork;
577 &$cb 746 &$cb
578 }, @args; 747 } @args;
579 748
580 wantarray ? @res : $res[-1] 749 wantarray ? @res : $res[-1]
750}
751
752sub objinfo {
753 (
754 "counter value" => cf::object::object_count,
755 "objects created" => cf::object::create_count,
756 "objects destroyed" => cf::object::destroy_count,
757 "freelist size" => cf::object::free_count,
758 "allocated objects" => cf::object::objects_size,
759 "active objects" => cf::object::actives_size,
760 )
581} 761}
582 762
583=item $coin = coin_from_name $name 763=item $coin = coin_from_name $name
584 764
585=cut 765=cut
… …
622within each server. 802within each server.
623 803
624=cut 804=cut
625 805
626sub db_table($) { 806sub db_table($) {
807 cf::error "db_get called from main context"
808 if $Coro::current == $Coro::main;
809
627 my ($name) = @_; 810 my ($name) = @_;
628 my $db = BDB::db_create $DB_ENV; 811 my $db = BDB::db_create $DB_ENV;
629 812
630 eval { 813 eval {
631 $db->set_flags (BDB::CHKSUM); 814 $db->set_flags (BDB::CHKSUM);
… …
641} 824}
642 825
643our $DB; 826our $DB;
644 827
645sub db_init { 828sub db_init {
646 cf::sync_job {
647 $DB ||= db_table "db"; 829 $DB ||= db_table "db";
648 };
649} 830}
650 831
651sub db_get($$) { 832sub db_get($$) {
652 my $key = "$_[0]/$_[1]"; 833 my $key = "$_[0]/$_[1]";
653 834
654 cf::sync_job { 835 cf::error "db_get called from main context"
836 if $Coro::current == $Coro::main;
837
655 BDB::db_get $DB, undef, $key, my $data; 838 BDB::db_get $DB, undef, $key, my $data;
656 839
657 $! ? () 840 $! ? ()
658 : $data 841 : $data
659 }
660} 842}
661 843
662sub db_put($$$) { 844sub db_put($$$) {
663 BDB::dbreq_pri 4; 845 BDB::dbreq_pri 4;
664 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 846 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
692 874
693 my @data; 875 my @data;
694 my $md5; 876 my $md5;
695 877
696 for (0 .. $#$src) { 878 for (0 .. $#$src) {
697 0 <= aio_load $src->[$_], $data[$_] 879 $data[$_] = load_file $src->[$_];
698 or Carp::croak "$src->[$_]: $!";
699 } 880 }
700 881
701 # if processing is expensive, check 882 # if processing is expensive, check
702 # checksum first 883 # checksum first
703 if (1) { 884 if (1) {
… …
716 897
717 return db_get cache => "$id/data"; 898 return db_get cache => "$id/data";
718 } 899 }
719 } 900 }
720 901
721 my $t1 = Time::HiRes::time; 902 my $t1 = EV::time;
722 my $data = $process->(\@data); 903 my $data = $process->(\@data);
723 my $t2 = Time::HiRes::time; 904 my $t2 = EV::time;
724 905
725 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 906 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
726 907
727 db_put cache => "$id/data", $data; 908 db_put cache => "$id/data", $data;
728 db_put cache => "$id/md5" , $md5; 909 db_put cache => "$id/md5" , $md5;
729 db_put cache => "$id/meta", $meta; 910 db_put cache => "$id/meta", $meta;
730 911
… …
740 921
741=cut 922=cut
742 923
743sub datalog($@) { 924sub datalog($@) {
744 my ($type, %kv) = @_; 925 my ($type, %kv) = @_;
745 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 926 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
746} 927}
747 928
748=back 929=back
749 930
750=cut 931=cut
… …
945 1126
946 } elsif (exists $cb_id{$type}) { 1127 } elsif (exists $cb_id{$type}) {
947 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1128 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
948 1129
949 } elsif (ref $type) { 1130 } elsif (ref $type) {
950 warn "attaching objects not supported, ignoring.\n"; 1131 error "attaching objects not supported, ignoring.\n";
951 1132
952 } else { 1133 } else {
953 shift @arg; 1134 shift @arg;
954 warn "attach argument '$type' not supported, ignoring.\n"; 1135 error "attach argument '$type' not supported, ignoring.\n";
955 } 1136 }
956 } 1137 }
957} 1138}
958 1139
959sub _object_attach { 1140sub _object_attach {
… …
969 _attach $registry, $klass, @attach; 1150 _attach $registry, $klass, @attach;
970 } 1151 }
971 1152
972 $obj->{$name} = \%arg; 1153 $obj->{$name} = \%arg;
973 } else { 1154 } else {
974 warn "object uses attachment '$name' which is not available, postponing.\n"; 1155 info "object uses attachment '$name' which is not available, postponing.\n";
975 } 1156 }
976 1157
977 $obj->{_attachment}{$name} = undef; 1158 $obj->{_attachment}{$name} = undef;
978} 1159}
979 1160
… …
1038 1219
1039 for (@$callbacks) { 1220 for (@$callbacks) {
1040 eval { &{$_->[1]} }; 1221 eval { &{$_->[1]} };
1041 1222
1042 if ($@) { 1223 if ($@) {
1043 warn "$@";
1044 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1224 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1045 override; 1225 override;
1046 } 1226 }
1047 1227
1048 return 1 if $override; 1228 return 1 if $override;
1049 } 1229 }
… …
1128 for (@$attach) { 1308 for (@$attach) {
1129 my ($klass, @attach) = @$_; 1309 my ($klass, @attach) = @$_;
1130 _attach $registry, $klass, @attach; 1310 _attach $registry, $klass, @attach;
1131 } 1311 }
1132 } else { 1312 } else {
1133 warn "object uses attachment '$name' that is not available, postponing.\n"; 1313 info "object uses attachment '$name' that is not available, postponing.\n";
1134 } 1314 }
1135 } 1315 }
1136} 1316}
1137 1317
1138cf::attachable->attach ( 1318cf::attachable->attach (
… …
1165 my ($filename, $rdata, $objs) = @_; 1345 my ($filename, $rdata, $objs) = @_;
1166 1346
1167 sync_job { 1347 sync_job {
1168 if (length $$rdata) { 1348 if (length $$rdata) {
1169 utf8::decode (my $decname = $filename); 1349 utf8::decode (my $decname = $filename);
1170 warn sprintf "saving %s (%d,%d)\n", 1350 trace sprintf "saving %s (%d,%d)\n",
1171 $decname, length $$rdata, scalar @$objs; 1351 $decname, length $$rdata, scalar @$objs
1352 if $VERBOSE_IO;
1172 1353
1173 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1354 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1174 aio_chmod $fh, SAVE_MODE; 1355 aio_chmod $fh, SAVE_MODE;
1175 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1356 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1176 if ($cf::USE_FSYNC) { 1357 if ($cf::USE_FSYNC) {
… …
1198 aio_rename "$filename~", $filename; 1379 aio_rename "$filename~", $filename;
1199 1380
1200 $filename =~ s%/[^/]+$%%; 1381 $filename =~ s%/[^/]+$%%;
1201 aio_pathsync $filename if $cf::USE_FSYNC; 1382 aio_pathsync $filename if $cf::USE_FSYNC;
1202 } else { 1383 } else {
1203 warn "unable to save objects: $filename~: $!\n"; 1384 error "unable to save objects: $filename~: $!\n";
1204 } 1385 }
1205 } else { 1386 } else {
1206 aio_unlink $filename; 1387 aio_unlink $filename;
1207 aio_unlink "$filename.pst"; 1388 aio_unlink "$filename.pst";
1208 } 1389 }
… …
1232 my $st = eval { Coro::Storable::thaw $av }; 1413 my $st = eval { Coro::Storable::thaw $av };
1233 $av = $st->{objs}; 1414 $av = $st->{objs};
1234 } 1415 }
1235 1416
1236 utf8::decode (my $decname = $filename); 1417 utf8::decode (my $decname = $filename);
1237 warn sprintf "loading %s (%d,%d)\n", 1418 trace sprintf "loading %s (%d,%d)\n",
1238 $decname, length $data, scalar @{$av || []}; 1419 $decname, length $data, scalar @{$av || []}
1420 if $VERBOSE_IO;
1239 1421
1240 ($data, $av) 1422 ($data, $av)
1241} 1423}
1242 1424
1243=head2 COMMAND CALLBACKS 1425=head2 COMMAND CALLBACKS
… …
1247=cut 1429=cut
1248 1430
1249############################################################################# 1431#############################################################################
1250# command handling &c 1432# command handling &c
1251 1433
1252=item cf::register_command $name => \&callback($ob,$args); 1434=item cf::register_command $name => \&callback($ob,$args)
1253 1435
1254Register a callback for execution when the client sends the user command 1436Register a callback for execution when the client sends the user command
1255$name. 1437$name.
1256 1438
1257=cut 1439=cut
… …
1263 #warn "registering command '$name/$time' to '$caller'"; 1445 #warn "registering command '$name/$time' to '$caller'";
1264 1446
1265 push @{ $COMMAND{$name} }, [$caller, $cb]; 1447 push @{ $COMMAND{$name} }, [$caller, $cb];
1266} 1448}
1267 1449
1268=item cf::register_extcmd $name => \&callback($pl,$packet); 1450=item cf::register_extcmd $name => \&callback($pl,@args)
1269 1451
1270Register a callback for execution when the client sends an (synchronous) 1452Register a callback for execution when the client sends an (synchronous)
1271extcmd packet. Ext commands will be processed in the order they are 1453extcmd packet. Ext commands will be processed in the order they are
1272received by the server, like other user commands. The first argument is 1454received by the server, like other user commands. The first argument is
1273the logged-in player. Ext commands can only be processed after a player 1455the logged-in player. Ext commands can only be processed after a player
1274has logged in successfully. 1456has logged in successfully.
1275 1457
1276If the callback returns something, it is sent back as if reply was being 1458The values will be sent back to the client.
1277called.
1278 1459
1460=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
1461
1462Same as C<cf::register_extcmd>, but instead of returning values, the
1463callback needs to clal the C<$reply> function.
1464
1279=item cf::register_exticmd $name => \&callback($ns,$packet); 1465=item cf::register_exticmd $name => \&callback($ns,@args)
1280 1466
1281Register a callback for execution when the client sends an (asynchronous) 1467Register a callback for execution when the client sends an (asynchronous)
1282exticmd packet. Exti commands are processed by the server as soon as they 1468exticmd packet. Exti commands are processed by the server as soon as they
1283are received, i.e. out of order w.r.t. other commands. The first argument 1469are received, i.e. out of order w.r.t. other commands. The first argument
1284is a client socket. Exti commands can be received anytime, even before 1470is a client socket. Exti commands can be received anytime, even before
1285log-in. 1471log-in.
1286 1472
1287If the callback returns something, it is sent back as if reply was being 1473The values will be sent back to the client.
1288called.
1289 1474
1290=cut 1475=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1291 1476
1477Same as C<cf::register_extcmd>, but instead of returning values, the
1478callback needs to clal the C<$reply> function.
1479
1480=cut
1481
1292sub register_extcmd { 1482sub register_extcmd($$) {
1293 my ($name, $cb) = @_; 1483 my ($name, $cb) = @_;
1294 1484
1295 $EXTCMD{$name} = $cb; 1485 $EXTCMD{$name} = $cb;
1296} 1486}
1297 1487
1298sub register_exticmd { 1488sub register_async_extcmd($$) {
1299 my ($name, $cb) = @_; 1489 my ($name, $cb) = @_;
1300 1490
1491 $EXTACMD{$name} = $cb;
1492}
1493
1494sub register_exticmd($$) {
1495 my ($name, $cb) = @_;
1496
1301 $EXTICMD{$name} = $cb; 1497 $EXTICMD{$name} = $cb;
1302} 1498}
1303 1499
1500sub register_async_exticmd($$) {
1501 my ($name, $cb) = @_;
1502
1503 $EXTIACMD{$name} = $cb;
1504}
1505
1304use File::Glob (); 1506use File::Glob ();
1305 1507
1306cf::player->attach ( 1508cf::player->attach (
1307 on_command => sub { 1509 on_unknown_command => sub {
1308 my ($pl, $name, $params) = @_; 1510 my ($pl, $name, $params) = @_;
1309 1511
1310 my $cb = $COMMAND{$name} 1512 my $cb = $COMMAND{$name}
1311 or return; 1513 or return;
1312 1514
… …
1320 my ($pl, $buf) = @_; 1522 my ($pl, $buf) = @_;
1321 1523
1322 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1524 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1323 1525
1324 if (ref $msg) { 1526 if (ref $msg) {
1325 my ($type, $reply, @payload) = 1527 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1326 "ARRAY" eq ref $msg
1327 ? @$msg
1328 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1329 1528
1330 my @reply;
1331
1332 if (my $cb = $EXTCMD{$type}) { 1529 if (my $cb = $EXTACMD{$type}) {
1530 $cb->(
1531 $pl,
1532 sub {
1533 $pl->ext_msg ("reply-$reply", @_)
1534 if $reply;
1535 },
1536 @payload
1537 );
1538 } else {
1539 my @reply;
1540
1541 if (my $cb = $EXTCMD{$type}) {
1333 @reply = $cb->($pl, @payload); 1542 @reply = $cb->($pl, @payload);
1543 }
1544
1545 $pl->ext_msg ("reply-$reply", @reply)
1546 if $reply;
1334 } 1547 }
1335 1548
1336 $pl->ext_reply ($reply, @reply)
1337 if $reply;
1338
1339 } else { 1549 } else {
1340 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1550 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1341 } 1551 }
1342 1552
1343 cf::override; 1553 cf::override;
1344 }, 1554 },
1345); 1555);
… …
1355 }; 1565 };
1356 1566
1357 $grp 1567 $grp
1358} 1568}
1359 1569
1570sub _ext_cfg_reg($$$$) {
1571 my ($rvar, $varname, $cfgname, $default) = @_;
1572
1573 $cfgname = lc $varname
1574 unless length $cfgname;
1575
1576 $EXT_CFG{$cfgname} = [$rvar, $default];
1577
1578 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1579}
1580
1360sub load_extensions { 1581sub load_extensions {
1582 info "loading extensions...";
1583
1584 %EXT_CFG = ();
1585
1361 cf::sync_job { 1586 cf::sync_job {
1362 my %todo; 1587 my %todo;
1363 1588
1364 for my $path (<$LIBDIR/*.ext>) { 1589 for my $path (<$LIBDIR/*.ext>) {
1365 next unless -r $path; 1590 next unless -r $path;
… …
1383 1608
1384 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1609 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1385 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1610 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1386 1611
1387 $ext{source} = 1612 $ext{source} =
1388 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1613 "package $pkg; use common::sense;\n"
1389 . "#line 1 \"$path\"\n{\n" 1614 . "#line 1 \"$path\"\n{\n"
1390 . $source 1615 . $source
1391 . "\n};\n1"; 1616 . "\n};\n1";
1392 1617
1393 $todo{$base} = \%ext; 1618 $todo{$base} = \%ext;
1394 } 1619 }
1395 1620
1621 my $pass = 0;
1396 my %done; 1622 my %done;
1397 while (%todo) { 1623 while (%todo) {
1398 my $progress; 1624 my $progress;
1399 1625
1626 ++$pass;
1627
1628 ext:
1400 while (my ($k, $v) = each %todo) { 1629 while (my ($k, $v) = each %todo) {
1401 for (split /,\s*/, $v->{meta}{depends}) { 1630 for (split /,\s*/, $v->{meta}{depends}) {
1402 goto skip 1631 next ext
1403 unless exists $done{$_}; 1632 unless exists $done{$_};
1404 } 1633 }
1405 1634
1406 warn "... loading '$k' into '$v->{pkg}'\n"; 1635 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1407 1636
1408 unless (eval $v->{source}) { 1637 my $source = $v->{source};
1638
1639 # support "CONF varname :confname = default" pseudo-statements
1640 $source =~ s{
1641 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1642 }{
1643 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1644 }gmxe;
1645
1646 my $active = eval $source;
1647
1648 if (length $@) {
1409 my $msg = $@ ? "$v->{path}: $@\n" 1649 error "$v->{path}: $@\n";
1410 : "$v->{base}: extension inactive.\n";
1411 1650
1412 if (exists $v->{meta}{mandatory}) {
1413 warn $msg;
1414 cf::cleanup "mandatory extension failed to load, exiting."; 1651 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1415 } 1652 if exists $v->{meta}{mandatory};
1416 1653
1417 warn $msg; 1654 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1655 delete $todo{$k};
1656 } else {
1657 $done{$k} = delete $todo{$k};
1658 push @EXTS, $v->{pkg};
1659 $progress = 1;
1660
1661 info "$v->{base}: extension inactive.\n"
1662 unless $active;
1418 } 1663 }
1419
1420 $done{$k} = delete $todo{$k};
1421 push @EXTS, $v->{pkg};
1422 $progress = 1;
1423 } 1664 }
1424 1665
1425 skip: 1666 unless ($progress) {
1426 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1667 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1427 unless $progress; 1668
1669 while (my ($k, $v) = each %todo) {
1670 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1671 if exists $v->{meta}{mandatory};
1672 }
1673
1674 last;
1675 }
1428 } 1676 }
1429 }; 1677 };
1430} 1678}
1431 1679
1432############################################################################# 1680#############################################################################
… …
1516 $cf::PLAYER{$login} = $pl 1764 $cf::PLAYER{$login} = $pl
1517 } 1765 }
1518 } 1766 }
1519} 1767}
1520 1768
1769cf::player->attach (
1770 on_load => sub {
1771 my ($pl, $path) = @_;
1772
1773 # restore slots saved in save, below
1774 my $slots = delete $pl->{_slots};
1775
1776 $pl->ob->current_weapon ($slots->[0]);
1777 $pl->combat_ob ($slots->[1]);
1778 $pl->ranged_ob ($slots->[2]);
1779 },
1780);
1781
1521sub save($) { 1782sub save($) {
1522 my ($pl) = @_; 1783 my ($pl) = @_;
1523 1784
1524 return if $pl->{deny_save}; 1785 return if $pl->{deny_save};
1525 1786
… …
1530 1791
1531 aio_mkdir playerdir $pl, 0770; 1792 aio_mkdir playerdir $pl, 0770;
1532 $pl->{last_save} = $cf::RUNTIME; 1793 $pl->{last_save} = $cf::RUNTIME;
1533 1794
1534 cf::get_slot 0.01; 1795 cf::get_slot 0.01;
1796
1797 # save slots, to be restored later
1798 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1535 1799
1536 $pl->save_pl ($path); 1800 $pl->save_pl ($path);
1537 cf::cede_to_tick; 1801 cf::cede_to_tick;
1538} 1802}
1539 1803
… …
1573 my $name = $pl->ob->name; 1837 my $name = $pl->ob->name;
1574 1838
1575 $pl->{deny_save} = 1; 1839 $pl->{deny_save} = 1;
1576 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1840 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1577 1841
1578 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1842 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1579 $pl->deactivate; 1843 $pl->deactivate;
1844
1580 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1845 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1581 $pl->ob->check_score;
1582 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1846 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1847 ext::highscore::check ($pl->ob);
1848
1583 $pl->ns->destroy if $pl->ns; 1849 $pl->ns->destroy if $pl->ns;
1584 1850
1585 my $path = playerdir $pl; 1851 my $path = playerdir $pl;
1586 my $temp = "$path~$cf::RUNTIME~deleting~"; 1852 my $temp = "$path~$cf::RUNTIME~deleting~";
1587 aio_rename $path, $temp; 1853 aio_rename $path, $temp;
… …
1641 \@logins 1907 \@logins
1642} 1908}
1643 1909
1644=item $player->maps 1910=item $player->maps
1645 1911
1912=item cf::player::maps $login
1913
1646Returns an arrayref of map paths that are private for this 1914Returns an arrayref of map paths that are private for this
1647player. May block. 1915player. May block.
1648 1916
1649=cut 1917=cut
1650 1918
… …
1671 1939
1672=item $protocol_xml = $player->expand_cfpod ($cfpod) 1940=item $protocol_xml = $player->expand_cfpod ($cfpod)
1673 1941
1674Expand deliantra pod fragments into protocol xml. 1942Expand deliantra pod fragments into protocol xml.
1675 1943
1676=item $player->ext_reply ($msgid, @msg)
1677
1678Sends an ext reply to the player.
1679
1680=cut
1681
1682sub ext_reply($$@) {
1683 my ($self, $id, @msg) = @_;
1684
1685 $self->ns->ext_reply ($id, @msg)
1686}
1687
1688=item $player->ext_msg ($type, @msg) 1944=item $player->ext_msg ($type, @msg)
1689 1945
1690Sends an ext event to the client. 1946Sends an ext event to the client.
1691 1947
1692=cut 1948=cut
… …
1711 1967
1712=cut 1968=cut
1713 1969
1714sub find_by_path($) { 1970sub find_by_path($) {
1715 my ($path) = @_; 1971 my ($path) = @_;
1972
1973 $path =~ s/^~[^\/]*//; # skip ~login
1716 1974
1717 my ($match, $specificity); 1975 my ($match, $specificity);
1718 1976
1719 for my $region (list) { 1977 for my $region (list) {
1720 if ($region->{match} && $path =~ $region->{match}) { 1978 if ($region->{match} && $path =~ $region->{match}) {
… …
1749sub generate_random_map { 2007sub generate_random_map {
1750 my ($self, $rmp) = @_; 2008 my ($self, $rmp) = @_;
1751 2009
1752 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 2010 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1753 2011
1754 # mit "rum" bekleckern, nicht
1755 $self->_create_random_map ( 2012 $self->_create_random_map ($rmp);
1756 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1757 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1758 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1759 $rmp->{exit_on_final_map},
1760 $rmp->{xsize}, $rmp->{ysize},
1761 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1762 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1763 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1764 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1765 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1766 (cf::region::find $rmp->{region}), $rmp->{custom}
1767 )
1768} 2013}
1769 2014
1770=item cf::map->register ($regex, $prio) 2015=item cf::map->register ($regex, $prio)
1771 2016
1772Register a handler for the map path matching the given regex at the 2017Register a handler for the map path matching the given regex at the
… …
1777 2022
1778sub register { 2023sub register {
1779 my (undef, $regex, $prio) = @_; 2024 my (undef, $regex, $prio) = @_;
1780 my $pkg = caller; 2025 my $pkg = caller;
1781 2026
1782 no strict;
1783 push @{"$pkg\::ISA"}, __PACKAGE__; 2027 push @{"$pkg\::ISA"}, __PACKAGE__;
1784 2028
1785 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 2029 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1786} 2030}
1787 2031
1788# also paths starting with '/' 2032# also paths starting with '/'
1789$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 2033$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1790 2034
1791sub thawer_merge { 2035sub thawer_merge {
1792 my ($self, $merge) = @_; 2036 my ($self, $merge) = @_;
1793 2037
1794 # we have to keep some variables in memory intact 2038 # we have to keep some variables in memory intact
… …
1799} 2043}
1800 2044
1801sub normalise { 2045sub normalise {
1802 my ($path, $base) = @_; 2046 my ($path, $base) = @_;
1803 2047
1804 $path = "$path"; # make sure its a string 2048 $path = "$path"; # make sure it's a string
1805 2049
1806 $path =~ s/\.map$//; 2050 $path =~ s/\.map$//;
1807 2051
1808 # map plan: 2052 # map plan:
1809 # 2053 #
… …
1824 $base =~ s{[^/]+/?$}{}; 2068 $base =~ s{[^/]+/?$}{};
1825 $path = "$base/$path"; 2069 $path = "$base/$path";
1826 } 2070 }
1827 2071
1828 for ($path) { 2072 for ($path) {
1829 redo if s{//}{/};
1830 redo if s{/\.?/}{/}; 2073 redo if s{/\.?/}{/};
1831 redo if s{/[^/]+/\.\./}{/}; 2074 redo if s{/[^/]+/\.\./}{/};
1832 } 2075 }
1833 2076
1834 $path 2077 $path
… …
1848 $self->init; # pass $1 etc. 2091 $self->init; # pass $1 etc.
1849 return $self; 2092 return $self;
1850 } 2093 }
1851 } 2094 }
1852 2095
1853 Carp::cluck "unable to resolve path '$path' (base '$base')."; 2096 Carp::cluck "unable to resolve path '$path' (base '$base')";
1854 () 2097 ()
1855} 2098}
1856 2099
2100# may re-bless or do other evil things
1857sub init { 2101sub init {
1858 my ($self) = @_; 2102 my ($self) = @_;
1859 2103
1860 $self 2104 $self
1861} 2105}
… …
1926 $self->{load_path} = $path; 2170 $self->{load_path} = $path;
1927 2171
1928 1 2172 1
1929} 2173}
1930 2174
2175# used to laod the header of an original map
1931sub load_header_orig { 2176sub load_header_orig {
1932 my ($self) = @_; 2177 my ($self) = @_;
1933 2178
1934 $self->load_header_from ($self->load_path) 2179 $self->load_header_from ($self->load_path)
1935} 2180}
1936 2181
2182# used to laod the header of an instantiated map
1937sub load_header_temp { 2183sub load_header_temp {
1938 my ($self) = @_; 2184 my ($self) = @_;
1939 2185
1940 $self->load_header_from ($self->save_path) 2186 $self->load_header_from ($self->save_path)
1941} 2187}
1942 2188
2189# called after loading the header from an instantiated map
1943sub prepare_temp { 2190sub prepare_temp {
1944 my ($self) = @_; 2191 my ($self) = @_;
1945 2192
1946 $self->last_access ((delete $self->{last_access}) 2193 $self->last_access ((delete $self->{last_access})
1947 || $cf::RUNTIME); #d# 2194 || $cf::RUNTIME); #d#
1948 # safety 2195 # safety
1949 $self->{instantiate_time} = $cf::RUNTIME 2196 $self->{instantiate_time} = $cf::RUNTIME
1950 if $self->{instantiate_time} > $cf::RUNTIME; 2197 if $self->{instantiate_time} > $cf::RUNTIME;
1951} 2198}
1952 2199
2200# called after loading the header from an original map
1953sub prepare_orig { 2201sub prepare_orig {
1954 my ($self) = @_; 2202 my ($self) = @_;
1955 2203
1956 $self->{load_original} = 1; 2204 $self->{load_original} = 1;
1957 $self->{instantiate_time} = $cf::RUNTIME; 2205 $self->{instantiate_time} = $cf::RUNTIME;
… …
1981 2229
1982sub find; 2230sub find;
1983sub find { 2231sub find {
1984 my ($path, $origin) = @_; 2232 my ($path, $origin) = @_;
1985 2233
2234 cf::cede_to_tick;
2235
1986 $path = normalise $path, $origin && $origin->path; 2236 $path = normalise $path, $origin;
1987 2237
1988 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2238 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1989 my $guard2 = cf::lock_acquire "map_find:$path"; 2239 my $guard2 = cf::lock_acquire "map_find:$path";
1990 2240
1991 $cf::MAP{$path} || do { 2241 $cf::MAP{$path} || do {
… …
2008 2258
2009 $cf::MAP{$path} = $map 2259 $cf::MAP{$path} = $map
2010 } 2260 }
2011} 2261}
2012 2262
2013sub pre_load { } 2263sub pre_load { }
2014sub post_load { } 2264#sub post_load { } # XS
2015 2265
2016sub load { 2266sub load {
2017 my ($self) = @_; 2267 my ($self) = @_;
2018 2268
2019 local $self->{deny_reset} = 1; # loading can take a long time 2269 local $self->{deny_reset} = 1; # loading can take a long time
… …
2022 2272
2023 { 2273 {
2024 my $guard = cf::lock_acquire "map_data:$path"; 2274 my $guard = cf::lock_acquire "map_data:$path";
2025 2275
2026 return unless $self->valid; 2276 return unless $self->valid;
2027 return unless $self->in_memory == cf::MAP_SWAPPED; 2277 return unless $self->state == cf::MAP_SWAPPED;
2028
2029 $self->in_memory (cf::MAP_LOADING);
2030 2278
2031 $self->alloc; 2279 $self->alloc;
2032 2280
2033 $self->pre_load; 2281 $self->pre_load;
2034 cf::cede_to_tick; 2282 cf::cede_to_tick;
2035 2283
2284 if (exists $self->{load_path}) {
2036 my $f = new_from_file cf::object::thawer $self->{load_path}; 2285 my $f = new_from_file cf::object::thawer $self->{load_path};
2037 $f->skip_block; 2286 $f->skip_block;
2038 $self->_load_objects ($f) 2287 $self->_load_objects ($f)
2039 or return; 2288 or return;
2040 2289
2041 $self->post_load_original 2290 $self->post_load_original
2042 if delete $self->{load_original}; 2291 if delete $self->{load_original};
2043 2292
2044 if (my $uniq = $self->uniq_path) { 2293 if (my $uniq = $self->uniq_path) {
2045 utf8::encode $uniq; 2294 utf8::encode $uniq;
2046 unless (aio_stat $uniq) { 2295 unless (aio_stat $uniq) {
2047 if (my $f = new_from_file cf::object::thawer $uniq) { 2296 if (my $f = new_from_file cf::object::thawer $uniq) {
2048 $self->clear_unique_items; 2297 $self->clear_unique_items;
2049 $self->_load_objects ($f); 2298 $self->_load_objects ($f);
2050 $f->resolve_delayed_derefs; 2299 $f->resolve_delayed_derefs;
2300 }
2051 } 2301 }
2052 } 2302 }
2053 }
2054 2303
2055 $f->resolve_delayed_derefs; 2304 $f->resolve_delayed_derefs;
2305 } else {
2306 $self->post_load_original
2307 if delete $self->{load_original};
2308 }
2309
2310 $self->state (cf::MAP_INACTIVE);
2056 2311
2057 cf::cede_to_tick; 2312 cf::cede_to_tick;
2058 # now do the right thing for maps 2313 # now do the right thing for maps
2059 $self->link_multipart_objects; 2314 $self->link_multipart_objects;
2060 $self->difficulty ($self->estimate_difficulty) 2315 $self->difficulty ($self->estimate_difficulty)
… …
2064 unless ($self->{deny_activate}) { 2319 unless ($self->{deny_activate}) {
2065 $self->decay_objects; 2320 $self->decay_objects;
2066 $self->fix_auto_apply; 2321 $self->fix_auto_apply;
2067 $self->update_buttons; 2322 $self->update_buttons;
2068 cf::cede_to_tick; 2323 cf::cede_to_tick;
2069 $self->activate; 2324 #$self->activate; # no longer activate maps automatically
2070 } 2325 }
2071 2326
2072 $self->{last_save} = $cf::RUNTIME; 2327 $self->{last_save} = $cf::RUNTIME;
2073 $self->last_access ($cf::RUNTIME); 2328 $self->last_access ($cf::RUNTIME);
2074
2075 $self->in_memory (cf::MAP_ACTIVE);
2076 } 2329 }
2077 2330
2078 $self->post_load; 2331 $self->post_load;
2079}
2080 2332
2333 1
2334}
2335
2336# customize the map for a given player, i.e.
2337# return the _real_ map. used by e.g. per-player
2338# maps to change the path to ~playername/mappath
2081sub customise_for { 2339sub customise_for {
2082 my ($self, $ob) = @_; 2340 my ($self, $ob) = @_;
2083 2341
2084 return find "~" . $ob->name . "/" . $self->{path} 2342 return find "~" . $ob->name . "/" . $self->{path}
2085 if $self->per_player; 2343 if $self->per_player;
… …
2088# if $self->per_party; 2346# if $self->per_party;
2089 2347
2090 $self 2348 $self
2091} 2349}
2092 2350
2093# find and load all maps in the 3x3 area around a map
2094sub load_neighbours {
2095 my ($map) = @_;
2096
2097 my @neigh; # diagonal neighbours
2098
2099 for (0 .. 3) {
2100 my $neigh = $map->tile_path ($_)
2101 or next;
2102 $neigh = find $neigh, $map
2103 or next;
2104 $neigh->load;
2105
2106 push @neigh,
2107 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2108 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2109 }
2110
2111 for (grep defined $_->[0], @neigh) {
2112 my ($path, $origin) = @$_;
2113 my $neigh = find $path, $origin
2114 or next;
2115 $neigh->load;
2116 }
2117}
2118
2119sub find_sync { 2351sub find_sync {
2120 my ($path, $origin) = @_; 2352 my ($path, $origin) = @_;
2121 2353
2122 cf::sync_job { find $path, $origin } 2354 # it's a bug to call this from the main context
2355 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2356 if $Coro::current == $Coro::main;
2357
2358 find $path, $origin
2123} 2359}
2124 2360
2125sub do_load_sync { 2361sub do_load_sync {
2126 my ($map) = @_; 2362 my ($map) = @_;
2127 2363
2364 # it's a bug to call this from the main context
2128 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2365 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2129 if $Coro::current == $Coro::main; 2366 if $Coro::current == $Coro::main;
2130 2367
2131 cf::sync_job { $map->load }; 2368 $map->load;
2132} 2369}
2133 2370
2134our %MAP_PREFETCH; 2371our %MAP_PREFETCH;
2135our $MAP_PREFETCHER = undef; 2372our $MAP_PREFETCHER = undef;
2136 2373
2137sub find_async { 2374sub find_async {
2138 my ($path, $origin, $load) = @_; 2375 my ($path, $origin, $load) = @_;
2139 2376
2140 $path = normalise $path, $origin && $origin->{path}; 2377 $path = normalise $path, $origin;
2141 2378
2142 if (my $map = $cf::MAP{$path}) { 2379 if (my $map = $cf::MAP{$path}) {
2143 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2380 return $map if !$load || $map->linkable;
2144 } 2381 }
2145 2382
2146 $MAP_PREFETCH{$path} |= $load; 2383 $MAP_PREFETCH{$path} |= $load;
2147 2384
2148 $MAP_PREFETCHER ||= cf::async { 2385 $MAP_PREFETCHER ||= cf::async {
… …
2162 $MAP_PREFETCHER->prio (6); 2399 $MAP_PREFETCHER->prio (6);
2163 2400
2164 () 2401 ()
2165} 2402}
2166 2403
2404# common code, used by both ->save and ->swapout
2167sub save { 2405sub _save {
2168 my ($self) = @_; 2406 my ($self) = @_;
2169
2170 my $lock = cf::lock_acquire "map_data:$self->{path}";
2171 2407
2172 $self->{last_save} = $cf::RUNTIME; 2408 $self->{last_save} = $cf::RUNTIME;
2173 2409
2174 return unless $self->dirty; 2410 return unless $self->dirty;
2175 2411
… …
2195 } else { 2431 } else {
2196 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2432 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2197 } 2433 }
2198} 2434}
2199 2435
2436sub save {
2437 my ($self) = @_;
2438
2439 my $lock = cf::lock_acquire "map_data:$self->{path}";
2440
2441 $self->_save;
2442}
2443
2200sub swap_out { 2444sub swap_out {
2201 my ($self) = @_; 2445 my ($self) = @_;
2202 2446
2203 # save first because save cedes
2204 $self->save;
2205
2206 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2447 my $lock = cf::lock_acquire "map_data:$self->{path}";
2207 2448
2449 return if !$self->linkable;
2450 return if $self->{deny_save};
2208 return if $self->players; 2451 return if $self->players;
2209 return if $self->in_memory != cf::MAP_ACTIVE; 2452
2453 # first deactivate the map and "unlink" it from the core
2454 $self->deactivate;
2455 $_->clear_links_to ($self) for values %cf::MAP;
2456 $self->state (cf::MAP_SWAPPED);
2457
2458 # then atomically save
2459 $self->_save;
2460
2461 # then free the map
2462 $self->clear;
2463}
2464
2465sub reset_at {
2466 my ($self) = @_;
2467
2468 # TODO: safety, remove and allow resettable per-player maps
2210 return if $self->{deny_save}; 2469 return 1e99 if $self->{deny_reset};
2211 2470
2471 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2472 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2473
2474 $time + $to
2475}
2476
2477sub should_reset {
2478 my ($self) = @_;
2479
2480 $self->reset_at <= $cf::RUNTIME
2481}
2482
2483sub reset {
2484 my ($self) = @_;
2485
2486 my $lock = cf::lock_acquire "map_data:$self->{path}";
2487
2488 return if $self->players;
2489
2490 cf::trace "resetting map ", $self->path, "\n";
2491
2212 $self->in_memory (cf::MAP_SWAPPED); 2492 $self->state (cf::MAP_SWAPPED);
2493
2494 # need to save uniques path
2495 unless ($self->{deny_save}) {
2496 my $uniq = $self->uniq_path; utf8::encode $uniq;
2497
2498 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2499 if $uniq;
2500 }
2501
2502 delete $cf::MAP{$self->path};
2213 2503
2214 $self->deactivate; 2504 $self->deactivate;
2215 $_->clear_links_to ($self) for values %cf::MAP; 2505 $_->clear_links_to ($self) for values %cf::MAP;
2216 $self->clear; 2506 $self->clear;
2217}
2218
2219sub reset_at {
2220 my ($self) = @_;
2221
2222 # TODO: safety, remove and allow resettable per-player maps
2223 return 1e99 if $self->{deny_reset};
2224
2225 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2226 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2227
2228 $time + $to
2229}
2230
2231sub should_reset {
2232 my ($self) = @_;
2233
2234 $self->reset_at <= $cf::RUNTIME
2235}
2236
2237sub reset {
2238 my ($self) = @_;
2239
2240 my $lock = cf::lock_acquire "map_data:$self->{path}";
2241
2242 return if $self->players;
2243
2244 warn "resetting map ", $self->path, "\n";
2245
2246 $self->in_memory (cf::MAP_SWAPPED);
2247
2248 # need to save uniques path
2249 unless ($self->{deny_save}) {
2250 my $uniq = $self->uniq_path; utf8::encode $uniq;
2251
2252 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2253 if $uniq;
2254 }
2255
2256 delete $cf::MAP{$self->path};
2257
2258 $self->deactivate;
2259 $_->clear_links_to ($self) for values %cf::MAP;
2260 $self->clear;
2261 2507
2262 $self->unlink_save; 2508 $self->unlink_save;
2263 $self->destroy; 2509 $self->destroy;
2264} 2510}
2265 2511
… …
2273 2519
2274 delete $cf::MAP{$self->path}; 2520 delete $cf::MAP{$self->path};
2275 2521
2276 $self->unlink_save; 2522 $self->unlink_save;
2277 2523
2278 bless $self, "cf::map"; 2524 bless $self, "cf::map::wrap";
2279 delete $self->{deny_reset}; 2525 delete $self->{deny_reset};
2280 $self->{deny_save} = 1; 2526 $self->{deny_save} = 1;
2281 $self->reset_timeout (1); 2527 $self->reset_timeout (1);
2282 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2528 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2283 2529
… …
2340 : normalise $_ 2586 : normalise $_
2341 } @{ aio_readdir $UNIQUEDIR or [] } 2587 } @{ aio_readdir $UNIQUEDIR or [] }
2342 ] 2588 ]
2343} 2589}
2344 2590
2591=item cf::map::static_maps
2592
2593Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2594file in the shared directory excluding F</styles> and F</editor>). May
2595block.
2596
2597=cut
2598
2599sub static_maps() {
2600 my @dirs = "";
2601 my @maps;
2602
2603 while (@dirs) {
2604 my $dir = shift @dirs;
2605
2606 next if $dir eq "/styles" || $dir eq "/editor";
2607
2608 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2609 or return;
2610
2611 for (@$files) {
2612 s/\.map$// or next;
2613 utf8::decode $_;
2614 push @maps, "$dir/$_";
2615 }
2616
2617 push @dirs, map "$dir/$_", @$dirs;
2618 }
2619
2620 \@maps
2621}
2622
2345=back 2623=back
2346 2624
2347=head3 cf::object 2625=head3 cf::object
2348 2626
2349=cut 2627=cut
… …
2372 2650
2373Creates and returns a persistent reference to an object that can be stored as a string. 2651Creates and returns a persistent reference to an object that can be stored as a string.
2374 2652
2375=item $ob = cf::object::deref ($refstring) 2653=item $ob = cf::object::deref ($refstring)
2376 2654
2377returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2655returns the objetc referenced by refstring. may return undef when it cannot find the object,
2378even if the object actually exists. May block. 2656even if the object actually exists. May block.
2379 2657
2380=cut 2658=cut
2381 2659
2382sub deref { 2660sub deref {
… …
2481 2759
2482Freezes the player and moves him/her to a special map (C<{link}>). 2760Freezes the player and moves him/her to a special map (C<{link}>).
2483 2761
2484The player should be reasonably safe there for short amounts of time (e.g. 2762The player should be reasonably safe there for short amounts of time (e.g.
2485for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2763for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2486though, as the palyer cannot control the character while it is on the link 2764though, as the player cannot control the character while it is on the link
2487map. 2765map.
2488 2766
2489Will never block. 2767Will never block.
2490 2768
2491=item $player_object->leave_link ($map, $x, $y) 2769=item $player_object->leave_link ($map, $x, $y)
… …
2512sub cf::object::player::enter_link { 2790sub cf::object::player::enter_link {
2513 my ($self) = @_; 2791 my ($self) = @_;
2514 2792
2515 $self->deactivate_recursive; 2793 $self->deactivate_recursive;
2516 2794
2795 ++$self->{_link_recursion};
2796
2517 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2797 return if UNIVERSAL::isa $self->map, "ext::map_link";
2518 2798
2519 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2799 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2520 if $self->map && $self->map->{path} ne "{link}"; 2800 if $self->map && $self->map->{path} ne "{link}";
2521 2801
2522 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2802 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2523} 2803}
2524 2804
2525sub cf::object::player::leave_link { 2805sub cf::object::player::leave_link {
2526 my ($self, $map, $x, $y) = @_; 2806 my ($self, $map, $x, $y) = @_;
2527 2807
… …
2544 ($x, $y) = (-1, -1) 2824 ($x, $y) = (-1, -1)
2545 unless (defined $x) && (defined $y); 2825 unless (defined $x) && (defined $y);
2546 2826
2547 # use -1 or undef as default coordinates, not 0, 0 2827 # use -1 or undef as default coordinates, not 0, 0
2548 ($x, $y) = ($map->enter_x, $map->enter_y) 2828 ($x, $y) = ($map->enter_x, $map->enter_y)
2549 if $x <=0 && $y <= 0; 2829 if $x <= 0 && $y <= 0;
2550 2830
2551 $map->load; 2831 $map->load;
2552 $map->load_neighbours;
2553 2832
2554 return unless $self->contr->active; 2833 return unless $self->contr->active;
2555 2834
2556 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2835 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2557 $self->enter_map ($map, $x, $y); 2836 if ($self->enter_map ($map, $x, $y)) {
2558 2837 # entering was successful
2838 delete $self->{_link_recursion};
2559 # only activate afterwards, to support waiting in hooks 2839 # only activate afterwards, to support waiting in hooks
2560 $self->activate_recursive; 2840 $self->activate_recursive;
2561} 2841 }
2562 2842
2843}
2844
2563=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2845=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2564 2846
2565Moves the player to the given map-path and coordinates by first freezing 2847Moves the player to the given map-path and coordinates by first freezing
2566her, loading and preparing them map, calling the provided $check callback 2848her, loading and preparing them map, calling the provided $check callback
2567that has to return the map if sucecssful, and then unfreezes the player on 2849that has to return the map if sucecssful, and then unfreezes the player on
2568the new (success) or old (failed) map position. In either case, $done will 2850the new (success) or old (failed) map position. In either case, $done will
… …
2575 2857
2576our $GOTOGEN; 2858our $GOTOGEN;
2577 2859
2578sub cf::object::player::goto { 2860sub cf::object::player::goto {
2579 my ($self, $path, $x, $y, $check, $done) = @_; 2861 my ($self, $path, $x, $y, $check, $done) = @_;
2862
2863 if ($self->{_link_recursion} >= $MAX_LINKS) {
2864 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2865 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2866 ($path, $x, $y) = @$EMERGENCY_POSITION;
2867 }
2580 2868
2581 # do generation counting so two concurrent goto's will be executed in-order 2869 # do generation counting so two concurrent goto's will be executed in-order
2582 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2870 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2583 2871
2584 $self->enter_link; 2872 $self->enter_link;
… …
2604 ($path, $x, $y) = (undef, undef, undef); 2892 ($path, $x, $y) = (undef, undef, undef);
2605 } 2893 }
2606 } 2894 }
2607 2895
2608 my $map = eval { 2896 my $map = eval {
2609 my $map = defined $path ? cf::map::find $path : undef; 2897 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2610 2898
2611 if ($map) { 2899 if ($map) {
2612 $map = $map->customise_for ($self); 2900 $map = $map->customise_for ($self);
2613 $map = $check->($map) if $check && $map; 2901 $map = $check->($map, $x, $y, $self) if $check && $map;
2614 } else { 2902 } else {
2615 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2903 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2616 } 2904 }
2617 2905
2618 $map 2906 $map
… …
2626 if ($gen == $self->{_goto_generation}) { 2914 if ($gen == $self->{_goto_generation}) {
2627 delete $self->{_goto_generation}; 2915 delete $self->{_goto_generation};
2628 $self->leave_link ($map, $x, $y); 2916 $self->leave_link ($map, $x, $y);
2629 } 2917 }
2630 2918
2631 $done->() if $done; 2919 $done->($self) if $done;
2632 })->prio (1); 2920 })->prio (1);
2633} 2921}
2634 2922
2635=item $player_object->enter_exit ($exit_object) 2923=item $player_object->enter_exit ($exit_object)
2636 2924
… …
2704 $Coro::current->{desc} = "enter_exit"; 2992 $Coro::current->{desc} = "enter_exit";
2705 2993
2706 unless (eval { 2994 unless (eval {
2707 $self->deactivate_recursive; # just to be sure 2995 $self->deactivate_recursive; # just to be sure
2708 2996
2709 # random map handling
2710 {
2711 my $guard = cf::lock_acquire "exit_prepare:$exit";
2712
2713 prepare_random_map $exit
2714 if $exit->slaying eq "/!";
2715 }
2716
2717 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2997 my $map = cf::map::normalise $exit->slaying, $exit->map;
2718 my $x = $exit->stats->hp; 2998 my $x = $exit->stats->hp;
2719 my $y = $exit->stats->sp; 2999 my $y = $exit->stats->sp;
3000
3001 # special map handling
3002 my $slaying = $exit->slaying;
3003
3004 # special map handling
3005 if ($slaying eq "/!") {
3006 my $guard = cf::lock_acquire "exit_prepare:$exit";
3007
3008 prepare_random_map $exit
3009 if $exit->slaying eq "/!"; # need to re-check after getting the lock
3010
3011 $map = $exit->slaying;
3012
3013 } elsif ($slaying eq '!up') {
3014 $map = $exit->map->tile_path (cf::TILE_UP);
3015 $x = $exit->x;
3016 $y = $exit->y;
3017
3018 } elsif ($slaying eq '!down') {
3019 $map = $exit->map->tile_path (cf::TILE_DOWN);
3020 $x = $exit->x;
3021 $y = $exit->y;
3022 }
2720 3023
2721 $self->goto ($map, $x, $y); 3024 $self->goto ($map, $x, $y);
2722 3025
2723 # if exit is damned, update players death & WoR home-position 3026 # if exit is damned, update players death & WoR home-position
2724 $self->contr->savebed ($map, $x, $y) 3027 $self->contr->savebed ($map, $x, $y)
… …
2729 $self->message ("Something went wrong deep within the deliantra server. " 3032 $self->message ("Something went wrong deep within the deliantra server. "
2730 . "I'll try to bring you back to the map you were before. " 3033 . "I'll try to bring you back to the map you were before. "
2731 . "Please report this to the dungeon master!", 3034 . "Please report this to the dungeon master!",
2732 cf::NDI_UNIQUE | cf::NDI_RED); 3035 cf::NDI_UNIQUE | cf::NDI_RED);
2733 3036
2734 warn "ERROR in enter_exit: $@"; 3037 error "ERROR in enter_exit: $@";
2735 $self->leave_link; 3038 $self->leave_link;
2736 } 3039 }
2737 })->prio (1); 3040 })->prio (1);
2738} 3041}
2739 3042
… …
2750 3053
2751sub cf::client::send_drawinfo { 3054sub cf::client::send_drawinfo {
2752 my ($self, $text, $flags) = @_; 3055 my ($self, $text, $flags) = @_;
2753 3056
2754 utf8::encode $text; 3057 utf8::encode $text;
2755 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 3058 $self->send_packet (sprintf "msg %d log %s", $flags || cf::NDI_BLACK, $text);
3059}
3060
3061=item $client->send_big_packet ($pkt)
3062
3063Like C<send_packet>, but tries to compress large packets, and fragments
3064them as required.
3065
3066=cut
3067
3068our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
3069
3070sub cf::client::send_big_packet {
3071 my ($self, $pkt) = @_;
3072
3073 # try lzf for large packets
3074 $pkt = "lzf " . Compress::LZF::compress $pkt
3075 if 1024 <= length $pkt and $self->{can_lzf};
3076
3077 # split very large packets
3078 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3079 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3080 $pkt = "frag";
3081 }
3082
3083 $self->send_packet ($pkt);
2756} 3084}
2757 3085
2758=item $client->send_msg ($channel, $msg, $color, [extra...]) 3086=item $client->send_msg ($channel, $msg, $color, [extra...])
2759 3087
2760Send a drawinfo or msg packet to the client, formatting the msg for the 3088Send a msg packet to the client, formatting the msg for the client if
2761client if neccessary. C<$type> should be a string identifying the type of 3089necessary. C<$type> should be a string identifying the type of the
2762the message, with C<log> being the default. If C<$color> is negative, suppress 3090message, with C<log> being the default. If C<$color> is negative, suppress
2763the message unless the client supports the msg packet. 3091the message unless the client supports the msg packet.
2764 3092
2765=cut 3093=cut
2766 3094
2767# non-persistent channels (usually the info channel) 3095# non-persistent channels (usually the info channel)
2768our %CHANNEL = ( 3096our %CHANNEL = (
3097 "c/motd" => {
3098 id => "infobox",
3099 title => "MOTD",
3100 reply => undef,
3101 tooltip => "The message of the day",
3102 },
2769 "c/identify" => { 3103 "c/identify" => {
2770 id => "infobox", 3104 id => "infobox",
2771 title => "Identify", 3105 title => "Identify",
2772 reply => undef, 3106 reply => undef,
2773 tooltip => "Items recently identified", 3107 tooltip => "Items recently identified",
… …
2775 "c/examine" => { 3109 "c/examine" => {
2776 id => "infobox", 3110 id => "infobox",
2777 title => "Examine", 3111 title => "Examine",
2778 reply => undef, 3112 reply => undef,
2779 tooltip => "Signs and other items you examined", 3113 tooltip => "Signs and other items you examined",
3114 },
3115 "c/shopinfo" => {
3116 id => "infobox",
3117 title => "Shop Info",
3118 reply => undef,
3119 tooltip => "What your bargaining skill tells you about the shop",
2780 }, 3120 },
2781 "c/book" => { 3121 "c/book" => {
2782 id => "infobox", 3122 id => "infobox",
2783 title => "Book", 3123 title => "Book",
2784 reply => undef, 3124 reply => undef,
… …
2860 id => "death", 3200 id => "death",
2861 title => "Death", 3201 title => "Death",
2862 reply => undef, 3202 reply => undef,
2863 tooltip => "Reason for and more info about your most recent death", 3203 tooltip => "Reason for and more info about your most recent death",
2864 }, 3204 },
3205 "c/fatal" => {
3206 id => "fatal",
3207 title => "Fatal Error",
3208 reply => undef,
3209 tooltip => "Reason for the server disconnect",
3210 },
2865 "c/say" => $SAY_CHANNEL, 3211 "c/say" => $SAY_CHANNEL,
2866 "c/chat" => $CHAT_CHANNEL, 3212 "c/chat" => $CHAT_CHANNEL,
2867); 3213);
2868 3214
2869sub cf::client::send_msg { 3215sub cf::client::send_msg {
… …
2900 my $pkt = "msg " 3246 my $pkt = "msg "
2901 . $self->{json_coder}->encode ( 3247 . $self->{json_coder}->encode (
2902 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3248 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2903 ); 3249 );
2904 3250
2905 # try lzf for large packets
2906 $pkt = "lzf " . Compress::LZF::compress $pkt
2907 if 1024 <= length $pkt and $self->{can_lzf};
2908
2909 # split very large packets
2910 if (8192 < length $pkt and $self->{can_lzf}) {
2911 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2912 $pkt = "frag";
2913 }
2914
2915 $self->send_packet ($pkt); 3251 $self->send_big_packet ($pkt);
2916} 3252}
2917 3253
2918=item $client->ext_msg ($type, @msg) 3254=item $client->ext_msg ($type, @msg)
2919 3255
2920Sends an ext event to the client. 3256Sends an ext event to the client.
… …
2922=cut 3258=cut
2923 3259
2924sub cf::client::ext_msg($$@) { 3260sub cf::client::ext_msg($$@) {
2925 my ($self, $type, @msg) = @_; 3261 my ($self, $type, @msg) = @_;
2926 3262
2927 if ($self->extcmd == 2) {
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3263 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2929 } elsif ($self->extcmd == 1) { # TODO: remove
2930 push @msg, msgtype => "event_$type";
2931 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2932 }
2933}
2934
2935=item $client->ext_reply ($msgid, @msg)
2936
2937Sends an ext reply to the client.
2938
2939=cut
2940
2941sub cf::client::ext_reply($$@) {
2942 my ($self, $id, @msg) = @_;
2943
2944 if ($self->extcmd == 2) {
2945 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2946 } elsif ($self->extcmd == 1) {
2947 #TODO: version 1, remove
2948 unshift @msg, msgtype => "reply", msgid => $id;
2949 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2950 }
2951} 3264}
2952 3265
2953=item $success = $client->query ($flags, "text", \&cb) 3266=item $success = $client->query ($flags, "text", \&cb)
2954 3267
2955Queues a query to the client, calling the given callback with 3268Queues a query to the client, calling the given callback with
… …
3010 my ($ns, $buf) = @_; 3323 my ($ns, $buf) = @_;
3011 3324
3012 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3325 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3013 3326
3014 if (ref $msg) { 3327 if (ref $msg) {
3015 my ($type, $reply, @payload) = 3328 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3016 "ARRAY" eq ref $msg
3017 ? @$msg
3018 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3019 3329
3020 my @reply;
3021
3022 if (my $cb = $EXTICMD{$type}) { 3330 if (my $cb = $EXTIACMD{$type}) {
3331 $cb->(
3332 $ns,
3333 sub {
3334 $ns->ext_msg ("reply-$reply", @_)
3335 if $reply;
3336 },
3337 @payload
3338 );
3339 } else {
3340 my @reply;
3341
3342 if (my $cb = $EXTICMD{$type}) {
3023 @reply = $cb->($ns, @payload); 3343 @reply = $cb->($ns, @payload);
3344 }
3345
3346 $ns->ext_msg ("reply-$reply", @reply)
3347 if $reply;
3024 } 3348 }
3025
3026 $ns->ext_reply ($reply, @reply)
3027 if $reply;
3028
3029 } else { 3349 } else {
3030 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3350 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3031 } 3351 }
3032 3352
3033 cf::override; 3353 cf::override;
3034 }, 3354 },
3035); 3355);
… …
3055 3375
3056 $coro 3376 $coro
3057} 3377}
3058 3378
3059cf::client->attach ( 3379cf::client->attach (
3060 on_destroy => sub { 3380 on_client_destroy => sub {
3061 my ($ns) = @_; 3381 my ($ns) = @_;
3062 3382
3063 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3383 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3064 }, 3384 },
3065); 3385);
… …
3081our $safe_hole = new Safe::Hole; 3401our $safe_hole = new Safe::Hole;
3082 3402
3083$SIG{FPE} = 'IGNORE'; 3403$SIG{FPE} = 'IGNORE';
3084 3404
3085$safe->permit_only (Opcode::opset qw( 3405$safe->permit_only (Opcode::opset qw(
3086 :base_core :base_mem :base_orig :base_math 3406 :base_core :base_mem :base_orig :base_math :base_loop
3087 grepstart grepwhile mapstart mapwhile 3407 grepstart grepwhile mapstart mapwhile
3088 sort time 3408 sort time
3089)); 3409));
3090 3410
3091# here we export the classes and methods available to script code 3411# here we export the classes and methods available to script code
… …
3116 decrease split destroy change_exp value msg lore send_msg)], 3436 decrease split destroy change_exp value msg lore send_msg)],
3117 ["cf::object::player" => qw(player)], 3437 ["cf::object::player" => qw(player)],
3118 ["cf::player" => qw(peaceful send_msg)], 3438 ["cf::player" => qw(peaceful send_msg)],
3119 ["cf::map" => qw(trigger)], 3439 ["cf::map" => qw(trigger)],
3120) { 3440) {
3121 no strict 'refs';
3122 my ($pkg, @funs) = @$_; 3441 my ($pkg, @funs) = @$_;
3123 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3442 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3124 for @funs; 3443 for @funs;
3125} 3444}
3126 3445
… …
3143 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3462 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3144 $qcode =~ s/\n/\\n/g; 3463 $qcode =~ s/\n/\\n/g;
3145 3464
3146 %vars = (_dummy => 0) unless %vars; 3465 %vars = (_dummy => 0) unless %vars;
3147 3466
3467 my @res;
3148 local $_; 3468 local $_;
3149 local @safe::cf::_safe_eval_args = values %vars;
3150 3469
3151 my $eval = 3470 my $eval =
3152 "do {\n" 3471 "do {\n"
3153 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3472 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3154 . "#line 0 \"{$qcode}\"\n" 3473 . "#line 0 \"{$qcode}\"\n"
3155 . $code 3474 . $code
3156 . "\n}" 3475 . "\n}"
3157 ; 3476 ;
3158 3477
3478 if ($CFG{safe_eval}) {
3159 sub_generation_inc; 3479 sub_generation_inc;
3480 local @safe::cf::_safe_eval_args = values %vars;
3160 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3481 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3161 sub_generation_inc; 3482 sub_generation_inc;
3483 } else {
3484 local @cf::_safe_eval_args = values %vars;
3485 @res = wantarray ? eval eval : scalar eval $eval;
3486 }
3162 3487
3163 if ($@) { 3488 if ($@) {
3164 warn "$@"; 3489 warn "$@",
3165 warn "while executing safe code '$code'\n"; 3490 "while executing safe code '$code'\n",
3166 warn "with arguments " . (join " ", %vars) . "\n"; 3491 "with arguments " . (join " ", %vars) . "\n";
3167 } 3492 }
3168 3493
3169 wantarray ? @res : $res[0] 3494 wantarray ? @res : $res[0]
3170} 3495}
3171 3496
… …
3185=cut 3510=cut
3186 3511
3187sub register_script_function { 3512sub register_script_function {
3188 my ($fun, $cb) = @_; 3513 my ($fun, $cb) = @_;
3189 3514
3190 no strict 'refs'; 3515 $fun = "safe::$fun" if $CFG{safe_eval};
3191 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3516 *$fun = $safe_hole->wrap ($cb);
3192} 3517}
3193 3518
3194=back 3519=back
3195 3520
3196=cut 3521=cut
3197 3522
3198############################################################################# 3523#############################################################################
3199# the server's init and main functions 3524# the server's init and main functions
3200 3525
3526{
3527 package cf::face;
3528
3529 our %HASH; # hash => idx
3530 our @DATA; # dynamically-created facedata, only faceste 0 used
3531 our @FOFS; # file offset, if > 0
3532 our @SIZE; # size of face, in octets
3533 our @META; # meta hash of face, if any
3534 our $DATAFH; # facedata filehandle
3535
3536 # internal api, not finalised
3537 sub set {
3538 my ($name, $type, $data) = @_;
3539
3540 my $idx = cf::face::find $name;
3541
3542 if ($idx) {
3543 delete $HASH{cf::face::get_csum $idx};
3544 } else {
3545 $idx = cf::face::alloc $name;
3546 }
3547
3548 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3549
3550 cf::face::set_type $idx, $type;
3551 cf::face::set_csum $idx, 0, $hash;
3552
3553 # we need to destroy the SV itself, not just modify it, as a running ix
3554 # might hold a reference to it: "delete" achieves that.
3555 delete $FOFS[0][$idx];
3556 delete $DATA[0][$idx];
3557 $DATA[0][$idx] = $data;
3558 $SIZE[0][$idx] = length $data;
3559 delete $META[$idx];
3560 $HASH{$hash} = $idx;#d#
3561
3562 $idx
3563 }
3564
3565 sub _get_data($$$) {
3566 my ($idx, $set, $cb) = @_;
3567
3568 if (defined $DATA[$set][$idx]) {
3569 $cb->($DATA[$set][$idx]);
3570 } elsif (my $fofs = $FOFS[$set][$idx]) {
3571 my $size = $SIZE[$set][$idx];
3572 my $buf;
3573 IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
3574 if ($_[0] == $size) {
3575 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3576 $cb->($buf);
3577 } else {
3578 cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
3579 }
3580 };
3581 } else {
3582 cf::error "requested facedata for unknown face $idx#$set, ignoring.";
3583 }
3584 }
3585
3586 # rather ineffient
3587 sub cf::face::get_data($;$) {
3588 my ($idx, $set) = @_;
3589
3590 _get_data $idx, $set, Coro::rouse_cb;
3591 Coro::rouse_wait
3592 }
3593
3594 sub cf::face::ix {
3595 my ($ns, $set, $idx, $pri) = @_;
3596
3597 _get_data $idx, $set, sub {
3598 $ns->ix_send ($idx, $pri, $_[0]);
3599 };
3600 }
3601}
3602
3201sub load_facedata($) { 3603sub load_facedata($) {
3202 my ($path) = @_; 3604 my ($path) = @_;
3203 3605
3204 # HACK to clear player env face cache, we need some signal framework
3205 # for this (global event?)
3206 %ext::player_env::MUSIC_FACE_CACHE = ();
3207
3208 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3606 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3209 3607
3210 warn "loading facedata from $path\n"; 3608 trace "loading facedata from $path\n";
3211 3609
3212 my $facedata; 3610 my $facedata = decode_storable load_file "$path/faceinfo";
3213 0 < aio_load $path, $facedata
3214 or die "$path: $!";
3215
3216 $facedata = Coro::Storable::thaw $facedata;
3217 3611
3218 $facedata->{version} == 2 3612 $facedata->{version} == 2
3219 or cf::cleanup "$path: version mismatch, cannot proceed."; 3613 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3220 3614
3221 # patch in the exptable 3615 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3222 $facedata->{resource}{"res/exp_table"} = { 3616 or cf::cleanup "$path/facedata: $!, cannot proceed.";
3223 type => FT_RSRC, 3617
3224 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3618 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3225 }; 3619
3226 cf::cede_to_tick; 3620 # BEGIN ATOMIC
3621 # from here on, everything must be atomic - no thread switch allowed
3622 my $t1 = EV::time;
3227 3623
3228 { 3624 {
3229 my $faces = $facedata->{faceinfo}; 3625 my $faces = $facedata->{faceinfo};
3230 3626
3231 while (my ($face, $info) = each %$faces) { 3627 for my $face (sort keys %$faces) {
3628 my $info = $faces->{$face};
3232 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3629 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3233 3630
3234 cf::face::set_visibility $idx, $info->{visibility}; 3631 cf::face::set_visibility $idx, $info->{visibility};
3235 cf::face::set_magicmap $idx, $info->{magicmap}; 3632 cf::face::set_magicmap $idx, $info->{magicmap};
3236 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3633 cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
3237 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3634 cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
3238 3635 cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3239 cf::cede_to_tick; 3636 $cf::face::HASH{$info->{hash64}} = $idx;
3637 delete $cf::face::META[$idx];
3240 } 3638 }
3241 3639
3242 while (my ($face, $info) = each %$faces) { 3640 while (my ($face, $info) = each %$faces) {
3243 next unless $info->{smooth}; 3641 next unless $info->{smooth};
3244 3642
… …
3247 3645
3248 if (my $smooth = cf::face::find $info->{smooth}) { 3646 if (my $smooth = cf::face::find $info->{smooth}) {
3249 cf::face::set_smooth $idx, $smooth; 3647 cf::face::set_smooth $idx, $smooth;
3250 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3648 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3251 } else { 3649 } else {
3252 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3650 error "smooth face '$info->{smooth}' not found for face '$face'";
3253 } 3651 }
3254
3255 cf::cede_to_tick;
3256 } 3652 }
3257 } 3653 }
3258 3654
3259 { 3655 {
3260 my $anims = $facedata->{animinfo}; 3656 my $anims = $facedata->{animinfo};
3261 3657
3262 while (my ($anim, $info) = each %$anims) { 3658 while (my ($anim, $info) = each %$anims) {
3263 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3659 cf::anim::set $anim, $info->{frames}, $info->{facings};
3264 cf::cede_to_tick;
3265 } 3660 }
3266 3661
3267 cf::anim::invalidate_all; # d'oh 3662 cf::anim::invalidate_all; # d'oh
3268 } 3663 }
3269 3664
3270 { 3665 {
3271 # TODO: for gcfclient pleasure, we should give resources
3272 # that gcfclient doesn't grok a >10000 face index.
3273 my $res = $facedata->{resource}; 3666 my $res = $facedata->{resource};
3274 3667
3275 while (my ($name, $info) = each %$res) { 3668 while (my ($name, $info) = each %$res) {
3276 if (defined $info->{type}) { 3669 if (defined (my $type = $info->{type})) {
3670 # TODO: different hash - must free and use new index, or cache ixface data queue
3277 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3671 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3278 my $data;
3279 3672
3280 if ($info->{type} & 1) {
3281 # prepend meta info
3282
3283 my $meta = $enc->encode ({
3284 name => $name,
3285 %{ $info->{meta} || {} },
3286 });
3287
3288 $data = pack "(w/a*)*", $meta, $info->{data};
3289 } else {
3290 $data = $info->{data};
3291 }
3292
3293 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3294 cf::face::set_type $idx, $info->{type}; 3673 cf::face::set_type $idx, $type;
3674 cf::face::set_csum $idx, 0, $info->{hash};
3675 $cf::face::SIZE[0][$idx] = $info->{size};
3676 $cf::face::FOFS[0][$idx] = $info->{fofs};
3677 $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3678 $cf::face::HASH{$info->{hash}} = $idx;
3295 } else { 3679 } else {
3296 $RESOURCE{$name} = $info; 3680# $RESOURCE{$name} = $info; # unused
3297 } 3681 }
3298
3299 cf::cede_to_tick;
3300 } 3682 }
3301 } 3683 }
3684
3685 ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
3686
3687 # HACK to clear player env face cache, we need some signal framework
3688 # for this (global event?)
3689 %ext::player_env::MUSIC_FACE_CACHE = ();
3690
3691 # END ATOMIC
3692
3693 cf::debug "facedata atomic update time ", EV::time - $t1;
3302 3694
3303 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3695 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3304 3696
3697 aio_close $fh if $fh; # close old facedata
3698
3305 1 3699 1
3306} 3700}
3307
3308cf::global->attach (on_resource_update => sub {
3309 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3310 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3311
3312 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3313 my $sound = $soundconf->{compat}[$_]
3314 or next;
3315
3316 my $face = cf::face::find "sound/$sound->[1]";
3317 cf::sound::set $sound->[0] => $face;
3318 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3319 }
3320
3321 while (my ($k, $v) = each %{$soundconf->{event}}) {
3322 my $face = cf::face::find "sound/$v";
3323 cf::sound::set $k => $face;
3324 }
3325 }
3326});
3327 3701
3328register_exticmd fx_want => sub { 3702register_exticmd fx_want => sub {
3329 my ($ns, $want) = @_; 3703 my ($ns, $want) = @_;
3330 3704
3331 while (my ($k, $v) = each %$want) { 3705 while (my ($k, $v) = each %$want) {
… …
3339 my $status = load_resource_file_ $_[0]; 3713 my $status = load_resource_file_ $_[0];
3340 get_slot 0.1, 100; 3714 get_slot 0.1, 100;
3341 cf::arch::commit_load; 3715 cf::arch::commit_load;
3342 3716
3343 $status 3717 $status
3718}
3719
3720sub reload_exp_table {
3721 _reload_exp_table;
3722
3723 cf::face::set
3724 "res/exp_table" => FT_RSRC,
3725 JSON::XS->new->utf8->canonical->encode (
3726 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3727 );
3728}
3729
3730sub reload_materials {
3731 _reload_materials;
3344} 3732}
3345 3733
3346sub reload_regions { 3734sub reload_regions {
3347 # HACK to clear player env face cache, we need some signal framework 3735 # HACK to clear player env face cache, we need some signal framework
3348 # for this (global event?) 3736 # for this (global event?)
… …
3356 if exists $_->{match}; 3744 if exists $_->{match};
3357 } 3745 }
3358} 3746}
3359 3747
3360sub reload_facedata { 3748sub reload_facedata {
3361 load_facedata "$DATADIR/facedata" 3749 load_facedata $DATADIR
3362 or die "unable to load facedata\n"; 3750 or die "unable to load facedata\n";
3363} 3751}
3364 3752
3365sub reload_archetypes { 3753sub reload_archetypes {
3366 load_resource_file "$DATADIR/archetypes" 3754 load_resource_file "$DATADIR/archetypes"
3367 or die "unable to load archetypes\n"; 3755 or die "unable to load archetypes\n";
3756
3757 cf::face::set
3758 "res/skill_info" => FT_RSRC,
3759 JSON::XS->new->utf8->canonical->encode (
3760 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3761 );
3762
3763 cf::face::set
3764 "res/spell_paths" => FT_RSRC,
3765 JSON::XS->new->utf8->canonical->encode (
3766 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3767 );
3368} 3768}
3369 3769
3370sub reload_treasures { 3770sub reload_treasures {
3371 load_resource_file "$DATADIR/treasures" 3771 load_resource_file "$DATADIR/treasures"
3372 or die "unable to load treasurelists\n"; 3772 or die "unable to load treasurelists\n";
3373} 3773}
3374 3774
3775sub reload_sound {
3776 trace "loading sound config from $DATADIR/sound\n";
3777
3778 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3779
3780 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3781 my $sound = $soundconf->{compat}[$_]
3782 or next;
3783
3784 my $face = cf::face::find "sound/$sound->[1]";
3785 cf::sound::set $sound->[0] => $face;
3786 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3787 }
3788
3789 while (my ($k, $v) = each %{$soundconf->{event}}) {
3790 my $face = cf::face::find "sound/$v";
3791 cf::sound::set $k => $face;
3792 }
3793}
3794
3375sub reload_resources { 3795sub reload_resources {
3376 warn "reloading resource files...\n"; 3796 trace "reloading resource files...\n";
3377 3797
3798 reload_materials;
3378 reload_facedata; 3799 reload_facedata;
3800 reload_exp_table;
3801 reload_sound;
3379 reload_archetypes; 3802 reload_archetypes;
3380 reload_regions; 3803 reload_regions;
3381 reload_treasures; 3804 reload_treasures;
3382 3805
3383 warn "finished reloading resource files\n"; 3806 trace "finished reloading resource files\n";
3384} 3807}
3385 3808
3386sub reload_config { 3809sub reload_config {
3387 open my $fh, "<:utf8", "$CONFDIR/config" 3810 trace "reloading config file...\n";
3388 or return;
3389 3811
3390 local $/; 3812 my $config = load_file "$CONFDIR/config";
3391 *CFG = YAML::Load <$fh>; 3813 utf8::decode $config;
3814 *CFG = decode_yaml $config;
3392 3815
3393 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3816 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3394 3817
3395 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3818 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3396 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3819 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3397 3820
3398 if (exists $CFG{mlockall}) { 3821 if (exists $CFG{mlockall}) {
… …
3422 seek $fh, 0, 0; 3845 seek $fh, 0, 0;
3423 print $fh $$; 3846 print $fh $$;
3424} 3847}
3425 3848
3426sub main_loop { 3849sub main_loop {
3427 warn "EV::loop starting\n"; 3850 trace "EV::loop starting\n";
3428 if (1) { 3851 if (1) {
3429 EV::loop; 3852 EV::loop;
3430 } 3853 }
3431 warn "EV::loop returned\n"; 3854 trace "EV::loop returned\n";
3432 goto &main_loop unless $REALLY_UNLOOP; 3855 goto &main_loop unless $REALLY_UNLOOP;
3433} 3856}
3434 3857
3435sub main { 3858sub main {
3436 cf::init_globals; # initialise logging 3859 cf::init_globals; # initialise logging
3437 3860
3438 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3861 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3439 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3862 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3440 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3863 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3441 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3864 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3442 3865
3443 cf::init_experience;
3444 cf::init_anim;
3445 cf::init_attackmess;
3446 cf::init_dynamic;
3447
3448 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3866 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3449 3867
3450 # we must not ever block the main coroutine 3868 # we must not ever block the main coroutine
3451 local $Coro::idle = sub { 3869 $Coro::idle = sub {
3452 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3870 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3453 (async { 3871 (async {
3454 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3872 $Coro::current->{desc} = "IDLE BUG HANDLER";
3455 EV::loop EV::LOOP_ONESHOT; 3873 EV::loop EV::LOOP_ONESHOT;
3456 })->prio (Coro::PRIO_MAX); 3874 })->prio (Coro::PRIO_MAX);
3457 }; 3875 };
3458 3876
3459 evthread_start IO::AIO::poll_fileno; 3877 evthread_start IO::AIO::poll_fileno;
3460 3878
3461 cf::sync_job { 3879 cf::sync_job {
3880 cf::incloader::init ();
3881
3882 db_init;
3883
3884 cf::init_anim;
3885 cf::init_attackmess;
3886 cf::init_dynamic;
3887
3888 cf::load_settings;
3889
3462 reload_resources; 3890 reload_resources;
3463 reload_config; 3891 reload_config;
3464 db_init;
3465 3892
3466 cf::load_settings;
3467 cf::load_materials;
3468 cf::init_uuid; 3893 cf::init_uuid;
3469 cf::init_signals; 3894 cf::init_signals;
3470 cf::init_commands;
3471 cf::init_skills; 3895 cf::init_skills;
3472 3896
3473 cf::init_beforeplay; 3897 cf::init_beforeplay;
3474 3898
3475 atomic; 3899 atomic;
… …
3480 3904
3481 # no (long-running) fork's whatsoever before this point(!) 3905 # no (long-running) fork's whatsoever before this point(!)
3482 use POSIX (); 3906 use POSIX ();
3483 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3907 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3484 3908
3485 (pop @POST_INIT)->(0) while @POST_INIT; 3909 cf::_post_init 0;
3486 }; 3910 };
3487 3911
3912 cf::object::thawer::errors_are_fatal 0;
3913 info "parse errors in files are no longer fatal from this point on.\n";
3914
3915 AE::postpone {
3916 undef &main; # free gobs of memory :)
3917 };
3918
3488 main_loop; 3919 goto &main_loop;
3489} 3920}
3490 3921
3491############################################################################# 3922#############################################################################
3492# initialisation and cleanup 3923# initialisation and cleanup
3493 3924
3494# install some emergency cleanup handlers 3925# install some emergency cleanup handlers
3495BEGIN { 3926BEGIN {
3496 our %SIGWATCHER = (); 3927 our %SIGWATCHER = ();
3497 for my $signal (qw(INT HUP TERM)) { 3928 for my $signal (qw(INT HUP TERM)) {
3498 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3929 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3499 cf::cleanup "SIG$signal"; 3930 cf::cleanup "SIG$signal";
3500 }; 3931 };
3501 } 3932 }
3502} 3933}
3503 3934
3504sub write_runtime_sync { 3935sub write_runtime_sync {
3936 my $t0 = AE::time;
3937
3505 # first touch the runtime file to show we are still running: 3938 # first touch the runtime file to show we are still running:
3506 # the fsync below can take a very very long time. 3939 # the fsync below can take a very very long time.
3507 3940
3508 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3941 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3509 3942
3510 my $guard = cf::lock_acquire "write_runtime"; 3943 my $guard = cf::lock_acquire "write_runtime";
3511 3944
3512 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3945 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3513 or return; 3946 or return;
3514 3947
3515 my $value = $cf::RUNTIME + 90 + 10; 3948 my $value = $cf::RUNTIME + 90 + 10;
3516 # 10 is the runtime save interval, for a monotonic clock 3949 # 10 is the runtime save interval, for a monotonic clock
3517 # 60 allows for the watchdog to kill the server. 3950 # 60 allows for the watchdog to kill the server.
… …
3530 or return; 3963 or return;
3531 3964
3532 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3965 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3533 and return; 3966 and return;
3534 3967
3535 warn "runtime file written.\n"; 3968 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3536 3969
3537 1 3970 1
3538} 3971}
3539 3972
3540our $uuid_lock; 3973our $uuid_lock;
… …
3552 or return; 3985 or return;
3553 3986
3554 my $value = uuid_seq uuid_cur; 3987 my $value = uuid_seq uuid_cur;
3555 3988
3556 unless ($value) { 3989 unless ($value) {
3557 warn "cowardly refusing to write zero uuid value!\n"; 3990 info "cowardly refusing to write zero uuid value!\n";
3558 return; 3991 return;
3559 } 3992 }
3560 3993
3561 my $value = uuid_str $value + $uuid_skip; 3994 my $value = uuid_str $value + $uuid_skip;
3562 $uuid_skip = 0; 3995 $uuid_skip = 0;
… …
3572 or return; 4005 or return;
3573 4006
3574 aio_rename "$uuid~", $uuid 4007 aio_rename "$uuid~", $uuid
3575 and return; 4008 and return;
3576 4009
3577 warn "uuid file written ($value).\n"; 4010 trace "uuid file written ($value).\n";
3578 4011
3579 1 4012 1
3580 4013
3581} 4014}
3582 4015
… …
3588} 4021}
3589 4022
3590sub emergency_save() { 4023sub emergency_save() {
3591 my $freeze_guard = cf::freeze_mainloop; 4024 my $freeze_guard = cf::freeze_mainloop;
3592 4025
3593 warn "emergency_perl_save: enter\n"; 4026 info "emergency_perl_save: enter\n";
4027
4028 # this is a trade-off: we want to be very quick here, so
4029 # save all maps without fsync, and later call a global sync
4030 # (which in turn might be very very slow)
4031 local $USE_FSYNC = 0;
3594 4032
3595 cf::sync_job { 4033 cf::sync_job {
3596 # this is a trade-off: we want to be very quick here, so 4034 cf::write_runtime_sync; # external watchdog should not bark
3597 # save all maps without fsync, and later call a global sync
3598 # (which in turn might be very very slow)
3599 local $USE_FSYNC = 0;
3600 4035
3601 # use a peculiar iteration method to avoid tripping on perl 4036 # use a peculiar iteration method to avoid tripping on perl
3602 # refcount bugs in for. also avoids problems with players 4037 # refcount bugs in for. also avoids problems with players
3603 # and maps saved/destroyed asynchronously. 4038 # and maps saved/destroyed asynchronously.
3604 warn "emergency_perl_save: begin player save\n"; 4039 info "emergency_perl_save: begin player save\n";
3605 for my $login (keys %cf::PLAYER) { 4040 for my $login (keys %cf::PLAYER) {
3606 my $pl = $cf::PLAYER{$login} or next; 4041 my $pl = $cf::PLAYER{$login} or next;
3607 $pl->valid or next; 4042 $pl->valid or next;
3608 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 4043 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3609 $pl->save; 4044 $pl->save;
3610 } 4045 }
3611 warn "emergency_perl_save: end player save\n"; 4046 info "emergency_perl_save: end player save\n";
3612 4047
4048 cf::write_runtime_sync; # external watchdog should not bark
4049
3613 warn "emergency_perl_save: begin map save\n"; 4050 info "emergency_perl_save: begin map save\n";
3614 for my $path (keys %cf::MAP) { 4051 for my $path (keys %cf::MAP) {
3615 my $map = $cf::MAP{$path} or next; 4052 my $map = $cf::MAP{$path} or next;
3616 $map->valid or next; 4053 $map->valid or next;
3617 $map->save; 4054 $map->save;
3618 } 4055 }
3619 warn "emergency_perl_save: end map save\n"; 4056 info "emergency_perl_save: end map save\n";
3620 4057
4058 cf::write_runtime_sync; # external watchdog should not bark
4059
3621 warn "emergency_perl_save: begin database checkpoint\n"; 4060 info "emergency_perl_save: begin database checkpoint\n";
3622 BDB::db_env_txn_checkpoint $DB_ENV; 4061 BDB::db_env_txn_checkpoint $DB_ENV;
3623 warn "emergency_perl_save: end database checkpoint\n"; 4062 info "emergency_perl_save: end database checkpoint\n";
3624 4063
3625 warn "emergency_perl_save: begin write uuid\n"; 4064 info "emergency_perl_save: begin write uuid\n";
3626 write_uuid_sync 1; 4065 write_uuid_sync 1;
3627 warn "emergency_perl_save: end write uuid\n"; 4066 info "emergency_perl_save: end write uuid\n";
4067
4068 cf::write_runtime_sync; # external watchdog should not bark
4069
4070 trace "emergency_perl_save: syncing database to disk";
4071 BDB::db_env_txn_checkpoint $DB_ENV;
4072
4073 info "emergency_perl_save: starting sync\n";
4074 IO::AIO::aio_sync sub {
4075 info "emergency_perl_save: finished sync\n";
4076 };
4077
4078 cf::write_runtime_sync; # external watchdog should not bark
4079
4080 trace "emergency_perl_save: flushing outstanding aio requests";
4081 while (IO::AIO::nreqs || BDB::nreqs) {
4082 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
4083 }
4084
4085 cf::write_runtime_sync; # external watchdog should not bark
3628 }; 4086 };
3629 4087
3630 warn "emergency_perl_save: starting sync()\n";
3631 IO::AIO::aio_sync sub {
3632 warn "emergency_perl_save: finished sync()\n";
3633 };
3634
3635 warn "emergency_perl_save: leave\n"; 4088 info "emergency_perl_save: leave\n";
3636} 4089}
3637 4090
3638sub post_cleanup { 4091sub post_cleanup {
3639 my ($make_core) = @_; 4092 my ($make_core) = @_;
3640 4093
4094 IO::AIO::flush;
4095
3641 warn Carp::longmess "post_cleanup backtrace" 4096 error Carp::longmess "post_cleanup backtrace"
3642 if $make_core; 4097 if $make_core;
3643 4098
3644 my $fh = pidfile; 4099 my $fh = pidfile;
3645 unlink $PIDFILE if <$fh> == $$; 4100 unlink $PIDFILE if <$fh> == $$;
3646} 4101}
… …
3666 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 4121 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3667 for my $name (keys %$leaf_symtab) { 4122 for my $name (keys %$leaf_symtab) {
3668 _gv_clear *{"$pkg$name"}; 4123 _gv_clear *{"$pkg$name"};
3669# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 4124# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3670 } 4125 }
3671 warn "cleared package $pkg\n";#d#
3672} 4126}
3673 4127
3674sub do_reload_perl() { 4128sub do_reload_perl() {
3675 # can/must only be called in main 4129 # can/must only be called in main
3676 if ($Coro::current != $Coro::main) { 4130 unless (in_main) {
3677 warn "can only reload from main coroutine"; 4131 error "can only reload from main coroutine";
3678 return; 4132 return;
3679 } 4133 }
3680 4134
3681 return if $RELOAD++; 4135 return if $RELOAD++;
3682 4136
3683 my $t1 = EV::time; 4137 my $t1 = AE::time;
3684 4138
3685 while ($RELOAD) { 4139 while ($RELOAD) {
3686 warn "reloading..."; 4140 cf::get_slot 0.1, -1, "reload_perl";
4141 info "perl_reload: reloading...";
3687 4142
3688 warn "entering sync_job"; 4143 trace "perl_reload: entering sync_job";
3689 4144
3690 cf::sync_job { 4145 cf::sync_job {
3691 cf::write_runtime_sync; # external watchdog should not bark
3692 cf::emergency_save; 4146 #cf::emergency_save;
3693 cf::write_runtime_sync; # external watchdog should not bark
3694 4147
3695 warn "syncing database to disk";
3696 BDB::db_env_txn_checkpoint $DB_ENV;
3697
3698 # if anything goes wrong in here, we should simply crash as we already saved
3699
3700 warn "flushing outstanding aio requests";
3701 while (IO::AIO::nreqs || BDB::nreqs) {
3702 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3703 }
3704
3705 warn "cancelling all extension coros"; 4148 trace "perl_reload: cancelling all extension coros";
3706 $_->cancel for values %EXT_CORO; 4149 $_->cancel for values %EXT_CORO;
3707 %EXT_CORO = (); 4150 %EXT_CORO = ();
3708 4151
3709 warn "removing commands"; 4152 trace "perl_reload: removing commands";
3710 %COMMAND = (); 4153 %COMMAND = ();
3711 4154
3712 warn "removing ext/exti commands"; 4155 trace "perl_reload: removing ext/exti commands";
3713 %EXTCMD = (); 4156 %EXTCMD = ();
3714 %EXTICMD = (); 4157 %EXTICMD = ();
3715 4158
3716 warn "unloading/nuking all extensions"; 4159 trace "perl_reload: unloading/nuking all extensions";
3717 for my $pkg (@EXTS) { 4160 for my $pkg (@EXTS) {
3718 warn "... unloading $pkg"; 4161 trace "... unloading $pkg";
3719 4162
3720 if (my $cb = $pkg->can ("unload")) { 4163 if (my $cb = $pkg->can ("unload")) {
3721 eval { 4164 eval {
3722 $cb->($pkg); 4165 $cb->($pkg);
3723 1 4166 1
3724 } or warn "$pkg unloaded, but with errors: $@"; 4167 } or error "$pkg unloaded, but with errors: $@";
3725 } 4168 }
3726 4169
3727 warn "... clearing $pkg"; 4170 trace "... clearing $pkg";
3728 clear_package $pkg; 4171 clear_package $pkg;
3729 } 4172 }
3730 4173
3731 warn "unloading all perl modules loaded from $LIBDIR"; 4174 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3732 while (my ($k, $v) = each %INC) { 4175 while (my ($k, $v) = each %INC) {
3733 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4176 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3734 4177
3735 warn "... unloading $k"; 4178 trace "... unloading $k";
3736 delete $INC{$k}; 4179 delete $INC{$k};
3737 4180
3738 $k =~ s/\.pm$//; 4181 $k =~ s/\.pm$//;
3739 $k =~ s/\//::/g; 4182 $k =~ s/\//::/g;
3740 4183
… …
3743 } 4186 }
3744 4187
3745 clear_package $k; 4188 clear_package $k;
3746 } 4189 }
3747 4190
3748 warn "getting rid of safe::, as good as possible"; 4191 trace "perl_reload: getting rid of safe::, as good as possible";
3749 clear_package "safe::$_" 4192 clear_package "safe::$_"
3750 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4193 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3751 4194
3752 warn "unloading cf.pm \"a bit\""; 4195 trace "perl_reload: unloading cf.pm \"a bit\"";
3753 delete $INC{"cf.pm"}; 4196 delete $INC{"cf.pm"};
3754 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4197 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3755 4198
3756 # don't, removes xs symbols, too, 4199 # don't, removes xs symbols, too,
3757 # and global variables created in xs 4200 # and global variables created in xs
3758 #clear_package __PACKAGE__; 4201 #clear_package __PACKAGE__;
3759 4202
3760 warn "unload completed, starting to reload now"; 4203 info "perl_reload: unload completed, starting to reload now";
3761 4204
3762 warn "reloading cf.pm"; 4205 trace "perl_reload: reloading cf.pm";
3763 require cf; 4206 require cf;
3764 cf::_connect_to_perl_1; 4207 cf::_connect_to_perl_1;
3765 4208
3766 warn "loading config and database again"; 4209 trace "perl_reload: loading config and database again";
3767 cf::reload_config; 4210 cf::reload_config;
3768 4211
3769 warn "loading extensions"; 4212 trace "perl_reload: loading extensions";
3770 cf::load_extensions; 4213 cf::load_extensions;
3771 4214
3772 if ($REATTACH_ON_RELOAD) { 4215 if ($REATTACH_ON_RELOAD) {
3773 warn "reattaching attachments to objects/players"; 4216 trace "perl_reload: reattaching attachments to objects/players";
3774 _global_reattach; # objects, sockets 4217 _global_reattach; # objects, sockets
3775 warn "reattaching attachments to maps"; 4218 trace "perl_reload: reattaching attachments to maps";
3776 reattach $_ for values %MAP; 4219 reattach $_ for values %MAP;
3777 warn "reattaching attachments to players"; 4220 trace "perl_reload: reattaching attachments to players";
3778 reattach $_ for values %PLAYER; 4221 reattach $_ for values %PLAYER;
3779 } 4222 }
3780 4223
3781 warn "running post_init jobs"; 4224 cf::_post_init 1;
3782 (pop @POST_INIT)->(1) while @POST_INIT;
3783 4225
3784 warn "leaving sync_job"; 4226 trace "perl_reload: leaving sync_job";
3785 4227
3786 1 4228 1
3787 } or do { 4229 } or do {
3788 warn $@; 4230 error $@;
3789 cf::cleanup "error while reloading, exiting."; 4231 cf::cleanup "perl_reload: error, exiting.";
3790 }; 4232 };
3791 4233
3792 warn "reloaded";
3793 --$RELOAD; 4234 --$RELOAD;
3794 } 4235 }
3795 4236
3796 $t1 = EV::time - $t1; 4237 $t1 = AE::time - $t1;
3797 warn "reload completed in ${t1}s\n"; 4238 info "perl_reload: completed in ${t1}s\n";
3798}; 4239};
3799 4240
3800our $RELOAD_WATCHER; # used only during reload 4241our $RELOAD_WATCHER; # used only during reload
3801 4242
3802sub reload_perl() { 4243sub reload_perl() {
… …
3804 # coro crashes during coro_state_free->destroy here. 4245 # coro crashes during coro_state_free->destroy here.
3805 4246
3806 $RELOAD_WATCHER ||= cf::async { 4247 $RELOAD_WATCHER ||= cf::async {
3807 Coro::AIO::aio_wait cache_extensions; 4248 Coro::AIO::aio_wait cache_extensions;
3808 4249
3809 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 4250 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3810 do_reload_perl; 4251 do_reload_perl;
3811 undef $RELOAD_WATCHER; 4252 undef $RELOAD_WATCHER;
3812 }; 4253 };
3813 }; 4254 };
3814} 4255}
… …
3823 reload_perl; 4264 reload_perl;
3824 }; 4265 };
3825 } 4266 }
3826}; 4267};
3827 4268
3828unshift @INC, $LIBDIR; 4269#############################################################################
3829 4270
3830my $bug_warning = 0; 4271my $bug_warning = 0;
3831 4272
3832our @WAIT_FOR_TICK;
3833our @WAIT_FOR_TICK_BEGIN;
3834
3835sub wait_for_tick { 4273sub wait_for_tick() {
3836 return if tick_inhibit || $Coro::current == $Coro::main; 4274 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3837 4275
3838 my $signal = new Coro::Signal; 4276 $WAIT_FOR_TICK->wait;
3839 push @WAIT_FOR_TICK, $signal;
3840 $signal->wait;
3841} 4277}
3842 4278
3843sub wait_for_tick_begin { 4279sub wait_for_tick_begin() {
3844 return if tick_inhibit || $Coro::current == $Coro::main; 4280 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3845 4281
3846 my $signal = new Coro::Signal; 4282 my $signal = new Coro::Signal;
3847 push @WAIT_FOR_TICK_BEGIN, $signal; 4283 push @WAIT_FOR_TICK_BEGIN, $signal;
3848 $signal->wait; 4284 $signal->wait;
3849} 4285}
… …
3853 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4289 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3854 unless ++$bug_warning > 10; 4290 unless ++$bug_warning > 10;
3855 return; 4291 return;
3856 } 4292 }
3857 4293
3858 cf::server_tick; # one server iteration 4294 cf::one_tick; # one server iteration
4295
4296 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3859 4297
3860 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4298 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3861 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4299 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3862 Coro::async_pool { 4300 Coro::async_pool {
3863 $Coro::current->{desc} = "runtime saver"; 4301 $Coro::current->{desc} = "runtime saver";
3864 write_runtime_sync 4302 write_runtime_sync
3865 or warn "ERROR: unable to write runtime file: $!"; 4303 or error "ERROR: unable to write runtime file: $!";
3866 }; 4304 };
3867 } 4305 }
3868 4306
3869 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4307 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3870 $sig->send; 4308 $sig->send;
3871 } 4309 }
3872 while (my $sig = shift @WAIT_FOR_TICK) { 4310 $WAIT_FOR_TICK->broadcast;
3873 $sig->send;
3874 }
3875 4311
3876 $LOAD = ($NOW - $TICK_START) / $TICK; 4312 $LOAD = ($NOW - $TICK_START) / $TICK;
3877 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4313 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3878 4314
3879 if (0) { 4315 if (0) {
3880 if ($NEXT_TICK) { 4316 if ($NEXT_TICK) {
3881 my $jitter = $TICK_START - $NEXT_TICK; 4317 my $jitter = $TICK_START - $NEXT_TICK;
3882 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4318 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3883 warn "jitter $JITTER\n";#d# 4319 debug "jitter $JITTER\n";#d#
3884 } 4320 }
3885 } 4321 }
3886} 4322}
3887 4323
3888{ 4324{
3889 # configure BDB 4325 # configure BDB
4326 info "initialising database";
3890 4327
3891 BDB::min_parallel 8; 4328 BDB::min_parallel 16;
3892 BDB::max_poll_reqs $TICK * 0.1; 4329 BDB::max_poll_reqs $TICK * 0.1;
3893 $AnyEvent::BDB::WATCHER->priority (1); 4330 #$AnyEvent::BDB::WATCHER->priority (1);
3894 4331
3895 unless ($DB_ENV) { 4332 unless ($DB_ENV) {
3896 $DB_ENV = BDB::db_env_create; 4333 $DB_ENV = BDB::db_env_create;
3897 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4334 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3898 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4335 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
3923 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4360 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3924 }; 4361 };
3925 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4362 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3926 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4363 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3927 }; 4364 };
4365
4366 info "database initialised";
3928} 4367}
3929 4368
3930{ 4369{
3931 # configure IO::AIO 4370 # configure IO::AIO
3932 4371
4372 info "initialising aio";
3933 IO::AIO::min_parallel 8; 4373 IO::AIO::min_parallel 8;
3934 IO::AIO::max_poll_time $TICK * 0.1; 4374 IO::AIO::max_poll_time $TICK * 0.1;
3935 undef $AnyEvent::AIO::WATCHER; 4375 undef $AnyEvent::AIO::WATCHER;
4376 info "aio initialised";
3936} 4377}
3937 4378
3938my $_log_backtrace; 4379our $_log_backtrace;
4380our $_log_backtrace_last;
3939 4381
3940sub _log_backtrace { 4382sub _log_backtrace {
3941 my ($msg, @addr) = @_; 4383 my ($msg, @addr) = @_;
3942 4384
3943 $msg =~ s/\n//; 4385 $msg =~ s/\n$//;
3944 4386
4387 if ($_log_backtrace_last eq $msg) {
4388 LOG llevInfo, "[ABT] $msg\n";
4389 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3945 # limit the # of concurrent backtraces 4390 # limit the # of concurrent backtraces
3946 if ($_log_backtrace < 2) { 4391 } elsif ($_log_backtrace < 2) {
4392 $_log_backtrace_last = $msg;
3947 ++$_log_backtrace; 4393 ++$_log_backtrace;
3948 my $perl_bt = Carp::longmess $msg; 4394 my $perl_bt = Carp::longmess $msg;
3949 async { 4395 async {
3950 $Coro::current->{desc} = "abt $msg"; 4396 $Coro::current->{desc} = "abt $msg";
3951 4397
… …
3971 LOG llevInfo, "[ABT] $_\n" for @bt; 4417 LOG llevInfo, "[ABT] $_\n" for @bt;
3972 --$_log_backtrace; 4418 --$_log_backtrace;
3973 }; 4419 };
3974 } else { 4420 } else {
3975 LOG llevInfo, "[ABT] $msg\n"; 4421 LOG llevInfo, "[ABT] $msg\n";
3976 LOG llevInfo, "[ABT] [suppressed]\n"; 4422 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3977 } 4423 }
3978} 4424}
3979 4425
3980# load additional modules 4426# load additional modules
3981require "cf/$_.pm" for @EXTRA_MODULES; 4427require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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