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.426 by root, Thu Apr 24 04:40:31 2008 UTC vs.
Revision 1.560 by root, Fri Apr 22 02:03:12 2011 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 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# <http://www.gnu.org/licenses/>.
18# 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 utf8; 25use common::sense;
25use strict;
26 26
27use Symbol; 27use Symbol;
28use List::Util; 28use List::Util;
29use Socket; 29use Socket;
30use EV 3.2; 30use EV;
31use Opcode; 31use Opcode;
32use Safe; 32use Safe;
33use Safe::Hole; 33use Safe::Hole;
34use Storable (); 34use Storable ();
35use Carp ();
35 36
37use Guard ();
36use Coro 4.50 (); 38use Coro ();
37use Coro::State; 39use Coro::State;
38use Coro::Handle; 40use Coro::Handle;
39use Coro::EV; 41use Coro::EV;
42use Coro::AnyEvent;
40use Coro::Timer; 43use Coro::Timer;
41use Coro::Signal; 44use Coro::Signal;
42use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
43use Coro::AIO; 48use Coro::AIO;
44use Coro::BDB; 49use Coro::BDB 1.6;
45use Coro::Storable; 50use Coro::Storable;
46use Coro::Util (); 51use Coro::Util ();
47 52
48use JSON::XS 2.01 (); 53use JSON::XS 2.01 ();
49use BDB (); 54use BDB ();
50use Data::Dumper; 55use Data::Dumper;
51use Digest::MD5;
52use Fcntl; 56use Fcntl;
53use YAML (); 57use YAML::XS ();
54use IO::AIO 2.51 (); 58use IO::AIO ();
55use Time::HiRes; 59use Time::HiRes;
56use Compress::LZF; 60use Compress::LZF;
57use Digest::MD5 (); 61use Digest::MD5 ();
62
63AnyEvent::detect;
58 64
59# configure various modules to our taste 65# configure various modules to our taste
60# 66#
61$Storable::canonical = 1; # reduce rsync transfers 67$Storable::canonical = 1; # reduce rsync transfers
62Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 68Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
69
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71
72# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
63Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
64 75
65$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 76# strictly for debugging
77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
66 78
67sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
68 82
69our %COMMAND = (); 83our %COMMAND = ();
70our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
71 85
72our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
73our %EXTCMD = (); 87our %EXTCMD = ();
74our %EXTICMD = (); 88our %EXTICMD = ();
75our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
76our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
77 91
78our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
79our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
80 96
81our $CONFDIR = confdir; 97our $CONFDIR = confdir;
98
82our $DATADIR = datadir; 99our $DATADIR = datadir;
83our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
84our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
85our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
103
86our $LOCALDIR = localdir; 104our $LOCALDIR = localdir;
87our $TMPDIR = "$LOCALDIR/" . tmpdir; 105our $TMPDIR = "$LOCALDIR/" . tmpdir;
88our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 106our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
89our $PLAYERDIR = "$LOCALDIR/" . playerdir; 107our $PLAYERDIR = "$LOCALDIR/" . playerdir;
90our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
91our $BDBDIR = "$LOCALDIR/db"; 109our $BDBDIR = "$LOCALDIR/db";
110our $PIDFILE = "$LOCALDIR/pid";
111our $RUNTIMEFILE = "$LOCALDIR/runtime";
112
92our %RESOURCE; 113our %RESOURCE; # unused
114
115our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000;
117
118our $MAX_LINKS = 32; # how many chained exits to follow
119our $VERBOSE_IO = 1;
93 120
94our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 121our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
95our $AIO_POLL_WATCHER;
96our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 122our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
97our $NEXT_TICK; 123our $NEXT_TICK;
98our $USE_FSYNC = 1; # use fsync to write maps - default off 124our $USE_FSYNC = 1; # use fsync to write maps - default on
99 125
100our $BDB_POLL_WATCHER;
101our $BDB_DEADLOCK_WATCHER; 126our $BDB_DEADLOCK_WATCHER;
102our $BDB_CHECKPOINT_WATCHER; 127our $BDB_CHECKPOINT_WATCHER;
103our $BDB_TRICKLE_WATCHER; 128our $BDB_TRICKLE_WATCHER;
104our $DB_ENV; 129our $DB_ENV;
105 130
131our @EXTRA_MODULES = qw(pod match mapscript incloader);
132
106our %CFG; 133our %CFG;
107 134
108our $UPTIME; $UPTIME ||= time; 135our $UPTIME; $UPTIME ||= time;
109our $RUNTIME; 136our $RUNTIME;
110our $NOW; 137our $NOW;
… …
119our $LOAD; # a number between 0 (idle) and 1 (too many objects) 146our $LOAD; # a number between 0 (idle) and 1 (too many objects)
120our $LOADAVG; # same thing, but with alpha-smoothing 147our $LOADAVG; # same thing, but with alpha-smoothing
121our $JITTER; # average jitter 148our $JITTER; # average jitter
122our $TICK_START; # for load detecting purposes 149our $TICK_START; # for load detecting purposes
123 150
151our @POST_INIT;
152
153our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
154our $REALLY_UNLOOP; # never set to true, please :)
155
124binmode STDOUT; 156binmode STDOUT;
125binmode STDERR; 157binmode STDERR;
126 158
127# read virtual server time, if available 159# read virtual server time, if available
128unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 160unless ($RUNTIME || !-e $RUNTIMEFILE) {
129 open my $fh, "<", "$LOCALDIR/runtime" 161 open my $fh, "<", $RUNTIMEFILE
130 or die "unable to read runtime file: $!"; 162 or die "unable to read $RUNTIMEFILE file: $!";
131 $RUNTIME = <$fh> + 0.; 163 $RUNTIME = <$fh> + 0.;
132} 164}
165
166eval "sub TICK() { $TICK } 1" or die;
133 167
134mkdir $_ 168mkdir $_
135 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 169 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
136 170
137our $EMERGENCY_POSITION; 171our $EMERGENCY_POSITION;
138 172
139sub cf::map::normalise; 173sub cf::map::normalise;
174
175sub in_main() {
176 $Coro::current == $Coro::main
177}
178
179#############################################################################
180
181%REFLECT = ();
182for (@REFLECT) {
183 my $reflect = JSON::XS::decode_json $_;
184 $REFLECT{$reflect->{class}} = $reflect;
185}
186
187# this is decidedly evil
188$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
140 189
141############################################################################# 190#############################################################################
142 191
143=head2 GLOBAL VARIABLES 192=head2 GLOBAL VARIABLES
144 193
… …
186from wherever your confdir points to. 235from wherever your confdir points to.
187 236
188=item cf::wait_for_tick, cf::wait_for_tick_begin 237=item cf::wait_for_tick, cf::wait_for_tick_begin
189 238
190These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 239These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
191returns directly I<after> the tick processing (and consequently, can only wake one process 240returns directly I<after> the tick processing (and consequently, can only wake one thread
192per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 241per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
193 242
243=cut
244
245sub wait_for_tick();
246sub wait_for_tick_begin();
247
194=item @cf::INVOKE_RESULTS 248=item @cf::INVOKE_RESULTS
195 249
196This array contains the results of the last C<invoke ()> call. When 250This array contains the results of the last C<invoke ()> call. When
197C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 251C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
198that call. 252that call.
199 253
254=item %cf::REFLECT
255
256Contains, for each (C++) class name, a hash reference with information
257about object members (methods, scalars, arrays and flags) and other
258metadata, which is useful for introspection.
259
200=back 260=back
201 261
202=cut 262=cut
203 263
204BEGIN { 264sub error(@) { LOG llevError, join "", @_ }
205 *CORE::GLOBAL::warn = sub { 265sub warn (@) { LOG llevWarn , join "", @_ }
266sub info (@) { LOG llevInfo , join "", @_ }
267sub debug(@) { LOG llevDebug, join "", @_ }
268sub trace(@) { LOG llevTrace, join "", @_ }
269
270$Coro::State::WARNHOOK = sub {
206 my $msg = join "", @_; 271 my $msg = join "", @_;
207 272
208 $msg .= "\n" 273 $msg .= "\n"
209 unless $msg =~ /\n$/; 274 unless $msg =~ /\n$/;
210 275
211 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 276 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
212 277
213 LOG llevError, $msg; 278 LOG llevWarn, $msg;
214 }; 279};
215}
216 280
217$Coro::State::DIEHOOK = sub { 281$Coro::State::DIEHOOK = sub {
218 return unless $^S eq 0; # "eq", not "==" 282 return unless $^S eq 0; # "eq", not "=="
219 283
220 if ($Coro::current == $Coro::main) {#d# 284 error Carp::longmess $_[0];
285
286 if (in_main) {#d#
221 warn "DIEHOOK called in main context, Coro bug?\n";#d# 287 error "DIEHOOK called in main context, Coro bug?\n";#d#
222 return;#d# 288 return;#d#
223 }#d# 289 }#d#
224 290
225 # kill coroutine otherwise 291 # kill coroutine otherwise
226 warn Carp::longmess $_[0];
227 Coro::terminate 292 Coro::terminate
228}; 293};
229
230$SIG{__DIE__} = sub { }; #d#?
231 294
232@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 295@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
233@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 296@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
234@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 297@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
235@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 298@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
242for my $pkg (qw( 305for my $pkg (qw(
243 cf::global cf::attachable 306 cf::global cf::attachable
244 cf::object cf::object::player 307 cf::object cf::object::player
245 cf::client cf::player 308 cf::client cf::player
246 cf::arch cf::living 309 cf::arch cf::living
310 cf::map cf::mapspace
247 cf::map cf::party cf::region 311 cf::party cf::region
248)) { 312)) {
249 no strict 'refs';
250 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 313 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
251} 314}
252 315
253$EV::DIED = sub { 316$EV::DIED = sub {
254 warn "error in event callback: @_"; 317 Carp::cluck "error in event callback: @_";
255}; 318};
319
320#############################################################################
321
322sub fork_call(&@);
323sub get_slot($;$$);
256 324
257############################################################################# 325#############################################################################
258 326
259=head2 UTILITY FUNCTIONS 327=head2 UTILITY FUNCTIONS
260 328
… …
281 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 349 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
282 $d 350 $d
283 } || "[unable to dump $_[0]: '$@']"; 351 } || "[unable to dump $_[0]: '$@']";
284} 352}
285 353
354=item $scalar = load_file $path
355
356Loads the given file from path and returns its contents. Croaks on error
357and can block.
358
359=cut
360
361sub load_file($) {
362 0 <= aio_load $_[0], my $data
363 or Carp::croak "$_[0]: $!";
364
365 $data
366}
367
286=item $ref = cf::decode_json $json 368=item $ref = cf::decode_json $json
287 369
288Converts a JSON string into the corresponding perl data structure. 370Converts a JSON string into the corresponding perl data structure.
289 371
290=item $json = cf::encode_json $ref 372=item $json = cf::encode_json $ref
… …
296our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 378our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
297 379
298sub encode_json($) { $json_coder->encode ($_[0]) } 380sub encode_json($) { $json_coder->encode ($_[0]) }
299sub decode_json($) { $json_coder->decode ($_[0]) } 381sub decode_json($) { $json_coder->decode ($_[0]) }
300 382
383=item $ref = cf::decode_storable $scalar
384
385Same as Coro::Storable::thaw, so blocks.
386
387=cut
388
389BEGIN { *decode_storable = \&Coro::Storable::thaw }
390
391=item $ref = cf::decode_yaml $scalar
392
393Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
394
395=cut
396
397sub decode_yaml($) {
398 fork_call { YAML::XS::Load $_[0] } @_
399}
400
401=item $scalar = cf::unlzf $scalar
402
403Same as Compress::LZF::compress, but takes server ticks into account, so
404blocks.
405
406=cut
407
408sub unlzf($) {
409 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
410 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
411 Compress::LZF::decompress $_[0]
412}
413
414=item cf::post_init { BLOCK }
415
416Execute the given codeblock, I<after> all extensions have been (re-)loaded,
417but I<before> the server starts ticking again.
418
419The codeblock will have a single boolean argument to indicate whether this
420is a reload or not.
421
422=cut
423
424sub post_init(&) {
425 push @POST_INIT, shift;
426}
427
428sub _post_init {
429 trace "running post_init jobs";
430
431 # run them in parallel...
432
433 my @join;
434
435 while () {
436 push @join, map &Coro::async ($_, 0), @POST_INIT;
437 @POST_INIT = ();
438
439 @join or last;
440
441 (pop @join)->join;
442 }
443}
444
301=item cf::lock_wait $string 445=item cf::lock_wait $string
302 446
303Wait until the given lock is available. See cf::lock_acquire. 447Wait until the given lock is available. See cf::lock_acquire.
304 448
305=item my $lock = cf::lock_acquire $string 449=item my $lock = cf::lock_acquire $string
306 450
307Wait until the given lock is available and then acquires it and returns 451Wait until the given lock is available and then acquires it and returns
308a Coro::guard object. If the guard object gets destroyed (goes out of scope, 452a L<Guard> object. If the guard object gets destroyed (goes out of scope,
309for example when the coroutine gets canceled), the lock is automatically 453for example when the coroutine gets canceled), the lock is automatically
310returned. 454returned.
311 455
312Locks are *not* recursive, locking from the same coro twice results in a 456Locks are *not* recursive, locking from the same coro twice results in a
313deadlocked coro. 457deadlocked coro.
… …
319 463
320Return true if the lock is currently active, i.e. somebody has locked it. 464Return true if the lock is currently active, i.e. somebody has locked it.
321 465
322=cut 466=cut
323 467
324our %LOCK; 468our $LOCKS = new Coro::SemaphoreSet;
325our %LOCKER;#d#
326 469
327sub lock_wait($) { 470sub lock_wait($) {
328 my ($key) = @_; 471 $LOCKS->wait ($_[0]);
329
330 if ($LOCKER{$key} == $Coro::current) {#d#
331 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
332 return;#d#
333 }#d#
334
335 # wait for lock, if any
336 while ($LOCK{$key}) {
337 push @{ $LOCK{$key} }, $Coro::current;
338 Coro::schedule;
339 }
340} 472}
341 473
342sub lock_acquire($) { 474sub lock_acquire($) {
343 my ($key) = @_; 475 $LOCKS->guard ($_[0])
344
345 # wait, to be sure we are not locked
346 lock_wait $key;
347
348 $LOCK{$key} = [];
349 $LOCKER{$key} = $Coro::current;#d#
350
351 Coro::guard {
352 delete $LOCKER{$key};#d#
353 # wake up all waiters, to be on the safe side
354 $_->ready for @{ delete $LOCK{$key} };
355 }
356} 476}
357 477
358sub lock_active($) { 478sub lock_active($) {
359 my ($key) = @_; 479 $LOCKS->count ($_[0]) < 1
360
361 ! ! $LOCK{$key}
362} 480}
363 481
364sub freeze_mainloop { 482sub freeze_mainloop {
365 tick_inhibit_inc; 483 tick_inhibit_inc;
366 484
367 Coro::guard \&tick_inhibit_dec; 485 &Guard::guard (\&tick_inhibit_dec);
368} 486}
369 487
370=item cf::periodic $interval, $cb 488=item cf::periodic $interval, $cb
371 489
372Like EV::periodic, but randomly selects a starting point so that the actions 490Like EV::periodic, but randomly selects a starting point so that the actions
373get spread over timer. 491get spread over time.
374 492
375=cut 493=cut
376 494
377sub periodic($$) { 495sub periodic($$) {
378 my ($interval, $cb) = @_; 496 my ($interval, $cb) = @_;
… …
382 EV::periodic $start, $interval, 0, $cb 500 EV::periodic $start, $interval, 0, $cb
383} 501}
384 502
385=item cf::get_slot $time[, $priority[, $name]] 503=item cf::get_slot $time[, $priority[, $name]]
386 504
387Allocate $time seconds of blocking CPU time at priority C<$priority>: 505Allocate $time seconds of blocking CPU time at priority C<$priority>
388This call blocks and returns only when you have at least C<$time> seconds 506(default: 0): This call blocks and returns only when you have at least
389of cpu time till the next tick. The slot is only valid till the next cede. 507C<$time> seconds of cpu time till the next tick. The slot is only valid
508till the next cede.
509
510Background jobs should use a priority les than zero, interactive jobs
511should use 100 or more.
390 512
391The optional C<$name> can be used to identify the job to run. It might be 513The optional C<$name> can be used to identify the job to run. It might be
392used for statistical purposes and should identify the same time-class. 514used for statistical purposes and should identify the same time-class.
393 515
394Useful for short background jobs. 516Useful for short background jobs.
395 517
396=cut 518=cut
397 519
398our @SLOT_QUEUE; 520our @SLOT_QUEUE;
399our $SLOT_QUEUE; 521our $SLOT_QUEUE;
522our $SLOT_DECAY = 0.9;
400 523
401$SLOT_QUEUE->cancel if $SLOT_QUEUE; 524$SLOT_QUEUE->cancel if $SLOT_QUEUE;
402$SLOT_QUEUE = Coro::async { 525$SLOT_QUEUE = Coro::async {
403 $Coro::current->desc ("timeslot manager"); 526 $Coro::current->desc ("timeslot manager");
404 527
405 my $signal = new Coro::Signal; 528 my $signal = new Coro::Signal;
529 my $busy;
406 530
407 while () { 531 while () {
408 next_job: 532 next_job:
533
409 my $avail = cf::till_tick; 534 my $avail = cf::till_tick;
410 if ($avail > 0.01) { 535
411 for (0 .. $#SLOT_QUEUE) { 536 for (0 .. $#SLOT_QUEUE) {
412 if ($SLOT_QUEUE[$_][0] < $avail) { 537 if ($SLOT_QUEUE[$_][0] <= $avail) {
538 $busy = 0;
413 my $job = splice @SLOT_QUEUE, $_, 1, (); 539 my $job = splice @SLOT_QUEUE, $_, 1, ();
414 $job->[2]->send; 540 $job->[2]->send;
415 Coro::cede; 541 Coro::cede;
416 goto next_job; 542 goto next_job;
417 } 543 } else {
544 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
418 } 545 }
419 } 546 }
420 547
421 if (@SLOT_QUEUE) { 548 if (@SLOT_QUEUE) {
422 # we do not use wait_for_tick() as it returns immediately when tick is inactive 549 # we do not use wait_for_tick() as it returns immediately when tick is inactive
423 push @cf::WAIT_FOR_TICK, $signal; 550 push @cf::WAIT_FOR_TICK, $signal;
424 $signal->wait; 551 $signal->wait;
425 } else { 552 } else {
553 $busy = 0;
426 Coro::schedule; 554 Coro::schedule;
427 } 555 }
428 } 556 }
429}; 557};
430 558
431sub get_slot($;$$) { 559sub get_slot($;$$) {
432 return if tick_inhibit || $Coro::current == $Coro::main; 560 return if tick_inhibit || $Coro::current == $Coro::main;
433 561
434 my ($time, $pri, $name) = @_; 562 my ($time, $pri, $name) = @_;
435 563
436 $time = $TICK * .6 if $time > $TICK * .6; 564 $time = clamp $time, 0.01, $TICK * .6;
565
437 my $sig = new Coro::Signal; 566 my $sig = new Coro::Signal;
438 567
439 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 568 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
440 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 569 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
441 $SLOT_QUEUE->ready; 570 $SLOT_QUEUE->ready;
… …
467=cut 596=cut
468 597
469sub sync_job(&) { 598sub sync_job(&) {
470 my ($job) = @_; 599 my ($job) = @_;
471 600
472 if ($Coro::current == $Coro::main) { 601 if (in_main) {
473 my $time = EV::time; 602 my $time = AE::time;
474 603
475 # this is the main coro, too bad, we have to block 604 # this is the main coro, too bad, we have to block
476 # till the operation succeeds, freezing the server :/ 605 # till the operation succeeds, freezing the server :/
477 606
478 LOG llevError, Carp::longmess "sync job";#d# 607 #LOG llevError, Carp::longmess "sync job";#d#
479 608
480 my $freeze_guard = freeze_mainloop; 609 my $freeze_guard = freeze_mainloop;
481 610
482 my $busy = 1; 611 my $busy = 1;
483 my @res; 612 my @res;
484 613
485 (async { 614 (async {
486 $Coro::current->desc ("sync job coro"); 615 $Coro::current->desc ("sync job coro");
487 @res = eval { $job->() }; 616 @res = eval { $job->() };
488 warn $@ if $@; 617 error $@ if $@;
489 undef $busy; 618 undef $busy;
490 })->prio (Coro::PRIO_MAX); 619 })->prio (Coro::PRIO_MAX);
491 620
492 while ($busy) { 621 while ($busy) {
493 if (Coro::nready) { 622 if (Coro::nready) {
… …
495 } else { 624 } else {
496 EV::loop EV::LOOP_ONESHOT; 625 EV::loop EV::LOOP_ONESHOT;
497 } 626 }
498 } 627 }
499 628
500 my $time = EV::time - $time; 629 my $time = AE::time - $time;
501 630
502 $TICK_START += $time; # do not account sync jobs to server load 631 $TICK_START += $time; # do not account sync jobs to server load
503 632
504 wantarray ? @res : $res[0] 633 wantarray ? @res : $res[0]
505 } else { 634 } else {
… …
527 $EXT_CORO{$coro+0} = $coro; 656 $EXT_CORO{$coro+0} = $coro;
528 657
529 $coro 658 $coro
530} 659}
531 660
532=item fork_call { }, $args 661=item fork_call { }, @args
533 662
534Executes the given code block with the given arguments in a seperate 663Executes the given code block with the given arguments in a seperate
535process, returning the results. Everything must be serialisable with 664process, returning the results. Everything must be serialisable with
536Coro::Storable. May, of course, block. Note that the executed sub may 665Coro::Storable. May, of course, block. Note that the executed sub may
537never block itself or use any form of event handling. 666never block itself or use any form of event handling.
538 667
539=cut 668=cut
540 669
670sub post_fork {
671 reset_signals;
672}
673
541sub fork_call(&@) { 674sub fork_call(&@) {
542 my ($cb, @args) = @_; 675 my ($cb, @args) = @_;
543 676
544 # we seemingly have to make a local copy of the whole thing, 677 # we seemingly have to make a local copy of the whole thing,
545 # otherwise perl prematurely frees the stuff :/ 678 # otherwise perl prematurely frees the stuff :/
546 # TODO: investigate and fix (likely this will be rather laborious) 679 # TODO: investigate and fix (likely this will be rather laborious)
547 680
548 my @res = Coro::Util::fork_eval { 681 my @res = Coro::Util::fork_eval {
549 reset_signals; 682 cf::post_fork;
550 &$cb 683 &$cb
551 }, @args; 684 } @args;
552 685
553 wantarray ? @res : $res[-1] 686 wantarray ? @res : $res[-1]
687}
688
689sub objinfo {
690 (
691 "counter value" => cf::object::object_count,
692 "objects created" => cf::object::create_count,
693 "objects destroyed" => cf::object::destroy_count,
694 "freelist size" => cf::object::free_count,
695 "allocated objects" => cf::object::objects_size,
696 "active objects" => cf::object::actives_size,
697 )
554} 698}
555 699
556=item $coin = coin_from_name $name 700=item $coin = coin_from_name $name
557 701
558=cut 702=cut
… …
595within each server. 739within each server.
596 740
597=cut 741=cut
598 742
599sub db_table($) { 743sub db_table($) {
744 cf::error "db_get called from main context"
745 if $Coro::current == $Coro::main;
746
600 my ($name) = @_; 747 my ($name) = @_;
601 my $db = BDB::db_create $DB_ENV; 748 my $db = BDB::db_create $DB_ENV;
602 749
603 eval { 750 eval {
604 $db->set_flags (BDB::CHKSUM); 751 $db->set_flags (BDB::CHKSUM);
… …
614} 761}
615 762
616our $DB; 763our $DB;
617 764
618sub db_init { 765sub db_init {
619 cf::sync_job {
620 $DB ||= db_table "db"; 766 $DB ||= db_table "db";
621 };
622} 767}
623 768
624sub db_get($$) { 769sub db_get($$) {
625 my $key = "$_[0]/$_[1]"; 770 my $key = "$_[0]/$_[1]";
626 771
627 cf::sync_job { 772 cf::error "db_get called from main context"
773 if $Coro::current == $Coro::main;
774
628 BDB::db_get $DB, undef, $key, my $data; 775 BDB::db_get $DB, undef, $key, my $data;
629 776
630 $! ? () 777 $! ? ()
631 : $data 778 : $data
632 }
633} 779}
634 780
635sub db_put($$$) { 781sub db_put($$$) {
636 BDB::dbreq_pri 4; 782 BDB::dbreq_pri 4;
637 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 783 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
665 811
666 my @data; 812 my @data;
667 my $md5; 813 my $md5;
668 814
669 for (0 .. $#$src) { 815 for (0 .. $#$src) {
670 0 <= aio_load $src->[$_], $data[$_] 816 $data[$_] = load_file $src->[$_];
671 or Carp::croak "$src->[$_]: $!";
672 } 817 }
673 818
674 # if processing is expensive, check 819 # if processing is expensive, check
675 # checksum first 820 # checksum first
676 if (1) { 821 if (1) {
… …
693 838
694 my $t1 = Time::HiRes::time; 839 my $t1 = Time::HiRes::time;
695 my $data = $process->(\@data); 840 my $data = $process->(\@data);
696 my $t2 = Time::HiRes::time; 841 my $t2 = Time::HiRes::time;
697 842
698 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 843 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
699 844
700 db_put cache => "$id/data", $data; 845 db_put cache => "$id/data", $data;
701 db_put cache => "$id/md5" , $md5; 846 db_put cache => "$id/md5" , $md5;
702 db_put cache => "$id/meta", $meta; 847 db_put cache => "$id/meta", $meta;
703 848
… …
713 858
714=cut 859=cut
715 860
716sub datalog($@) { 861sub datalog($@) {
717 my ($type, %kv) = @_; 862 my ($type, %kv) = @_;
718 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 863 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
719} 864}
720 865
721=back 866=back
722 867
723=cut 868=cut
724 869
725############################################################################# 870#############################################################################
726 871
727=head2 ATTACHABLE OBJECTS 872=head2 ATTACHABLE OBJECTS
728 873
729Many objects in crossfire are so-called attachable objects. That means you can 874Many objects in deliantra are so-called attachable objects. That means you can
730attach callbacks/event handlers (a collection of which is called an "attachment") 875attach callbacks/event handlers (a collection of which is called an "attachment")
731to it. All such attachable objects support the following methods. 876to it. All such attachable objects support the following methods.
732 877
733In the following description, CLASS can be any of C<global>, C<object> 878In the following description, CLASS can be any of C<global>, C<object>
734C<player>, C<client> or C<map> (i.e. the attachable objects in 879C<player>, C<client> or C<map> (i.e. the attachable objects in
… …
784=item cf::CLASS::attachment $name, ... 929=item cf::CLASS::attachment $name, ...
785 930
786Register an attachment by C<$name> through which attachable objects of the 931Register an attachment by C<$name> through which attachable objects of the
787given CLASS can refer to this attachment. 932given CLASS can refer to this attachment.
788 933
789Some classes such as crossfire maps and objects can specify attachments 934Some classes such as deliantra maps and objects can specify attachments
790that are attached at load/instantiate time, thus the need for a name. 935that are attached at load/instantiate time, thus the need for a name.
791 936
792These calls expect any number of the following handler/hook descriptions: 937These calls expect any number of the following handler/hook descriptions:
793 938
794=over 4 939=over 4
… …
918 1063
919 } elsif (exists $cb_id{$type}) { 1064 } elsif (exists $cb_id{$type}) {
920 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1065 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
921 1066
922 } elsif (ref $type) { 1067 } elsif (ref $type) {
923 warn "attaching objects not supported, ignoring.\n"; 1068 error "attaching objects not supported, ignoring.\n";
924 1069
925 } else { 1070 } else {
926 shift @arg; 1071 shift @arg;
927 warn "attach argument '$type' not supported, ignoring.\n"; 1072 error "attach argument '$type' not supported, ignoring.\n";
928 } 1073 }
929 } 1074 }
930} 1075}
931 1076
932sub _object_attach { 1077sub _object_attach {
… …
942 _attach $registry, $klass, @attach; 1087 _attach $registry, $klass, @attach;
943 } 1088 }
944 1089
945 $obj->{$name} = \%arg; 1090 $obj->{$name} = \%arg;
946 } else { 1091 } else {
947 warn "object uses attachment '$name' which is not available, postponing.\n"; 1092 info "object uses attachment '$name' which is not available, postponing.\n";
948 } 1093 }
949 1094
950 $obj->{_attachment}{$name} = undef; 1095 $obj->{_attachment}{$name} = undef;
951} 1096}
952 1097
… …
1011 1156
1012 for (@$callbacks) { 1157 for (@$callbacks) {
1013 eval { &{$_->[1]} }; 1158 eval { &{$_->[1]} };
1014 1159
1015 if ($@) { 1160 if ($@) {
1016 warn "$@";
1017 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1161 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1018 override; 1162 override;
1019 } 1163 }
1020 1164
1021 return 1 if $override; 1165 return 1 if $override;
1022 } 1166 }
… …
1085 1229
1086sub reattach { 1230sub reattach {
1087 # basically do the same as instantiate, without calling instantiate 1231 # basically do the same as instantiate, without calling instantiate
1088 my ($obj) = @_; 1232 my ($obj) = @_;
1089 1233
1234 # no longer needed after getting rid of delete_package?
1090 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1235 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1091 1236
1092 my $registry = $obj->registry; 1237 my $registry = $obj->registry;
1093 1238
1094 @$registry = (); 1239 @$registry = ();
1095 1240
… …
1100 for (@$attach) { 1245 for (@$attach) {
1101 my ($klass, @attach) = @$_; 1246 my ($klass, @attach) = @$_;
1102 _attach $registry, $klass, @attach; 1247 _attach $registry, $klass, @attach;
1103 } 1248 }
1104 } else { 1249 } else {
1105 warn "object uses attachment '$name' that is not available, postponing.\n"; 1250 info "object uses attachment '$name' that is not available, postponing.\n";
1106 } 1251 }
1107 } 1252 }
1108} 1253}
1109 1254
1110cf::attachable->attach ( 1255cf::attachable->attach (
… …
1137 my ($filename, $rdata, $objs) = @_; 1282 my ($filename, $rdata, $objs) = @_;
1138 1283
1139 sync_job { 1284 sync_job {
1140 if (length $$rdata) { 1285 if (length $$rdata) {
1141 utf8::decode (my $decname = $filename); 1286 utf8::decode (my $decname = $filename);
1142 warn sprintf "saving %s (%d,%d)\n", 1287 trace sprintf "saving %s (%d,%d)\n",
1143 $decname, length $$rdata, scalar @$objs; 1288 $decname, length $$rdata, scalar @$objs
1289 if $VERBOSE_IO;
1144 1290
1145 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1291 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1146 chmod SAVE_MODE, $fh; 1292 aio_chmod $fh, SAVE_MODE;
1147 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1293 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1148 aio_fsync $fh if $cf::USE_FSYNC; 1294 if ($cf::USE_FSYNC) {
1295 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;
1296 aio_fsync $fh;
1297 }
1149 close $fh; 1298 aio_close $fh;
1150 1299
1151 if (@$objs) { 1300 if (@$objs) {
1152 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1301 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1153 chmod SAVE_MODE, $fh; 1302 aio_chmod $fh, SAVE_MODE;
1154 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1303 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1155 aio_write $fh, 0, (length $data), $data, 0; 1304 aio_write $fh, 0, (length $data), $data, 0;
1156 aio_fsync $fh if $cf::USE_FSYNC; 1305 if ($cf::USE_FSYNC) {
1306 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;
1307 aio_fsync $fh;
1308 }
1157 close $fh; 1309 aio_close $fh;
1158 aio_rename "$filename.pst~", "$filename.pst"; 1310 aio_rename "$filename.pst~", "$filename.pst";
1159 } 1311 }
1160 } else { 1312 } else {
1161 aio_unlink "$filename.pst"; 1313 aio_unlink "$filename.pst";
1162 } 1314 }
1163 1315
1164 aio_rename "$filename~", $filename; 1316 aio_rename "$filename~", $filename;
1317
1318 $filename =~ s%/[^/]+$%%;
1319 aio_pathsync $filename if $cf::USE_FSYNC;
1165 } else { 1320 } else {
1166 warn "FATAL: $filename~: $!\n"; 1321 error "unable to save objects: $filename~: $!\n";
1167 } 1322 }
1168 } else { 1323 } else {
1169 aio_unlink $filename; 1324 aio_unlink $filename;
1170 aio_unlink "$filename.pst"; 1325 aio_unlink "$filename.pst";
1171 } 1326 }
… …
1195 my $st = eval { Coro::Storable::thaw $av }; 1350 my $st = eval { Coro::Storable::thaw $av };
1196 $av = $st->{objs}; 1351 $av = $st->{objs};
1197 } 1352 }
1198 1353
1199 utf8::decode (my $decname = $filename); 1354 utf8::decode (my $decname = $filename);
1200 warn sprintf "loading %s (%d,%d)\n", 1355 trace sprintf "loading %s (%d,%d)\n",
1201 $decname, length $data, scalar @{$av || []}; 1356 $decname, length $data, scalar @{$av || []}
1357 if $VERBOSE_IO;
1202 1358
1203 ($data, $av) 1359 ($data, $av)
1204} 1360}
1205 1361
1206=head2 COMMAND CALLBACKS 1362=head2 COMMAND CALLBACKS
… …
1262 my ($name, $cb) = @_; 1418 my ($name, $cb) = @_;
1263 1419
1264 $EXTICMD{$name} = $cb; 1420 $EXTICMD{$name} = $cb;
1265} 1421}
1266 1422
1423use File::Glob ();
1424
1267cf::player->attach ( 1425cf::player->attach (
1268 on_command => sub { 1426 on_unknown_command => sub {
1269 my ($pl, $name, $params) = @_; 1427 my ($pl, $name, $params) = @_;
1270 1428
1271 my $cb = $COMMAND{$name} 1429 my $cb = $COMMAND{$name}
1272 or return; 1430 or return;
1273 1431
… …
1296 1454
1297 $pl->ext_reply ($reply, @reply) 1455 $pl->ext_reply ($reply, @reply)
1298 if $reply; 1456 if $reply;
1299 1457
1300 } else { 1458 } else {
1301 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1459 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1302 } 1460 }
1303 1461
1304 cf::override; 1462 cf::override;
1305 }, 1463 },
1306); 1464);
1307 1465
1466# "readahead" all extensions
1467sub cache_extensions {
1468 my $grp = IO::AIO::aio_group;
1469
1470 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1471 for (grep /\.ext$/, @{$_[0]}) {
1472 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1473 }
1474 };
1475
1476 $grp
1477}
1478
1308sub load_extensions { 1479sub load_extensions {
1480 info "loading extensions...";
1481
1309 cf::sync_job { 1482 cf::sync_job {
1310 my %todo; 1483 my %todo;
1311 1484
1312 for my $path (<$LIBDIR/*.ext>) { 1485 for my $path (<$LIBDIR/*.ext>) {
1313 next unless -r $path; 1486 next unless -r $path;
… …
1331 1504
1332 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1505 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1333 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1506 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1334 1507
1335 $ext{source} = 1508 $ext{source} =
1336 "package $pkg; use strict; use utf8;\n" 1509 "package $pkg; use common::sense;\n"
1337 . "#line 1 \"$path\"\n{\n" 1510 . "#line 1 \"$path\"\n{\n"
1338 . $source 1511 . $source
1339 . "\n};\n1"; 1512 . "\n};\n1";
1340 1513
1341 $todo{$base} = \%ext; 1514 $todo{$base} = \%ext;
1342 } 1515 }
1343 1516
1517 my $pass = 0;
1344 my %done; 1518 my %done;
1345 while (%todo) { 1519 while (%todo) {
1346 my $progress; 1520 my $progress;
1347 1521
1522 ++$pass;
1523
1524 ext:
1348 while (my ($k, $v) = each %todo) { 1525 while (my ($k, $v) = each %todo) {
1349 for (split /,\s*/, $v->{meta}{depends}) { 1526 for (split /,\s*/, $v->{meta}{depends}) {
1350 goto skip 1527 next ext
1351 unless exists $done{$_}; 1528 unless exists $done{$_};
1352 } 1529 }
1353 1530
1354 warn "... loading '$k' into '$v->{pkg}'\n"; 1531 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1355 1532
1356 unless (eval $v->{source}) { 1533 my $active = eval $v->{source};
1534
1535 if (length $@) {
1357 my $msg = $@ ? "$v->{path}: $@\n" 1536 error "$v->{path}: $@\n";
1358 : "$v->{base}: extension inactive.\n";
1359 1537
1360 if (exists $v->{meta}{mandatory}) {
1361 warn $msg;
1362 cf::cleanup "mandatory extension failed to load, exiting."; 1538 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1363 } 1539 if exists $v->{meta}{mandatory};
1364 1540
1365 warn $msg; 1541 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1542 delete $todo{$k};
1543 } else {
1544 $done{$k} = delete $todo{$k};
1545 push @EXTS, $v->{pkg};
1546 $progress = 1;
1547
1548 info "$v->{base}: extension inactive.\n"
1549 unless $active;
1366 } 1550 }
1367
1368 $done{$k} = delete $todo{$k};
1369 push @EXTS, $v->{pkg};
1370 $progress = 1;
1371 } 1551 }
1372 1552
1373 skip: 1553 unless ($progress) {
1374 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1554 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1375 unless $progress; 1555
1556 while (my ($k, $v) = each %todo) {
1557 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1558 if exists $v->{meta}{mandatory};
1559 }
1560 }
1376 } 1561 }
1377 }; 1562 };
1378} 1563}
1379 1564
1380############################################################################# 1565#############################################################################
1381 1566
1382=back 1567=back
1383 1568
1384=head2 CORE EXTENSIONS 1569=head2 CORE EXTENSIONS
1385 1570
1386Functions and methods that extend core crossfire objects. 1571Functions and methods that extend core deliantra objects.
1387 1572
1388=cut 1573=cut
1389 1574
1390package cf::player; 1575package cf::player;
1391 1576
… …
1434 1619
1435sub exists($) { 1620sub exists($) {
1436 my ($login) = @_; 1621 my ($login) = @_;
1437 1622
1438 $cf::PLAYER{$login} 1623 $cf::PLAYER{$login}
1439 or cf::sync_job { !aio_stat path $login } 1624 or !aio_stat path $login
1440} 1625}
1441 1626
1442sub find($) { 1627sub find($) {
1443 return $cf::PLAYER{$_[0]} || do { 1628 return $cf::PLAYER{$_[0]} || do {
1444 my $login = $_[0]; 1629 my $login = $_[0];
… …
1456 my $f = new_from_file cf::object::thawer path $login 1641 my $f = new_from_file cf::object::thawer path $login
1457 or return; 1642 or return;
1458 1643
1459 my $pl = cf::player::load_pl $f 1644 my $pl = cf::player::load_pl $f
1460 or return; 1645 or return;
1646
1461 local $cf::PLAYER_LOADING{$login} = $pl; 1647 local $cf::PLAYER_LOADING{$login} = $pl;
1462 $f->resolve_delayed_derefs; 1648 $f->resolve_delayed_derefs;
1463 $cf::PLAYER{$login} = $pl 1649 $cf::PLAYER{$login} = $pl
1464 } 1650 }
1465 } 1651 }
1466} 1652}
1467 1653
1654cf::player->attach (
1655 on_load => sub {
1656 my ($pl, $path) = @_;
1657
1658 # restore slots saved in save, below
1659 my $slots = delete $pl->{_slots};
1660
1661 $pl->ob->current_weapon ($slots->[0]);
1662 $pl->combat_ob ($slots->[1]);
1663 $pl->ranged_ob ($slots->[2]);
1664 },
1665);
1666
1468sub save($) { 1667sub save($) {
1469 my ($pl) = @_; 1668 my ($pl) = @_;
1470 1669
1471 return if $pl->{deny_save}; 1670 return if $pl->{deny_save};
1472 1671
… …
1477 1676
1478 aio_mkdir playerdir $pl, 0770; 1677 aio_mkdir playerdir $pl, 0770;
1479 $pl->{last_save} = $cf::RUNTIME; 1678 $pl->{last_save} = $cf::RUNTIME;
1480 1679
1481 cf::get_slot 0.01; 1680 cf::get_slot 0.01;
1681
1682 # save slots, to be restored later
1683 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1482 1684
1483 $pl->save_pl ($path); 1685 $pl->save_pl ($path);
1484 cf::cede_to_tick; 1686 cf::cede_to_tick;
1485} 1687}
1486 1688
… …
1518 my ($pl) = @_; 1720 my ($pl) = @_;
1519 1721
1520 my $name = $pl->ob->name; 1722 my $name = $pl->ob->name;
1521 1723
1522 $pl->{deny_save} = 1; 1724 $pl->{deny_save} = 1;
1523 $pl->password ("*"); # this should lock out the player until we nuked the dir 1725 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1524 1726
1525 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1727 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1526 $pl->deactivate; 1728 $pl->deactivate;
1729
1730 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1527 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1731 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1732 ext::highscore::check ($pl->ob);
1733
1528 $pl->ns->destroy if $pl->ns; 1734 $pl->ns->destroy if $pl->ns;
1529 1735
1530 my $path = playerdir $pl; 1736 my $path = playerdir $pl;
1531 my $temp = "$path~$cf::RUNTIME~deleting~"; 1737 my $temp = "$path~$cf::RUNTIME~deleting~";
1532 aio_rename $path, $temp; 1738 aio_rename $path, $temp;
… …
1570 1776
1571 for my $login (@$dirs) { 1777 for my $login (@$dirs) {
1572 my $path = path $login; 1778 my $path = path $login;
1573 1779
1574 # a .pst is a dead give-away for a valid player 1780 # a .pst is a dead give-away for a valid player
1575 unless (-e "$path.pst") { 1781 # if no pst file found, open and chekc for blocked users
1782 if (aio_stat "$path.pst") {
1576 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1783 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1577 aio_read $fh, 0, 512, my $buf, 0 or next; 1784 aio_read $fh, 0, 512, my $buf, 0 or next;
1578 $buf !~ /^password -------------$/m or next; # official not-valid tag 1785 $buf !~ /^password -------------$/m or next; # official not-valid tag
1579 } 1786 }
1580 1787
… …
1584 1791
1585 \@logins 1792 \@logins
1586} 1793}
1587 1794
1588=item $player->maps 1795=item $player->maps
1796
1797=item cf::player::maps $login
1589 1798
1590Returns an arrayref of map paths that are private for this 1799Returns an arrayref of map paths that are private for this
1591player. May block. 1800player. May block.
1592 1801
1593=cut 1802=cut
… …
1611 } 1820 }
1612 1821
1613 \@paths 1822 \@paths
1614} 1823}
1615 1824
1616=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1825=item $protocol_xml = $player->expand_cfpod ($cfpod)
1617 1826
1618Expand crossfire pod fragments into protocol xml. 1827Expand deliantra pod fragments into protocol xml.
1619
1620=cut
1621
1622use re 'eval';
1623
1624my $group;
1625my $interior; $interior = qr{
1626 # match a pod interior sequence sans C<< >>
1627 (?:
1628 \ (.*?)\ (?{ $group = $^N })
1629 | < (??{$interior}) >
1630 )
1631}x;
1632
1633sub expand_cfpod {
1634 my ($self, $pod) = @_;
1635
1636 my $xml;
1637
1638 while () {
1639 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1640 $group = $1;
1641
1642 $group =~ s/&/&amp;/g;
1643 $group =~ s/</&lt;/g;
1644
1645 $xml .= $group;
1646 } elsif ($pod =~ m%\G
1647 ([BCGHITU])
1648 <
1649 (?:
1650 ([^<>]*) (?{ $group = $^N })
1651 | < $interior >
1652 )
1653 >
1654 %gcsx
1655 ) {
1656 my ($code, $data) = ($1, $group);
1657
1658 if ($code eq "B") {
1659 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1660 } elsif ($code eq "I") {
1661 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1662 } elsif ($code eq "U") {
1663 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1664 } elsif ($code eq "C") {
1665 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1666 } elsif ($code eq "T") {
1667 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1668 } elsif ($code eq "G") {
1669 my ($male, $female) = split /\|/, $data;
1670 $data = $self->gender ? $female : $male;
1671 $xml .= expand_cfpod ($self, $data);
1672 } elsif ($code eq "H") {
1673 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1674 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1675 "")
1676 [$self->{hintmode}];
1677 } else {
1678 $xml .= "error processing '$code($data)' directive";
1679 }
1680 } else {
1681 if ($pod =~ /\G(.+)/) {
1682 warn "parse error while expanding $pod (at $1)";
1683 }
1684 last;
1685 }
1686 }
1687
1688 for ($xml) {
1689 # create single paragraphs (very hackish)
1690 s/(?<=\S)\n(?=\w)/ /g;
1691
1692 # compress some whitespace
1693 s/\s+\n/\n/g; # ws line-ends
1694 s/\n\n+/\n/g; # double lines
1695 s/^\n+//; # beginning lines
1696 s/\n+$//; # ending lines
1697 }
1698
1699 $xml
1700}
1701
1702no re 'eval';
1703
1704sub hintmode {
1705 $_[0]{hintmode} = $_[1] if @_ > 1;
1706 $_[0]{hintmode}
1707}
1708 1828
1709=item $player->ext_reply ($msgid, @msg) 1829=item $player->ext_reply ($msgid, @msg)
1710 1830
1711Sends an ext reply to the player. 1831Sends an ext reply to the player.
1712 1832
… …
1744 1864
1745=cut 1865=cut
1746 1866
1747sub find_by_path($) { 1867sub find_by_path($) {
1748 my ($path) = @_; 1868 my ($path) = @_;
1869
1870 $path =~ s/^~[^\/]*//; # skip ~login
1749 1871
1750 my ($match, $specificity); 1872 my ($match, $specificity);
1751 1873
1752 for my $region (list) { 1874 for my $region (list) {
1753 if ($region->{match} && $path =~ $region->{match}) { 1875 if ($region->{match} && $path =~ $region->{match}) {
… …
1782sub generate_random_map { 1904sub generate_random_map {
1783 my ($self, $rmp) = @_; 1905 my ($self, $rmp) = @_;
1784 1906
1785 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1907 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1786 1908
1787 # mit "rum" bekleckern, nicht
1788 $self->_create_random_map ( 1909 $self->_create_random_map ($rmp);
1789 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1790 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1791 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1792 $rmp->{exit_on_final_map},
1793 $rmp->{xsize}, $rmp->{ysize},
1794 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1795 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1796 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1797 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1798 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1799 (cf::region::find $rmp->{region}), $rmp->{custom}
1800 )
1801} 1910}
1802 1911
1803=item cf::map->register ($regex, $prio) 1912=item cf::map->register ($regex, $prio)
1804 1913
1805Register a handler for the map path matching the given regex at the 1914Register a handler for the map path matching the given regex at the
… …
1810 1919
1811sub register { 1920sub register {
1812 my (undef, $regex, $prio) = @_; 1921 my (undef, $regex, $prio) = @_;
1813 my $pkg = caller; 1922 my $pkg = caller;
1814 1923
1815 no strict;
1816 push @{"$pkg\::ISA"}, __PACKAGE__; 1924 push @{"$pkg\::ISA"}, __PACKAGE__;
1817 1925
1818 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1926 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1819} 1927}
1820 1928
1821# also paths starting with '/' 1929# also paths starting with '/'
1822$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1930$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1823 1931
1824sub thawer_merge { 1932sub thawer_merge {
1825 my ($self, $merge) = @_; 1933 my ($self, $merge) = @_;
1826 1934
1827 # we have to keep some variables in memory intact 1935 # we have to keep some variables in memory intact
… …
1832} 1940}
1833 1941
1834sub normalise { 1942sub normalise {
1835 my ($path, $base) = @_; 1943 my ($path, $base) = @_;
1836 1944
1837 $path = "$path"; # make sure its a string 1945 $path = "$path"; # make sure it's a string
1838 1946
1839 $path =~ s/\.map$//; 1947 $path =~ s/\.map$//;
1840 1948
1841 # map plan: 1949 # map plan:
1842 # 1950 #
… …
1857 $base =~ s{[^/]+/?$}{}; 1965 $base =~ s{[^/]+/?$}{};
1858 $path = "$base/$path"; 1966 $path = "$base/$path";
1859 } 1967 }
1860 1968
1861 for ($path) { 1969 for ($path) {
1862 redo if s{//}{/};
1863 redo if s{/\.?/}{/}; 1970 redo if s{/\.?/}{/};
1864 redo if s{/[^/]+/\.\./}{/}; 1971 redo if s{/[^/]+/\.\./}{/};
1865 } 1972 }
1866 1973
1867 $path 1974 $path
… …
1881 $self->init; # pass $1 etc. 1988 $self->init; # pass $1 etc.
1882 return $self; 1989 return $self;
1883 } 1990 }
1884 } 1991 }
1885 1992
1886 Carp::cluck "unable to resolve path '$path' (base '$base')."; 1993 Carp::cluck "unable to resolve path '$path' (base '$base')";
1887 () 1994 ()
1888} 1995}
1889 1996
1890sub init { 1997sub init {
1891 my ($self) = @_; 1998 my ($self) = @_;
… …
1923sub uniq_path { 2030sub uniq_path {
1924 my ($self) = @_; 2031 my ($self) = @_;
1925 2032
1926 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 2033 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1927 "$UNIQUEDIR/$path" 2034 "$UNIQUEDIR/$path"
1928}
1929
1930# and all this just because we cannot iterate over
1931# all maps in C++...
1932sub change_all_map_light {
1933 my ($change) = @_;
1934
1935 $_->change_map_light ($change)
1936 for grep $_->outdoor, values %cf::MAP;
1937} 2035}
1938 2036
1939sub decay_objects { 2037sub decay_objects {
1940 my ($self) = @_; 2038 my ($self) = @_;
1941 2039
… …
2023 2121
2024sub find; 2122sub find;
2025sub find { 2123sub find {
2026 my ($path, $origin) = @_; 2124 my ($path, $origin) = @_;
2027 2125
2126 cf::cede_to_tick;
2127
2028 $path = normalise $path, $origin && $origin->path; 2128 $path = normalise $path, $origin && $origin->path;
2029 2129
2030 cf::lock_wait "map_data:$path";#d#remove 2130 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2031 cf::lock_wait "map_find:$path"; 2131 my $guard2 = cf::lock_acquire "map_find:$path";
2032 2132
2033 $cf::MAP{$path} || do { 2133 $cf::MAP{$path} || do {
2034 my $guard1 = cf::lock_acquire "map_find:$path";
2035 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2036
2037 my $map = new_from_path cf::map $path 2134 my $map = new_from_path cf::map $path
2038 or return; 2135 or return;
2039 2136
2040 $map->{last_save} = $cf::RUNTIME; 2137 $map->{last_save} = $cf::RUNTIME;
2041 2138
… …
2043 or return; 2140 or return;
2044 2141
2045 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2142 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2046 # doing this can freeze the server in a sync job, obviously 2143 # doing this can freeze the server in a sync job, obviously
2047 #$cf::WAIT_FOR_TICK->wait; 2144 #$cf::WAIT_FOR_TICK->wait;
2145 undef $guard2;
2048 undef $guard1; 2146 undef $guard1;
2049 undef $guard2;
2050 $map->reset; 2147 $map->reset;
2051 return find $path; 2148 return find $path;
2052 } 2149 }
2053 2150
2054 $cf::MAP{$path} = $map 2151 $cf::MAP{$path} = $map
2055 } 2152 }
2056} 2153}
2057 2154
2058sub pre_load { } 2155sub pre_load { }
2059sub post_load { } 2156#sub post_load { } # XS
2060 2157
2061sub load { 2158sub load {
2062 my ($self) = @_; 2159 my ($self) = @_;
2063 2160
2064 local $self->{deny_reset} = 1; # loading can take a long time 2161 local $self->{deny_reset} = 1; # loading can take a long time
… …
2081 my $f = new_from_file cf::object::thawer $self->{load_path}; 2178 my $f = new_from_file cf::object::thawer $self->{load_path};
2082 $f->skip_block; 2179 $f->skip_block;
2083 $self->_load_objects ($f) 2180 $self->_load_objects ($f)
2084 or return; 2181 or return;
2085 2182
2086 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2183 $self->post_load_original
2087 if delete $self->{load_original}; 2184 if delete $self->{load_original};
2088 2185
2089 if (my $uniq = $self->uniq_path) { 2186 if (my $uniq = $self->uniq_path) {
2090 utf8::encode $uniq; 2187 utf8::encode $uniq;
2091 unless (aio_stat $uniq) { 2188 unless (aio_stat $uniq) {
… …
2109 unless ($self->{deny_activate}) { 2206 unless ($self->{deny_activate}) {
2110 $self->decay_objects; 2207 $self->decay_objects;
2111 $self->fix_auto_apply; 2208 $self->fix_auto_apply;
2112 $self->update_buttons; 2209 $self->update_buttons;
2113 cf::cede_to_tick; 2210 cf::cede_to_tick;
2114 $self->set_darkness_map;
2115 cf::cede_to_tick;
2116 $self->activate; 2211 $self->activate;
2117 } 2212 }
2118 2213
2119 $self->{last_save} = $cf::RUNTIME; 2214 $self->{last_save} = $cf::RUNTIME;
2120 $self->last_access ($cf::RUNTIME); 2215 $self->last_access ($cf::RUNTIME);
2121 2216
2122 $self->in_memory (cf::MAP_ACTIVE); 2217 $self->in_memory (cf::MAP_ACTIVE);
2123 } 2218 }
2124 2219
2125 $self->post_load; 2220 $self->post_load;
2126}
2127 2221
2222 1
2223}
2224
2225# customize the map for a given player, i.e.
2226# return the _real_ map. used by e.g. per-player
2227# maps to change the path to ~playername/mappath
2128sub customise_for { 2228sub customise_for {
2129 my ($self, $ob) = @_; 2229 my ($self, $ob) = @_;
2130 2230
2131 return find "~" . $ob->name . "/" . $self->{path} 2231 return find "~" . $ob->name . "/" . $self->{path}
2132 if $self->per_player; 2232 if $self->per_player;
… …
2148 or next; 2248 or next;
2149 $neigh = find $neigh, $map 2249 $neigh = find $neigh, $map
2150 or next; 2250 or next;
2151 $neigh->load; 2251 $neigh->load;
2152 2252
2253 # now find the diagonal neighbours
2153 push @neigh, 2254 push @neigh,
2154 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2255 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2155 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2256 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2156 } 2257 }
2157 2258
… …
2164} 2265}
2165 2266
2166sub find_sync { 2267sub find_sync {
2167 my ($path, $origin) = @_; 2268 my ($path, $origin) = @_;
2168 2269
2169 cf::sync_job { find $path, $origin } 2270 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2271 if $Coro::current == $Coro::main;
2272
2273 find $path, $origin
2170} 2274}
2171 2275
2172sub do_load_sync { 2276sub do_load_sync {
2173 my ($map) = @_; 2277 my ($map) = @_;
2174 2278
2175 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2279 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2176 if $Coro::current == $Coro::main; 2280 if $Coro::current == $Coro::main;
2177 2281
2178 cf::sync_job { $map->load }; 2282 $map->load;
2179} 2283}
2180 2284
2181our %MAP_PREFETCH; 2285our %MAP_PREFETCH;
2182our $MAP_PREFETCHER = undef; 2286our $MAP_PREFETCHER = undef;
2183 2287
… …
2209 $MAP_PREFETCHER->prio (6); 2313 $MAP_PREFETCHER->prio (6);
2210 2314
2211 () 2315 ()
2212} 2316}
2213 2317
2318# common code, used by both ->save and ->swapout
2214sub save { 2319sub _save {
2215 my ($self) = @_; 2320 my ($self) = @_;
2216
2217 my $lock = cf::lock_acquire "map_data:$self->{path}";
2218 2321
2219 $self->{last_save} = $cf::RUNTIME; 2322 $self->{last_save} = $cf::RUNTIME;
2220 2323
2221 return unless $self->dirty; 2324 return unless $self->dirty;
2222 2325
… …
2242 } else { 2345 } else {
2243 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2346 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2244 } 2347 }
2245} 2348}
2246 2349
2350sub save {
2351 my ($self) = @_;
2352
2353 my $lock = cf::lock_acquire "map_data:$self->{path}";
2354
2355 $self->_save;
2356}
2357
2247sub swap_out { 2358sub swap_out {
2248 my ($self) = @_; 2359 my ($self) = @_;
2249 2360
2250 # save first because save cedes
2251 $self->save;
2252
2253 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2361 my $lock = cf::lock_acquire "map_data:$self->{path}";
2254 2362
2255 return if $self->players;
2256 return if $self->in_memory != cf::MAP_ACTIVE; 2363 return if $self->in_memory != cf::MAP_ACTIVE;
2257 return if $self->{deny_save}; 2364 return if $self->{deny_save};
2365 return if $self->players;
2258 2366
2367 # first deactivate the map and "unlink" it from the core
2368 $self->deactivate;
2369 $_->clear_links_to ($self) for values %cf::MAP;
2259 $self->in_memory (cf::MAP_SWAPPED); 2370 $self->in_memory (cf::MAP_SWAPPED);
2371
2372 # then atomically save
2373 $self->_save;
2374
2375 # then free the map
2376 $self->clear;
2377}
2378
2379sub reset_at {
2380 my ($self) = @_;
2381
2382 # TODO: safety, remove and allow resettable per-player maps
2383 return 1e99 if $self->{deny_reset};
2384
2385 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2386 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2387
2388 $time + $to
2389}
2390
2391sub should_reset {
2392 my ($self) = @_;
2393
2394 $self->reset_at <= $cf::RUNTIME
2395}
2396
2397sub reset {
2398 my ($self) = @_;
2399
2400 my $lock = cf::lock_acquire "map_data:$self->{path}";
2401
2402 return if $self->players;
2403
2404 cf::trace "resetting map ", $self->path, "\n";
2405
2406 $self->in_memory (cf::MAP_SWAPPED);
2407
2408 # need to save uniques path
2409 unless ($self->{deny_save}) {
2410 my $uniq = $self->uniq_path; utf8::encode $uniq;
2411
2412 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2413 if $uniq;
2414 }
2415
2416 delete $cf::MAP{$self->path};
2260 2417
2261 $self->deactivate; 2418 $self->deactivate;
2262 $_->clear_links_to ($self) for values %cf::MAP; 2419 $_->clear_links_to ($self) for values %cf::MAP;
2263 $self->clear; 2420 $self->clear;
2264}
2265
2266sub reset_at {
2267 my ($self) = @_;
2268
2269 # TODO: safety, remove and allow resettable per-player maps
2270 return 1e99 if $self->{deny_reset};
2271
2272 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2273 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2274
2275 $time + $to
2276}
2277
2278sub should_reset {
2279 my ($self) = @_;
2280
2281 $self->reset_at <= $cf::RUNTIME
2282}
2283
2284sub reset {
2285 my ($self) = @_;
2286
2287 my $lock = cf::lock_acquire "map_data:$self->{path}";
2288
2289 return if $self->players;
2290
2291 warn "resetting map ", $self->path;
2292
2293 $self->in_memory (cf::MAP_SWAPPED);
2294
2295 # need to save uniques path
2296 unless ($self->{deny_save}) {
2297 my $uniq = $self->uniq_path; utf8::encode $uniq;
2298
2299 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2300 if $uniq;
2301 }
2302
2303 delete $cf::MAP{$self->path};
2304
2305 $self->deactivate;
2306 $_->clear_links_to ($self) for values %cf::MAP;
2307 $self->clear;
2308 2421
2309 $self->unlink_save; 2422 $self->unlink_save;
2310 $self->destroy; 2423 $self->destroy;
2311} 2424}
2312 2425
… …
2320 2433
2321 delete $cf::MAP{$self->path}; 2434 delete $cf::MAP{$self->path};
2322 2435
2323 $self->unlink_save; 2436 $self->unlink_save;
2324 2437
2325 bless $self, "cf::map"; 2438 bless $self, "cf::map::wrap";
2326 delete $self->{deny_reset}; 2439 delete $self->{deny_reset};
2327 $self->{deny_save} = 1; 2440 $self->{deny_save} = 1;
2328 $self->reset_timeout (1); 2441 $self->reset_timeout (1);
2329 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2442 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2330 2443
… …
2387 : normalise $_ 2500 : normalise $_
2388 } @{ aio_readdir $UNIQUEDIR or [] } 2501 } @{ aio_readdir $UNIQUEDIR or [] }
2389 ] 2502 ]
2390} 2503}
2391 2504
2505=item cf::map::static_maps
2506
2507Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2508file in the shared directory excluding F</styles> and F</editor>). May
2509block.
2510
2511=cut
2512
2513sub static_maps() {
2514 my @dirs = "";
2515 my @maps;
2516
2517 while (@dirs) {
2518 my $dir = shift @dirs;
2519
2520 next if $dir eq "/styles" || $dir eq "/editor";
2521
2522 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2523 or return;
2524
2525 for (@$files) {
2526 s/\.map$// or next;
2527 utf8::decode $_;
2528 push @maps, "$dir/$_";
2529 }
2530
2531 push @dirs, map "$dir/$_", @$dirs;
2532 }
2533
2534 \@maps
2535}
2536
2392=back 2537=back
2393 2538
2394=head3 cf::object 2539=head3 cf::object
2395 2540
2396=cut 2541=cut
… …
2457can be C<undef>. Does the right thing when the player is currently in a 2602can be C<undef>. Does the right thing when the player is currently in a
2458dialogue with the given NPC character. 2603dialogue with the given NPC character.
2459 2604
2460=cut 2605=cut
2461 2606
2607our $SAY_CHANNEL = {
2608 id => "say",
2609 title => "Map",
2610 reply => "say ",
2611 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2612};
2613
2614our $CHAT_CHANNEL = {
2615 id => "chat",
2616 title => "Chat",
2617 reply => "chat ",
2618 tooltip => "Player chat and shouts, global to the server.",
2619};
2620
2462# rough implementation of a future "reply" method that works 2621# rough implementation of a future "reply" method that works
2463# with dialog boxes. 2622# with dialog boxes.
2464#TODO: the first argument must go, split into a $npc->reply_to ( method 2623#TODO: the first argument must go, split into a $npc->reply_to ( method
2465sub cf::object::player::reply($$$;$) { 2624sub cf::object::player::reply($$$;$) {
2466 my ($self, $npc, $msg, $flags) = @_; 2625 my ($self, $npc, $msg, $flags) = @_;
… …
2477 my $dialog = $pl->{npc_dialog}; 2636 my $dialog = $pl->{npc_dialog};
2478 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2637 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2479 2638
2480 } else { 2639 } else {
2481 $msg = $npc->name . " says: $msg" if $npc; 2640 $msg = $npc->name . " says: $msg" if $npc;
2482 $self->message ($msg, $flags); 2641 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2483 } 2642 }
2484 } 2643 }
2485} 2644}
2486 2645
2487=item $object->send_msg ($channel, $msg, $color, [extra...]) 2646=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2512 2671
2513=item $player_object->enter_link 2672=item $player_object->enter_link
2514 2673
2515Freezes the player and moves him/her to a special map (C<{link}>). 2674Freezes the player and moves him/her to a special map (C<{link}>).
2516 2675
2517The player should be reasonably safe there for short amounts of time. You 2676The player should be reasonably safe there for short amounts of time (e.g.
2518I<MUST> call C<leave_link> as soon as possible, though. 2677for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2678though, as the player cannot control the character while it is on the link
2679map.
2519 2680
2520Will never block. 2681Will never block.
2521 2682
2522=item $player_object->leave_link ($map, $x, $y) 2683=item $player_object->leave_link ($map, $x, $y)
2523 2684
… …
2543sub cf::object::player::enter_link { 2704sub cf::object::player::enter_link {
2544 my ($self) = @_; 2705 my ($self) = @_;
2545 2706
2546 $self->deactivate_recursive; 2707 $self->deactivate_recursive;
2547 2708
2709 ++$self->{_link_recursion};
2710
2548 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2711 return if UNIVERSAL::isa $self->map, "ext::map_link";
2549 2712
2550 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2713 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2551 if $self->map && $self->map->{path} ne "{link}"; 2714 if $self->map && $self->map->{path} ne "{link}";
2552 2715
2553 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2716 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2554} 2717}
2555 2718
2556sub cf::object::player::leave_link { 2719sub cf::object::player::leave_link {
2557 my ($self, $map, $x, $y) = @_; 2720 my ($self, $map, $x, $y) = @_;
2558 2721
… …
2575 ($x, $y) = (-1, -1) 2738 ($x, $y) = (-1, -1)
2576 unless (defined $x) && (defined $y); 2739 unless (defined $x) && (defined $y);
2577 2740
2578 # use -1 or undef as default coordinates, not 0, 0 2741 # use -1 or undef as default coordinates, not 0, 0
2579 ($x, $y) = ($map->enter_x, $map->enter_y) 2742 ($x, $y) = ($map->enter_x, $map->enter_y)
2580 if $x <=0 && $y <= 0; 2743 if $x <= 0 && $y <= 0;
2581 2744
2582 $map->load; 2745 $map->load;
2583 $map->load_neighbours; 2746 $map->load_neighbours;
2584 2747
2585 return unless $self->contr->active; 2748 return unless $self->contr->active;
2586 $self->activate_recursive;
2587 2749
2588 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2750 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2589 $self->enter_map ($map, $x, $y); 2751 if ($self->enter_map ($map, $x, $y)) {
2590} 2752 # entering was successful
2753 delete $self->{_link_recursion};
2754 # only activate afterwards, to support waiting in hooks
2755 $self->activate_recursive;
2756 }
2591 2757
2758}
2759
2592=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2760=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2593 2761
2594Moves the player to the given map-path and coordinates by first freezing 2762Moves the player to the given map-path and coordinates by first freezing
2595her, loading and preparing them map, calling the provided $check callback 2763her, loading and preparing them map, calling the provided $check callback
2596that has to return the map if sucecssful, and then unfreezes the player on 2764that has to return the map if sucecssful, and then unfreezes the player on
2597the new (success) or old (failed) map position. In either case, $done will 2765the new (success) or old (failed) map position. In either case, $done will
2598be called at the end of this process. 2766be called at the end of this process.
2599 2767
2768Note that $check will be called with a potentially non-loaded map, so if
2769it needs a loaded map it has to call C<< ->load >>.
2770
2600=cut 2771=cut
2601 2772
2602our $GOTOGEN; 2773our $GOTOGEN;
2603 2774
2604sub cf::object::player::goto { 2775sub cf::object::player::goto {
2605 my ($self, $path, $x, $y, $check, $done) = @_; 2776 my ($self, $path, $x, $y, $check, $done) = @_;
2777
2778 if ($self->{_link_recursion} >= $MAX_LINKS) {
2779 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2780 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2781 ($path, $x, $y) = @$EMERGENCY_POSITION;
2782 }
2606 2783
2607 # do generation counting so two concurrent goto's will be executed in-order 2784 # do generation counting so two concurrent goto's will be executed in-order
2608 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2785 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2609 2786
2610 $self->enter_link; 2787 $self->enter_link;
… …
2634 my $map = eval { 2811 my $map = eval {
2635 my $map = defined $path ? cf::map::find $path : undef; 2812 my $map = defined $path ? cf::map::find $path : undef;
2636 2813
2637 if ($map) { 2814 if ($map) {
2638 $map = $map->customise_for ($self); 2815 $map = $map->customise_for ($self);
2639 $map = $check->($map) if $check && $map; 2816 $map = $check->($map, $x, $y, $self) if $check && $map;
2640 } else { 2817 } else {
2641 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2818 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2642 } 2819 }
2643 2820
2644 $map 2821 $map
… …
2652 if ($gen == $self->{_goto_generation}) { 2829 if ($gen == $self->{_goto_generation}) {
2653 delete $self->{_goto_generation}; 2830 delete $self->{_goto_generation};
2654 $self->leave_link ($map, $x, $y); 2831 $self->leave_link ($map, $x, $y);
2655 } 2832 }
2656 2833
2657 $done->() if $done; 2834 $done->($self) if $done;
2658 })->prio (1); 2835 })->prio (1);
2659} 2836}
2660 2837
2661=item $player_object->enter_exit ($exit_object) 2838=item $player_object->enter_exit ($exit_object)
2662 2839
… …
2682} 2859}
2683 2860
2684sub prepare_random_map { 2861sub prepare_random_map {
2685 my ($exit) = @_; 2862 my ($exit) = @_;
2686 2863
2687 my $guard = cf::lock_acquire "exit_prepare:$exit";
2688
2689 # all this does is basically replace the /! path by 2864 # all this does is basically replace the /! path by
2690 # a new random map path (?random/...) with a seed 2865 # a new random map path (?random/...) with a seed
2691 # that depends on the exit object 2866 # that depends on the exit object
2692 2867
2693 my $rmp = parse_random_map_params $exit->msg; 2868 my $rmp = parse_random_map_params $exit->msg;
… …
2695 if ($exit->map) { 2870 if ($exit->map) {
2696 $rmp->{region} = $exit->region->name; 2871 $rmp->{region} = $exit->region->name;
2697 $rmp->{origin_map} = $exit->map->path; 2872 $rmp->{origin_map} = $exit->map->path;
2698 $rmp->{origin_x} = $exit->x; 2873 $rmp->{origin_x} = $exit->x;
2699 $rmp->{origin_y} = $exit->y; 2874 $rmp->{origin_y} = $exit->y;
2875
2876 $exit->map->touch;
2700 } 2877 }
2701 2878
2702 $rmp->{random_seed} ||= $exit->random_seed; 2879 $rmp->{random_seed} ||= $exit->random_seed;
2703 2880
2704 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp); 2881 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
… …
2708 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2885 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2709 aio_write $fh, 0, (length $data), $data, 0; 2886 aio_write $fh, 0, (length $data), $data, 0;
2710 undef $fh; 2887 undef $fh;
2711 aio_rename "$meta~", $meta; 2888 aio_rename "$meta~", $meta;
2712 2889
2890 my $slaying = "?random/$md5";
2891
2892 if ($exit->valid) {
2713 $exit->slaying ("?random/$md5"); 2893 $exit->slaying ("?random/$md5");
2714 $exit->msg (undef); 2894 $exit->msg (undef);
2895 }
2715 } 2896 }
2716} 2897}
2717 2898
2718sub cf::object::player::enter_exit { 2899sub cf::object::player::enter_exit {
2719 my ($self, $exit) = @_; 2900 my ($self, $exit) = @_;
2720 2901
2721 return unless $self->type == cf::PLAYER; 2902 return unless $self->type == cf::PLAYER;
2722 2903
2723 if ($exit->slaying eq "/!") {
2724 #TODO: this should de-fi-ni-te-ly not be a sync-job
2725 # the problem is that $exit might not survive long enough
2726 # so it needs to be done right now, right here
2727 cf::sync_job { prepare_random_map $exit };
2728 }
2729
2730 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2731 my $hp = $exit->stats->hp;
2732 my $sp = $exit->stats->sp;
2733
2734 $self->enter_link; 2904 $self->enter_link;
2735 2905
2736 # if exit is damned, update players death & WoR home-position
2737 $self->contr->savebed ($slaying, $hp, $sp)
2738 if $exit->flag (FLAG_DAMNED);
2739
2740 (async { 2906 (async {
2741 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2907 $Coro::current->{desc} = "enter_exit";
2742 2908
2743 $self->deactivate_recursive; # just to be sure
2744 unless (eval { 2909 unless (eval {
2910 $self->deactivate_recursive; # just to be sure
2911
2912 # random map handling
2913 {
2914 my $guard = cf::lock_acquire "exit_prepare:$exit";
2915
2916 prepare_random_map $exit
2917 if $exit->slaying eq "/!";
2918 }
2919
2920 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2921 my $x = $exit->stats->hp;
2922 my $y = $exit->stats->sp;
2923
2745 $self->goto ($slaying, $hp, $sp); 2924 $self->goto ($map, $x, $y);
2746 2925
2926 # if exit is damned, update players death & WoR home-position
2927 $self->contr->savebed ($map, $x, $y)
2928 if $exit->flag (cf::FLAG_DAMNED);
2929
2747 1; 2930 1
2748 }) { 2931 }) {
2749 $self->message ("Something went wrong deep within the crossfire server. " 2932 $self->message ("Something went wrong deep within the deliantra server. "
2750 . "I'll try to bring you back to the map you were before. " 2933 . "I'll try to bring you back to the map you were before. "
2751 . "Please report this to the dungeon master!", 2934 . "Please report this to the dungeon master!",
2752 cf::NDI_UNIQUE | cf::NDI_RED); 2935 cf::NDI_UNIQUE | cf::NDI_RED);
2753 2936
2754 warn "ERROR in enter_exit: $@"; 2937 error "ERROR in enter_exit: $@";
2755 $self->leave_link; 2938 $self->leave_link;
2756 } 2939 }
2757 })->prio (1); 2940 })->prio (1);
2758} 2941}
2759 2942
… …
2771sub cf::client::send_drawinfo { 2954sub cf::client::send_drawinfo {
2772 my ($self, $text, $flags) = @_; 2955 my ($self, $text, $flags) = @_;
2773 2956
2774 utf8::encode $text; 2957 utf8::encode $text;
2775 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2958 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2959}
2960
2961=item $client->send_big_packet ($pkt)
2962
2963Like C<send_packet>, but tries to compress large packets, and fragments
2964them as required.
2965
2966=cut
2967
2968our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2969
2970sub cf::client::send_big_packet {
2971 my ($self, $pkt) = @_;
2972
2973 # try lzf for large packets
2974 $pkt = "lzf " . Compress::LZF::compress $pkt
2975 if 1024 <= length $pkt and $self->{can_lzf};
2976
2977 # split very large packets
2978 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2979 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2980 $pkt = "frag";
2981 }
2982
2983 $self->send_packet ($pkt);
2776} 2984}
2777 2985
2778=item $client->send_msg ($channel, $msg, $color, [extra...]) 2986=item $client->send_msg ($channel, $msg, $color, [extra...])
2779 2987
2780Send a drawinfo or msg packet to the client, formatting the msg for the 2988Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2784 2992
2785=cut 2993=cut
2786 2994
2787# non-persistent channels (usually the info channel) 2995# non-persistent channels (usually the info channel)
2788our %CHANNEL = ( 2996our %CHANNEL = (
2997 "c/motd" => {
2998 id => "infobox",
2999 title => "MOTD",
3000 reply => undef,
3001 tooltip => "The message of the day",
3002 },
2789 "c/identify" => { 3003 "c/identify" => {
2790 id => "infobox", 3004 id => "infobox",
2791 title => "Identify", 3005 title => "Identify",
2792 reply => undef, 3006 reply => undef,
2793 tooltip => "Items recently identified", 3007 tooltip => "Items recently identified",
… …
2795 "c/examine" => { 3009 "c/examine" => {
2796 id => "infobox", 3010 id => "infobox",
2797 title => "Examine", 3011 title => "Examine",
2798 reply => undef, 3012 reply => undef,
2799 tooltip => "Signs and other items you examined", 3013 tooltip => "Signs and other items you examined",
3014 },
3015 "c/shopinfo" => {
3016 id => "infobox",
3017 title => "Shop Info",
3018 reply => undef,
3019 tooltip => "What your bargaining skill tells you about the shop",
2800 }, 3020 },
2801 "c/book" => { 3021 "c/book" => {
2802 id => "infobox", 3022 id => "infobox",
2803 title => "Book", 3023 title => "Book",
2804 reply => undef, 3024 reply => undef,
… …
2820 id => "infobox", 3040 id => "infobox",
2821 title => "Body Parts", 3041 title => "Body Parts",
2822 reply => undef, 3042 reply => undef,
2823 tooltip => "Shows which body parts you posess and are available", 3043 tooltip => "Shows which body parts you posess and are available",
2824 }, 3044 },
3045 "c/statistics" => {
3046 id => "infobox",
3047 title => "Statistics",
3048 reply => undef,
3049 tooltip => "Shows your primary statistics",
3050 },
3051 "c/skills" => {
3052 id => "infobox",
3053 title => "Skills",
3054 reply => undef,
3055 tooltip => "Shows your experience per skill and item power",
3056 },
3057 "c/shopitems" => {
3058 id => "infobox",
3059 title => "Shop Items",
3060 reply => undef,
3061 tooltip => "Shows the items currently for sale in this shop",
3062 },
3063 "c/resistances" => {
3064 id => "infobox",
3065 title => "Resistances",
3066 reply => undef,
3067 tooltip => "Shows your resistances",
3068 },
3069 "c/pets" => {
3070 id => "infobox",
3071 title => "Pets",
3072 reply => undef,
3073 tooltip => "Shows information abotu your pets/a specific pet",
3074 },
3075 "c/perceiveself" => {
3076 id => "infobox",
3077 title => "Perceive Self",
3078 reply => undef,
3079 tooltip => "You gained detailed knowledge about yourself",
3080 },
2825 "c/uptime" => { 3081 "c/uptime" => {
2826 id => "infobox", 3082 id => "infobox",
2827 title => "Uptime", 3083 title => "Uptime",
2828 reply => undef, 3084 reply => undef,
2829 tooltip => "How long the server has been running since last restart", 3085 tooltip => "How long the server has been running since last restart",
… …
2838 id => "party", 3094 id => "party",
2839 title => "Party", 3095 title => "Party",
2840 reply => "gsay ", 3096 reply => "gsay ",
2841 tooltip => "Messages and chat related to your party", 3097 tooltip => "Messages and chat related to your party",
2842 }, 3098 },
3099 "c/death" => {
3100 id => "death",
3101 title => "Death",
3102 reply => undef,
3103 tooltip => "Reason for and more info about your most recent death",
3104 },
3105 "c/say" => $SAY_CHANNEL,
3106 "c/chat" => $CHAT_CHANNEL,
2843); 3107);
2844 3108
2845sub cf::client::send_msg { 3109sub cf::client::send_msg {
2846 my ($self, $channel, $msg, $color, @extra) = @_; 3110 my ($self, $channel, $msg, $color, @extra) = @_;
2847 3111
2848 $msg = $self->pl->expand_cfpod ($msg); 3112 $msg = $self->pl->expand_cfpod ($msg)
3113 unless $color & cf::NDI_VERBATIM;
2849 3114
2850 $color &= cf::NDI_CLIENT_MASK; # just in case... 3115 $color &= cf::NDI_CLIENT_MASK; # just in case...
2851 3116
2852 # check predefined channels, for the benefit of C 3117 # check predefined channels, for the benefit of C
2853 if ($CHANNEL{$channel}) { 3118 if ($CHANNEL{$channel}) {
2854 $channel = $CHANNEL{$channel}; 3119 $channel = $CHANNEL{$channel};
2855 3120
2856 $self->ext_msg (channel_info => $channel) 3121 $self->ext_msg (channel_info => $channel);
2857 if $self->can_msg;
2858
2859 $channel = $channel->{id}; 3122 $channel = $channel->{id};
2860 3123
2861 } elsif (ref $channel) { 3124 } elsif (ref $channel) {
2862 # send meta info to client, if not yet sent 3125 # send meta info to client, if not yet sent
2863 unless (exists $self->{channel}{$channel->{id}}) { 3126 unless (exists $self->{channel}{$channel->{id}}) {
2864 $self->{channel}{$channel->{id}} = $channel; 3127 $self->{channel}{$channel->{id}} = $channel;
2865 $self->ext_msg (channel_info => $channel) 3128 $self->ext_msg (channel_info => $channel);
2866 if $self->can_msg;
2867 } 3129 }
2868 3130
2869 $channel = $channel->{id}; 3131 $channel = $channel->{id};
2870 } 3132 }
2871 3133
2872 return unless @extra || length $msg; 3134 return unless @extra || length $msg;
2873 3135
2874 if ($self->can_msg) {
2875 # default colour, mask it out 3136 # default colour, mask it out
2876 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3137 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2877 if $color & cf::NDI_DEF; 3138 if $color & cf::NDI_DEF;
2878 3139
2879 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3140 my $pkt = "msg "
3141 . $self->{json_coder}->encode (
2880 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3142 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2881 } else { 3143 );
2882 if ($color >= 0) {
2883 # replace some tags by gcfclient-compatible ones
2884 for ($msg) {
2885 1 while
2886 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2887 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2888 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2889 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2890 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2891 }
2892 3144
2893 $color &= cf::NDI_COLOR_MASK; 3145 $self->send_big_packet ($pkt);
2894
2895 utf8::encode $msg;
2896
2897 if (0 && $msg =~ /\[/) {
2898 # COMMAND/INFO
2899 $self->send_packet ("drawextinfo $color 10 8 $msg")
2900 } else {
2901 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2902 $self->send_packet ("drawinfo $color $msg")
2903 }
2904 }
2905 }
2906} 3146}
2907 3147
2908=item $client->ext_msg ($type, @msg) 3148=item $client->ext_msg ($type, @msg)
2909 3149
2910Sends an ext event to the client. 3150Sends an ext event to the client.
… …
2913 3153
2914sub cf::client::ext_msg($$@) { 3154sub cf::client::ext_msg($$@) {
2915 my ($self, $type, @msg) = @_; 3155 my ($self, $type, @msg) = @_;
2916 3156
2917 if ($self->extcmd == 2) { 3157 if ($self->extcmd == 2) {
2918 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3158 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2919 } elsif ($self->extcmd == 1) { # TODO: remove 3159 } elsif ($self->extcmd == 1) { # TODO: remove
2920 push @msg, msgtype => "event_$type"; 3160 push @msg, msgtype => "event_$type";
2921 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3161 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2922 } 3162 }
2923} 3163}
2924 3164
2925=item $client->ext_reply ($msgid, @msg) 3165=item $client->ext_reply ($msgid, @msg)
2926 3166
… …
2930 3170
2931sub cf::client::ext_reply($$@) { 3171sub cf::client::ext_reply($$@) {
2932 my ($self, $id, @msg) = @_; 3172 my ($self, $id, @msg) = @_;
2933 3173
2934 if ($self->extcmd == 2) { 3174 if ($self->extcmd == 2) {
2935 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3175 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2936 } elsif ($self->extcmd == 1) { 3176 } elsif ($self->extcmd == 1) {
2937 #TODO: version 1, remove 3177 #TODO: version 1, remove
2938 unshift @msg, msgtype => "reply", msgid => $id; 3178 unshift @msg, msgtype => "reply", msgid => $id;
2939 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3179 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2940 } 3180 }
2941} 3181}
2942 3182
2943=item $success = $client->query ($flags, "text", \&cb) 3183=item $success = $client->query ($flags, "text", \&cb)
2944 3184
… …
3015 3255
3016 $ns->ext_reply ($reply, @reply) 3256 $ns->ext_reply ($reply, @reply)
3017 if $reply; 3257 if $reply;
3018 3258
3019 } else { 3259 } else {
3020 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3260 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3021 } 3261 }
3022 3262
3023 cf::override; 3263 cf::override;
3024 }, 3264 },
3025); 3265);
… …
3045 3285
3046 $coro 3286 $coro
3047} 3287}
3048 3288
3049cf::client->attach ( 3289cf::client->attach (
3050 on_destroy => sub { 3290 on_client_destroy => sub {
3051 my ($ns) = @_; 3291 my ($ns) = @_;
3052 3292
3053 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3293 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3054 }, 3294 },
3055); 3295);
… …
3071our $safe_hole = new Safe::Hole; 3311our $safe_hole = new Safe::Hole;
3072 3312
3073$SIG{FPE} = 'IGNORE'; 3313$SIG{FPE} = 'IGNORE';
3074 3314
3075$safe->permit_only (Opcode::opset qw( 3315$safe->permit_only (Opcode::opset qw(
3076 :base_core :base_mem :base_orig :base_math 3316 :base_core :base_mem :base_orig :base_math :base_loop
3077 grepstart grepwhile mapstart mapwhile 3317 grepstart grepwhile mapstart mapwhile
3078 sort time 3318 sort time
3079)); 3319));
3080 3320
3081# here we export the classes and methods available to script code 3321# here we export the classes and methods available to script code
… …
3085The following functions and methods are available within a safe environment: 3325The following functions and methods are available within a safe environment:
3086 3326
3087 cf::object 3327 cf::object
3088 contr pay_amount pay_player map x y force_find force_add destroy 3328 contr pay_amount pay_player map x y force_find force_add destroy
3089 insert remove name archname title slaying race decrease split 3329 insert remove name archname title slaying race decrease split
3330 value
3090 3331
3091 cf::object::player 3332 cf::object::player
3092 player 3333 player
3093 3334
3094 cf::player 3335 cf::player
… …
3099 3340
3100=cut 3341=cut
3101 3342
3102for ( 3343for (
3103 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3344 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3104 insert remove inv name archname title slaying race 3345 insert remove inv nrof name archname title slaying race
3105 decrease split destroy)], 3346 decrease split destroy change_exp value msg lore send_msg)],
3106 ["cf::object::player" => qw(player)], 3347 ["cf::object::player" => qw(player)],
3107 ["cf::player" => qw(peaceful)], 3348 ["cf::player" => qw(peaceful send_msg)],
3108 ["cf::map" => qw(trigger)], 3349 ["cf::map" => qw(trigger)],
3109) { 3350) {
3110 no strict 'refs';
3111 my ($pkg, @funs) = @$_; 3351 my ($pkg, @funs) = @$_;
3112 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3352 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3113 for @funs; 3353 for @funs;
3114} 3354}
3115 3355
… …
3130 3370
3131 my $qcode = $code; 3371 my $qcode = $code;
3132 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3372 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3133 $qcode =~ s/\n/\\n/g; 3373 $qcode =~ s/\n/\\n/g;
3134 3374
3375 %vars = (_dummy => 0) unless %vars;
3376
3377 my @res;
3135 local $_; 3378 local $_;
3136 local @safe::cf::_safe_eval_args = values %vars;
3137 3379
3138 my $eval = 3380 my $eval =
3139 "do {\n" 3381 "do {\n"
3140 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3382 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3141 . "#line 0 \"{$qcode}\"\n" 3383 . "#line 0 \"{$qcode}\"\n"
3142 . $code 3384 . $code
3143 . "\n}" 3385 . "\n}"
3144 ; 3386 ;
3145 3387
3388 if ($CFG{safe_eval}) {
3146 sub_generation_inc; 3389 sub_generation_inc;
3390 local @safe::cf::_safe_eval_args = values %vars;
3147 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3391 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3148 sub_generation_inc; 3392 sub_generation_inc;
3393 } else {
3394 local @cf::_safe_eval_args = values %vars;
3395 @res = wantarray ? eval eval : scalar eval $eval;
3396 }
3149 3397
3150 if ($@) { 3398 if ($@) {
3151 warn "$@"; 3399 warn "$@",
3152 warn "while executing safe code '$code'\n"; 3400 "while executing safe code '$code'\n",
3153 warn "with arguments " . (join " ", %vars) . "\n"; 3401 "with arguments " . (join " ", %vars) . "\n";
3154 } 3402 }
3155 3403
3156 wantarray ? @res : $res[0] 3404 wantarray ? @res : $res[0]
3157} 3405}
3158 3406
… …
3172=cut 3420=cut
3173 3421
3174sub register_script_function { 3422sub register_script_function {
3175 my ($fun, $cb) = @_; 3423 my ($fun, $cb) = @_;
3176 3424
3177 no strict 'refs'; 3425 $fun = "safe::$fun" if $CFG{safe_eval};
3178 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3426 *$fun = $safe_hole->wrap ($cb);
3179} 3427}
3180 3428
3181=back 3429=back
3182 3430
3183=cut 3431=cut
… …
3192 # for this (global event?) 3440 # for this (global event?)
3193 %ext::player_env::MUSIC_FACE_CACHE = (); 3441 %ext::player_env::MUSIC_FACE_CACHE = ();
3194 3442
3195 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3443 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3196 3444
3197 warn "loading facedata from $path\n"; 3445 trace "loading facedata from $path\n";
3198 3446
3199 my $facedata; 3447 my $facedata = decode_storable load_file $path;
3200 0 < aio_load $path, $facedata
3201 or die "$path: $!";
3202
3203 $facedata = Coro::Storable::thaw $facedata;
3204 3448
3205 $facedata->{version} == 2 3449 $facedata->{version} == 2
3206 or cf::cleanup "$path: version mismatch, cannot proceed."; 3450 or cf::cleanup "$path: version mismatch, cannot proceed.";
3207 3451
3208 # patch in the exptable 3452 # patch in the exptable
3453 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3209 $facedata->{resource}{"res/exp_table"} = { 3454 $facedata->{resource}{"res/exp_table"} = {
3210 type => FT_RSRC, 3455 type => FT_RSRC,
3211 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3456 data => $exp_table,
3457 hash => (Digest::MD5::md5 $exp_table),
3212 }; 3458 };
3213 cf::cede_to_tick; 3459 cf::cede_to_tick;
3214 3460
3215 { 3461 {
3216 my $faces = $facedata->{faceinfo}; 3462 my $faces = $facedata->{faceinfo};
… …
3218 while (my ($face, $info) = each %$faces) { 3464 while (my ($face, $info) = each %$faces) {
3219 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3465 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3220 3466
3221 cf::face::set_visibility $idx, $info->{visibility}; 3467 cf::face::set_visibility $idx, $info->{visibility};
3222 cf::face::set_magicmap $idx, $info->{magicmap}; 3468 cf::face::set_magicmap $idx, $info->{magicmap};
3223 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3469 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3224 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3470 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3471 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3225 3472
3226 cf::cede_to_tick; 3473 cf::cede_to_tick;
3227 } 3474 }
3228 3475
3229 while (my ($face, $info) = each %$faces) { 3476 while (my ($face, $info) = each %$faces) {
… …
3234 3481
3235 if (my $smooth = cf::face::find $info->{smooth}) { 3482 if (my $smooth = cf::face::find $info->{smooth}) {
3236 cf::face::set_smooth $idx, $smooth; 3483 cf::face::set_smooth $idx, $smooth;
3237 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3484 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3238 } else { 3485 } else {
3239 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3486 error "smooth face '$info->{smooth}' not found for face '$face'";
3240 } 3487 }
3241 3488
3242 cf::cede_to_tick; 3489 cf::cede_to_tick;
3243 } 3490 }
3244 } 3491 }
… …
3253 3500
3254 cf::anim::invalidate_all; # d'oh 3501 cf::anim::invalidate_all; # d'oh
3255 } 3502 }
3256 3503
3257 { 3504 {
3258 # TODO: for gcfclient pleasure, we should give resources
3259 # that gcfclient doesn't grok a >10000 face index.
3260 my $res = $facedata->{resource}; 3505 my $res = $facedata->{resource};
3261 3506
3262 while (my ($name, $info) = each %$res) { 3507 while (my ($name, $info) = each %$res) {
3263 if (defined $info->{type}) { 3508 if (defined $info->{type}) {
3264 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3509 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3265 my $data;
3266 3510
3267 if ($info->{type} & 1) { 3511 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3268 # prepend meta info
3269
3270 my $meta = $enc->encode ({
3271 name => $name,
3272 %{ $info->{meta} || {} },
3273 });
3274
3275 $data = pack "(w/a*)*", $meta, $info->{data};
3276 } else {
3277 $data = $info->{data};
3278 }
3279
3280 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3281 cf::face::set_type $idx, $info->{type}; 3512 cf::face::set_type $idx, $info->{type};
3282 } else { 3513 } else {
3283 $RESOURCE{$name} = $info; 3514 $RESOURCE{$name} = $info; # unused
3284 } 3515 }
3285 3516
3286 cf::cede_to_tick; 3517 cf::cede_to_tick;
3287 } 3518 }
3288 } 3519 }
3289 3520
3290 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3521 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3291 3522
3292 1 3523 1
3293} 3524}
3294
3295cf::global->attach (on_resource_update => sub {
3296 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3297 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3298
3299 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3300 my $sound = $soundconf->{compat}[$_]
3301 or next;
3302
3303 my $face = cf::face::find "sound/$sound->[1]";
3304 cf::sound::set $sound->[0] => $face;
3305 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3306 }
3307
3308 while (my ($k, $v) = each %{$soundconf->{event}}) {
3309 my $face = cf::face::find "sound/$v";
3310 cf::sound::set $k => $face;
3311 }
3312 }
3313});
3314 3525
3315register_exticmd fx_want => sub { 3526register_exticmd fx_want => sub {
3316 my ($ns, $want) = @_; 3527 my ($ns, $want) = @_;
3317 3528
3318 while (my ($k, $v) = each %$want) { 3529 while (my ($k, $v) = each %$want) {
… …
3357sub reload_treasures { 3568sub reload_treasures {
3358 load_resource_file "$DATADIR/treasures" 3569 load_resource_file "$DATADIR/treasures"
3359 or die "unable to load treasurelists\n"; 3570 or die "unable to load treasurelists\n";
3360} 3571}
3361 3572
3573sub reload_sound {
3574 trace "loading sound config from $DATADIR/sound\n";
3575
3576 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3577
3578 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3579 my $sound = $soundconf->{compat}[$_]
3580 or next;
3581
3582 my $face = cf::face::find "sound/$sound->[1]";
3583 cf::sound::set $sound->[0] => $face;
3584 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3585 }
3586
3587 while (my ($k, $v) = each %{$soundconf->{event}}) {
3588 my $face = cf::face::find "sound/$v";
3589 cf::sound::set $k => $face;
3590 }
3591}
3592
3362sub reload_resources { 3593sub reload_resources {
3363 warn "reloading resource files...\n"; 3594 trace "reloading resource files...\n";
3364 3595
3596 reload_exp_table;
3597 reload_materials;
3365 reload_facedata; 3598 reload_facedata;
3599 reload_sound;
3366 reload_archetypes; 3600 reload_archetypes;
3367 reload_regions; 3601 reload_regions;
3368 reload_treasures; 3602 reload_treasures;
3369 3603
3370 warn "finished reloading resource files\n"; 3604 trace "finished reloading resource files\n";
3371}
3372
3373sub init {
3374 my $guard = freeze_mainloop;
3375
3376 reload_resources;
3377} 3605}
3378 3606
3379sub reload_config { 3607sub reload_config {
3380 open my $fh, "<:utf8", "$CONFDIR/config" 3608 trace "reloading config file...\n";
3381 or return;
3382 3609
3383 local $/; 3610 my $config = load_file "$CONFDIR/config";
3384 *CFG = YAML::Load <$fh>; 3611 utf8::decode $config;
3612 *CFG = decode_yaml $config;
3385 3613
3386 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3614 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3387 3615
3388 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3616 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3389 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3617 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3390 3618
3391 if (exists $CFG{mlockall}) { 3619 if (exists $CFG{mlockall}) {
… …
3395 }; 3623 };
3396 warn $@ if $@; 3624 warn $@ if $@;
3397 } 3625 }
3398} 3626}
3399 3627
3628sub pidfile() {
3629 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3630 or die "$PIDFILE: $!";
3631 flock $fh, &Fcntl::LOCK_EX
3632 or die "$PIDFILE: flock: $!";
3633 $fh
3634}
3635
3636# make sure only one server instance is running at any one time
3637sub atomic {
3638 my $fh = pidfile;
3639
3640 my $pid = <$fh>;
3641 kill 9, $pid if $pid > 0;
3642
3643 seek $fh, 0, 0;
3644 print $fh $$;
3645}
3646
3647sub main_loop {
3648 trace "EV::loop starting\n";
3649 if (1) {
3650 EV::loop;
3651 }
3652 trace "EV::loop returned\n";
3653 goto &main_loop unless $REALLY_UNLOOP;
3654}
3655
3400sub main { 3656sub main {
3657 cf::init_globals; # initialise logging
3658
3659 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3660 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3661 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3662 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3663
3664 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3665
3401 # we must not ever block the main coroutine 3666 # we must not ever block the main coroutine
3402 local $Coro::idle = sub { 3667 local $Coro::idle = sub {
3403 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3668 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3404 (async { 3669 (async {
3405 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3670 $Coro::current->{desc} = "IDLE BUG HANDLER";
3406 EV::loop EV::LOOP_ONESHOT; 3671 EV::loop EV::LOOP_ONESHOT;
3407 })->prio (Coro::PRIO_MAX); 3672 })->prio (Coro::PRIO_MAX);
3408 }; 3673 };
3409 3674
3410 { 3675 evthread_start IO::AIO::poll_fileno;
3411 my $guard = freeze_mainloop; 3676
3677 cf::sync_job {
3678 cf::incloader::init ();
3679
3680 cf::init_anim;
3681 cf::init_attackmess;
3682 cf::init_dynamic;
3683
3684 cf::load_settings;
3685
3686 reload_resources;
3412 reload_config; 3687 reload_config;
3413 db_init; 3688 db_init;
3689
3690 cf::init_uuid;
3691 cf::init_signals;
3692 cf::init_skills;
3693
3694 cf::init_beforeplay;
3695
3696 atomic;
3697
3414 load_extensions; 3698 load_extensions;
3415 3699
3416 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3700 utime time, time, $RUNTIMEFILE;
3417 evthread_start IO::AIO::poll_fileno; 3701
3702 # no (long-running) fork's whatsoever before this point(!)
3703 use POSIX ();
3704 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3705
3706 cf::_post_init 0;
3418 } 3707 };
3419 3708
3420 EV::loop; 3709 cf::object::thawer::errors_are_fatal 0;
3710 info "parse errors in files are no longer fatal from this point on.\n";
3711
3712 my $free_main; $free_main = EV::idle sub {
3713 undef $free_main;
3714 undef &main; # free gobs of memory :)
3715 };
3716
3717 goto &main_loop;
3421} 3718}
3422 3719
3423############################################################################# 3720#############################################################################
3424# initialisation and cleanup 3721# initialisation and cleanup
3425 3722
3426# install some emergency cleanup handlers 3723# install some emergency cleanup handlers
3427BEGIN { 3724BEGIN {
3428 our %SIGWATCHER = (); 3725 our %SIGWATCHER = ();
3429 for my $signal (qw(INT HUP TERM)) { 3726 for my $signal (qw(INT HUP TERM)) {
3430 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3727 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3431 cf::cleanup "SIG$signal"; 3728 cf::cleanup "SIG$signal";
3432 }; 3729 };
3433 } 3730 }
3434} 3731}
3435 3732
3436sub write_runtime_sync { 3733sub write_runtime_sync {
3437 my $runtime = "$LOCALDIR/runtime"; 3734 my $t0 = AE::time;
3438 3735
3439 # first touch the runtime file to show we are still running: 3736 # first touch the runtime file to show we are still running:
3440 # the fsync below can take a very very long time. 3737 # the fsync below can take a very very long time.
3441 3738
3442 IO::AIO::aio_utime $runtime, undef, undef; 3739 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3443 3740
3444 my $guard = cf::lock_acquire "write_runtime"; 3741 my $guard = cf::lock_acquire "write_runtime";
3445 3742
3446 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3743 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3447 or return; 3744 or return;
3448 3745
3449 my $value = $cf::RUNTIME + 90 + 10; 3746 my $value = $cf::RUNTIME + 90 + 10;
3450 # 10 is the runtime save interval, for a monotonic clock 3747 # 10 is the runtime save interval, for a monotonic clock
3451 # 60 allows for the watchdog to kill the server. 3748 # 60 allows for the watchdog to kill the server.
… …
3461 aio_utime $fh, undef, undef; 3758 aio_utime $fh, undef, undef;
3462 3759
3463 close $fh 3760 close $fh
3464 or return; 3761 or return;
3465 3762
3466 aio_rename "$runtime~", $runtime 3763 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3467 and return; 3764 and return;
3468 3765
3469 warn "runtime file written.\n"; 3766 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3470 3767
3471 1 3768 1
3472} 3769}
3473 3770
3474our $uuid_lock; 3771our $uuid_lock;
… …
3483 my $uuid = "$LOCALDIR/uuid"; 3780 my $uuid = "$LOCALDIR/uuid";
3484 3781
3485 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3782 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3486 or return; 3783 or return;
3487 3784
3488 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3785 my $value = uuid_seq uuid_cur;
3786
3787 unless ($value) {
3788 info "cowardly refusing to write zero uuid value!\n";
3789 return;
3790 }
3791
3792 my $value = uuid_str $value + $uuid_skip;
3489 $uuid_skip = 0; 3793 $uuid_skip = 0;
3490 3794
3491 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3795 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3492 and return; 3796 and return;
3493 3797
… …
3499 or return; 3803 or return;
3500 3804
3501 aio_rename "$uuid~", $uuid 3805 aio_rename "$uuid~", $uuid
3502 and return; 3806 and return;
3503 3807
3504 warn "uuid file written ($value).\n"; 3808 trace "uuid file written ($value).\n";
3505 3809
3506 1 3810 1
3507 3811
3508} 3812}
3509 3813
… …
3515} 3819}
3516 3820
3517sub emergency_save() { 3821sub emergency_save() {
3518 my $freeze_guard = cf::freeze_mainloop; 3822 my $freeze_guard = cf::freeze_mainloop;
3519 3823
3520 warn "enter emergency perl save\n"; 3824 info "emergency_perl_save: enter\n";
3825
3826 # this is a trade-off: we want to be very quick here, so
3827 # save all maps without fsync, and later call a global sync
3828 # (which in turn might be very very slow)
3829 local $USE_FSYNC = 0;
3521 3830
3522 cf::sync_job { 3831 cf::sync_job {
3832 cf::write_runtime_sync; # external watchdog should not bark
3833
3523 # use a peculiar iteration method to avoid tripping on perl 3834 # use a peculiar iteration method to avoid tripping on perl
3524 # refcount bugs in for. also avoids problems with players 3835 # refcount bugs in for. also avoids problems with players
3525 # and maps saved/destroyed asynchronously. 3836 # and maps saved/destroyed asynchronously.
3526 warn "begin emergency player save\n"; 3837 info "emergency_perl_save: begin player save\n";
3527 for my $login (keys %cf::PLAYER) { 3838 for my $login (keys %cf::PLAYER) {
3528 my $pl = $cf::PLAYER{$login} or next; 3839 my $pl = $cf::PLAYER{$login} or next;
3529 $pl->valid or next; 3840 $pl->valid or next;
3530 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3841 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3531 $pl->save; 3842 $pl->save;
3532 } 3843 }
3533 warn "end emergency player save\n"; 3844 info "emergency_perl_save: end player save\n";
3534 3845
3535 warn "begin emergency map save\n"; 3846 cf::write_runtime_sync; # external watchdog should not bark
3847
3848 info "emergency_perl_save: begin map save\n";
3536 for my $path (keys %cf::MAP) { 3849 for my $path (keys %cf::MAP) {
3537 my $map = $cf::MAP{$path} or next; 3850 my $map = $cf::MAP{$path} or next;
3538 $map->valid or next; 3851 $map->valid or next;
3539 $map->save; 3852 $map->save;
3540 } 3853 }
3541 warn "end emergency map save\n"; 3854 info "emergency_perl_save: end map save\n";
3542 3855
3543 warn "begin emergency database checkpoint\n"; 3856 cf::write_runtime_sync; # external watchdog should not bark
3857
3858 info "emergency_perl_save: begin database checkpoint\n";
3544 BDB::db_env_txn_checkpoint $DB_ENV; 3859 BDB::db_env_txn_checkpoint $DB_ENV;
3545 warn "end emergency database checkpoint\n"; 3860 info "emergency_perl_save: end database checkpoint\n";
3546 3861
3547 warn "begin write uuid\n"; 3862 info "emergency_perl_save: begin write uuid\n";
3548 write_uuid_sync 1; 3863 write_uuid_sync 1;
3549 warn "end write uuid\n"; 3864 info "emergency_perl_save: end write uuid\n";
3865
3866 cf::write_runtime_sync; # external watchdog should not bark
3867
3868 trace "emergency_perl_save: syncing database to disk";
3869 BDB::db_env_txn_checkpoint $DB_ENV;
3870
3871 info "emergency_perl_save: starting sync\n";
3872 IO::AIO::aio_sync sub {
3873 info "emergency_perl_save: finished sync\n";
3874 };
3875
3876 cf::write_runtime_sync; # external watchdog should not bark
3877
3878 trace "emergency_perl_save: flushing outstanding aio requests";
3879 while (IO::AIO::nreqs || BDB::nreqs) {
3880 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3881 }
3882
3883 cf::write_runtime_sync; # external watchdog should not bark
3550 }; 3884 };
3551 3885
3552 warn "leave emergency perl save\n"; 3886 info "emergency_perl_save: leave\n";
3553} 3887}
3554 3888
3555sub post_cleanup { 3889sub post_cleanup {
3556 my ($make_core) = @_; 3890 my ($make_core) = @_;
3557 3891
3892 IO::AIO::flush;
3893
3558 warn Carp::longmess "post_cleanup backtrace" 3894 error Carp::longmess "post_cleanup backtrace"
3559 if $make_core; 3895 if $make_core;
3896
3897 my $fh = pidfile;
3898 unlink $PIDFILE if <$fh> == $$;
3899}
3900
3901# a safer delete_package, copied from Symbol
3902sub clear_package($) {
3903 my $pkg = shift;
3904
3905 # expand to full symbol table name if needed
3906 unless ($pkg =~ /^main::.*::$/) {
3907 $pkg = "main$pkg" if $pkg =~ /^::/;
3908 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3909 $pkg .= '::' unless $pkg =~ /::$/;
3910 }
3911
3912 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3913 my $stem_symtab = *{$stem}{HASH};
3914
3915 defined $stem_symtab and exists $stem_symtab->{$leaf}
3916 or return;
3917
3918 # clear all symbols
3919 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3920 for my $name (keys %$leaf_symtab) {
3921 _gv_clear *{"$pkg$name"};
3922# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3923 }
3560} 3924}
3561 3925
3562sub do_reload_perl() { 3926sub do_reload_perl() {
3563 # can/must only be called in main 3927 # can/must only be called in main
3564 if ($Coro::current != $Coro::main) { 3928 unless (in_main) {
3565 warn "can only reload from main coroutine"; 3929 error "can only reload from main coroutine";
3566 return; 3930 return;
3567 } 3931 }
3568 3932
3569 warn "reloading..."; 3933 return if $RELOAD++;
3570 3934
3571 warn "entering sync_job"; 3935 my $t1 = AE::time;
3572 3936
3937 while ($RELOAD) {
3938 cf::get_slot 0.1, -1, "reload_perl";
3939 info "perl_reload: reloading...";
3940
3941 trace "perl_reload: entering sync_job";
3942
3573 cf::sync_job { 3943 cf::sync_job {
3574 cf::write_runtime_sync; # external watchdog should not bark
3575 cf::emergency_save; 3944 #cf::emergency_save;
3576 cf::write_runtime_sync; # external watchdog should not bark
3577 3945
3578 warn "syncing database to disk";
3579 BDB::db_env_txn_checkpoint $DB_ENV;
3580
3581 # if anything goes wrong in here, we should simply crash as we already saved
3582
3583 warn "flushing outstanding aio requests";
3584 for (;;) {
3585 BDB::flush;
3586 IO::AIO::flush;
3587 Coro::cede_notself;
3588 last unless IO::AIO::nreqs || BDB::nreqs;
3589 warn "iterate...";
3590 }
3591
3592 ++$RELOAD;
3593
3594 warn "cancelling all extension coros"; 3946 trace "perl_reload: cancelling all extension coros";
3595 $_->cancel for values %EXT_CORO; 3947 $_->cancel for values %EXT_CORO;
3596 %EXT_CORO = (); 3948 %EXT_CORO = ();
3597 3949
3598 warn "removing commands"; 3950 trace "perl_reload: removing commands";
3599 %COMMAND = (); 3951 %COMMAND = ();
3600 3952
3601 warn "removing ext/exti commands"; 3953 trace "perl_reload: removing ext/exti commands";
3602 %EXTCMD = (); 3954 %EXTCMD = ();
3603 %EXTICMD = (); 3955 %EXTICMD = ();
3604 3956
3605 warn "unloading/nuking all extensions"; 3957 trace "perl_reload: unloading/nuking all extensions";
3606 for my $pkg (@EXTS) { 3958 for my $pkg (@EXTS) {
3607 warn "... unloading $pkg"; 3959 trace "... unloading $pkg";
3608 3960
3609 if (my $cb = $pkg->can ("unload")) { 3961 if (my $cb = $pkg->can ("unload")) {
3610 eval { 3962 eval {
3611 $cb->($pkg); 3963 $cb->($pkg);
3612 1 3964 1
3613 } or warn "$pkg unloaded, but with errors: $@"; 3965 } or error "$pkg unloaded, but with errors: $@";
3966 }
3967
3968 trace "... clearing $pkg";
3969 clear_package $pkg;
3614 } 3970 }
3615 3971
3616 warn "... nuking $pkg";
3617 Symbol::delete_package $pkg;
3618 }
3619
3620 warn "unloading all perl modules loaded from $LIBDIR"; 3972 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3621 while (my ($k, $v) = each %INC) { 3973 while (my ($k, $v) = each %INC) {
3622 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3974 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3623 3975
3624 warn "... unloading $k"; 3976 trace "... unloading $k";
3625 delete $INC{$k}; 3977 delete $INC{$k};
3626 3978
3627 $k =~ s/\.pm$//; 3979 $k =~ s/\.pm$//;
3628 $k =~ s/\//::/g; 3980 $k =~ s/\//::/g;
3629 3981
3630 if (my $cb = $k->can ("unload_module")) { 3982 if (my $cb = $k->can ("unload_module")) {
3631 $cb->(); 3983 $cb->();
3984 }
3985
3986 clear_package $k;
3632 } 3987 }
3633 3988
3634 Symbol::delete_package $k;
3635 }
3636
3637 warn "getting rid of safe::, as good as possible"; 3989 trace "perl_reload: getting rid of safe::, as good as possible";
3638 Symbol::delete_package "safe::$_" 3990 clear_package "safe::$_"
3639 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3991 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3640 3992
3641 warn "unloading cf.pm \"a bit\""; 3993 trace "perl_reload: unloading cf.pm \"a bit\"";
3642 delete $INC{"cf.pm"}; 3994 delete $INC{"cf.pm"};
3643 delete $INC{"cf/pod.pm"}; 3995 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3644 3996
3645 # don't, removes xs symbols, too, 3997 # don't, removes xs symbols, too,
3646 # and global variables created in xs 3998 # and global variables created in xs
3647 #Symbol::delete_package __PACKAGE__; 3999 #clear_package __PACKAGE__;
3648 4000
3649 warn "unload completed, starting to reload now"; 4001 info "perl_reload: unload completed, starting to reload now";
3650 4002
3651 warn "reloading cf.pm"; 4003 trace "perl_reload: reloading cf.pm";
3652 require cf; 4004 require cf;
3653 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 4005 cf::_connect_to_perl_1;
3654 4006
3655 warn "loading config and database again"; 4007 trace "perl_reload: loading config and database again";
3656 cf::reload_config; 4008 cf::reload_config;
3657 4009
3658 warn "loading extensions"; 4010 trace "perl_reload: loading extensions";
3659 cf::load_extensions; 4011 cf::load_extensions;
3660 4012
4013 if ($REATTACH_ON_RELOAD) {
3661 warn "reattaching attachments to objects/players"; 4014 trace "perl_reload: reattaching attachments to objects/players";
3662 _global_reattach; # objects, sockets 4015 _global_reattach; # objects, sockets
3663 warn "reattaching attachments to maps"; 4016 trace "perl_reload: reattaching attachments to maps";
3664 reattach $_ for values %MAP; 4017 reattach $_ for values %MAP;
3665 warn "reattaching attachments to players"; 4018 trace "perl_reload: reattaching attachments to players";
3666 reattach $_ for values %PLAYER; 4019 reattach $_ for values %PLAYER;
4020 }
3667 4021
3668 warn "leaving sync_job"; 4022 cf::_post_init 1;
3669 4023
4024 trace "perl_reload: leaving sync_job";
4025
3670 1 4026 1
3671 } or do { 4027 } or do {
3672 warn $@; 4028 error $@;
3673 cf::cleanup "error while reloading, exiting."; 4029 cf::cleanup "perl_reload: error, exiting.";
4030 };
4031
4032 --$RELOAD;
3674 }; 4033 }
3675 4034
3676 warn "reloaded"; 4035 $t1 = AE::time - $t1;
4036 info "perl_reload: completed in ${t1}s\n";
3677}; 4037};
3678 4038
3679our $RELOAD_WATCHER; # used only during reload 4039our $RELOAD_WATCHER; # used only during reload
3680 4040
3681sub reload_perl() { 4041sub reload_perl() {
3682 # doing reload synchronously and two reloads happen back-to-back, 4042 # doing reload synchronously and two reloads happen back-to-back,
3683 # coro crashes during coro_state_free->destroy here. 4043 # coro crashes during coro_state_free->destroy here.
3684 4044
4045 $RELOAD_WATCHER ||= cf::async {
4046 Coro::AIO::aio_wait cache_extensions;
4047
3685 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 4048 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3686 do_reload_perl; 4049 do_reload_perl;
3687 undef $RELOAD_WATCHER; 4050 undef $RELOAD_WATCHER;
4051 };
3688 }; 4052 };
3689} 4053}
3690 4054
3691register_command "reload" => sub { 4055register_command "reload" => sub {
3692 my ($who, $arg) = @_; 4056 my ($who, $arg) = @_;
… …
3698 reload_perl; 4062 reload_perl;
3699 }; 4063 };
3700 } 4064 }
3701}; 4065};
3702 4066
3703unshift @INC, $LIBDIR; 4067#############################################################################
3704 4068
3705my $bug_warning = 0; 4069my $bug_warning = 0;
3706 4070
3707our @WAIT_FOR_TICK; 4071our @WAIT_FOR_TICK;
3708our @WAIT_FOR_TICK_BEGIN; 4072our @WAIT_FOR_TICK_BEGIN;
3709 4073
3710sub wait_for_tick { 4074sub wait_for_tick() {
3711 return if tick_inhibit || $Coro::current == $Coro::main; 4075 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3712 4076
3713 my $signal = new Coro::Signal; 4077 my $signal = new Coro::Signal;
3714 push @WAIT_FOR_TICK, $signal; 4078 push @WAIT_FOR_TICK, $signal;
3715 $signal->wait; 4079 $signal->wait;
3716} 4080}
3717 4081
3718sub wait_for_tick_begin { 4082sub wait_for_tick_begin() {
3719 return if tick_inhibit || $Coro::current == $Coro::main; 4083 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3720 4084
3721 my $signal = new Coro::Signal; 4085 my $signal = new Coro::Signal;
3722 push @WAIT_FOR_TICK_BEGIN, $signal; 4086 push @WAIT_FOR_TICK_BEGIN, $signal;
3723 $signal->wait; 4087 $signal->wait;
3724} 4088}
… …
3730 return; 4094 return;
3731 } 4095 }
3732 4096
3733 cf::server_tick; # one server iteration 4097 cf::server_tick; # one server iteration
3734 4098
4099 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4100
3735 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4101 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3736 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4102 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3737 Coro::async_pool { 4103 Coro::async_pool {
3738 $Coro::current->{desc} = "runtime saver"; 4104 $Coro::current->{desc} = "runtime saver";
3739 write_runtime_sync 4105 write_runtime_sync
3740 or warn "ERROR: unable to write runtime file: $!"; 4106 or error "ERROR: unable to write runtime file: $!";
3741 }; 4107 };
3742 } 4108 }
3743 4109
3744 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4110 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3745 $sig->send; 4111 $sig->send;
… …
3753 4119
3754 if (0) { 4120 if (0) {
3755 if ($NEXT_TICK) { 4121 if ($NEXT_TICK) {
3756 my $jitter = $TICK_START - $NEXT_TICK; 4122 my $jitter = $TICK_START - $NEXT_TICK;
3757 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4123 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3758 warn "jitter $JITTER\n";#d# 4124 debug "jitter $JITTER\n";#d#
3759 } 4125 }
3760 } 4126 }
3761} 4127}
3762 4128
3763{ 4129{
3764 # configure BDB 4130 # configure BDB
3765 4131
3766 BDB::min_parallel 8; 4132 BDB::min_parallel 16;
3767 BDB::max_poll_reqs $TICK * 0.1; 4133 BDB::max_poll_reqs $TICK * 0.1;
3768 $Coro::BDB::WATCHER->priority (1); 4134 $AnyEvent::BDB::WATCHER->priority (1);
3769 4135
3770 unless ($DB_ENV) { 4136 unless ($DB_ENV) {
3771 $DB_ENV = BDB::db_env_create; 4137 $DB_ENV = BDB::db_env_create;
3772 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 4138 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3773 | BDB::LOG_AUTOREMOVE, 1); 4139 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4140 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3774 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4141 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3775 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4142 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3776 4143
3777 cf::sync_job { 4144 cf::sync_job {
3778 eval { 4145 eval {
… …
3804{ 4171{
3805 # configure IO::AIO 4172 # configure IO::AIO
3806 4173
3807 IO::AIO::min_parallel 8; 4174 IO::AIO::min_parallel 8;
3808 IO::AIO::max_poll_time $TICK * 0.1; 4175 IO::AIO::max_poll_time $TICK * 0.1;
3809 $Coro::AIO::WATCHER->priority (1); 4176 undef $AnyEvent::AIO::WATCHER;
3810} 4177}
3811 4178
3812my $_log_backtrace; 4179our $_log_backtrace;
4180our $_log_backtrace_last;
3813 4181
3814sub _log_backtrace { 4182sub _log_backtrace {
3815 my ($msg, @addr) = @_; 4183 my ($msg, @addr) = @_;
3816 4184
3817 $msg =~ s/\n//; 4185 $msg =~ s/\n$//;
3818 4186
4187 if ($_log_backtrace_last eq $msg) {
4188 LOG llevInfo, "[ABT] $msg\n";
4189 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3819 # limit the # of concurrent backtraces 4190 # limit the # of concurrent backtraces
3820 if ($_log_backtrace < 2) { 4191 } elsif ($_log_backtrace < 2) {
4192 $_log_backtrace_last = $msg;
3821 ++$_log_backtrace; 4193 ++$_log_backtrace;
4194 my $perl_bt = Carp::longmess $msg;
3822 async { 4195 async {
3823 $Coro::current->{desc} = "abt $msg"; 4196 $Coro::current->{desc} = "abt $msg";
3824 4197
3825 my @bt = fork_call { 4198 my @bt = fork_call {
3826 @addr = map { sprintf "%x", $_ } @addr; 4199 @addr = map { sprintf "%x", $_ } @addr;
… …
3837 } 4210 }
3838 4211
3839 @funcs 4212 @funcs
3840 }; 4213 };
3841 4214
3842 LOG llevInfo, "[ABT] $msg\n"; 4215 LOG llevInfo, "[ABT] $perl_bt\n";
4216 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3843 LOG llevInfo, "[ABT] $_\n" for @bt; 4217 LOG llevInfo, "[ABT] $_\n" for @bt;
3844 --$_log_backtrace; 4218 --$_log_backtrace;
3845 }; 4219 };
3846 } else { 4220 } else {
3847 LOG llevInfo, "[ABT] $msg\n"; 4221 LOG llevInfo, "[ABT] $msg\n";
3848 LOG llevInfo, "[ABT] [suppressed]\n"; 4222 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3849 } 4223 }
3850} 4224}
3851 4225
3852# load additional modules 4226# load additional modules
3853use cf::pod; 4227require "cf/$_.pm" for @EXTRA_MODULES;
4228cf::_connect_to_perl_2;
3854 4229
3855END { cf::emergency_save } 4230END { cf::emergency_save }
3856 4231
38571 42321
3858 4233

Diff Legend

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