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

Diff Legend

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