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.468 by root, Thu Jan 8 19:23:44 2009 UTC vs.
Revision 1.583 by root, Mon Oct 29 23:12:37 2012 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 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 ();
35use Carp ();
36 36
37use Guard (); 37use Guard ();
38use Coro (); 38use Coro ();
39use Coro::State; 39use Coro::State;
40use Coro::Handle; 40use Coro::Handle;
… …
51use Coro::Util (); 51use Coro::Util ();
52 52
53use JSON::XS 2.01 (); 53use JSON::XS 2.01 ();
54use BDB (); 54use BDB ();
55use Data::Dumper; 55use Data::Dumper;
56use Digest::MD5;
57use Fcntl; 56use Fcntl;
58use YAML (); 57use YAML::XS ();
59use IO::AIO (); 58use IO::AIO ();
60use Time::HiRes; 59use Time::HiRes;
61use Compress::LZF; 60use Compress::LZF;
62use Digest::MD5 (); 61use Digest::MD5 ();
63 62
… …
72 71
73# make sure c-lzf reinitialises itself 72# make sure c-lzf reinitialises itself
74Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve"; 73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
75Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
76 75
76# strictly for debugging
77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
78
77sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
78 82
79our %COMMAND = (); 83our %COMMAND = ();
80our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
81 85
82our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
… …
85our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
86our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
87 91
88our $RELOAD; # number of reloads so far, non-zero while in reload 92our $RELOAD; # number of reloads so far, non-zero while in reload
89our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
90 96
91our $CONFDIR = confdir; 97our $CONFDIR = confdir;
98
92our $DATADIR = datadir; 99our $DATADIR = datadir;
93our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
94our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
95our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
103
96our $LOCALDIR = localdir; 104our $LOCALDIR = localdir;
97our $TMPDIR = "$LOCALDIR/" . tmpdir; 105our $TMPDIR = "$LOCALDIR/" . tmpdir;
98our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 106our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
99our $PLAYERDIR = "$LOCALDIR/" . playerdir; 107our $PLAYERDIR = "$LOCALDIR/" . playerdir;
100our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
101our $BDBDIR = "$LOCALDIR/db"; 109our $BDBDIR = "$LOCALDIR/db";
102our $PIDFILE = "$LOCALDIR/pid"; 110our $PIDFILE = "$LOCALDIR/pid";
103our $RUNTIMEFILE = "$LOCALDIR/runtime"; 111our $RUNTIMEFILE = "$LOCALDIR/runtime";
104 112
105our %RESOURCE; 113#our %RESOURCE; # unused
114
115our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000;
117
118our $MAX_LINKS = 32; # how many chained exits to follow
119our $VERBOSE_IO = 1;
106 120
107our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 121our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
108our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 122our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
109our $NEXT_TICK; 123our $NEXT_TICK;
110our $USE_FSYNC = 1; # use fsync to write maps - default off 124our $USE_FSYNC = 1; # use fsync to write maps - default on
111 125
112our $BDB_DEADLOCK_WATCHER; 126our $BDB_DEADLOCK_WATCHER;
113our $BDB_CHECKPOINT_WATCHER; 127our $BDB_CHECKPOINT_WATCHER;
114our $BDB_TRICKLE_WATCHER; 128our $BDB_TRICKLE_WATCHER;
115our $DB_ENV; 129our $DB_ENV;
116 130
117our @EXTRA_MODULES = qw(pod mapscript); 131our @EXTRA_MODULES = qw(pod match mapscript incloader);
118 132
119our %CFG; 133our %CFG;
134our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
120 135
121our $UPTIME; $UPTIME ||= time; 136our $UPTIME; $UPTIME ||= time;
122our $RUNTIME; 137our $RUNTIME = 0;
138our $SERVER_TICK = 0;
123our $NOW; 139our $NOW;
124 140
125our (%PLAYER, %PLAYER_LOADING); # all users 141our (%PLAYER, %PLAYER_LOADING); # all users
126our (%MAP, %MAP_LOADING ); # all maps 142our (%MAP, %MAP_LOADING ); # all maps
127our $LINK_MAP; # the special {link} map, which is always available 143our $LINK_MAP; # the special {link} map, which is always available
… …
134our $JITTER; # average jitter 150our $JITTER; # average jitter
135our $TICK_START; # for load detecting purposes 151our $TICK_START; # for load detecting purposes
136 152
137our @POST_INIT; 153our @POST_INIT;
138 154
139our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow) 155our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
156our $REALLY_UNLOOP; # never set to true, please :)
157
158our $WAIT_FOR_TICK = new Coro::Signal;
159our @WAIT_FOR_TICK_BEGIN;
140 160
141binmode STDOUT; 161binmode STDOUT;
142binmode STDERR; 162binmode STDERR;
143 163
144# read virtual server time, if available 164# read virtual server time, if available
… …
155 175
156our $EMERGENCY_POSITION; 176our $EMERGENCY_POSITION;
157 177
158sub cf::map::normalise; 178sub cf::map::normalise;
159 179
180sub in_main() {
181 $Coro::current == $Coro::main
182}
183
160############################################################################# 184#############################################################################
161 185
186%REFLECT = ();
187for (@REFLECT) {
188 my $reflect = JSON::XS::decode_json $_;
189 $REFLECT{$reflect->{class}} = $reflect;
190}
191
192# this is decidedly evil
193$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
194
195#############################################################################
196
162=head2 GLOBAL VARIABLES 197=head2 GLOBAL VARIABLES
163 198
164=over 4 199=over 4
165 200
166=item $cf::UPTIME 201=item $cf::UPTIME
167 202
168The timestamp of the server start (so not actually an uptime). 203The timestamp of the server start (so not actually an "uptime").
204
205=item $cf::SERVER_TICK
206
207An unsigned integer that starts at zero when the server is started and is
208incremented on every tick.
209
210=item $cf::NOW
211
212The (real) time of the last (current) server tick - updated before and
213after tick processing, so this is useful only as a rough "what time is it
214now" estimate.
215
216=item $cf::TICK
217
218The interval between each server tick, in seconds.
169 219
170=item $cf::RUNTIME 220=item $cf::RUNTIME
171 221
172The time this server has run, starts at 0 and is increased by $cf::TICK on 222The time this server has run, starts at 0 and is increased by $cf::TICK on
173every server tick. 223every server tick.
… …
179Various directories - "/etc", read-only install directory, perl-library 229Various directories - "/etc", read-only install directory, perl-library
180directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 230directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
181unique-items directory, player file directory, random maps directory and 231unique-items directory, player file directory, random maps directory and
182database environment. 232database environment.
183 233
184=item $cf::NOW
185
186The time of the last (current) server tick.
187
188=item $cf::TICK
189
190The interval between server ticks, in seconds.
191
192=item $cf::LOADAVG 234=item $cf::LOADAVG
193 235
194The current CPU load on the server (alpha-smoothed), as a value between 0 236The current CPU load on the server (alpha-smoothed), as a value between 0
195(none) and 1 (overloaded), indicating how much time is spent on processing 237(none) and 1 (overloaded), indicating how much time is spent on processing
196objects per tick. Healthy values are < 0.5. 238objects per tick. Healthy values are < 0.5.
… …
205from wherever your confdir points to. 247from wherever your confdir points to.
206 248
207=item cf::wait_for_tick, cf::wait_for_tick_begin 249=item cf::wait_for_tick, cf::wait_for_tick_begin
208 250
209These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 251These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
210returns directly I<after> the tick processing (and consequently, can only wake one process 252returns directly I<after> the tick processing (and consequently, can only wake one thread
211per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 253per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
212 254
255Note that cf::Wait_for_tick will immediately return when the server is not
256ticking, making it suitable for small pauses in threads that need to run
257when the server is paused. If that is not applicable (i.e. you I<really>
258want to wait, use C<$cf::WAIT_FOR_TICK>).
259
260=item $cf::WAIT_FOR_TICK
261
262Note that C<cf::wait_for_tick> is probably the correct thing to use. This
263variable contains a L<Coro::Signal> that is broadcats after every server
264tick. Calling C<< ->wait >> on it will suspend the caller until after the
265next server tick.
266
267=cut
268
269sub wait_for_tick();
270sub wait_for_tick_begin();
271
213=item @cf::INVOKE_RESULTS 272=item @cf::INVOKE_RESULTS
214 273
215This array contains the results of the last C<invoke ()> call. When 274This array contains the results of the last C<invoke ()> call. When
216C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 275C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
217that call. 276that call.
218 277
278=item %cf::REFLECT
279
280Contains, for each (C++) class name, a hash reference with information
281about object members (methods, scalars, arrays and flags) and other
282metadata, which is useful for introspection.
283
219=back 284=back
220 285
221=cut 286=cut
222 287
223BEGIN { 288sub error(@) { LOG llevError, join "", @_ }
224 *CORE::GLOBAL::warn = sub { 289sub warn (@) { LOG llevWarn , join "", @_ }
290sub info (@) { LOG llevInfo , join "", @_ }
291sub debug(@) { LOG llevDebug, join "", @_ }
292sub trace(@) { LOG llevTrace, join "", @_ }
293
294$Coro::State::WARNHOOK = sub {
225 my $msg = join "", @_; 295 my $msg = join "", @_;
226 296
227 $msg .= "\n" 297 $msg .= "\n"
228 unless $msg =~ /\n$/; 298 unless $msg =~ /\n$/;
229 299
230 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 300 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
231 301
232 LOG llevError, $msg; 302 LOG llevWarn, $msg;
233 }; 303};
234}
235 304
236$Coro::State::DIEHOOK = sub { 305$Coro::State::DIEHOOK = sub {
237 return unless $^S eq 0; # "eq", not "==" 306 return unless $^S eq 0; # "eq", not "=="
238 307
239 if ($Coro::current == $Coro::main) {#d# 308 error Carp::longmess $_[0];
309
310 if (in_main) {#d#
240 warn "DIEHOOK called in main context, Coro bug?\n";#d# 311 error "DIEHOOK called in main context, Coro bug?\n";#d#
241 return;#d# 312 return;#d#
242 }#d# 313 }#d#
243 314
244 # kill coroutine otherwise 315 # kill coroutine otherwise
245 warn Carp::longmess $_[0];
246 Coro::terminate 316 Coro::terminate
247}; 317};
248
249$SIG{__DIE__} = sub { }; #d#?
250 318
251@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 319@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
252@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 320@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
253@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 321@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
254@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 322@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
268)) { 336)) {
269 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 337 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
270} 338}
271 339
272$EV::DIED = sub { 340$EV::DIED = sub {
273 warn "error in event callback: @_"; 341 Carp::cluck "error in event callback: @_";
274}; 342};
343
344#############################################################################
345
346sub fork_call(&@);
347sub get_slot($;$$);
275 348
276############################################################################# 349#############################################################################
277 350
278=head2 UTILITY FUNCTIONS 351=head2 UTILITY FUNCTIONS
279 352
… …
300 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 373 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
301 $d 374 $d
302 } || "[unable to dump $_[0]: '$@']"; 375 } || "[unable to dump $_[0]: '$@']";
303} 376}
304 377
378=item $scalar = cf::load_file $path
379
380Loads the given file from path and returns its contents. Croaks on error
381and can block.
382
383=cut
384
385sub load_file($) {
386 0 <= aio_load $_[0], my $data
387 or Carp::croak "$_[0]: $!";
388
389 $data
390}
391
392=item $success = cf::replace_file $path, $data, $sync
393
394Atomically replaces the file at the given $path with new $data, and
395optionally $sync the data to disk before replacing the file.
396
397=cut
398
399sub replace_file($$;$) {
400 my ($path, $data, $sync) = @_;
401
402 my $lock = cf::lock_acquire ("replace_file:$path");
403
404 my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
405 or return;
406
407 $data = $data->() if ref $data;
408
409 length $data == aio_write $fh, 0, (length $data), $data, 0
410 or return;
411
412 !$sync
413 or !aio_fsync $fh
414 or return;
415
416 aio_close $fh
417 and return;
418
419 aio_rename "$path~", $path
420 and return;
421
422 if ($sync) {
423 $path =~ s%/[^/]*$%%;
424 aio_pathsync $path;
425 }
426
427 1
428}
429
305=item $ref = cf::decode_json $json 430=item $ref = cf::decode_json $json
306 431
307Converts a JSON string into the corresponding perl data structure. 432Converts a JSON string into the corresponding perl data structure.
308 433
309=item $json = cf::encode_json $ref 434=item $json = cf::encode_json $ref
… …
315our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 440our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
316 441
317sub encode_json($) { $json_coder->encode ($_[0]) } 442sub encode_json($) { $json_coder->encode ($_[0]) }
318sub decode_json($) { $json_coder->decode ($_[0]) } 443sub decode_json($) { $json_coder->decode ($_[0]) }
319 444
445=item $ref = cf::decode_storable $scalar
446
447Same as Coro::Storable::thaw, so blocks.
448
449=cut
450
451BEGIN { *decode_storable = \&Coro::Storable::thaw }
452
453=item $ref = cf::decode_yaml $scalar
454
455Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
456
457=cut
458
459sub decode_yaml($) {
460 fork_call { YAML::XS::Load $_[0] } @_
461}
462
463=item $scalar = cf::unlzf $scalar
464
465Same as Compress::LZF::compress, but takes server ticks into account, so
466blocks.
467
468=cut
469
470sub unlzf($) {
471 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
472 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
473 Compress::LZF::decompress $_[0]
474}
475
320=item cf::post_init { BLOCK } 476=item cf::post_init { BLOCK }
321 477
322Execute the given codeblock, I<after> all extensions have been (re-)loaded, 478Execute the given codeblock, I<after> all extensions have been (re-)loaded,
323but I<before> the server starts ticking again. 479but I<before> the server starts ticking again.
324 480
325The cdoeblock will have a single boolean argument to indicate whether this 481The codeblock will have a single boolean argument to indicate whether this
326is a reload or not. 482is a reload or not.
327 483
328=cut 484=cut
329 485
330sub post_init(&) { 486sub post_init(&) {
331 push @POST_INIT, shift; 487 push @POST_INIT, shift;
488}
489
490sub _post_init {
491 trace "running post_init jobs";
492
493 # run them in parallel...
494
495 my @join;
496
497 while () {
498 push @join, map &Coro::async ($_, 0), @POST_INIT;
499 @POST_INIT = ();
500
501 @join or last;
502
503 (pop @join)->join;
504 }
332} 505}
333 506
334=item cf::lock_wait $string 507=item cf::lock_wait $string
335 508
336Wait until the given lock is available. See cf::lock_acquire. 509Wait until the given lock is available. See cf::lock_acquire.
… …
375} 548}
376 549
377=item cf::periodic $interval, $cb 550=item cf::periodic $interval, $cb
378 551
379Like EV::periodic, but randomly selects a starting point so that the actions 552Like EV::periodic, but randomly selects a starting point so that the actions
380get spread over timer. 553get spread over time.
381 554
382=cut 555=cut
383 556
384sub periodic($$) { 557sub periodic($$) {
385 my ($interval, $cb) = @_; 558 my ($interval, $cb) = @_;
… …
389 EV::periodic $start, $interval, 0, $cb 562 EV::periodic $start, $interval, 0, $cb
390} 563}
391 564
392=item cf::get_slot $time[, $priority[, $name]] 565=item cf::get_slot $time[, $priority[, $name]]
393 566
394Allocate $time seconds of blocking CPU time at priority C<$priority>: 567Allocate $time seconds of blocking CPU time at priority C<$priority>
395This call blocks and returns only when you have at least C<$time> seconds 568(default: 0): This call blocks and returns only when you have at least
396of cpu time till the next tick. The slot is only valid till the next cede. 569C<$time> seconds of cpu time till the next tick. The slot is only valid
570till the next cede.
571
572Background jobs should use a priority les than zero, interactive jobs
573should use 100 or more.
397 574
398The optional C<$name> can be used to identify the job to run. It might be 575The optional C<$name> can be used to identify the job to run. It might be
399used for statistical purposes and should identify the same time-class. 576used for statistical purposes and should identify the same time-class.
400 577
401Useful for short background jobs. 578Useful for short background jobs.
402 579
403=cut 580=cut
404 581
405our @SLOT_QUEUE; 582our @SLOT_QUEUE;
406our $SLOT_QUEUE; 583our $SLOT_QUEUE;
584our $SLOT_DECAY = 0.9;
407 585
408$SLOT_QUEUE->cancel if $SLOT_QUEUE; 586$SLOT_QUEUE->cancel if $SLOT_QUEUE;
409$SLOT_QUEUE = Coro::async { 587$SLOT_QUEUE = Coro::async {
410 $Coro::current->desc ("timeslot manager"); 588 $Coro::current->desc ("timeslot manager");
411 589
412 my $signal = new Coro::Signal; 590 my $signal = new Coro::Signal;
591 my $busy;
413 592
414 while () { 593 while () {
415 next_job: 594 next_job:
595
416 my $avail = cf::till_tick; 596 my $avail = cf::till_tick;
417 if ($avail > 0.01) { 597
418 for (0 .. $#SLOT_QUEUE) { 598 for (0 .. $#SLOT_QUEUE) {
419 if ($SLOT_QUEUE[$_][0] < $avail) { 599 if ($SLOT_QUEUE[$_][0] <= $avail) {
600 $busy = 0;
420 my $job = splice @SLOT_QUEUE, $_, 1, (); 601 my $job = splice @SLOT_QUEUE, $_, 1, ();
421 $job->[2]->send; 602 $job->[2]->send;
422 Coro::cede; 603 Coro::cede;
423 goto next_job; 604 goto next_job;
424 } 605 } else {
606 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
425 } 607 }
426 } 608 }
427 609
428 if (@SLOT_QUEUE) { 610 if (@SLOT_QUEUE) {
429 # we do not use wait_for_tick() as it returns immediately when tick is inactive 611 # we do not use wait_for_tick() as it returns immediately when tick is inactive
430 push @cf::WAIT_FOR_TICK, $signal; 612 $WAIT_FOR_TICK->wait;
431 $signal->wait;
432 } else { 613 } else {
614 $busy = 0;
433 Coro::schedule; 615 Coro::schedule;
434 } 616 }
435 } 617 }
436}; 618};
437 619
438sub get_slot($;$$) { 620sub get_slot($;$$) {
439 return if tick_inhibit || $Coro::current == $Coro::main; 621 return if tick_inhibit || $Coro::current == $Coro::main;
440 622
441 my ($time, $pri, $name) = @_; 623 my ($time, $pri, $name) = @_;
442 624
443 $time = $TICK * .6 if $time > $TICK * .6; 625 $time = clamp $time, 0.01, $TICK * .6;
626
444 my $sig = new Coro::Signal; 627 my $sig = new Coro::Signal;
445 628
446 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 629 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
447 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 630 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
448 $SLOT_QUEUE->ready; 631 $SLOT_QUEUE->ready;
… …
474=cut 657=cut
475 658
476sub sync_job(&) { 659sub sync_job(&) {
477 my ($job) = @_; 660 my ($job) = @_;
478 661
479 if ($Coro::current == $Coro::main) { 662 if (in_main) {
480 my $time = EV::time; 663 my $time = AE::time;
481 664
482 # this is the main coro, too bad, we have to block 665 # this is the main coro, too bad, we have to block
483 # till the operation succeeds, freezing the server :/ 666 # till the operation succeeds, freezing the server :/
484 667
485 LOG llevError, Carp::longmess "sync job";#d# 668 #LOG llevError, Carp::longmess "sync job";#d#
486 669
487 my $freeze_guard = freeze_mainloop; 670 my $freeze_guard = freeze_mainloop;
488 671
489 my $busy = 1; 672 my $busy = 1;
490 my @res; 673 my @res;
491 674
492 (async { 675 (async {
493 $Coro::current->desc ("sync job coro"); 676 $Coro::current->desc ("sync job coro");
494 @res = eval { $job->() }; 677 @res = eval { $job->() };
495 warn $@ if $@; 678 error $@ if $@;
496 undef $busy; 679 undef $busy;
497 })->prio (Coro::PRIO_MAX); 680 })->prio (Coro::PRIO_MAX);
498 681
499 while ($busy) { 682 while ($busy) {
500 if (Coro::nready) { 683 if (Coro::nready) {
… …
502 } else { 685 } else {
503 EV::loop EV::LOOP_ONESHOT; 686 EV::loop EV::LOOP_ONESHOT;
504 } 687 }
505 } 688 }
506 689
507 my $time = EV::time - $time; 690 my $time = AE::time - $time;
508 691
509 $TICK_START += $time; # do not account sync jobs to server load 692 $TICK_START += $time; # do not account sync jobs to server load
510 693
511 wantarray ? @res : $res[0] 694 wantarray ? @res : $res[0]
512 } else { 695 } else {
… …
534 $EXT_CORO{$coro+0} = $coro; 717 $EXT_CORO{$coro+0} = $coro;
535 718
536 $coro 719 $coro
537} 720}
538 721
539=item fork_call { }, $args 722=item fork_call { }, @args
540 723
541Executes the given code block with the given arguments in a seperate 724Executes the given code block with the given arguments in a seperate
542process, returning the results. Everything must be serialisable with 725process, returning the results. Everything must be serialisable with
543Coro::Storable. May, of course, block. Note that the executed sub may 726Coro::Storable. May, of course, block. Note that the executed sub may
544never block itself or use any form of event handling. 727never block itself or use any form of event handling.
545 728
546=cut 729=cut
547 730
731sub post_fork {
732 reset_signals;
733}
734
548sub fork_call(&@) { 735sub fork_call(&@) {
549 my ($cb, @args) = @_; 736 my ($cb, @args) = @_;
550 737
551 # we seemingly have to make a local copy of the whole thing, 738 # we seemingly have to make a local copy of the whole thing,
552 # otherwise perl prematurely frees the stuff :/ 739 # otherwise perl prematurely frees the stuff :/
553 # TODO: investigate and fix (likely this will be rather laborious) 740 # TODO: investigate and fix (likely this will be rather laborious)
554 741
555 my @res = Coro::Util::fork_eval { 742 my @res = Coro::Util::fork_eval {
556 reset_signals; 743 cf::post_fork;
557 &$cb 744 &$cb
558 }, @args; 745 } @args;
559 746
560 wantarray ? @res : $res[-1] 747 wantarray ? @res : $res[-1]
748}
749
750sub objinfo {
751 (
752 "counter value" => cf::object::object_count,
753 "objects created" => cf::object::create_count,
754 "objects destroyed" => cf::object::destroy_count,
755 "freelist size" => cf::object::free_count,
756 "allocated objects" => cf::object::objects_size,
757 "active objects" => cf::object::actives_size,
758 )
561} 759}
562 760
563=item $coin = coin_from_name $name 761=item $coin = coin_from_name $name
564 762
565=cut 763=cut
… …
602within each server. 800within each server.
603 801
604=cut 802=cut
605 803
606sub db_table($) { 804sub db_table($) {
805 cf::error "db_get called from main context"
806 if $Coro::current == $Coro::main;
807
607 my ($name) = @_; 808 my ($name) = @_;
608 my $db = BDB::db_create $DB_ENV; 809 my $db = BDB::db_create $DB_ENV;
609 810
610 eval { 811 eval {
611 $db->set_flags (BDB::CHKSUM); 812 $db->set_flags (BDB::CHKSUM);
… …
621} 822}
622 823
623our $DB; 824our $DB;
624 825
625sub db_init { 826sub db_init {
626 cf::sync_job {
627 $DB ||= db_table "db"; 827 $DB ||= db_table "db";
628 };
629} 828}
630 829
631sub db_get($$) { 830sub db_get($$) {
632 my $key = "$_[0]/$_[1]"; 831 my $key = "$_[0]/$_[1]";
633 832
634 cf::sync_job { 833 cf::error "db_get called from main context"
834 if $Coro::current == $Coro::main;
835
635 BDB::db_get $DB, undef, $key, my $data; 836 BDB::db_get $DB, undef, $key, my $data;
636 837
637 $! ? () 838 $! ? ()
638 : $data 839 : $data
639 }
640} 840}
641 841
642sub db_put($$$) { 842sub db_put($$$) {
643 BDB::dbreq_pri 4; 843 BDB::dbreq_pri 4;
644 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 844 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
672 872
673 my @data; 873 my @data;
674 my $md5; 874 my $md5;
675 875
676 for (0 .. $#$src) { 876 for (0 .. $#$src) {
677 0 <= aio_load $src->[$_], $data[$_] 877 $data[$_] = load_file $src->[$_];
678 or Carp::croak "$src->[$_]: $!";
679 } 878 }
680 879
681 # if processing is expensive, check 880 # if processing is expensive, check
682 # checksum first 881 # checksum first
683 if (1) { 882 if (1) {
… …
700 899
701 my $t1 = Time::HiRes::time; 900 my $t1 = Time::HiRes::time;
702 my $data = $process->(\@data); 901 my $data = $process->(\@data);
703 my $t2 = Time::HiRes::time; 902 my $t2 = Time::HiRes::time;
704 903
705 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 904 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
706 905
707 db_put cache => "$id/data", $data; 906 db_put cache => "$id/data", $data;
708 db_put cache => "$id/md5" , $md5; 907 db_put cache => "$id/md5" , $md5;
709 db_put cache => "$id/meta", $meta; 908 db_put cache => "$id/meta", $meta;
710 909
… …
720 919
721=cut 920=cut
722 921
723sub datalog($@) { 922sub datalog($@) {
724 my ($type, %kv) = @_; 923 my ($type, %kv) = @_;
725 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 924 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
726} 925}
727 926
728=back 927=back
729 928
730=cut 929=cut
… …
925 1124
926 } elsif (exists $cb_id{$type}) { 1125 } elsif (exists $cb_id{$type}) {
927 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1126 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
928 1127
929 } elsif (ref $type) { 1128 } elsif (ref $type) {
930 warn "attaching objects not supported, ignoring.\n"; 1129 error "attaching objects not supported, ignoring.\n";
931 1130
932 } else { 1131 } else {
933 shift @arg; 1132 shift @arg;
934 warn "attach argument '$type' not supported, ignoring.\n"; 1133 error "attach argument '$type' not supported, ignoring.\n";
935 } 1134 }
936 } 1135 }
937} 1136}
938 1137
939sub _object_attach { 1138sub _object_attach {
… …
949 _attach $registry, $klass, @attach; 1148 _attach $registry, $klass, @attach;
950 } 1149 }
951 1150
952 $obj->{$name} = \%arg; 1151 $obj->{$name} = \%arg;
953 } else { 1152 } else {
954 warn "object uses attachment '$name' which is not available, postponing.\n"; 1153 info "object uses attachment '$name' which is not available, postponing.\n";
955 } 1154 }
956 1155
957 $obj->{_attachment}{$name} = undef; 1156 $obj->{_attachment}{$name} = undef;
958} 1157}
959 1158
… …
1018 1217
1019 for (@$callbacks) { 1218 for (@$callbacks) {
1020 eval { &{$_->[1]} }; 1219 eval { &{$_->[1]} };
1021 1220
1022 if ($@) { 1221 if ($@) {
1023 warn "$@";
1024 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1222 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1025 override; 1223 override;
1026 } 1224 }
1027 1225
1028 return 1 if $override; 1226 return 1 if $override;
1029 } 1227 }
… …
1108 for (@$attach) { 1306 for (@$attach) {
1109 my ($klass, @attach) = @$_; 1307 my ($klass, @attach) = @$_;
1110 _attach $registry, $klass, @attach; 1308 _attach $registry, $klass, @attach;
1111 } 1309 }
1112 } else { 1310 } else {
1113 warn "object uses attachment '$name' that is not available, postponing.\n"; 1311 info "object uses attachment '$name' that is not available, postponing.\n";
1114 } 1312 }
1115 } 1313 }
1116} 1314}
1117 1315
1118cf::attachable->attach ( 1316cf::attachable->attach (
… …
1145 my ($filename, $rdata, $objs) = @_; 1343 my ($filename, $rdata, $objs) = @_;
1146 1344
1147 sync_job { 1345 sync_job {
1148 if (length $$rdata) { 1346 if (length $$rdata) {
1149 utf8::decode (my $decname = $filename); 1347 utf8::decode (my $decname = $filename);
1150 warn sprintf "saving %s (%d,%d)\n", 1348 trace sprintf "saving %s (%d,%d)\n",
1151 $decname, length $$rdata, scalar @$objs; 1349 $decname, length $$rdata, scalar @$objs
1350 if $VERBOSE_IO;
1152 1351
1153 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1352 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1154 aio_chmod $fh, SAVE_MODE; 1353 aio_chmod $fh, SAVE_MODE;
1155 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1354 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1156 aio_fsync $fh if $cf::USE_FSYNC; 1355 if ($cf::USE_FSYNC) {
1356 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1357 aio_fsync $fh;
1358 }
1157 aio_close $fh; 1359 aio_close $fh;
1158 1360
1159 if (@$objs) { 1361 if (@$objs) {
1160 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1362 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1161 aio_chmod $fh, SAVE_MODE; 1363 aio_chmod $fh, SAVE_MODE;
1162 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1364 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1163 aio_write $fh, 0, (length $data), $data, 0; 1365 aio_write $fh, 0, (length $data), $data, 0;
1164 aio_fsync $fh if $cf::USE_FSYNC; 1366 if ($cf::USE_FSYNC) {
1367 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1368 aio_fsync $fh;
1369 }
1165 aio_close $fh; 1370 aio_close $fh;
1166 aio_rename "$filename.pst~", "$filename.pst"; 1371 aio_rename "$filename.pst~", "$filename.pst";
1167 } 1372 }
1168 } else { 1373 } else {
1169 aio_unlink "$filename.pst"; 1374 aio_unlink "$filename.pst";
… …
1172 aio_rename "$filename~", $filename; 1377 aio_rename "$filename~", $filename;
1173 1378
1174 $filename =~ s%/[^/]+$%%; 1379 $filename =~ s%/[^/]+$%%;
1175 aio_pathsync $filename if $cf::USE_FSYNC; 1380 aio_pathsync $filename if $cf::USE_FSYNC;
1176 } else { 1381 } else {
1177 warn "unable to save objects: $filename~: $!\n"; 1382 error "unable to save objects: $filename~: $!\n";
1178 } 1383 }
1179 } else { 1384 } else {
1180 aio_unlink $filename; 1385 aio_unlink $filename;
1181 aio_unlink "$filename.pst"; 1386 aio_unlink "$filename.pst";
1182 } 1387 }
… …
1206 my $st = eval { Coro::Storable::thaw $av }; 1411 my $st = eval { Coro::Storable::thaw $av };
1207 $av = $st->{objs}; 1412 $av = $st->{objs};
1208 } 1413 }
1209 1414
1210 utf8::decode (my $decname = $filename); 1415 utf8::decode (my $decname = $filename);
1211 warn sprintf "loading %s (%d,%d)\n", 1416 trace sprintf "loading %s (%d,%d)\n",
1212 $decname, length $data, scalar @{$av || []}; 1417 $decname, length $data, scalar @{$av || []}
1418 if $VERBOSE_IO;
1213 1419
1214 ($data, $av) 1420 ($data, $av)
1215} 1421}
1216 1422
1217=head2 COMMAND CALLBACKS 1423=head2 COMMAND CALLBACKS
… …
1276} 1482}
1277 1483
1278use File::Glob (); 1484use File::Glob ();
1279 1485
1280cf::player->attach ( 1486cf::player->attach (
1281 on_command => sub { 1487 on_unknown_command => sub {
1282 my ($pl, $name, $params) = @_; 1488 my ($pl, $name, $params) = @_;
1283 1489
1284 my $cb = $COMMAND{$name} 1490 my $cb = $COMMAND{$name}
1285 or return; 1491 or return;
1286 1492
… …
1294 my ($pl, $buf) = @_; 1500 my ($pl, $buf) = @_;
1295 1501
1296 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1502 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1297 1503
1298 if (ref $msg) { 1504 if (ref $msg) {
1299 my ($type, $reply, @payload) = 1505 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1300 "ARRAY" eq ref $msg
1301 ? @$msg
1302 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1303 1506
1304 my @reply; 1507 my @reply;
1305 1508
1306 if (my $cb = $EXTCMD{$type}) { 1509 if (my $cb = $EXTCMD{$type}) {
1307 @reply = $cb->($pl, @payload); 1510 @reply = $cb->($pl, @payload);
… …
1309 1512
1310 $pl->ext_reply ($reply, @reply) 1513 $pl->ext_reply ($reply, @reply)
1311 if $reply; 1514 if $reply;
1312 1515
1313 } else { 1516 } else {
1314 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1517 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1315 } 1518 }
1316 1519
1317 cf::override; 1520 cf::override;
1318 }, 1521 },
1319); 1522);
1320 1523
1321# "readahead" all extensions 1524# "readahead" all extensions
1322sub cache_extensions { 1525sub cache_extensions {
1323 my $grp = IO::AIO::aio_group; 1526 my $grp = IO::AIO::aio_group;
1324 1527
1325 add $grp IO::AIO::aio_readdir $LIBDIR, sub { 1528 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1326 for (grep /\.ext$/, @{$_[0]}) { 1529 for (grep /\.ext$/, @{$_[0]}) {
1327 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; 1530 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1328 } 1531 }
1329 }; 1532 };
1330 1533
1331 $grp 1534 $grp
1332} 1535}
1333 1536
1537sub _ext_cfg_reg($$$$) {
1538 my ($rvar, $varname, $cfgname, $default) = @_;
1539
1540 $cfgname = lc $varname
1541 unless length $cfgname;
1542
1543 $EXT_CFG{$cfgname} = [$rvar, $default];
1544
1545 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1546}
1547
1334sub load_extensions { 1548sub load_extensions {
1549 info "loading extensions...";
1550
1551 %EXT_CFG = ();
1552
1335 cf::sync_job { 1553 cf::sync_job {
1336 my %todo; 1554 my %todo;
1337 1555
1338 for my $path (<$LIBDIR/*.ext>) { 1556 for my $path (<$LIBDIR/*.ext>) {
1339 next unless -r $path; 1557 next unless -r $path;
… …
1357 1575
1358 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1576 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1359 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1577 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1360 1578
1361 $ext{source} = 1579 $ext{source} =
1362 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1580 "package $pkg; use common::sense;\n"
1363 . "#line 1 \"$path\"\n{\n" 1581 . "#line 1 \"$path\"\n{\n"
1364 . $source 1582 . $source
1365 . "\n};\n1"; 1583 . "\n};\n1";
1366 1584
1367 $todo{$base} = \%ext; 1585 $todo{$base} = \%ext;
1368 } 1586 }
1369 1587
1588 my $pass = 0;
1370 my %done; 1589 my %done;
1371 while (%todo) { 1590 while (%todo) {
1372 my $progress; 1591 my $progress;
1373 1592
1593 ++$pass;
1594
1595 ext:
1374 while (my ($k, $v) = each %todo) { 1596 while (my ($k, $v) = each %todo) {
1375 for (split /,\s*/, $v->{meta}{depends}) { 1597 for (split /,\s*/, $v->{meta}{depends}) {
1376 goto skip 1598 next ext
1377 unless exists $done{$_}; 1599 unless exists $done{$_};
1378 } 1600 }
1379 1601
1380 warn "... loading '$k' into '$v->{pkg}'\n"; 1602 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1381 1603
1382 unless (eval $v->{source}) { 1604 my $source = $v->{source};
1605
1606 # support "CONF varname :confname = default" pseudo-statements
1607 $source =~ s{
1608 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1609 }{
1610 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1611 }gmxe;
1612
1613 my $active = eval $source;
1614
1615 if (length $@) {
1383 my $msg = $@ ? "$v->{path}: $@\n" 1616 error "$v->{path}: $@\n";
1384 : "$v->{base}: extension inactive.\n";
1385 1617
1386 if (exists $v->{meta}{mandatory}) {
1387 warn $msg;
1388 cf::cleanup "mandatory extension failed to load, exiting."; 1618 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1389 } 1619 if exists $v->{meta}{mandatory};
1390 1620
1391 warn $msg; 1621 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1622 delete $todo{$k};
1623 } else {
1624 $done{$k} = delete $todo{$k};
1625 push @EXTS, $v->{pkg};
1626 $progress = 1;
1627
1628 info "$v->{base}: extension inactive.\n"
1629 unless $active;
1392 } 1630 }
1393
1394 $done{$k} = delete $todo{$k};
1395 push @EXTS, $v->{pkg};
1396 $progress = 1;
1397 } 1631 }
1398 1632
1399 skip: 1633 unless ($progress) {
1400 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1634 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1401 unless $progress; 1635
1636 while (my ($k, $v) = each %todo) {
1637 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1638 if exists $v->{meta}{mandatory};
1639 }
1640
1641 last;
1642 }
1402 } 1643 }
1403 }; 1644 };
1404} 1645}
1405 1646
1406############################################################################# 1647#############################################################################
… …
1490 $cf::PLAYER{$login} = $pl 1731 $cf::PLAYER{$login} = $pl
1491 } 1732 }
1492 } 1733 }
1493} 1734}
1494 1735
1736cf::player->attach (
1737 on_load => sub {
1738 my ($pl, $path) = @_;
1739
1740 # restore slots saved in save, below
1741 my $slots = delete $pl->{_slots};
1742
1743 $pl->ob->current_weapon ($slots->[0]);
1744 $pl->combat_ob ($slots->[1]);
1745 $pl->ranged_ob ($slots->[2]);
1746 },
1747);
1748
1495sub save($) { 1749sub save($) {
1496 my ($pl) = @_; 1750 my ($pl) = @_;
1497 1751
1498 return if $pl->{deny_save}; 1752 return if $pl->{deny_save};
1499 1753
… …
1504 1758
1505 aio_mkdir playerdir $pl, 0770; 1759 aio_mkdir playerdir $pl, 0770;
1506 $pl->{last_save} = $cf::RUNTIME; 1760 $pl->{last_save} = $cf::RUNTIME;
1507 1761
1508 cf::get_slot 0.01; 1762 cf::get_slot 0.01;
1763
1764 # save slots, to be restored later
1765 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1509 1766
1510 $pl->save_pl ($path); 1767 $pl->save_pl ($path);
1511 cf::cede_to_tick; 1768 cf::cede_to_tick;
1512} 1769}
1513 1770
… …
1547 my $name = $pl->ob->name; 1804 my $name = $pl->ob->name;
1548 1805
1549 $pl->{deny_save} = 1; 1806 $pl->{deny_save} = 1;
1550 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1807 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1551 1808
1552 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1809 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1553 $pl->deactivate; 1810 $pl->deactivate;
1811
1554 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1812 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1555 $pl->ob->check_score;
1556 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1813 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1814 ext::highscore::check ($pl->ob);
1815
1557 $pl->ns->destroy if $pl->ns; 1816 $pl->ns->destroy if $pl->ns;
1558 1817
1559 my $path = playerdir $pl; 1818 my $path = playerdir $pl;
1560 my $temp = "$path~$cf::RUNTIME~deleting~"; 1819 my $temp = "$path~$cf::RUNTIME~deleting~";
1561 aio_rename $path, $temp; 1820 aio_rename $path, $temp;
… …
1615 \@logins 1874 \@logins
1616} 1875}
1617 1876
1618=item $player->maps 1877=item $player->maps
1619 1878
1879=item cf::player::maps $login
1880
1620Returns an arrayref of map paths that are private for this 1881Returns an arrayref of map paths that are private for this
1621player. May block. 1882player. May block.
1622 1883
1623=cut 1884=cut
1624 1885
… …
1686=cut 1947=cut
1687 1948
1688sub find_by_path($) { 1949sub find_by_path($) {
1689 my ($path) = @_; 1950 my ($path) = @_;
1690 1951
1952 $path =~ s/^~[^\/]*//; # skip ~login
1953
1691 my ($match, $specificity); 1954 my ($match, $specificity);
1692 1955
1693 for my $region (list) { 1956 for my $region (list) {
1694 if ($region->{match} && $path =~ $region->{match}) { 1957 if ($region->{match} && $path =~ $region->{match}) {
1695 ($match, $specificity) = ($region, $region->specificity) 1958 ($match, $specificity) = ($region, $region->specificity)
… …
1723sub generate_random_map { 1986sub generate_random_map {
1724 my ($self, $rmp) = @_; 1987 my ($self, $rmp) = @_;
1725 1988
1726 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1989 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1727 1990
1728 # mit "rum" bekleckern, nicht
1729 $self->_create_random_map ( 1991 $self->_create_random_map ($rmp);
1730 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1731 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1732 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1733 $rmp->{exit_on_final_map},
1734 $rmp->{xsize}, $rmp->{ysize},
1735 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1736 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1737 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1738 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1739 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1740 (cf::region::find $rmp->{region}), $rmp->{custom}
1741 )
1742} 1992}
1743 1993
1744=item cf::map->register ($regex, $prio) 1994=item cf::map->register ($regex, $prio)
1745 1995
1746Register a handler for the map path matching the given regex at the 1996Register a handler for the map path matching the given regex at the
… …
1751 2001
1752sub register { 2002sub register {
1753 my (undef, $regex, $prio) = @_; 2003 my (undef, $regex, $prio) = @_;
1754 my $pkg = caller; 2004 my $pkg = caller;
1755 2005
1756 no strict;
1757 push @{"$pkg\::ISA"}, __PACKAGE__; 2006 push @{"$pkg\::ISA"}, __PACKAGE__;
1758 2007
1759 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 2008 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1760} 2009}
1761 2010
1762# also paths starting with '/' 2011# also paths starting with '/'
1763$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 2012$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1764 2013
1765sub thawer_merge { 2014sub thawer_merge {
1766 my ($self, $merge) = @_; 2015 my ($self, $merge) = @_;
1767 2016
1768 # we have to keep some variables in memory intact 2017 # we have to keep some variables in memory intact
… …
1773} 2022}
1774 2023
1775sub normalise { 2024sub normalise {
1776 my ($path, $base) = @_; 2025 my ($path, $base) = @_;
1777 2026
1778 $path = "$path"; # make sure its a string 2027 $path = "$path"; # make sure it's a string
1779 2028
1780 $path =~ s/\.map$//; 2029 $path =~ s/\.map$//;
1781 2030
1782 # map plan: 2031 # map plan:
1783 # 2032 #
… …
1798 $base =~ s{[^/]+/?$}{}; 2047 $base =~ s{[^/]+/?$}{};
1799 $path = "$base/$path"; 2048 $path = "$base/$path";
1800 } 2049 }
1801 2050
1802 for ($path) { 2051 for ($path) {
1803 redo if s{//}{/};
1804 redo if s{/\.?/}{/}; 2052 redo if s{/\.?/}{/};
1805 redo if s{/[^/]+/\.\./}{/}; 2053 redo if s{/[^/]+/\.\./}{/};
1806 } 2054 }
1807 2055
1808 $path 2056 $path
… …
1822 $self->init; # pass $1 etc. 2070 $self->init; # pass $1 etc.
1823 return $self; 2071 return $self;
1824 } 2072 }
1825 } 2073 }
1826 2074
1827 Carp::cluck "unable to resolve path '$path' (base '$base')."; 2075 Carp::cluck "unable to resolve path '$path' (base '$base')";
1828 () 2076 ()
1829} 2077}
1830 2078
2079# may re-bless or do other evil things
1831sub init { 2080sub init {
1832 my ($self) = @_; 2081 my ($self) = @_;
1833 2082
1834 $self 2083 $self
1835} 2084}
… …
1900 $self->{load_path} = $path; 2149 $self->{load_path} = $path;
1901 2150
1902 1 2151 1
1903} 2152}
1904 2153
2154# used to laod the header of an original map
1905sub load_header_orig { 2155sub load_header_orig {
1906 my ($self) = @_; 2156 my ($self) = @_;
1907 2157
1908 $self->load_header_from ($self->load_path) 2158 $self->load_header_from ($self->load_path)
1909} 2159}
1910 2160
2161# used to laod the header of an instantiated map
1911sub load_header_temp { 2162sub load_header_temp {
1912 my ($self) = @_; 2163 my ($self) = @_;
1913 2164
1914 $self->load_header_from ($self->save_path) 2165 $self->load_header_from ($self->save_path)
1915} 2166}
1916 2167
2168# called after loading the header from an instantiated map
1917sub prepare_temp { 2169sub prepare_temp {
1918 my ($self) = @_; 2170 my ($self) = @_;
1919 2171
1920 $self->last_access ((delete $self->{last_access}) 2172 $self->last_access ((delete $self->{last_access})
1921 || $cf::RUNTIME); #d# 2173 || $cf::RUNTIME); #d#
1922 # safety 2174 # safety
1923 $self->{instantiate_time} = $cf::RUNTIME 2175 $self->{instantiate_time} = $cf::RUNTIME
1924 if $self->{instantiate_time} > $cf::RUNTIME; 2176 if $self->{instantiate_time} > $cf::RUNTIME;
1925} 2177}
1926 2178
2179# called after loading the header from an original map
1927sub prepare_orig { 2180sub prepare_orig {
1928 my ($self) = @_; 2181 my ($self) = @_;
1929 2182
1930 $self->{load_original} = 1; 2183 $self->{load_original} = 1;
1931 $self->{instantiate_time} = $cf::RUNTIME; 2184 $self->{instantiate_time} = $cf::RUNTIME;
… …
1955 2208
1956sub find; 2209sub find;
1957sub find { 2210sub find {
1958 my ($path, $origin) = @_; 2211 my ($path, $origin) = @_;
1959 2212
2213 cf::cede_to_tick;
2214
1960 $path = normalise $path, $origin && $origin->path; 2215 $path = normalise $path, $origin;
1961 2216
1962 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2217 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1963 my $guard2 = cf::lock_acquire "map_find:$path"; 2218 my $guard2 = cf::lock_acquire "map_find:$path";
1964 2219
1965 $cf::MAP{$path} || do { 2220 $cf::MAP{$path} || do {
… …
1982 2237
1983 $cf::MAP{$path} = $map 2238 $cf::MAP{$path} = $map
1984 } 2239 }
1985} 2240}
1986 2241
1987sub pre_load { } 2242sub pre_load { }
1988sub post_load { } 2243#sub post_load { } # XS
1989 2244
1990sub load { 2245sub load {
1991 my ($self) = @_; 2246 my ($self) = @_;
1992 2247
1993 local $self->{deny_reset} = 1; # loading can take a long time 2248 local $self->{deny_reset} = 1; # loading can take a long time
… …
1996 2251
1997 { 2252 {
1998 my $guard = cf::lock_acquire "map_data:$path"; 2253 my $guard = cf::lock_acquire "map_data:$path";
1999 2254
2000 return unless $self->valid; 2255 return unless $self->valid;
2001 return unless $self->in_memory == cf::MAP_SWAPPED; 2256 return unless $self->state == cf::MAP_SWAPPED;
2002
2003 $self->in_memory (cf::MAP_LOADING);
2004 2257
2005 $self->alloc; 2258 $self->alloc;
2006 2259
2007 $self->pre_load; 2260 $self->pre_load;
2008 cf::cede_to_tick; 2261 cf::cede_to_tick;
2009 2262
2263 if (exists $self->{load_path}) {
2010 my $f = new_from_file cf::object::thawer $self->{load_path}; 2264 my $f = new_from_file cf::object::thawer $self->{load_path};
2011 $f->skip_block; 2265 $f->skip_block;
2012 $self->_load_objects ($f) 2266 $self->_load_objects ($f)
2013 or return; 2267 or return;
2014 2268
2015 $self->post_load_original 2269 $self->post_load_original
2016 if delete $self->{load_original}; 2270 if delete $self->{load_original};
2017 2271
2018 if (my $uniq = $self->uniq_path) { 2272 if (my $uniq = $self->uniq_path) {
2019 utf8::encode $uniq; 2273 utf8::encode $uniq;
2020 unless (aio_stat $uniq) { 2274 unless (aio_stat $uniq) {
2021 if (my $f = new_from_file cf::object::thawer $uniq) { 2275 if (my $f = new_from_file cf::object::thawer $uniq) {
2022 $self->clear_unique_items; 2276 $self->clear_unique_items;
2023 $self->_load_objects ($f); 2277 $self->_load_objects ($f);
2024 $f->resolve_delayed_derefs; 2278 $f->resolve_delayed_derefs;
2279 }
2025 } 2280 }
2026 } 2281 }
2027 }
2028 2282
2029 $f->resolve_delayed_derefs; 2283 $f->resolve_delayed_derefs;
2284 } else {
2285 $self->post_load_original
2286 if delete $self->{load_original};
2287 }
2288
2289 $self->state (cf::MAP_INACTIVE);
2030 2290
2031 cf::cede_to_tick; 2291 cf::cede_to_tick;
2032 # now do the right thing for maps 2292 # now do the right thing for maps
2033 $self->link_multipart_objects; 2293 $self->link_multipart_objects;
2034 $self->difficulty ($self->estimate_difficulty) 2294 $self->difficulty ($self->estimate_difficulty)
… …
2038 unless ($self->{deny_activate}) { 2298 unless ($self->{deny_activate}) {
2039 $self->decay_objects; 2299 $self->decay_objects;
2040 $self->fix_auto_apply; 2300 $self->fix_auto_apply;
2041 $self->update_buttons; 2301 $self->update_buttons;
2042 cf::cede_to_tick; 2302 cf::cede_to_tick;
2043 $self->activate; 2303 #$self->activate; # no longer activate maps automatically
2044 } 2304 }
2045 2305
2046 $self->{last_save} = $cf::RUNTIME; 2306 $self->{last_save} = $cf::RUNTIME;
2047 $self->last_access ($cf::RUNTIME); 2307 $self->last_access ($cf::RUNTIME);
2048
2049 $self->in_memory (cf::MAP_ACTIVE);
2050 } 2308 }
2051 2309
2052 $self->post_load; 2310 $self->post_load;
2053}
2054 2311
2312 1
2313}
2314
2315# customize the map for a given player, i.e.
2316# return the _real_ map. used by e.g. per-player
2317# maps to change the path to ~playername/mappath
2055sub customise_for { 2318sub customise_for {
2056 my ($self, $ob) = @_; 2319 my ($self, $ob) = @_;
2057 2320
2058 return find "~" . $ob->name . "/" . $self->{path} 2321 return find "~" . $ob->name . "/" . $self->{path}
2059 if $self->per_player; 2322 if $self->per_player;
… …
2062# if $self->per_party; 2325# if $self->per_party;
2063 2326
2064 $self 2327 $self
2065} 2328}
2066 2329
2067# find and load all maps in the 3x3 area around a map
2068sub load_neighbours {
2069 my ($map) = @_;
2070
2071 my @neigh; # diagonal neighbours
2072
2073 for (0 .. 3) {
2074 my $neigh = $map->tile_path ($_)
2075 or next;
2076 $neigh = find $neigh, $map
2077 or next;
2078 $neigh->load;
2079
2080 push @neigh,
2081 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2082 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2083 }
2084
2085 for (grep defined $_->[0], @neigh) {
2086 my ($path, $origin) = @$_;
2087 my $neigh = find $path, $origin
2088 or next;
2089 $neigh->load;
2090 }
2091}
2092
2093sub find_sync { 2330sub find_sync {
2094 my ($path, $origin) = @_; 2331 my ($path, $origin) = @_;
2095 2332
2096 cf::sync_job { find $path, $origin } 2333 # it's a bug to call this from the main context
2334 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2335 if $Coro::current == $Coro::main;
2336
2337 find $path, $origin
2097} 2338}
2098 2339
2099sub do_load_sync { 2340sub do_load_sync {
2100 my ($map) = @_; 2341 my ($map) = @_;
2101 2342
2343 # it's a bug to call this from the main context
2102 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2344 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2103 if $Coro::current == $Coro::main; 2345 if $Coro::current == $Coro::main;
2104 2346
2105 cf::sync_job { $map->load }; 2347 $map->load;
2106} 2348}
2107 2349
2108our %MAP_PREFETCH; 2350our %MAP_PREFETCH;
2109our $MAP_PREFETCHER = undef; 2351our $MAP_PREFETCHER = undef;
2110 2352
2111sub find_async { 2353sub find_async {
2112 my ($path, $origin, $load) = @_; 2354 my ($path, $origin, $load) = @_;
2113 2355
2114 $path = normalise $path, $origin && $origin->{path}; 2356 $path = normalise $path, $origin;
2115 2357
2116 if (my $map = $cf::MAP{$path}) { 2358 if (my $map = $cf::MAP{$path}) {
2117 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2359 return $map if !$load || $map->linkable;
2118 } 2360 }
2119 2361
2120 $MAP_PREFETCH{$path} |= $load; 2362 $MAP_PREFETCH{$path} |= $load;
2121 2363
2122 $MAP_PREFETCHER ||= cf::async { 2364 $MAP_PREFETCHER ||= cf::async {
… …
2136 $MAP_PREFETCHER->prio (6); 2378 $MAP_PREFETCHER->prio (6);
2137 2379
2138 () 2380 ()
2139} 2381}
2140 2382
2383# common code, used by both ->save and ->swapout
2141sub save { 2384sub _save {
2142 my ($self) = @_; 2385 my ($self) = @_;
2143
2144 my $lock = cf::lock_acquire "map_data:$self->{path}";
2145 2386
2146 $self->{last_save} = $cf::RUNTIME; 2387 $self->{last_save} = $cf::RUNTIME;
2147 2388
2148 return unless $self->dirty; 2389 return unless $self->dirty;
2149 2390
… …
2169 } else { 2410 } else {
2170 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2411 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2171 } 2412 }
2172} 2413}
2173 2414
2415sub save {
2416 my ($self) = @_;
2417
2418 my $lock = cf::lock_acquire "map_data:$self->{path}";
2419
2420 $self->_save;
2421}
2422
2174sub swap_out { 2423sub swap_out {
2175 my ($self) = @_; 2424 my ($self) = @_;
2176 2425
2177 # save first because save cedes
2178 $self->save;
2179
2180 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2426 my $lock = cf::lock_acquire "map_data:$self->{path}";
2181 2427
2428 return if !$self->linkable;
2429 return if $self->{deny_save};
2182 return if $self->players; 2430 return if $self->players;
2183 return if $self->in_memory != cf::MAP_ACTIVE; 2431
2432 # first deactivate the map and "unlink" it from the core
2433 $self->deactivate;
2434 $_->clear_links_to ($self) for values %cf::MAP;
2435 $self->state (cf::MAP_SWAPPED);
2436
2437 # then atomically save
2438 $self->_save;
2439
2440 # then free the map
2441 $self->clear;
2442}
2443
2444sub reset_at {
2445 my ($self) = @_;
2446
2447 # TODO: safety, remove and allow resettable per-player maps
2184 return if $self->{deny_save}; 2448 return 1e99 if $self->{deny_reset};
2185 2449
2450 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2451 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2452
2453 $time + $to
2454}
2455
2456sub should_reset {
2457 my ($self) = @_;
2458
2459 $self->reset_at <= $cf::RUNTIME
2460}
2461
2462sub reset {
2463 my ($self) = @_;
2464
2465 my $lock = cf::lock_acquire "map_data:$self->{path}";
2466
2467 return if $self->players;
2468
2469 cf::trace "resetting map ", $self->path, "\n";
2470
2186 $self->in_memory (cf::MAP_SWAPPED); 2471 $self->state (cf::MAP_SWAPPED);
2472
2473 # need to save uniques path
2474 unless ($self->{deny_save}) {
2475 my $uniq = $self->uniq_path; utf8::encode $uniq;
2476
2477 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2478 if $uniq;
2479 }
2480
2481 delete $cf::MAP{$self->path};
2187 2482
2188 $self->deactivate; 2483 $self->deactivate;
2189 $_->clear_links_to ($self) for values %cf::MAP; 2484 $_->clear_links_to ($self) for values %cf::MAP;
2190 $self->clear; 2485 $self->clear;
2191}
2192
2193sub reset_at {
2194 my ($self) = @_;
2195
2196 # TODO: safety, remove and allow resettable per-player maps
2197 return 1e99 if $self->{deny_reset};
2198
2199 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2200 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2201
2202 $time + $to
2203}
2204
2205sub should_reset {
2206 my ($self) = @_;
2207
2208 $self->reset_at <= $cf::RUNTIME
2209}
2210
2211sub reset {
2212 my ($self) = @_;
2213
2214 my $lock = cf::lock_acquire "map_data:$self->{path}";
2215
2216 return if $self->players;
2217
2218 warn "resetting map ", $self->path;
2219
2220 $self->in_memory (cf::MAP_SWAPPED);
2221
2222 # need to save uniques path
2223 unless ($self->{deny_save}) {
2224 my $uniq = $self->uniq_path; utf8::encode $uniq;
2225
2226 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2227 if $uniq;
2228 }
2229
2230 delete $cf::MAP{$self->path};
2231
2232 $self->deactivate;
2233 $_->clear_links_to ($self) for values %cf::MAP;
2234 $self->clear;
2235 2486
2236 $self->unlink_save; 2487 $self->unlink_save;
2237 $self->destroy; 2488 $self->destroy;
2238} 2489}
2239 2490
… …
2247 2498
2248 delete $cf::MAP{$self->path}; 2499 delete $cf::MAP{$self->path};
2249 2500
2250 $self->unlink_save; 2501 $self->unlink_save;
2251 2502
2252 bless $self, "cf::map"; 2503 bless $self, "cf::map::wrap";
2253 delete $self->{deny_reset}; 2504 delete $self->{deny_reset};
2254 $self->{deny_save} = 1; 2505 $self->{deny_save} = 1;
2255 $self->reset_timeout (1); 2506 $self->reset_timeout (1);
2256 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2507 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2257 2508
… …
2314 : normalise $_ 2565 : normalise $_
2315 } @{ aio_readdir $UNIQUEDIR or [] } 2566 } @{ aio_readdir $UNIQUEDIR or [] }
2316 ] 2567 ]
2317} 2568}
2318 2569
2570=item cf::map::static_maps
2571
2572Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2573file in the shared directory excluding F</styles> and F</editor>). May
2574block.
2575
2576=cut
2577
2578sub static_maps() {
2579 my @dirs = "";
2580 my @maps;
2581
2582 while (@dirs) {
2583 my $dir = shift @dirs;
2584
2585 next if $dir eq "/styles" || $dir eq "/editor";
2586
2587 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2588 or return;
2589
2590 for (@$files) {
2591 s/\.map$// or next;
2592 utf8::decode $_;
2593 push @maps, "$dir/$_";
2594 }
2595
2596 push @dirs, map "$dir/$_", @$dirs;
2597 }
2598
2599 \@maps
2600}
2601
2319=back 2602=back
2320 2603
2321=head3 cf::object 2604=head3 cf::object
2322 2605
2323=cut 2606=cut
… …
2455 2738
2456Freezes the player and moves him/her to a special map (C<{link}>). 2739Freezes the player and moves him/her to a special map (C<{link}>).
2457 2740
2458The player should be reasonably safe there for short amounts of time (e.g. 2741The player should be reasonably safe there for short amounts of time (e.g.
2459for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2742for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2460though, as the palyer cannot control the character while it is on the link 2743though, as the player cannot control the character while it is on the link
2461map. 2744map.
2462 2745
2463Will never block. 2746Will never block.
2464 2747
2465=item $player_object->leave_link ($map, $x, $y) 2748=item $player_object->leave_link ($map, $x, $y)
… …
2486sub cf::object::player::enter_link { 2769sub cf::object::player::enter_link {
2487 my ($self) = @_; 2770 my ($self) = @_;
2488 2771
2489 $self->deactivate_recursive; 2772 $self->deactivate_recursive;
2490 2773
2774 ++$self->{_link_recursion};
2775
2491 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2776 return if UNIVERSAL::isa $self->map, "ext::map_link";
2492 2777
2493 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2778 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2494 if $self->map && $self->map->{path} ne "{link}"; 2779 if $self->map && $self->map->{path} ne "{link}";
2495 2780
2496 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2781 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2497} 2782}
2498 2783
2499sub cf::object::player::leave_link { 2784sub cf::object::player::leave_link {
2500 my ($self, $map, $x, $y) = @_; 2785 my ($self, $map, $x, $y) = @_;
2501 2786
… …
2518 ($x, $y) = (-1, -1) 2803 ($x, $y) = (-1, -1)
2519 unless (defined $x) && (defined $y); 2804 unless (defined $x) && (defined $y);
2520 2805
2521 # use -1 or undef as default coordinates, not 0, 0 2806 # use -1 or undef as default coordinates, not 0, 0
2522 ($x, $y) = ($map->enter_x, $map->enter_y) 2807 ($x, $y) = ($map->enter_x, $map->enter_y)
2523 if $x <=0 && $y <= 0; 2808 if $x <= 0 && $y <= 0;
2524 2809
2525 $map->load; 2810 $map->load;
2526 $map->load_neighbours;
2527 2811
2528 return unless $self->contr->active; 2812 return unless $self->contr->active;
2529 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2530 $self->activate_recursive;
2531 2813
2532 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2814 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2533 $self->enter_map ($map, $x, $y); 2815 if ($self->enter_map ($map, $x, $y)) {
2534} 2816 # entering was successful
2817 delete $self->{_link_recursion};
2818 # only activate afterwards, to support waiting in hooks
2819 $self->activate_recursive;
2820 }
2535 2821
2822}
2823
2536=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2824=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2537 2825
2538Moves the player to the given map-path and coordinates by first freezing 2826Moves the player to the given map-path and coordinates by first freezing
2539her, loading and preparing them map, calling the provided $check callback 2827her, loading and preparing them map, calling the provided $check callback
2540that has to return the map if sucecssful, and then unfreezes the player on 2828that has to return the map if sucecssful, and then unfreezes the player on
2541the new (success) or old (failed) map position. In either case, $done will 2829the new (success) or old (failed) map position. In either case, $done will
… …
2548 2836
2549our $GOTOGEN; 2837our $GOTOGEN;
2550 2838
2551sub cf::object::player::goto { 2839sub cf::object::player::goto {
2552 my ($self, $path, $x, $y, $check, $done) = @_; 2840 my ($self, $path, $x, $y, $check, $done) = @_;
2841
2842 if ($self->{_link_recursion} >= $MAX_LINKS) {
2843 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2844 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2845 ($path, $x, $y) = @$EMERGENCY_POSITION;
2846 }
2553 2847
2554 # do generation counting so two concurrent goto's will be executed in-order 2848 # do generation counting so two concurrent goto's will be executed in-order
2555 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2849 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2556 2850
2557 $self->enter_link; 2851 $self->enter_link;
… …
2577 ($path, $x, $y) = (undef, undef, undef); 2871 ($path, $x, $y) = (undef, undef, undef);
2578 } 2872 }
2579 } 2873 }
2580 2874
2581 my $map = eval { 2875 my $map = eval {
2582 my $map = defined $path ? cf::map::find $path : undef; 2876 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2583 2877
2584 if ($map) { 2878 if ($map) {
2585 $map = $map->customise_for ($self); 2879 $map = $map->customise_for ($self);
2586 $map = $check->($map) if $check && $map; 2880 $map = $check->($map, $x, $y, $self) if $check && $map;
2587 } else { 2881 } else {
2588 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2882 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2589 } 2883 }
2590 2884
2591 $map 2885 $map
… …
2599 if ($gen == $self->{_goto_generation}) { 2893 if ($gen == $self->{_goto_generation}) {
2600 delete $self->{_goto_generation}; 2894 delete $self->{_goto_generation};
2601 $self->leave_link ($map, $x, $y); 2895 $self->leave_link ($map, $x, $y);
2602 } 2896 }
2603 2897
2604 $done->() if $done; 2898 $done->($self) if $done;
2605 })->prio (1); 2899 })->prio (1);
2606} 2900}
2607 2901
2608=item $player_object->enter_exit ($exit_object) 2902=item $player_object->enter_exit ($exit_object)
2609 2903
… …
2677 $Coro::current->{desc} = "enter_exit"; 2971 $Coro::current->{desc} = "enter_exit";
2678 2972
2679 unless (eval { 2973 unless (eval {
2680 $self->deactivate_recursive; # just to be sure 2974 $self->deactivate_recursive; # just to be sure
2681 2975
2682 # random map handling
2683 {
2684 my $guard = cf::lock_acquire "exit_prepare:$exit";
2685
2686 prepare_random_map $exit
2687 if $exit->slaying eq "/!";
2688 }
2689
2690 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2976 my $map = cf::map::normalise $exit->slaying, $exit->map;
2691 my $x = $exit->stats->hp; 2977 my $x = $exit->stats->hp;
2692 my $y = $exit->stats->sp; 2978 my $y = $exit->stats->sp;
2979
2980 # special map handling
2981 my $slaying = $exit->slaying;
2982
2983 # special map handling
2984 if ($slaying eq "/!") {
2985 my $guard = cf::lock_acquire "exit_prepare:$exit";
2986
2987 prepare_random_map $exit
2988 if $exit->slaying eq "/!"; # need to re-check after getting the lock
2989
2990 $map = $exit->slaying;
2991
2992 } elsif ($slaying eq '!up') {
2993 $map = $exit->map->tile_path (cf::TILE_UP);
2994 $x = $exit->x;
2995 $y = $exit->y;
2996
2997 } elsif ($slaying eq '!down') {
2998 $map = $exit->map->tile_path (cf::TILE_DOWN);
2999 $x = $exit->x;
3000 $y = $exit->y;
3001 }
2693 3002
2694 $self->goto ($map, $x, $y); 3003 $self->goto ($map, $x, $y);
2695 3004
2696 # if exit is damned, update players death & WoR home-position 3005 # if exit is damned, update players death & WoR home-position
2697 $self->contr->savebed ($map, $x, $y) 3006 $self->contr->savebed ($map, $x, $y)
… …
2702 $self->message ("Something went wrong deep within the deliantra server. " 3011 $self->message ("Something went wrong deep within the deliantra server. "
2703 . "I'll try to bring you back to the map you were before. " 3012 . "I'll try to bring you back to the map you were before. "
2704 . "Please report this to the dungeon master!", 3013 . "Please report this to the dungeon master!",
2705 cf::NDI_UNIQUE | cf::NDI_RED); 3014 cf::NDI_UNIQUE | cf::NDI_RED);
2706 3015
2707 warn "ERROR in enter_exit: $@"; 3016 error "ERROR in enter_exit: $@";
2708 $self->leave_link; 3017 $self->leave_link;
2709 } 3018 }
2710 })->prio (1); 3019 })->prio (1);
2711} 3020}
2712 3021
… …
2724sub cf::client::send_drawinfo { 3033sub cf::client::send_drawinfo {
2725 my ($self, $text, $flags) = @_; 3034 my ($self, $text, $flags) = @_;
2726 3035
2727 utf8::encode $text; 3036 utf8::encode $text;
2728 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 3037 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
3038}
3039
3040=item $client->send_big_packet ($pkt)
3041
3042Like C<send_packet>, but tries to compress large packets, and fragments
3043them as required.
3044
3045=cut
3046
3047our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
3048
3049sub cf::client::send_big_packet {
3050 my ($self, $pkt) = @_;
3051
3052 # try lzf for large packets
3053 $pkt = "lzf " . Compress::LZF::compress $pkt
3054 if 1024 <= length $pkt and $self->{can_lzf};
3055
3056 # split very large packets
3057 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3058 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3059 $pkt = "frag";
3060 }
3061
3062 $self->send_packet ($pkt);
2729} 3063}
2730 3064
2731=item $client->send_msg ($channel, $msg, $color, [extra...]) 3065=item $client->send_msg ($channel, $msg, $color, [extra...])
2732 3066
2733Send a drawinfo or msg packet to the client, formatting the msg for the 3067Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2737 3071
2738=cut 3072=cut
2739 3073
2740# non-persistent channels (usually the info channel) 3074# non-persistent channels (usually the info channel)
2741our %CHANNEL = ( 3075our %CHANNEL = (
3076 "c/motd" => {
3077 id => "infobox",
3078 title => "MOTD",
3079 reply => undef,
3080 tooltip => "The message of the day",
3081 },
2742 "c/identify" => { 3082 "c/identify" => {
2743 id => "infobox", 3083 id => "infobox",
2744 title => "Identify", 3084 title => "Identify",
2745 reply => undef, 3085 reply => undef,
2746 tooltip => "Items recently identified", 3086 tooltip => "Items recently identified",
… …
2748 "c/examine" => { 3088 "c/examine" => {
2749 id => "infobox", 3089 id => "infobox",
2750 title => "Examine", 3090 title => "Examine",
2751 reply => undef, 3091 reply => undef,
2752 tooltip => "Signs and other items you examined", 3092 tooltip => "Signs and other items you examined",
3093 },
3094 "c/shopinfo" => {
3095 id => "infobox",
3096 title => "Shop Info",
3097 reply => undef,
3098 tooltip => "What your bargaining skill tells you about the shop",
2753 }, 3099 },
2754 "c/book" => { 3100 "c/book" => {
2755 id => "infobox", 3101 id => "infobox",
2756 title => "Book", 3102 title => "Book",
2757 reply => undef, 3103 reply => undef,
… …
2785 id => "infobox", 3131 id => "infobox",
2786 title => "Skills", 3132 title => "Skills",
2787 reply => undef, 3133 reply => undef,
2788 tooltip => "Shows your experience per skill and item power", 3134 tooltip => "Shows your experience per skill and item power",
2789 }, 3135 },
3136 "c/shopitems" => {
3137 id => "infobox",
3138 title => "Shop Items",
3139 reply => undef,
3140 tooltip => "Shows the items currently for sale in this shop",
3141 },
2790 "c/resistances" => { 3142 "c/resistances" => {
2791 id => "infobox", 3143 id => "infobox",
2792 title => "Resistances", 3144 title => "Resistances",
2793 reply => undef, 3145 reply => undef,
2794 tooltip => "Shows your resistances", 3146 tooltip => "Shows your resistances",
… …
2796 "c/pets" => { 3148 "c/pets" => {
2797 id => "infobox", 3149 id => "infobox",
2798 title => "Pets", 3150 title => "Pets",
2799 reply => undef, 3151 reply => undef,
2800 tooltip => "Shows information abotu your pets/a specific pet", 3152 tooltip => "Shows information abotu your pets/a specific pet",
3153 },
3154 "c/perceiveself" => {
3155 id => "infobox",
3156 title => "Perceive Self",
3157 reply => undef,
3158 tooltip => "You gained detailed knowledge about yourself",
2801 }, 3159 },
2802 "c/uptime" => { 3160 "c/uptime" => {
2803 id => "infobox", 3161 id => "infobox",
2804 title => "Uptime", 3162 title => "Uptime",
2805 reply => undef, 3163 reply => undef,
… …
2861 my $pkt = "msg " 3219 my $pkt = "msg "
2862 . $self->{json_coder}->encode ( 3220 . $self->{json_coder}->encode (
2863 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3221 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2864 ); 3222 );
2865 3223
2866 # try lzf for large packets
2867 $pkt = "lzf " . Compress::LZF::compress $pkt
2868 if 1024 <= length $pkt and $self->{can_lzf};
2869
2870 # split very large packets
2871 if (8192 < length $pkt and $self->{can_lzf}) {
2872 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2873 $pkt = "frag";
2874 }
2875
2876 $self->send_packet ($pkt); 3224 $self->send_big_packet ($pkt);
2877} 3225}
2878 3226
2879=item $client->ext_msg ($type, @msg) 3227=item $client->ext_msg ($type, @msg)
2880 3228
2881Sends an ext event to the client. 3229Sends an ext event to the client.
… …
2884 3232
2885sub cf::client::ext_msg($$@) { 3233sub cf::client::ext_msg($$@) {
2886 my ($self, $type, @msg) = @_; 3234 my ($self, $type, @msg) = @_;
2887 3235
2888 if ($self->extcmd == 2) { 3236 if ($self->extcmd == 2) {
2889 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3237 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2890 } elsif ($self->extcmd == 1) { # TODO: remove 3238 } elsif ($self->extcmd == 1) { # TODO: remove
2891 push @msg, msgtype => "event_$type"; 3239 push @msg, msgtype => "event_$type";
2892 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3240 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2893 } 3241 }
2894} 3242}
2895 3243
2896=item $client->ext_reply ($msgid, @msg) 3244=item $client->ext_reply ($msgid, @msg)
2897 3245
… …
2900=cut 3248=cut
2901 3249
2902sub cf::client::ext_reply($$@) { 3250sub cf::client::ext_reply($$@) {
2903 my ($self, $id, @msg) = @_; 3251 my ($self, $id, @msg) = @_;
2904 3252
2905 if ($self->extcmd == 2) { 3253 return unless $self->extcmd == 2;
3254
2906 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3255 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2907 } elsif ($self->extcmd == 1) {
2908 #TODO: version 1, remove
2909 unshift @msg, msgtype => "reply", msgid => $id;
2910 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2911 }
2912} 3256}
2913 3257
2914=item $success = $client->query ($flags, "text", \&cb) 3258=item $success = $client->query ($flags, "text", \&cb)
2915 3259
2916Queues a query to the client, calling the given callback with 3260Queues a query to the client, calling the given callback with
… …
2971 my ($ns, $buf) = @_; 3315 my ($ns, $buf) = @_;
2972 3316
2973 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3317 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2974 3318
2975 if (ref $msg) { 3319 if (ref $msg) {
2976 my ($type, $reply, @payload) = 3320 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
2977 "ARRAY" eq ref $msg
2978 ? @$msg
2979 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2980 3321
2981 my @reply; 3322 my @reply;
2982 3323
2983 if (my $cb = $EXTICMD{$type}) { 3324 if (my $cb = $EXTICMD{$type}) {
2984 @reply = $cb->($ns, @payload); 3325 @reply = $cb->($ns, @payload);
… …
2986 3327
2987 $ns->ext_reply ($reply, @reply) 3328 $ns->ext_reply ($reply, @reply)
2988 if $reply; 3329 if $reply;
2989 3330
2990 } else { 3331 } else {
2991 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3332 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2992 } 3333 }
2993 3334
2994 cf::override; 3335 cf::override;
2995 }, 3336 },
2996); 3337);
… …
3016 3357
3017 $coro 3358 $coro
3018} 3359}
3019 3360
3020cf::client->attach ( 3361cf::client->attach (
3021 on_destroy => sub { 3362 on_client_destroy => sub {
3022 my ($ns) = @_; 3363 my ($ns) = @_;
3023 3364
3024 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3365 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3025 }, 3366 },
3026); 3367);
… …
3042our $safe_hole = new Safe::Hole; 3383our $safe_hole = new Safe::Hole;
3043 3384
3044$SIG{FPE} = 'IGNORE'; 3385$SIG{FPE} = 'IGNORE';
3045 3386
3046$safe->permit_only (Opcode::opset qw( 3387$safe->permit_only (Opcode::opset qw(
3047 :base_core :base_mem :base_orig :base_math 3388 :base_core :base_mem :base_orig :base_math :base_loop
3048 grepstart grepwhile mapstart mapwhile 3389 grepstart grepwhile mapstart mapwhile
3049 sort time 3390 sort time
3050)); 3391));
3051 3392
3052# here we export the classes and methods available to script code 3393# here we export the classes and methods available to script code
… …
3077 decrease split destroy change_exp value msg lore send_msg)], 3418 decrease split destroy change_exp value msg lore send_msg)],
3078 ["cf::object::player" => qw(player)], 3419 ["cf::object::player" => qw(player)],
3079 ["cf::player" => qw(peaceful send_msg)], 3420 ["cf::player" => qw(peaceful send_msg)],
3080 ["cf::map" => qw(trigger)], 3421 ["cf::map" => qw(trigger)],
3081) { 3422) {
3082 no strict 'refs';
3083 my ($pkg, @funs) = @$_; 3423 my ($pkg, @funs) = @$_;
3084 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3424 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3085 for @funs; 3425 for @funs;
3086} 3426}
3087 3427
… …
3104 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3444 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3105 $qcode =~ s/\n/\\n/g; 3445 $qcode =~ s/\n/\\n/g;
3106 3446
3107 %vars = (_dummy => 0) unless %vars; 3447 %vars = (_dummy => 0) unless %vars;
3108 3448
3449 my @res;
3109 local $_; 3450 local $_;
3110 local @safe::cf::_safe_eval_args = values %vars;
3111 3451
3112 my $eval = 3452 my $eval =
3113 "do {\n" 3453 "do {\n"
3114 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3454 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3115 . "#line 0 \"{$qcode}\"\n" 3455 . "#line 0 \"{$qcode}\"\n"
3116 . $code 3456 . $code
3117 . "\n}" 3457 . "\n}"
3118 ; 3458 ;
3119 3459
3460 if ($CFG{safe_eval}) {
3120 sub_generation_inc; 3461 sub_generation_inc;
3462 local @safe::cf::_safe_eval_args = values %vars;
3121 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3463 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3122 sub_generation_inc; 3464 sub_generation_inc;
3465 } else {
3466 local @cf::_safe_eval_args = values %vars;
3467 @res = wantarray ? eval eval : scalar eval $eval;
3468 }
3123 3469
3124 if ($@) { 3470 if ($@) {
3125 warn "$@"; 3471 warn "$@",
3126 warn "while executing safe code '$code'\n"; 3472 "while executing safe code '$code'\n",
3127 warn "with arguments " . (join " ", %vars) . "\n"; 3473 "with arguments " . (join " ", %vars) . "\n";
3128 } 3474 }
3129 3475
3130 wantarray ? @res : $res[0] 3476 wantarray ? @res : $res[0]
3131} 3477}
3132 3478
… …
3146=cut 3492=cut
3147 3493
3148sub register_script_function { 3494sub register_script_function {
3149 my ($fun, $cb) = @_; 3495 my ($fun, $cb) = @_;
3150 3496
3151 no strict 'refs'; 3497 $fun = "safe::$fun" if $CFG{safe_eval};
3152 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3498 *$fun = $safe_hole->wrap ($cb);
3153} 3499}
3154 3500
3155=back 3501=back
3156 3502
3157=cut 3503=cut
… …
3166 # for this (global event?) 3512 # for this (global event?)
3167 %ext::player_env::MUSIC_FACE_CACHE = (); 3513 %ext::player_env::MUSIC_FACE_CACHE = ();
3168 3514
3169 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3515 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3170 3516
3171 warn "loading facedata from $path\n"; 3517 trace "loading facedata from $path\n";
3172 3518
3173 my $facedata; 3519 my $facedata = decode_storable load_file $path;
3174 0 < aio_load $path, $facedata
3175 or die "$path: $!";
3176
3177 $facedata = Coro::Storable::thaw $facedata;
3178 3520
3179 $facedata->{version} == 2 3521 $facedata->{version} == 2
3180 or cf::cleanup "$path: version mismatch, cannot proceed."; 3522 or cf::cleanup "$path: version mismatch, cannot proceed.";
3181 3523
3182 # patch in the exptable 3524 # patch in the exptable
3525 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3183 $facedata->{resource}{"res/exp_table"} = { 3526 $facedata->{resource}{"res/exp_table"} = {
3184 type => FT_RSRC, 3527 type => FT_RSRC,
3185 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3528 data => $exp_table,
3529 hash => (Digest::MD5::md5 $exp_table),
3186 }; 3530 };
3187 cf::cede_to_tick; 3531 cf::cede_to_tick;
3188 3532
3189 { 3533 {
3190 my $faces = $facedata->{faceinfo}; 3534 my $faces = $facedata->{faceinfo};
… …
3192 while (my ($face, $info) = each %$faces) { 3536 while (my ($face, $info) = each %$faces) {
3193 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3537 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3194 3538
3195 cf::face::set_visibility $idx, $info->{visibility}; 3539 cf::face::set_visibility $idx, $info->{visibility};
3196 cf::face::set_magicmap $idx, $info->{magicmap}; 3540 cf::face::set_magicmap $idx, $info->{magicmap};
3197 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3541 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3198 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3542 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3543 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3199 3544
3200 cf::cede_to_tick; 3545 cf::cede_to_tick;
3201 } 3546 }
3202 3547
3203 while (my ($face, $info) = each %$faces) { 3548 while (my ($face, $info) = each %$faces) {
… …
3208 3553
3209 if (my $smooth = cf::face::find $info->{smooth}) { 3554 if (my $smooth = cf::face::find $info->{smooth}) {
3210 cf::face::set_smooth $idx, $smooth; 3555 cf::face::set_smooth $idx, $smooth;
3211 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3556 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3212 } else { 3557 } else {
3213 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3558 error "smooth face '$info->{smooth}' not found for face '$face'";
3214 } 3559 }
3215 3560
3216 cf::cede_to_tick; 3561 cf::cede_to_tick;
3217 } 3562 }
3218 } 3563 }
… …
3227 3572
3228 cf::anim::invalidate_all; # d'oh 3573 cf::anim::invalidate_all; # d'oh
3229 } 3574 }
3230 3575
3231 { 3576 {
3232 # TODO: for gcfclient pleasure, we should give resources
3233 # that gcfclient doesn't grok a >10000 face index.
3234 my $res = $facedata->{resource}; 3577 my $res = $facedata->{resource};
3235 3578
3236 while (my ($name, $info) = each %$res) { 3579 while (my ($name, $info) = each %$res) {
3237 if (defined $info->{type}) { 3580 if (defined (my $type = $info->{type})) {
3581 # TODO: different hash - must free and use new index, or cache ixface data queue
3238 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3582 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3239 my $data;
3240 3583
3241 if ($info->{type} & 1) { 3584 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3242 # prepend meta info
3243
3244 my $meta = $enc->encode ({
3245 name => $name,
3246 %{ $info->{meta} || {} },
3247 });
3248
3249 $data = pack "(w/a*)*", $meta, $info->{data};
3250 } else {
3251 $data = $info->{data};
3252 }
3253
3254 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3255 cf::face::set_type $idx, $info->{type}; 3585 cf::face::set_type $idx, $type;
3586 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3256 } else { 3587 } else {
3257 $RESOURCE{$name} = $info; 3588# $RESOURCE{$name} = $info; # unused
3258 } 3589 }
3259 3590
3260 cf::cede_to_tick; 3591 cf::cede_to_tick;
3261 } 3592 }
3262 } 3593 }
3263 3594
3264 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3595 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3265 3596
3266 1 3597 1
3267} 3598}
3268
3269cf::global->attach (on_resource_update => sub {
3270 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3271 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3272
3273 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3274 my $sound = $soundconf->{compat}[$_]
3275 or next;
3276
3277 my $face = cf::face::find "sound/$sound->[1]";
3278 cf::sound::set $sound->[0] => $face;
3279 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3280 }
3281
3282 while (my ($k, $v) = each %{$soundconf->{event}}) {
3283 my $face = cf::face::find "sound/$v";
3284 cf::sound::set $k => $face;
3285 }
3286 }
3287});
3288 3599
3289register_exticmd fx_want => sub { 3600register_exticmd fx_want => sub {
3290 my ($ns, $want) = @_; 3601 my ($ns, $want) = @_;
3291 3602
3292 while (my ($k, $v) = each %$want) { 3603 while (my ($k, $v) = each %$want) {
… …
3331sub reload_treasures { 3642sub reload_treasures {
3332 load_resource_file "$DATADIR/treasures" 3643 load_resource_file "$DATADIR/treasures"
3333 or die "unable to load treasurelists\n"; 3644 or die "unable to load treasurelists\n";
3334} 3645}
3335 3646
3647sub reload_sound {
3648 trace "loading sound config from $DATADIR/sound\n";
3649
3650 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3651
3652 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3653 my $sound = $soundconf->{compat}[$_]
3654 or next;
3655
3656 my $face = cf::face::find "sound/$sound->[1]";
3657 cf::sound::set $sound->[0] => $face;
3658 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3659 }
3660
3661 while (my ($k, $v) = each %{$soundconf->{event}}) {
3662 my $face = cf::face::find "sound/$v";
3663 cf::sound::set $k => $face;
3664 }
3665}
3666
3336sub reload_resources { 3667sub reload_resources {
3337 warn "reloading resource files...\n"; 3668 trace "reloading resource files...\n";
3338 3669
3670 reload_exp_table;
3671 reload_materials;
3339 reload_facedata; 3672 reload_facedata;
3673 reload_sound;
3340 reload_archetypes; 3674 reload_archetypes;
3341 reload_regions; 3675 reload_regions;
3342 reload_treasures; 3676 reload_treasures;
3343 3677
3344 warn "finished reloading resource files\n"; 3678 trace "finished reloading resource files\n";
3345} 3679}
3346 3680
3347sub reload_config { 3681sub reload_config {
3348 open my $fh, "<:utf8", "$CONFDIR/config" 3682 trace "reloading config file...\n";
3349 or return;
3350 3683
3351 local $/; 3684 my $config = load_file "$CONFDIR/config";
3352 *CFG = YAML::Load <$fh>; 3685 utf8::decode $config;
3686 *CFG = decode_yaml $config;
3353 3687
3354 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3688 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3355 3689
3356 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3690 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3357 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3691 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3358 3692
3359 if (exists $CFG{mlockall}) { 3693 if (exists $CFG{mlockall}) {
… …
3382 3716
3383 seek $fh, 0, 0; 3717 seek $fh, 0, 0;
3384 print $fh $$; 3718 print $fh $$;
3385} 3719}
3386 3720
3721sub main_loop {
3722 trace "EV::loop starting\n";
3723 if (1) {
3724 EV::loop;
3725 }
3726 trace "EV::loop returned\n";
3727 goto &main_loop unless $REALLY_UNLOOP;
3728}
3729
3387sub main { 3730sub main {
3388 cf::init_globals; # initialise logging 3731 cf::init_globals; # initialise logging
3389 3732
3390 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3733 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3391 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3734 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3392 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3735 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3393 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3736 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3394
3395 cf::init_experience;
3396 cf::init_anim;
3397 cf::init_attackmess;
3398 cf::init_dynamic;
3399 3737
3400 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3738 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3401 3739
3402 # we must not ever block the main coroutine 3740 # we must not ever block the main coroutine
3403 local $Coro::idle = sub { 3741 local $Coro::idle = sub {
… …
3409 }; 3747 };
3410 3748
3411 evthread_start IO::AIO::poll_fileno; 3749 evthread_start IO::AIO::poll_fileno;
3412 3750
3413 cf::sync_job { 3751 cf::sync_job {
3752 cf::incloader::init ();
3753
3754 cf::init_anim;
3755 cf::init_attackmess;
3756 cf::init_dynamic;
3757
3758 cf::load_settings;
3759
3414 reload_resources; 3760 reload_resources;
3415 reload_config; 3761 reload_config;
3416 db_init; 3762 db_init;
3417 3763
3418 cf::load_settings;
3419 cf::load_materials;
3420 cf::init_uuid; 3764 cf::init_uuid;
3421 cf::init_signals; 3765 cf::init_signals;
3422 cf::init_commands;
3423 cf::init_skills; 3766 cf::init_skills;
3424 3767
3425 cf::init_beforeplay; 3768 cf::init_beforeplay;
3426 3769
3427 atomic; 3770 atomic;
… …
3429 load_extensions; 3772 load_extensions;
3430 3773
3431 utime time, time, $RUNTIMEFILE; 3774 utime time, time, $RUNTIMEFILE;
3432 3775
3433 # no (long-running) fork's whatsoever before this point(!) 3776 # no (long-running) fork's whatsoever before this point(!)
3777 use POSIX ();
3434 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3778 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3435 3779
3436 (pop @POST_INIT)->(0) while @POST_INIT; 3780 cf::_post_init 0;
3437 }; 3781 };
3438 3782
3439 EV::loop; 3783 cf::object::thawer::errors_are_fatal 0;
3784 info "parse errors in files are no longer fatal from this point on.\n";
3785
3786 AE::postpone {
3787 undef &main; # free gobs of memory :)
3788 };
3789
3790 goto &main_loop;
3440} 3791}
3441 3792
3442############################################################################# 3793#############################################################################
3443# initialisation and cleanup 3794# initialisation and cleanup
3444 3795
3445# install some emergency cleanup handlers 3796# install some emergency cleanup handlers
3446BEGIN { 3797BEGIN {
3447 our %SIGWATCHER = (); 3798 our %SIGWATCHER = ();
3448 for my $signal (qw(INT HUP TERM)) { 3799 for my $signal (qw(INT HUP TERM)) {
3449 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3800 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3450 cf::cleanup "SIG$signal"; 3801 cf::cleanup "SIG$signal";
3451 }; 3802 };
3452 } 3803 }
3453} 3804}
3454 3805
3455sub write_runtime_sync { 3806sub write_runtime_sync {
3807 my $t0 = AE::time;
3808
3456 # first touch the runtime file to show we are still running: 3809 # first touch the runtime file to show we are still running:
3457 # the fsync below can take a very very long time. 3810 # the fsync below can take a very very long time.
3458 3811
3459 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3812 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3460 3813
3461 my $guard = cf::lock_acquire "write_runtime"; 3814 my $guard = cf::lock_acquire "write_runtime";
3462 3815
3463 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3816 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3464 or return; 3817 or return;
3465 3818
3466 my $value = $cf::RUNTIME + 90 + 10; 3819 my $value = $cf::RUNTIME + 90 + 10;
3467 # 10 is the runtime save interval, for a monotonic clock 3820 # 10 is the runtime save interval, for a monotonic clock
3468 # 60 allows for the watchdog to kill the server. 3821 # 60 allows for the watchdog to kill the server.
… …
3481 or return; 3834 or return;
3482 3835
3483 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3836 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3484 and return; 3837 and return;
3485 3838
3486 warn "runtime file written.\n"; 3839 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3487 3840
3488 1 3841 1
3489} 3842}
3490 3843
3491our $uuid_lock; 3844our $uuid_lock;
… …
3503 or return; 3856 or return;
3504 3857
3505 my $value = uuid_seq uuid_cur; 3858 my $value = uuid_seq uuid_cur;
3506 3859
3507 unless ($value) { 3860 unless ($value) {
3508 warn "cowardly refusing to write zero uuid value!\n"; 3861 info "cowardly refusing to write zero uuid value!\n";
3509 return; 3862 return;
3510 } 3863 }
3511 3864
3512 my $value = uuid_str $value + $uuid_skip; 3865 my $value = uuid_str $value + $uuid_skip;
3513 $uuid_skip = 0; 3866 $uuid_skip = 0;
… …
3523 or return; 3876 or return;
3524 3877
3525 aio_rename "$uuid~", $uuid 3878 aio_rename "$uuid~", $uuid
3526 and return; 3879 and return;
3527 3880
3528 warn "uuid file written ($value).\n"; 3881 trace "uuid file written ($value).\n";
3529 3882
3530 1 3883 1
3531 3884
3532} 3885}
3533 3886
… …
3539} 3892}
3540 3893
3541sub emergency_save() { 3894sub emergency_save() {
3542 my $freeze_guard = cf::freeze_mainloop; 3895 my $freeze_guard = cf::freeze_mainloop;
3543 3896
3544 warn "emergency_perl_save: enter\n"; 3897 info "emergency_perl_save: enter\n";
3898
3899 # this is a trade-off: we want to be very quick here, so
3900 # save all maps without fsync, and later call a global sync
3901 # (which in turn might be very very slow)
3902 local $USE_FSYNC = 0;
3545 3903
3546 cf::sync_job { 3904 cf::sync_job {
3547 # this is a trade-off: we want to be very quick here, so 3905 cf::write_runtime_sync; # external watchdog should not bark
3548 # save all maps without fsync, and later call a global sync
3549 # (which in turn might be very very slow)
3550 local $USE_FSYNC = 0;
3551 3906
3552 # use a peculiar iteration method to avoid tripping on perl 3907 # use a peculiar iteration method to avoid tripping on perl
3553 # refcount bugs in for. also avoids problems with players 3908 # refcount bugs in for. also avoids problems with players
3554 # and maps saved/destroyed asynchronously. 3909 # and maps saved/destroyed asynchronously.
3555 warn "emergency_perl_save: begin player save\n"; 3910 info "emergency_perl_save: begin player save\n";
3556 for my $login (keys %cf::PLAYER) { 3911 for my $login (keys %cf::PLAYER) {
3557 my $pl = $cf::PLAYER{$login} or next; 3912 my $pl = $cf::PLAYER{$login} or next;
3558 $pl->valid or next; 3913 $pl->valid or next;
3559 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3914 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3560 $pl->save; 3915 $pl->save;
3561 } 3916 }
3562 warn "emergency_perl_save: end player save\n"; 3917 info "emergency_perl_save: end player save\n";
3563 3918
3919 cf::write_runtime_sync; # external watchdog should not bark
3920
3564 warn "emergency_perl_save: begin map save\n"; 3921 info "emergency_perl_save: begin map save\n";
3565 for my $path (keys %cf::MAP) { 3922 for my $path (keys %cf::MAP) {
3566 my $map = $cf::MAP{$path} or next; 3923 my $map = $cf::MAP{$path} or next;
3567 $map->valid or next; 3924 $map->valid or next;
3568 $map->save; 3925 $map->save;
3569 } 3926 }
3570 warn "emergency_perl_save: end map save\n"; 3927 info "emergency_perl_save: end map save\n";
3571 3928
3929 cf::write_runtime_sync; # external watchdog should not bark
3930
3572 warn "emergency_perl_save: begin database checkpoint\n"; 3931 info "emergency_perl_save: begin database checkpoint\n";
3573 BDB::db_env_txn_checkpoint $DB_ENV; 3932 BDB::db_env_txn_checkpoint $DB_ENV;
3574 warn "emergency_perl_save: end database checkpoint\n"; 3933 info "emergency_perl_save: end database checkpoint\n";
3575 3934
3576 warn "emergency_perl_save: begin write uuid\n"; 3935 info "emergency_perl_save: begin write uuid\n";
3577 write_uuid_sync 1; 3936 write_uuid_sync 1;
3578 warn "emergency_perl_save: end write uuid\n"; 3937 info "emergency_perl_save: end write uuid\n";
3938
3939 cf::write_runtime_sync; # external watchdog should not bark
3940
3941 trace "emergency_perl_save: syncing database to disk";
3942 BDB::db_env_txn_checkpoint $DB_ENV;
3943
3944 info "emergency_perl_save: starting sync\n";
3945 IO::AIO::aio_sync sub {
3946 info "emergency_perl_save: finished sync\n";
3947 };
3948
3949 cf::write_runtime_sync; # external watchdog should not bark
3950
3951 trace "emergency_perl_save: flushing outstanding aio requests";
3952 while (IO::AIO::nreqs || BDB::nreqs) {
3953 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3954 }
3955
3956 cf::write_runtime_sync; # external watchdog should not bark
3579 }; 3957 };
3580 3958
3581 warn "emergency_perl_save: starting sync()\n";
3582 IO::AIO::aio_sync sub {
3583 warn "emergency_perl_save: finished sync()\n";
3584 };
3585
3586 warn "emergency_perl_save: leave\n"; 3959 info "emergency_perl_save: leave\n";
3587} 3960}
3588 3961
3589sub post_cleanup { 3962sub post_cleanup {
3590 my ($make_core) = @_; 3963 my ($make_core) = @_;
3591 3964
3965 IO::AIO::flush;
3966
3592 warn Carp::longmess "post_cleanup backtrace" 3967 error Carp::longmess "post_cleanup backtrace"
3593 if $make_core; 3968 if $make_core;
3594 3969
3595 my $fh = pidfile; 3970 my $fh = pidfile;
3596 unlink $PIDFILE if <$fh> == $$; 3971 unlink $PIDFILE if <$fh> == $$;
3597} 3972}
… …
3617 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3992 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3618 for my $name (keys %$leaf_symtab) { 3993 for my $name (keys %$leaf_symtab) {
3619 _gv_clear *{"$pkg$name"}; 3994 _gv_clear *{"$pkg$name"};
3620# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3995# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3621 } 3996 }
3622 warn "cleared package $pkg\n";#d#
3623} 3997}
3624 3998
3625sub do_reload_perl() { 3999sub do_reload_perl() {
3626 # can/must only be called in main 4000 # can/must only be called in main
3627 if ($Coro::current != $Coro::main) { 4001 unless (in_main) {
3628 warn "can only reload from main coroutine"; 4002 error "can only reload from main coroutine";
3629 return; 4003 return;
3630 } 4004 }
3631 4005
3632 return if $RELOAD++; 4006 return if $RELOAD++;
3633 4007
3634 my $t1 = EV::time; 4008 my $t1 = AE::time;
3635 4009
3636 while ($RELOAD) { 4010 while ($RELOAD) {
3637 warn "reloading..."; 4011 cf::get_slot 0.1, -1, "reload_perl";
4012 info "perl_reload: reloading...";
3638 4013
3639 warn "entering sync_job"; 4014 trace "perl_reload: entering sync_job";
3640 4015
3641 cf::sync_job { 4016 cf::sync_job {
3642 cf::write_runtime_sync; # external watchdog should not bark
3643 cf::emergency_save; 4017 #cf::emergency_save;
3644 cf::write_runtime_sync; # external watchdog should not bark
3645 4018
3646 warn "syncing database to disk";
3647 BDB::db_env_txn_checkpoint $DB_ENV;
3648
3649 # if anything goes wrong in here, we should simply crash as we already saved
3650
3651 warn "flushing outstanding aio requests";
3652 while (IO::AIO::nreqs || BDB::nreqs) {
3653 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3654 }
3655
3656 warn "cancelling all extension coros"; 4019 trace "perl_reload: cancelling all extension coros";
3657 $_->cancel for values %EXT_CORO; 4020 $_->cancel for values %EXT_CORO;
3658 %EXT_CORO = (); 4021 %EXT_CORO = ();
3659 4022
3660 warn "removing commands"; 4023 trace "perl_reload: removing commands";
3661 %COMMAND = (); 4024 %COMMAND = ();
3662 4025
3663 warn "removing ext/exti commands"; 4026 trace "perl_reload: removing ext/exti commands";
3664 %EXTCMD = (); 4027 %EXTCMD = ();
3665 %EXTICMD = (); 4028 %EXTICMD = ();
3666 4029
3667 warn "unloading/nuking all extensions"; 4030 trace "perl_reload: unloading/nuking all extensions";
3668 for my $pkg (@EXTS) { 4031 for my $pkg (@EXTS) {
3669 warn "... unloading $pkg"; 4032 trace "... unloading $pkg";
3670 4033
3671 if (my $cb = $pkg->can ("unload")) { 4034 if (my $cb = $pkg->can ("unload")) {
3672 eval { 4035 eval {
3673 $cb->($pkg); 4036 $cb->($pkg);
3674 1 4037 1
3675 } or warn "$pkg unloaded, but with errors: $@"; 4038 } or error "$pkg unloaded, but with errors: $@";
3676 } 4039 }
3677 4040
3678 warn "... clearing $pkg"; 4041 trace "... clearing $pkg";
3679 clear_package $pkg; 4042 clear_package $pkg;
3680 } 4043 }
3681 4044
3682 warn "unloading all perl modules loaded from $LIBDIR"; 4045 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3683 while (my ($k, $v) = each %INC) { 4046 while (my ($k, $v) = each %INC) {
3684 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4047 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3685 4048
3686 warn "... unloading $k"; 4049 trace "... unloading $k";
3687 delete $INC{$k}; 4050 delete $INC{$k};
3688 4051
3689 $k =~ s/\.pm$//; 4052 $k =~ s/\.pm$//;
3690 $k =~ s/\//::/g; 4053 $k =~ s/\//::/g;
3691 4054
… …
3694 } 4057 }
3695 4058
3696 clear_package $k; 4059 clear_package $k;
3697 } 4060 }
3698 4061
3699 warn "getting rid of safe::, as good as possible"; 4062 trace "perl_reload: getting rid of safe::, as good as possible";
3700 clear_package "safe::$_" 4063 clear_package "safe::$_"
3701 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4064 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3702 4065
3703 warn "unloading cf.pm \"a bit\""; 4066 trace "perl_reload: unloading cf.pm \"a bit\"";
3704 delete $INC{"cf.pm"}; 4067 delete $INC{"cf.pm"};
3705 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4068 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3706 4069
3707 # don't, removes xs symbols, too, 4070 # don't, removes xs symbols, too,
3708 # and global variables created in xs 4071 # and global variables created in xs
3709 #clear_package __PACKAGE__; 4072 #clear_package __PACKAGE__;
3710 4073
3711 warn "unload completed, starting to reload now"; 4074 info "perl_reload: unload completed, starting to reload now";
3712 4075
3713 warn "reloading cf.pm"; 4076 trace "perl_reload: reloading cf.pm";
3714 require cf; 4077 require cf;
3715 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 4078 cf::_connect_to_perl_1;
3716 4079
3717 warn "loading config and database again"; 4080 trace "perl_reload: loading config and database again";
3718 cf::reload_config; 4081 cf::reload_config;
3719 4082
3720 warn "loading extensions"; 4083 trace "perl_reload: loading extensions";
3721 cf::load_extensions; 4084 cf::load_extensions;
3722 4085
3723 if ($REATTACH_ON_RELOAD) { 4086 if ($REATTACH_ON_RELOAD) {
3724 warn "reattaching attachments to objects/players"; 4087 trace "perl_reload: reattaching attachments to objects/players";
3725 _global_reattach; # objects, sockets 4088 _global_reattach; # objects, sockets
3726 warn "reattaching attachments to maps"; 4089 trace "perl_reload: reattaching attachments to maps";
3727 reattach $_ for values %MAP; 4090 reattach $_ for values %MAP;
3728 warn "reattaching attachments to players"; 4091 trace "perl_reload: reattaching attachments to players";
3729 reattach $_ for values %PLAYER; 4092 reattach $_ for values %PLAYER;
3730 } 4093 }
3731 4094
3732 warn "running post_init jobs"; 4095 cf::_post_init 1;
3733 (pop @POST_INIT)->(1) while @POST_INIT;
3734 4096
3735 warn "leaving sync_job"; 4097 trace "perl_reload: leaving sync_job";
3736 4098
3737 1 4099 1
3738 } or do { 4100 } or do {
3739 warn $@; 4101 error $@;
3740 cf::cleanup "error while reloading, exiting."; 4102 cf::cleanup "perl_reload: error, exiting.";
3741 }; 4103 };
3742 4104
3743 warn "reloaded";
3744 --$RELOAD; 4105 --$RELOAD;
3745 } 4106 }
3746 4107
3747 $t1 = EV::time - $t1; 4108 $t1 = AE::time - $t1;
3748 warn "reload completed in ${t1}s\n"; 4109 info "perl_reload: completed in ${t1}s\n";
3749}; 4110};
3750 4111
3751our $RELOAD_WATCHER; # used only during reload 4112our $RELOAD_WATCHER; # used only during reload
3752 4113
3753sub reload_perl() { 4114sub reload_perl() {
… …
3755 # coro crashes during coro_state_free->destroy here. 4116 # coro crashes during coro_state_free->destroy here.
3756 4117
3757 $RELOAD_WATCHER ||= cf::async { 4118 $RELOAD_WATCHER ||= cf::async {
3758 Coro::AIO::aio_wait cache_extensions; 4119 Coro::AIO::aio_wait cache_extensions;
3759 4120
3760 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 4121 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3761 do_reload_perl; 4122 do_reload_perl;
3762 undef $RELOAD_WATCHER; 4123 undef $RELOAD_WATCHER;
3763 }; 4124 };
3764 }; 4125 };
3765} 4126}
… …
3774 reload_perl; 4135 reload_perl;
3775 }; 4136 };
3776 } 4137 }
3777}; 4138};
3778 4139
3779unshift @INC, $LIBDIR; 4140#############################################################################
3780 4141
3781my $bug_warning = 0; 4142my $bug_warning = 0;
3782 4143
3783our @WAIT_FOR_TICK;
3784our @WAIT_FOR_TICK_BEGIN;
3785
3786sub wait_for_tick { 4144sub wait_for_tick() {
3787 return if tick_inhibit || $Coro::current == $Coro::main; 4145 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3788 4146
3789 my $signal = new Coro::Signal; 4147 $WAIT_FOR_TICK->wait;
3790 push @WAIT_FOR_TICK, $signal;
3791 $signal->wait;
3792} 4148}
3793 4149
3794sub wait_for_tick_begin { 4150sub wait_for_tick_begin() {
3795 return if tick_inhibit || $Coro::current == $Coro::main; 4151 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3796 4152
3797 my $signal = new Coro::Signal; 4153 my $signal = new Coro::Signal;
3798 push @WAIT_FOR_TICK_BEGIN, $signal; 4154 push @WAIT_FOR_TICK_BEGIN, $signal;
3799 $signal->wait; 4155 $signal->wait;
3800} 4156}
… …
3804 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4160 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3805 unless ++$bug_warning > 10; 4161 unless ++$bug_warning > 10;
3806 return; 4162 return;
3807 } 4163 }
3808 4164
3809 cf::server_tick; # one server iteration 4165 cf::one_tick; # one server iteration
4166
4167 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3810 4168
3811 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4169 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3812 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4170 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3813 Coro::async_pool { 4171 Coro::async_pool {
3814 $Coro::current->{desc} = "runtime saver"; 4172 $Coro::current->{desc} = "runtime saver";
3815 write_runtime_sync 4173 write_runtime_sync
3816 or warn "ERROR: unable to write runtime file: $!"; 4174 or error "ERROR: unable to write runtime file: $!";
3817 }; 4175 };
3818 } 4176 }
3819 4177
3820 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4178 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3821 $sig->send; 4179 $sig->send;
3822 } 4180 }
3823 while (my $sig = shift @WAIT_FOR_TICK) { 4181 $WAIT_FOR_TICK->broadcast;
3824 $sig->send;
3825 }
3826 4182
3827 $LOAD = ($NOW - $TICK_START) / $TICK; 4183 $LOAD = ($NOW - $TICK_START) / $TICK;
3828 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4184 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3829 4185
3830 if (0) { 4186 if (0) {
3831 if ($NEXT_TICK) { 4187 if ($NEXT_TICK) {
3832 my $jitter = $TICK_START - $NEXT_TICK; 4188 my $jitter = $TICK_START - $NEXT_TICK;
3833 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4189 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3834 warn "jitter $JITTER\n";#d# 4190 debug "jitter $JITTER\n";#d#
3835 } 4191 }
3836 } 4192 }
3837} 4193}
3838 4194
3839{ 4195{
3840 # configure BDB 4196 # configure BDB
3841 4197
3842 BDB::min_parallel 8; 4198 BDB::min_parallel 16;
3843 BDB::max_poll_reqs $TICK * 0.1; 4199 BDB::max_poll_reqs $TICK * 0.1;
3844 $AnyEvent::BDB::WATCHER->priority (1); 4200 #$AnyEvent::BDB::WATCHER->priority (1);
3845 4201
3846 unless ($DB_ENV) { 4202 unless ($DB_ENV) {
3847 $DB_ENV = BDB::db_env_create; 4203 $DB_ENV = BDB::db_env_create;
3848 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4204 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3849 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4205 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
3884 IO::AIO::min_parallel 8; 4240 IO::AIO::min_parallel 8;
3885 IO::AIO::max_poll_time $TICK * 0.1; 4241 IO::AIO::max_poll_time $TICK * 0.1;
3886 undef $AnyEvent::AIO::WATCHER; 4242 undef $AnyEvent::AIO::WATCHER;
3887} 4243}
3888 4244
3889my $_log_backtrace; 4245our $_log_backtrace;
4246our $_log_backtrace_last;
3890 4247
3891sub _log_backtrace { 4248sub _log_backtrace {
3892 my ($msg, @addr) = @_; 4249 my ($msg, @addr) = @_;
3893 4250
3894 $msg =~ s/\n//; 4251 $msg =~ s/\n$//;
3895 4252
4253 if ($_log_backtrace_last eq $msg) {
4254 LOG llevInfo, "[ABT] $msg\n";
4255 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3896 # limit the # of concurrent backtraces 4256 # limit the # of concurrent backtraces
3897 if ($_log_backtrace < 2) { 4257 } elsif ($_log_backtrace < 2) {
4258 $_log_backtrace_last = $msg;
3898 ++$_log_backtrace; 4259 ++$_log_backtrace;
3899 my $perl_bt = Carp::longmess $msg; 4260 my $perl_bt = Carp::longmess $msg;
3900 async { 4261 async {
3901 $Coro::current->{desc} = "abt $msg"; 4262 $Coro::current->{desc} = "abt $msg";
3902 4263
… …
3922 LOG llevInfo, "[ABT] $_\n" for @bt; 4283 LOG llevInfo, "[ABT] $_\n" for @bt;
3923 --$_log_backtrace; 4284 --$_log_backtrace;
3924 }; 4285 };
3925 } else { 4286 } else {
3926 LOG llevInfo, "[ABT] $msg\n"; 4287 LOG llevInfo, "[ABT] $msg\n";
3927 LOG llevInfo, "[ABT] [suppressed]\n"; 4288 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3928 } 4289 }
3929} 4290}
3930 4291
3931# load additional modules 4292# load additional modules
3932require "cf/$_.pm" for @EXTRA_MODULES; 4293require "cf/$_.pm" for @EXTRA_MODULES;
4294cf::_connect_to_perl_2;
3933 4295
3934END { cf::emergency_save } 4296END { cf::emergency_save }
3935 4297
39361 42981
3937 4299

Diff Legend

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