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.382 by root, Thu Oct 11 00:34:31 2007 UTC vs.
Revision 1.533 by root, Thu Apr 29 07:59:17 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
25use 5.10.0;
3use utf8; 26use utf8;
4use strict; 27use strict qw(vars subs);
5 28
6use Symbol; 29use Symbol;
7use List::Util; 30use List::Util;
8use Socket; 31use Socket;
9use Storable; 32use EV;
10use Event;
11use Opcode; 33use Opcode;
12use Safe; 34use Safe;
13use Safe::Hole; 35use Safe::Hole;
36use Storable ();
37use Carp ();
14 38
39use Guard ();
15use Coro 4.1 (); 40use Coro ();
16use Coro::State; 41use Coro::State;
17use Coro::Handle; 42use Coro::Handle;
43use Coro::EV;
18use Coro::Event; 44use Coro::AnyEvent;
19use Coro::Timer; 45use Coro::Timer;
20use Coro::Signal; 46use Coro::Signal;
21use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
22use Coro::AIO; 50use Coro::AIO;
51use Coro::BDB 1.6;
23use Coro::Storable; 52use Coro::Storable;
24use Coro::Util (); 53use Coro::Util ();
25 54
26use JSON::XS (); 55use JSON::XS 2.01 ();
27use BDB (); 56use BDB ();
28use Data::Dumper; 57use Data::Dumper;
29use Digest::MD5;
30use Fcntl; 58use Fcntl;
31use YAML::Syck (); 59use YAML::XS ();
32use IO::AIO 2.51 (); 60use IO::AIO ();
33use Time::HiRes; 61use Time::HiRes;
34use Compress::LZF; 62use Compress::LZF;
35use Digest::MD5 (); 63use Digest::MD5 ();
64
65AnyEvent::detect;
36 66
37# configure various modules to our taste 67# configure various modules to our taste
38# 68#
39$Storable::canonical = 1; # reduce rsync transfers 69$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 70Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
71
72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
73
74# make sure c-lzf reinitialises itself
75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42 77
43$Event::Eval = 1; # no idea why this is required, but it is 78# strictly for debugging
44 79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 80
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 82
52our %COMMAND = (); 83our %COMMAND = ();
53our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
56our %EXTCMD = (); 87our %EXTCMD = ();
57our %EXTICMD = (); 88our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
60 91
61our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
62our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
63 96
64our $CONFDIR = confdir; 97our $CONFDIR = confdir;
65our $DATADIR = datadir; 98our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 101our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 102our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 103our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
111our %RESOURCE; # unused
112
113our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 1;
75 118
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 121our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
83 123
84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
88our $DB_ENV; 127our $DB_ENV;
89 128
129our @EXTRA_MODULES = qw(pod match mapscript);
130
90our %CFG; 131our %CFG;
91 132
92our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 134our $RUNTIME;
135our $NOW;
94 136
95our (%PLAYER, %PLAYER_LOADING); # all users 137our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 138our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 139our $LINK_MAP; # the special {link} map, which is always available
98 140
99# used to convert map paths into valid unix filenames by replacing / by ∕ 141# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 142our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 143
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 144our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 145our $LOADAVG; # same thing, but with alpha-smoothing
146our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 147our $TICK_START; # for load detecting purposes
148
149our @POST_INIT;
150
151our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
152our $REALLY_UNLOOP; # never set to true, please :)
105 153
106binmode STDOUT; 154binmode STDOUT;
107binmode STDERR; 155binmode STDERR;
108 156
109# read virtual server time, if available 157# read virtual server time, if available
110unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
111 open my $fh, "<", "$LOCALDIR/runtime" 159 open my $fh, "<", $RUNTIMEFILE
112 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
113 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
114} 162}
163
164eval "sub TICK() { $TICK } 1" or die;
115 165
116mkdir $_ 166mkdir $_
117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
118 168
119our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
120 170
121sub cf::map::normalise; 171sub cf::map::normalise;
172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
177#############################################################################
178
179%REFLECT = ();
180for (@REFLECT) {
181 my $reflect = JSON::XS::decode_json $_;
182 $REFLECT{$reflect->{class}} = $reflect;
183}
184
185# this is decidedly evil
186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
122 187
123############################################################################# 188#############################################################################
124 189
125=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
126 191
162 227
163The raw value load value from the last tick. 228The raw value load value from the last tick.
164 229
165=item %cf::CFG 230=item %cf::CFG
166 231
167Configuration for the server, loaded from C</etc/crossfire/config>, or 232Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 233from wherever your confdir points to.
169 234
170=item cf::wait_for_tick, cf::wait_for_tick_begin 235=item cf::wait_for_tick, cf::wait_for_tick_begin
171 236
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 237These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
173returns directly I<after> the tick processing (and consequently, can only wake one process 238returns directly I<after> the tick processing (and consequently, can only wake one process
174per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 239per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
175 240
176=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
177 242
178This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
179C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
180that call. 245that call.
181 246
247=item %cf::REFLECT
248
249Contains, for each (C++) class name, a hash reference with information
250about object members (methods, scalars, arrays and flags) and other
251metadata, which is useful for introspection.
252
182=back 253=back
183 254
184=cut 255=cut
185 256
186BEGIN { 257sub error(@) { LOG llevError, join "", @_ }
187 *CORE::GLOBAL::warn = sub { 258sub warn (@) { LOG llevWarn , join "", @_ }
259sub info (@) { LOG llevInfo , join "", @_ }
260sub debug(@) { LOG llevDebug, join "", @_ }
261sub trace(@) { LOG llevTrace, join "", @_ }
262
263$Coro::State::WARNHOOK = sub {
188 my $msg = join "", @_; 264 my $msg = join "", @_;
189 265
190 $msg .= "\n" 266 $msg .= "\n"
191 unless $msg =~ /\n$/; 267 unless $msg =~ /\n$/;
192 268
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 269 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 270
195 LOG llevError, $msg; 271 LOG llevWarn, $msg;
196 }; 272};
197} 273
274$Coro::State::DIEHOOK = sub {
275 return unless $^S eq 0; # "eq", not "=="
276
277 error Carp::longmess $_[0];
278
279 if (in_main) {#d#
280 error "DIEHOOK called in main context, Coro bug?\n";#d#
281 return;#d#
282 }#d#
283
284 # kill coroutine otherwise
285 Coro::terminate
286};
198 287
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 288@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 289@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 290@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 291@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
209for my $pkg (qw( 298for my $pkg (qw(
210 cf::global cf::attachable 299 cf::global cf::attachable
211 cf::object cf::object::player 300 cf::object cf::object::player
212 cf::client cf::player 301 cf::client cf::player
213 cf::arch cf::living 302 cf::arch cf::living
303 cf::map cf::mapspace
214 cf::map cf::party cf::region 304 cf::party cf::region
215)) { 305)) {
216 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 306 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 307}
219 308
220$Event::DIED = sub { 309$EV::DIED = sub {
221 warn "error in event callback: @_"; 310 Carp::cluck "error in event callback: @_";
222}; 311};
223 312
224############################################################################# 313#############################################################################
225 314
226=head2 UTILITY FUNCTIONS 315=head2 UTILITY FUNCTIONS
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 337 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 338 $d
250 } || "[unable to dump $_[0]: '$@']"; 339 } || "[unable to dump $_[0]: '$@']";
251} 340}
252 341
253=item $ref = cf::from_json $json 342=item $ref = cf::decode_json $json
254 343
255Converts a JSON string into the corresponding perl data structure. 344Converts a JSON string into the corresponding perl data structure.
256 345
257=item $json = cf::to_json $ref 346=item $json = cf::encode_json $ref
258 347
259Converts a perl data structure into its JSON representation. 348Converts a perl data structure into its JSON representation.
260 349
261=cut 350=cut
262 351
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 352our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 353
265sub to_json ($) { $json_coder->encode ($_[0]) } 354sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 355sub decode_json($) { $json_coder->decode ($_[0]) }
356
357=item cf::post_init { BLOCK }
358
359Execute the given codeblock, I<after> all extensions have been (re-)loaded,
360but I<before> the server starts ticking again.
361
362The cdoeblock will have a single boolean argument to indicate whether this
363is a reload or not.
364
365=cut
366
367sub post_init(&) {
368 push @POST_INIT, shift;
369}
267 370
268=item cf::lock_wait $string 371=item cf::lock_wait $string
269 372
270Wait until the given lock is available. See cf::lock_acquire. 373Wait until the given lock is available. See cf::lock_acquire.
271 374
272=item my $lock = cf::lock_acquire $string 375=item my $lock = cf::lock_acquire $string
273 376
274Wait until the given lock is available and then acquires it and returns 377Wait until the given lock is available and then acquires it and returns
275a Coro::guard object. If the guard object gets destroyed (goes out of scope, 378a L<Guard> object. If the guard object gets destroyed (goes out of scope,
276for example when the coroutine gets canceled), the lock is automatically 379for example when the coroutine gets canceled), the lock is automatically
277returned. 380returned.
278 381
279Locks are *not* recursive, locking from the same coro twice results in a 382Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro. 383deadlocked coro.
286 389
287Return true if the lock is currently active, i.e. somebody has locked it. 390Return true if the lock is currently active, i.e. somebody has locked it.
288 391
289=cut 392=cut
290 393
291our %LOCK; 394our $LOCKS = new Coro::SemaphoreSet;
292our %LOCKER;#d#
293 395
294sub lock_wait($) { 396sub lock_wait($) {
295 my ($key) = @_; 397 $LOCKS->wait ($_[0]);
296
297 if ($LOCKER{$key} == $Coro::current) {#d#
298 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
299 return;#d#
300 }#d#
301
302 # wait for lock, if any
303 while ($LOCK{$key}) {
304 push @{ $LOCK{$key} }, $Coro::current;
305 Coro::schedule;
306 }
307} 398}
308 399
309sub lock_acquire($) { 400sub lock_acquire($) {
310 my ($key) = @_; 401 $LOCKS->guard ($_[0])
311
312 # wait, to be sure we are not locked
313 lock_wait $key;
314
315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
317
318 Coro::guard {
319 delete $LOCKER{$key};#d#
320 # wake up all waiters, to be on the safe side
321 $_->ready for @{ delete $LOCK{$key} };
322 }
323} 402}
324 403
325sub lock_active($) { 404sub lock_active($) {
326 my ($key) = @_; 405 $LOCKS->count ($_[0]) < 1
327
328 ! ! $LOCK{$key}
329} 406}
330 407
331sub freeze_mainloop { 408sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 409 tick_inhibit_inc;
333 410
334 my $guard = Coro::guard { 411 &Guard::guard (\&tick_inhibit_dec);
335 $TICK_WATCHER->start; 412}
336 }; 413
337 $TICK_WATCHER->stop; 414=item cf::periodic $interval, $cb
338 $guard 415
416Like EV::periodic, but randomly selects a starting point so that the actions
417get spread over time.
418
419=cut
420
421sub periodic($$) {
422 my ($interval, $cb) = @_;
423
424 my $start = rand List::Util::min 180, $interval;
425
426 EV::periodic $start, $interval, 0, $cb
339} 427}
340 428
341=item cf::get_slot $time[, $priority[, $name]] 429=item cf::get_slot $time[, $priority[, $name]]
342 430
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 431Allocate $time seconds of blocking CPU time at priority C<$priority>:
351 439
352=cut 440=cut
353 441
354our @SLOT_QUEUE; 442our @SLOT_QUEUE;
355our $SLOT_QUEUE; 443our $SLOT_QUEUE;
444our $SLOT_DECAY = 0.9;
356 445
357$SLOT_QUEUE->cancel if $SLOT_QUEUE; 446$SLOT_QUEUE->cancel if $SLOT_QUEUE;
358$SLOT_QUEUE = Coro::async { 447$SLOT_QUEUE = Coro::async {
359 $Coro::current->desc ("timeslot manager"); 448 $Coro::current->desc ("timeslot manager");
360 449
361 my $signal = new Coro::Signal; 450 my $signal = new Coro::Signal;
451 my $busy;
362 452
363 while () { 453 while () {
364 next_job: 454 next_job:
455
365 my $avail = cf::till_tick; 456 my $avail = cf::till_tick;
366 if ($avail > 0.01) { 457
367 for (0 .. $#SLOT_QUEUE) { 458 for (0 .. $#SLOT_QUEUE) {
368 if ($SLOT_QUEUE[$_][0] < $avail) { 459 if ($SLOT_QUEUE[$_][0] <= $avail) {
460 $busy = 0;
369 my $job = splice @SLOT_QUEUE, $_, 1, (); 461 my $job = splice @SLOT_QUEUE, $_, 1, ();
370 $job->[2]->send; 462 $job->[2]->send;
371 Coro::cede; 463 Coro::cede;
372 goto next_job; 464 goto next_job;
373 } 465 } else {
466 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
374 } 467 }
375 } 468 }
376 469
377 if (@SLOT_QUEUE) { 470 if (@SLOT_QUEUE) {
378 # we do not use wait_for_tick() as it returns immediately when tick is inactive 471 # we do not use wait_for_tick() as it returns immediately when tick is inactive
379 push @cf::WAIT_FOR_TICK, $signal; 472 push @cf::WAIT_FOR_TICK, $signal;
380 $signal->wait; 473 $signal->wait;
381 } else { 474 } else {
475 $busy = 0;
382 Coro::schedule; 476 Coro::schedule;
383 } 477 }
384 } 478 }
385}; 479};
386 480
387sub get_slot($;$$) { 481sub get_slot($;$$) {
482 return if tick_inhibit || $Coro::current == $Coro::main;
483
388 my ($time, $pri, $name) = @_; 484 my ($time, $pri, $name) = @_;
389 485
390 $time = $TICK * .6 if $time > $TICK * .6; 486 $time = clamp $time, 0.01, $TICK * .6;
487
391 my $sig = new Coro::Signal; 488 my $sig = new Coro::Signal;
392 489
393 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 490 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
394 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 491 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
395 $SLOT_QUEUE->ready; 492 $SLOT_QUEUE->ready;
406 503
407BEGIN { *async = \&Coro::async_pool } 504BEGIN { *async = \&Coro::async_pool }
408 505
409=item cf::sync_job { BLOCK } 506=item cf::sync_job { BLOCK }
410 507
411The design of Crossfire TRT requires that the main coroutine ($Coro::main) 508The design of Deliantra requires that the main coroutine ($Coro::main)
412is always able to handle events or runnable, as Crossfire TRT is only 509is always able to handle events or runnable, as Deliantra is only
413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 510partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable. 511acceptable.
415 512
416If it must be done, put the blocking parts into C<sync_job>. This will run 513If it must be done, put the blocking parts into C<sync_job>. This will run
417the given BLOCK in another coroutine while waiting for the result. The 514the given BLOCK in another coroutine while waiting for the result. The
422 519
423sub sync_job(&) { 520sub sync_job(&) {
424 my ($job) = @_; 521 my ($job) = @_;
425 522
426 if ($Coro::current == $Coro::main) { 523 if ($Coro::current == $Coro::main) {
427 my $time = Event::time; 524 my $time = AE::time;
428 525
429 # this is the main coro, too bad, we have to block 526 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 527 # till the operation succeeds, freezing the server :/
431 528
432 LOG llevError | logBacktrace, Carp::longmess "sync job";#d# 529 LOG llevError, Carp::longmess "sync job";#d#
433 530
434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 531 my $freeze_guard = freeze_mainloop;
437 532
438 my $busy = 1; 533 my $busy = 1;
439 my @res; 534 my @res;
440 535
441 (async { 536 (async {
442 $Coro::current->desc ("sync job coro"); 537 $Coro::current->desc ("sync job coro");
443 @res = eval { $job->() }; 538 @res = eval { $job->() };
444 warn $@ if $@; 539 error $@ if $@;
445 undef $busy; 540 undef $busy;
446 })->prio (Coro::PRIO_MAX); 541 })->prio (Coro::PRIO_MAX);
447 542
448 while ($busy) { 543 while ($busy) {
449 Coro::cede or Event::one_event; 544 if (Coro::nready) {
545 Coro::cede_notself;
546 } else {
547 EV::loop EV::LOOP_ONESHOT;
450 } 548 }
549 }
451 550
452 $time = Event::time - $time; 551 my $time = AE::time - $time;
453 552
454 LOG llevError | logBacktrace, Carp::longmess "long sync job"
455 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
456
457 $tick_start += $time; # do not account sync jobs to server load 553 $TICK_START += $time; # do not account sync jobs to server load
458 554
459 wantarray ? @res : $res[0] 555 wantarray ? @res : $res[0]
460 } else { 556 } else {
461 # we are in another coroutine, how wonderful, everything just works 557 # we are in another coroutine, how wonderful, everything just works
462 558
487=item fork_call { }, $args 583=item fork_call { }, $args
488 584
489Executes the given code block with the given arguments in a seperate 585Executes the given code block with the given arguments in a seperate
490process, returning the results. Everything must be serialisable with 586process, returning the results. Everything must be serialisable with
491Coro::Storable. May, of course, block. Note that the executed sub may 587Coro::Storable. May, of course, block. Note that the executed sub may
492never block itself or use any form of Event handling. 588never block itself or use any form of event handling.
493 589
494=cut 590=cut
495 591
496sub fork_call(&@) { 592sub fork_call(&@) {
497 my ($cb, @args) = @_; 593 my ($cb, @args) = @_;
504 reset_signals; 600 reset_signals;
505 &$cb 601 &$cb
506 }, @args; 602 }, @args;
507 603
508 wantarray ? @res : $res[-1] 604 wantarray ? @res : $res[-1]
605}
606
607sub objinfo {
608 (
609 "counter value" => cf::object::object_count,
610 "objects created" => cf::object::create_count,
611 "objects destroyed" => cf::object::destroy_count,
612 "freelist size" => cf::object::free_count,
613 "allocated objects" => cf::object::objects_size,
614 "active objects" => cf::object::actives_size,
615 )
616}
617
618=item $coin = coin_from_name $name
619
620=cut
621
622our %coin_alias = (
623 "silver" => "silvercoin",
624 "silvercoin" => "silvercoin",
625 "silvercoins" => "silvercoin",
626 "gold" => "goldcoin",
627 "goldcoin" => "goldcoin",
628 "goldcoins" => "goldcoin",
629 "platinum" => "platinacoin",
630 "platinumcoin" => "platinacoin",
631 "platinumcoins" => "platinacoin",
632 "platina" => "platinacoin",
633 "platinacoin" => "platinacoin",
634 "platinacoins" => "platinacoin",
635 "royalty" => "royalty",
636 "royalties" => "royalty",
637);
638
639sub coin_from_name($) {
640 $coin_alias{$_[0]}
641 ? cf::arch::find $coin_alias{$_[0]}
642 : undef
509} 643}
510 644
511=item $value = cf::db_get $family => $key 645=item $value = cf::db_get $family => $key
512 646
513Returns a single value from the environment database. 647Returns a single value from the environment database.
621 755
622 my $t1 = Time::HiRes::time; 756 my $t1 = Time::HiRes::time;
623 my $data = $process->(\@data); 757 my $data = $process->(\@data);
624 my $t2 = Time::HiRes::time; 758 my $t2 = Time::HiRes::time;
625 759
626 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 760 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
627 761
628 db_put cache => "$id/data", $data; 762 db_put cache => "$id/data", $data;
629 db_put cache => "$id/md5" , $md5; 763 db_put cache => "$id/md5" , $md5;
630 db_put cache => "$id/meta", $meta; 764 db_put cache => "$id/meta", $meta;
631 765
641 775
642=cut 776=cut
643 777
644sub datalog($@) { 778sub datalog($@) {
645 my ($type, %kv) = @_; 779 my ($type, %kv) = @_;
646 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 780 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
647} 781}
648 782
649=back 783=back
650 784
651=cut 785=cut
652 786
653############################################################################# 787#############################################################################
654 788
655=head2 ATTACHABLE OBJECTS 789=head2 ATTACHABLE OBJECTS
656 790
657Many objects in crossfire are so-called attachable objects. That means you can 791Many objects in deliantra are so-called attachable objects. That means you can
658attach callbacks/event handlers (a collection of which is called an "attachment") 792attach callbacks/event handlers (a collection of which is called an "attachment")
659to it. All such attachable objects support the following methods. 793to it. All such attachable objects support the following methods.
660 794
661In the following description, CLASS can be any of C<global>, C<object> 795In the following description, CLASS can be any of C<global>, C<object>
662C<player>, C<client> or C<map> (i.e. the attachable objects in 796C<player>, C<client> or C<map> (i.e. the attachable objects in
663Crossfire TRT). 797Deliantra).
664 798
665=over 4 799=over 4
666 800
667=item $attachable->attach ($attachment, key => $value...) 801=item $attachable->attach ($attachment, key => $value...)
668 802
712=item cf::CLASS::attachment $name, ... 846=item cf::CLASS::attachment $name, ...
713 847
714Register an attachment by C<$name> through which attachable objects of the 848Register an attachment by C<$name> through which attachable objects of the
715given CLASS can refer to this attachment. 849given CLASS can refer to this attachment.
716 850
717Some classes such as crossfire maps and objects can specify attachments 851Some classes such as deliantra maps and objects can specify attachments
718that are attached at load/instantiate time, thus the need for a name. 852that are attached at load/instantiate time, thus the need for a name.
719 853
720These calls expect any number of the following handler/hook descriptions: 854These calls expect any number of the following handler/hook descriptions:
721 855
722=over 4 856=over 4
846 980
847 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
848 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
849 983
850 } elsif (ref $type) { 984 } elsif (ref $type) {
851 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
852 986
853 } else { 987 } else {
854 shift @arg; 988 shift @arg;
855 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
856 } 990 }
857 } 991 }
858} 992}
859 993
860sub _object_attach { 994sub _object_attach {
870 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
871 } 1005 }
872 1006
873 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
874 } else { 1008 } else {
875 warn "object uses attachment '$name' which is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
876 } 1010 }
877 1011
878 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
879} 1013}
880 1014
939 1073
940 for (@$callbacks) { 1074 for (@$callbacks) {
941 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
942 1076
943 if ($@) { 1077 if ($@) {
944 warn "$@";
945 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
946 override; 1079 override;
947 } 1080 }
948 1081
949 return 1 if $override; 1082 return 1 if $override;
950 } 1083 }
951 1084
952 0 1085 0
953} 1086}
954 1087
955=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1088=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
956 1089
957=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1090=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
958 1091
959Generate an object-specific event with the given arguments. 1092Generate an object-specific event with the given arguments.
960 1093
966 1099
967=cut 1100=cut
968 1101
969############################################################################# 1102#############################################################################
970# object support 1103# object support
971#
972 1104
1105sub _object_equal($$);
1106sub _object_equal($$) {
1107 my ($a, $b) = @_;
1108
1109 return 0 unless (ref $a) eq (ref $b);
1110
1111 if ("HASH" eq ref $a) {
1112 my @ka = keys %$a;
1113 my @kb = keys %$b;
1114
1115 return 0 if @ka != @kb;
1116
1117 for (0 .. $#ka) {
1118 return 0 unless $ka[$_] eq $kb[$_];
1119 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1120 }
1121
1122 } elsif ("ARRAY" eq ref $a) {
1123
1124 return 0 if @$a != @$b;
1125
1126 for (0 .. $#$a) {
1127 return 0 unless _object_equal $a->[$_], $b->[$_];
1128 }
1129
1130 } elsif ($a ne $b) {
1131 return 0;
1132 }
1133
1134 1
1135}
1136
1137our $SLOW_MERGES;#d#
973sub _can_merge { 1138sub _can_merge {
974 my ($ob1, $ob2) = @_; 1139 my ($ob1, $ob2) = @_;
975 1140
976 local $Storable::canonical = 1; 1141 ++$SLOW_MERGES;#d#
977 my $fob1 = Storable::freeze $ob1;
978 my $fob2 = Storable::freeze $ob2;
979 1142
980 $fob1 eq $fob2 1143 # we do the slow way here
1144 return _object_equal $ob1, $ob2
981} 1145}
982 1146
983sub reattach { 1147sub reattach {
984 # basically do the same as instantiate, without calling instantiate 1148 # basically do the same as instantiate, without calling instantiate
985 my ($obj) = @_; 1149 my ($obj) = @_;
986 1150
1151 # no longer needed after getting rid of delete_package?
987 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1152 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
988 1153
989 my $registry = $obj->registry; 1154 my $registry = $obj->registry;
990 1155
991 @$registry = (); 1156 @$registry = ();
992 1157
997 for (@$attach) { 1162 for (@$attach) {
998 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
999 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
1000 } 1165 }
1001 } else { 1166 } else {
1002 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
1003 } 1168 }
1004 } 1169 }
1005} 1170}
1006 1171
1007cf::attachable->attach ( 1172cf::attachable->attach (
1008 prio => -1000000, 1173 prio => -1000000,
1009 on_instantiate => sub { 1174 on_instantiate => sub {
1010 my ($obj, $data) = @_; 1175 my ($obj, $data) = @_;
1011 1176
1012 $data = from_json $data; 1177 $data = decode_json $data;
1013 1178
1014 for (@$data) { 1179 for (@$data) {
1015 my ($name, $args) = @$_; 1180 my ($name, $args) = @$_;
1016 1181
1017 $obj->attach ($name, %{$args || {} }); 1182 $obj->attach ($name, %{$args || {} });
1034 my ($filename, $rdata, $objs) = @_; 1199 my ($filename, $rdata, $objs) = @_;
1035 1200
1036 sync_job { 1201 sync_job {
1037 if (length $$rdata) { 1202 if (length $$rdata) {
1038 utf8::decode (my $decname = $filename); 1203 utf8::decode (my $decname = $filename);
1039 warn sprintf "saving %s (%d,%d)\n", 1204 trace sprintf "saving %s (%d,%d)\n",
1040 $decname, length $$rdata, scalar @$objs; 1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
1041 1207
1042 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1043 chmod SAVE_MODE, $fh; 1209 aio_chmod $fh, SAVE_MODE;
1044 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1045 aio_fsync $fh if $cf::USE_FSYNC; 1211 if ($cf::USE_FSYNC) {
1212 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;
1213 aio_fsync $fh;
1214 }
1046 close $fh; 1215 aio_close $fh;
1047 1216
1048 if (@$objs) { 1217 if (@$objs) {
1049 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1218 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1050 chmod SAVE_MODE, $fh; 1219 aio_chmod $fh, SAVE_MODE;
1051 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1220 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1052 aio_write $fh, 0, (length $data), $data, 0; 1221 aio_write $fh, 0, (length $data), $data, 0;
1053 aio_fsync $fh if $cf::USE_FSYNC; 1222 if ($cf::USE_FSYNC) {
1223 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;
1224 aio_fsync $fh;
1225 }
1054 close $fh; 1226 aio_close $fh;
1055 aio_rename "$filename.pst~", "$filename.pst"; 1227 aio_rename "$filename.pst~", "$filename.pst";
1056 } 1228 }
1057 } else { 1229 } else {
1058 aio_unlink "$filename.pst"; 1230 aio_unlink "$filename.pst";
1059 } 1231 }
1060 1232
1061 aio_rename "$filename~", $filename; 1233 aio_rename "$filename~", $filename;
1234
1235 $filename =~ s%/[^/]+$%%;
1236 aio_pathsync $filename if $cf::USE_FSYNC;
1062 } else { 1237 } else {
1063 warn "FATAL: $filename~: $!\n"; 1238 error "unable to save objects: $filename~: $!\n";
1064 } 1239 }
1065 } else { 1240 } else {
1066 aio_unlink $filename; 1241 aio_unlink $filename;
1067 aio_unlink "$filename.pst"; 1242 aio_unlink "$filename.pst";
1068 } 1243 }
1087 1262
1088 unless (aio_stat "$filename.pst") { 1263 unless (aio_stat "$filename.pst") {
1089 (aio_load "$filename.pst", $av) >= 0 1264 (aio_load "$filename.pst", $av) >= 0
1090 or return; 1265 or return;
1091 1266
1092 my $st = eval { Coro::Storable::thaw $av } 1267 my $st = eval { Coro::Storable::thaw $av };
1093 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1094 $av = $st->{objs}; 1268 $av = $st->{objs};
1095 } 1269 }
1096 1270
1097 utf8::decode (my $decname = $filename); 1271 utf8::decode (my $decname = $filename);
1098 warn sprintf "loading %s (%d,%d)\n", 1272 trace sprintf "loading %s (%d,%d)\n",
1099 $decname, length $data, scalar @{$av || []}; 1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1100 1275
1101 ($data, $av) 1276 ($data, $av)
1102} 1277}
1103 1278
1104=head2 COMMAND CALLBACKS 1279=head2 COMMAND CALLBACKS
1160 my ($name, $cb) = @_; 1335 my ($name, $cb) = @_;
1161 1336
1162 $EXTICMD{$name} = $cb; 1337 $EXTICMD{$name} = $cb;
1163} 1338}
1164 1339
1340use File::Glob ();
1341
1165cf::player->attach ( 1342cf::player->attach (
1166 on_command => sub { 1343 on_unknown_command => sub {
1167 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
1168 1345
1169 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
1170 or return; 1347 or return;
1171 1348
1194 1371
1195 $pl->ext_reply ($reply, @reply) 1372 $pl->ext_reply ($reply, @reply)
1196 if $reply; 1373 if $reply;
1197 1374
1198 } else { 1375 } else {
1199 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1200 } 1377 }
1201 1378
1202 cf::override; 1379 cf::override;
1203 }, 1380 },
1204); 1381);
1205 1382
1383# "readahead" all extensions
1384sub cache_extensions {
1385 my $grp = IO::AIO::aio_group;
1386
1387 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1388 for (grep /\.ext$/, @{$_[0]}) {
1389 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1390 }
1391 };
1392
1393 $grp
1394}
1395
1206sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1207 cf::sync_job { 1399 cf::sync_job {
1208 my %todo; 1400 my %todo;
1209 1401
1210 for my $path (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
1211 next unless -r $path; 1403 next unless -r $path;
1229 1421
1230 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1422 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1231 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1423 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1232 1424
1233 $ext{source} = 1425 $ext{source} =
1234 "package $pkg; use strict; use utf8;\n" 1426 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1235 . "#line 1 \"$path\"\n{\n" 1427 . "#line 1 \"$path\"\n{\n"
1236 . $source 1428 . $source
1237 . "\n};\n1"; 1429 . "\n};\n1";
1238 1430
1239 $todo{$base} = \%ext; 1431 $todo{$base} = \%ext;
1240 } 1432 }
1241 1433
1434 my $pass = 0;
1242 my %done; 1435 my %done;
1243 while (%todo) { 1436 while (%todo) {
1244 my $progress; 1437 my $progress;
1245 1438
1439 ++$pass;
1440
1441 ext:
1246 while (my ($k, $v) = each %todo) { 1442 while (my ($k, $v) = each %todo) {
1247 for (split /,\s*/, $v->{meta}{depends}) { 1443 for (split /,\s*/, $v->{meta}{depends}) {
1248 goto skip 1444 next ext
1249 unless exists $done{$_}; 1445 unless exists $done{$_};
1250 } 1446 }
1251 1447
1252 warn "... loading '$k' into '$v->{pkg}'\n"; 1448 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1253 1449
1254 unless (eval $v->{source}) { 1450 my $active = eval $v->{source};
1451
1452 if (length $@) {
1255 my $msg = $@ ? "$v->{path}: $@\n" 1453 error "$v->{path}: $@\n";
1256 : "$v->{base}: extension inactive.\n";
1257 1454
1455 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1258 if (exists $v->{meta}{mandatory}) { 1456 if exists $v->{meta}{mandatory};
1259 warn $msg; 1457
1260 warn "mandatory extension failed to load, exiting.\n"; 1458 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1261 exit 1; 1459 delete $todo{$k};
1262 } 1460 } else {
1263 1461 $done{$k} = delete $todo{$k};
1264 warn $msg; 1462 push @EXTS, $v->{pkg};
1463 $progress = 1;
1464
1465 info "$v->{base}: extension inactive.\n"
1466 unless $active;
1265 } 1467 }
1266
1267 $done{$k} = delete $todo{$k};
1268 push @EXTS, $v->{pkg};
1269 $progress = 1;
1270 } 1468 }
1271 1469
1272 skip: 1470 unless ($progress) {
1273 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1471 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1274 unless $progress; 1472
1473 while (my ($k, $v) = each %todo) {
1474 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1475 if exists $v->{meta}{mandatory};
1476 }
1477 }
1275 } 1478 }
1276 }; 1479 };
1277} 1480}
1278 1481
1279############################################################################# 1482#############################################################################
1280 1483
1281=back 1484=back
1282 1485
1283=head2 CORE EXTENSIONS 1486=head2 CORE EXTENSIONS
1284 1487
1285Functions and methods that extend core crossfire objects. 1488Functions and methods that extend core deliantra objects.
1286 1489
1287=cut 1490=cut
1288 1491
1289package cf::player; 1492package cf::player;
1290 1493
1333 1536
1334sub exists($) { 1537sub exists($) {
1335 my ($login) = @_; 1538 my ($login) = @_;
1336 1539
1337 $cf::PLAYER{$login} 1540 $cf::PLAYER{$login}
1338 or cf::sync_job { !aio_stat path $login } 1541 or !aio_stat path $login
1339} 1542}
1340 1543
1341sub find($) { 1544sub find($) {
1342 return $cf::PLAYER{$_[0]} || do { 1545 return $cf::PLAYER{$_[0]} || do {
1343 my $login = $_[0]; 1546 my $login = $_[0];
1355 my $f = new_from_file cf::object::thawer path $login 1558 my $f = new_from_file cf::object::thawer path $login
1356 or return; 1559 or return;
1357 1560
1358 my $pl = cf::player::load_pl $f 1561 my $pl = cf::player::load_pl $f
1359 or return; 1562 or return;
1563
1360 local $cf::PLAYER_LOADING{$login} = $pl; 1564 local $cf::PLAYER_LOADING{$login} = $pl;
1361 $f->resolve_delayed_derefs; 1565 $f->resolve_delayed_derefs;
1362 $cf::PLAYER{$login} = $pl 1566 $cf::PLAYER{$login} = $pl
1363 } 1567 }
1364 } 1568 }
1365} 1569}
1366 1570
1571cf::player->attach (
1572 on_load => sub {
1573 my ($pl, $path) = @_;
1574
1575 # restore slots saved in save, below
1576 my $slots = delete $pl->{_slots};
1577
1578 $pl->ob->current_weapon ($slots->[0]);
1579 $pl->combat_ob ($slots->[1]);
1580 $pl->ranged_ob ($slots->[2]);
1581 },
1582);
1583
1367sub save($) { 1584sub save($) {
1368 my ($pl) = @_; 1585 my ($pl) = @_;
1369 1586
1370 return if $pl->{deny_save}; 1587 return if $pl->{deny_save};
1371 1588
1374 1591
1375 return if $pl->{deny_save}; 1592 return if $pl->{deny_save};
1376 1593
1377 aio_mkdir playerdir $pl, 0770; 1594 aio_mkdir playerdir $pl, 0770;
1378 $pl->{last_save} = $cf::RUNTIME; 1595 $pl->{last_save} = $cf::RUNTIME;
1596
1597 cf::get_slot 0.01;
1598
1599 # save slots, to be restored later
1600 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1379 1601
1380 $pl->save_pl ($path); 1602 $pl->save_pl ($path);
1381 cf::cede_to_tick; 1603 cf::cede_to_tick;
1382} 1604}
1383 1605
1415 my ($pl) = @_; 1637 my ($pl) = @_;
1416 1638
1417 my $name = $pl->ob->name; 1639 my $name = $pl->ob->name;
1418 1640
1419 $pl->{deny_save} = 1; 1641 $pl->{deny_save} = 1;
1420 $pl->password ("*"); # this should lock out the player until we nuked the dir 1642 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1421 1643
1422 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1644 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1423 $pl->deactivate; 1645 $pl->deactivate;
1646 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1424 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1647 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1425 $pl->ns->destroy if $pl->ns; 1648 $pl->ns->destroy if $pl->ns;
1426 1649
1427 my $path = playerdir $pl; 1650 my $path = playerdir $pl;
1428 my $temp = "$path~$cf::RUNTIME~deleting~"; 1651 my $temp = "$path~$cf::RUNTIME~deleting~";
1467 1690
1468 for my $login (@$dirs) { 1691 for my $login (@$dirs) {
1469 my $path = path $login; 1692 my $path = path $login;
1470 1693
1471 # a .pst is a dead give-away for a valid player 1694 # a .pst is a dead give-away for a valid player
1472 unless (-e "$path.pst") { 1695 # if no pst file found, open and chekc for blocked users
1696 if (aio_stat "$path.pst") {
1473 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1697 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1474 aio_read $fh, 0, 512, my $buf, 0 or next; 1698 aio_read $fh, 0, 512, my $buf, 0 or next;
1475 $buf !~ /^password -------------$/m or next; # official not-valid tag 1699 $buf !~ /^password -------------$/m or next; # official not-valid tag
1476 } 1700 }
1477 1701
1481 1705
1482 \@logins 1706 \@logins
1483} 1707}
1484 1708
1485=item $player->maps 1709=item $player->maps
1710
1711=item cf::player::maps $login
1486 1712
1487Returns an arrayref of map paths that are private for this 1713Returns an arrayref of map paths that are private for this
1488player. May block. 1714player. May block.
1489 1715
1490=cut 1716=cut
1508 } 1734 }
1509 1735
1510 \@paths 1736 \@paths
1511} 1737}
1512 1738
1513=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1739=item $protocol_xml = $player->expand_cfpod ($cfpod)
1514 1740
1515Expand crossfire pod fragments into protocol xml. 1741Expand deliantra pod fragments into protocol xml.
1516
1517=cut
1518
1519sub expand_cfpod {
1520 ((my $self), (local $_)) = @_;
1521
1522 # escape & and <
1523 s/&/&amp;/g;
1524 s/(?<![BIUGHT])</&lt;/g;
1525
1526 # this is buggy, it needs to properly take care of nested <'s
1527
1528 1 while
1529 # replace B<>, I<>, U<> etc.
1530 s/B<([^\>]*)>/<b>$1<\/b>/
1531 || s/I<([^\>]*)>/<i>$1<\/i>/
1532 || s/U<([^\>]*)>/<u>$1<\/u>/
1533 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1534 # replace G<male|female> tags
1535 || s{G<([^>|]*)\|([^>]*)>}{
1536 $self->gender ? $2 : $1
1537 }ge
1538 # replace H<hint text>
1539 || s{H<([^\>]*)>}
1540 {
1541 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1542 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1543 "")
1544 [$self->{hintmode}]
1545 }ge;
1546
1547 # create single paragraphs (very hackish)
1548 s/(?<=\S)\n(?=\w)/ /g;
1549
1550 # compress some whitespace
1551 s/\s+\n/\n/g; # ws line-ends
1552 s/\n\n+/\n/g; # double lines
1553 s/^\n+//; # beginning lines
1554 s/\n+$//; # ending lines
1555
1556 $_
1557}
1558
1559sub hintmode {
1560 $_[0]{hintmode} = $_[1] if @_ > 1;
1561 $_[0]{hintmode}
1562}
1563 1742
1564=item $player->ext_reply ($msgid, @msg) 1743=item $player->ext_reply ($msgid, @msg)
1565 1744
1566Sends an ext reply to the player. 1745Sends an ext reply to the player.
1567 1746
1599 1778
1600=cut 1779=cut
1601 1780
1602sub find_by_path($) { 1781sub find_by_path($) {
1603 my ($path) = @_; 1782 my ($path) = @_;
1783
1784 $path =~ s/^~[^\/]*//; # skip ~login
1604 1785
1605 my ($match, $specificity); 1786 my ($match, $specificity);
1606 1787
1607 for my $region (list) { 1788 for my $region (list) {
1608 if ($region->{match} && $path =~ $region->{match}) { 1789 if ($region->{match} && $path =~ $region->{match}) {
1634our $MAX_RESET = 3600; 1815our $MAX_RESET = 3600;
1635our $DEFAULT_RESET = 3000; 1816our $DEFAULT_RESET = 3000;
1636 1817
1637sub generate_random_map { 1818sub generate_random_map {
1638 my ($self, $rmp) = @_; 1819 my ($self, $rmp) = @_;
1820
1821 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1822
1639 # mit "rum" bekleckern, nicht 1823 # mit "rum" bekleckern, nicht
1640 $self->_create_random_map ( 1824 $self->_create_random_map (
1641 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1825 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1642 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1826 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1643 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1827 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1644 $rmp->{exit_on_final_map}, 1828 $rmp->{exit_on_final_map},
1645 $rmp->{xsize}, $rmp->{ysize}, 1829 $rmp->{xsize}, $rmp->{ysize},
1646 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1830 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1647 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1831 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1669 1853
1670 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1671} 1855}
1672 1856
1673# also paths starting with '/' 1857# also paths starting with '/'
1674$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1675 1859
1676sub thawer_merge { 1860sub thawer_merge {
1677 my ($self, $merge) = @_; 1861 my ($self, $merge) = @_;
1678 1862
1679 # we have to keep some variables in memory intact 1863 # we have to keep some variables in memory intact
1765 1949
1766# the temporary/swap location 1950# the temporary/swap location
1767sub save_path { 1951sub save_path {
1768 my ($self) = @_; 1952 my ($self) = @_;
1769 1953
1770 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1954 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1771 "$TMPDIR/$path.map" 1955 "$TMPDIR/$path.map"
1772} 1956}
1773 1957
1774# the unique path, undef == no special unique path 1958# the unique path, undef == no special unique path
1775sub uniq_path { 1959sub uniq_path {
1776 my ($self) = @_; 1960 my ($self) = @_;
1777 1961
1778 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1962 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1779 "$UNIQUEDIR/$path" 1963 "$UNIQUEDIR/$path"
1780}
1781
1782# and all this just because we cannot iterate over
1783# all maps in C++...
1784sub change_all_map_light {
1785 my ($change) = @_;
1786
1787 $_->change_map_light ($change)
1788 for grep $_->outdoor, values %cf::MAP;
1789} 1964}
1790 1965
1791sub decay_objects { 1966sub decay_objects {
1792 my ($self) = @_; 1967 my ($self) = @_;
1793 1968
1877sub find { 2052sub find {
1878 my ($path, $origin) = @_; 2053 my ($path, $origin) = @_;
1879 2054
1880 $path = normalise $path, $origin && $origin->path; 2055 $path = normalise $path, $origin && $origin->path;
1881 2056
1882 cf::lock_wait "map_data:$path";#d#remove 2057 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1883 cf::lock_wait "map_find:$path"; 2058 my $guard2 = cf::lock_acquire "map_find:$path";
1884 2059
1885 $cf::MAP{$path} || do { 2060 $cf::MAP{$path} || do {
1886 my $guard1 = cf::lock_acquire "map_find:$path";
1887 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1888
1889 my $map = new_from_path cf::map $path 2061 my $map = new_from_path cf::map $path
1890 or return; 2062 or return;
1891 2063
1892 $map->{last_save} = $cf::RUNTIME; 2064 $map->{last_save} = $cf::RUNTIME;
1893 2065
1895 or return; 2067 or return;
1896 2068
1897 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2069 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1898 # doing this can freeze the server in a sync job, obviously 2070 # doing this can freeze the server in a sync job, obviously
1899 #$cf::WAIT_FOR_TICK->wait; 2071 #$cf::WAIT_FOR_TICK->wait;
2072 undef $guard2;
1900 undef $guard1; 2073 undef $guard1;
1901 undef $guard2;
1902 $map->reset; 2074 $map->reset;
1903 return find $path; 2075 return find $path;
1904 } 2076 }
1905 2077
1906 $cf::MAP{$path} = $map 2078 $cf::MAP{$path} = $map
1907 } 2079 }
1908} 2080}
1909 2081
1910sub pre_load { } 2082sub pre_load { }
1911sub post_load { } 2083#sub post_load { } # XS
1912 2084
1913sub load { 2085sub load {
1914 my ($self) = @_; 2086 my ($self) = @_;
1915 2087
1916 local $self->{deny_reset} = 1; # loading can take a long time 2088 local $self->{deny_reset} = 1; # loading can take a long time
1933 my $f = new_from_file cf::object::thawer $self->{load_path}; 2105 my $f = new_from_file cf::object::thawer $self->{load_path};
1934 $f->skip_block; 2106 $f->skip_block;
1935 $self->_load_objects ($f) 2107 $self->_load_objects ($f)
1936 or return; 2108 or return;
1937 2109
1938 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2110 $self->post_load_original
1939 if delete $self->{load_original}; 2111 if delete $self->{load_original};
1940 2112
1941 if (my $uniq = $self->uniq_path) { 2113 if (my $uniq = $self->uniq_path) {
1942 utf8::encode $uniq; 2114 utf8::encode $uniq;
1943 unless (aio_stat $uniq) { 2115 unless (aio_stat $uniq) {
1961 unless ($self->{deny_activate}) { 2133 unless ($self->{deny_activate}) {
1962 $self->decay_objects; 2134 $self->decay_objects;
1963 $self->fix_auto_apply; 2135 $self->fix_auto_apply;
1964 $self->update_buttons; 2136 $self->update_buttons;
1965 cf::cede_to_tick; 2137 cf::cede_to_tick;
1966 $self->set_darkness_map;
1967 cf::cede_to_tick;
1968 $self->activate; 2138 $self->activate;
1969 } 2139 }
1970 2140
1971 $self->{last_save} = $cf::RUNTIME; 2141 $self->{last_save} = $cf::RUNTIME;
1972 $self->last_access ($cf::RUNTIME); 2142 $self->last_access ($cf::RUNTIME);
1973 2143
1974 $self->in_memory (cf::MAP_IN_MEMORY); 2144 $self->in_memory (cf::MAP_ACTIVE);
1975 } 2145 }
1976 2146
1977 $self->post_load; 2147 $self->post_load;
1978} 2148}
1979 2149
2150# customize the map for a given player, i.e.
2151# return the _real_ map. used by e.g. per-player
2152# maps to change the path to ~playername/mappath
1980sub customise_for { 2153sub customise_for {
1981 my ($self, $ob) = @_; 2154 my ($self, $ob) = @_;
1982 2155
1983 return find "~" . $ob->name . "/" . $self->{path} 2156 return find "~" . $ob->name . "/" . $self->{path}
1984 if $self->per_player; 2157 if $self->per_player;
2000 or next; 2173 or next;
2001 $neigh = find $neigh, $map 2174 $neigh = find $neigh, $map
2002 or next; 2175 or next;
2003 $neigh->load; 2176 $neigh->load;
2004 2177
2178 # now find the diagonal neighbours
2005 push @neigh, 2179 push @neigh,
2006 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2007 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2008 } 2182 }
2009 2183
2037 my ($path, $origin, $load) = @_; 2211 my ($path, $origin, $load) = @_;
2038 2212
2039 $path = normalise $path, $origin && $origin->{path}; 2213 $path = normalise $path, $origin && $origin->{path};
2040 2214
2041 if (my $map = $cf::MAP{$path}) { 2215 if (my $map = $cf::MAP{$path}) {
2042 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2216 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2043 } 2217 }
2044 2218
2045 $MAP_PREFETCH{$path} |= $load; 2219 $MAP_PREFETCH{$path} |= $load;
2046 2220
2047 $MAP_PREFETCHER ||= cf::async { 2221 $MAP_PREFETCHER ||= cf::async {
2061 $MAP_PREFETCHER->prio (6); 2235 $MAP_PREFETCHER->prio (6);
2062 2236
2063 () 2237 ()
2064} 2238}
2065 2239
2240# common code, used by both ->save and ->swapout
2066sub save { 2241sub _save {
2067 my ($self) = @_; 2242 my ($self) = @_;
2068
2069 my $lock = cf::lock_acquire "map_data:$self->{path}";
2070 2243
2071 $self->{last_save} = $cf::RUNTIME; 2244 $self->{last_save} = $cf::RUNTIME;
2072 2245
2073 return unless $self->dirty; 2246 return unless $self->dirty;
2074 2247
2083 2256
2084 cf::async { 2257 cf::async {
2085 $Coro::current->{desc} = "map player save"; 2258 $Coro::current->{desc} = "map player save";
2086 $_->contr->save for $self->players; 2259 $_->contr->save for $self->players;
2087 }; 2260 };
2261
2262 cf::get_slot 0.02;
2088 2263
2089 if ($uniq) { 2264 if ($uniq) {
2090 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2265 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2091 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2266 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2092 } else { 2267 } else {
2093 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2268 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2094 } 2269 }
2095} 2270}
2096 2271
2272sub save {
2273 my ($self) = @_;
2274
2275 my $lock = cf::lock_acquire "map_data:$self->{path}";
2276
2277 $self->_save;
2278}
2279
2097sub swap_out { 2280sub swap_out {
2098 my ($self) = @_; 2281 my ($self) = @_;
2099 2282
2100 # save first because save cedes
2101 $self->save;
2102
2103 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2283 my $lock = cf::lock_acquire "map_data:$self->{path}";
2104 2284
2285 return if $self->in_memory != cf::MAP_ACTIVE;
2286 return if $self->{deny_save};
2105 return if $self->players; 2287 return if $self->players;
2106 return if $self->in_memory != cf::MAP_IN_MEMORY;
2107 return if $self->{deny_save};
2108 2288
2289 # first deactivate the map and "unlink" it from the core
2290 $self->deactivate;
2291 $_->clear_links_to ($self) for values %cf::MAP;
2109 $self->in_memory (cf::MAP_SWAPPED); 2292 $self->in_memory (cf::MAP_SWAPPED);
2293
2294 # then atomically save
2295 $self->_save;
2296
2297 # then free the map
2298 $self->clear;
2299}
2300
2301sub reset_at {
2302 my ($self) = @_;
2303
2304 # TODO: safety, remove and allow resettable per-player maps
2305 return 1e99 if $self->{deny_reset};
2306
2307 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2308 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2309
2310 $time + $to
2311}
2312
2313sub should_reset {
2314 my ($self) = @_;
2315
2316 $self->reset_at <= $cf::RUNTIME
2317}
2318
2319sub reset {
2320 my ($self) = @_;
2321
2322 my $lock = cf::lock_acquire "map_data:$self->{path}";
2323
2324 return if $self->players;
2325
2326 cf::trace "resetting map ", $self->path, "\n";
2327
2328 $self->in_memory (cf::MAP_SWAPPED);
2329
2330 # need to save uniques path
2331 unless ($self->{deny_save}) {
2332 my $uniq = $self->uniq_path; utf8::encode $uniq;
2333
2334 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2335 if $uniq;
2336 }
2337
2338 delete $cf::MAP{$self->path};
2110 2339
2111 $self->deactivate; 2340 $self->deactivate;
2112 $_->clear_links_to ($self) for values %cf::MAP; 2341 $_->clear_links_to ($self) for values %cf::MAP;
2113 $self->clear; 2342 $self->clear;
2114}
2115
2116sub reset_at {
2117 my ($self) = @_;
2118
2119 # TODO: safety, remove and allow resettable per-player maps
2120 return 1e99 if $self->{deny_reset};
2121
2122 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2123 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2124
2125 $time + $to
2126}
2127
2128sub should_reset {
2129 my ($self) = @_;
2130
2131 $self->reset_at <= $cf::RUNTIME
2132}
2133
2134sub reset {
2135 my ($self) = @_;
2136
2137 my $lock = cf::lock_acquire "map_data:$self->{path}";
2138
2139 return if $self->players;
2140
2141 warn "resetting map ", $self->path;
2142
2143 $self->in_memory (cf::MAP_SWAPPED);
2144
2145 # need to save uniques path
2146 unless ($self->{deny_save}) {
2147 my $uniq = $self->uniq_path; utf8::encode $uniq;
2148
2149 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2150 if $uniq;
2151 }
2152
2153 delete $cf::MAP{$self->path};
2154
2155 $self->deactivate;
2156 $_->clear_links_to ($self) for values %cf::MAP;
2157 $self->clear;
2158 2343
2159 $self->unlink_save; 2344 $self->unlink_save;
2160 $self->destroy; 2345 $self->destroy;
2161} 2346}
2162 2347
2170 2355
2171 delete $cf::MAP{$self->path}; 2356 delete $cf::MAP{$self->path};
2172 2357
2173 $self->unlink_save; 2358 $self->unlink_save;
2174 2359
2175 bless $self, "cf::map"; 2360 bless $self, "cf::map::wrap";
2176 delete $self->{deny_reset}; 2361 delete $self->{deny_reset};
2177 $self->{deny_save} = 1; 2362 $self->{deny_save} = 1;
2178 $self->reset_timeout (1); 2363 $self->reset_timeout (1);
2179 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2364 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2180 2365
2229 2414
2230sub unique_maps() { 2415sub unique_maps() {
2231 [ 2416 [
2232 map { 2417 map {
2233 utf8::decode $_; 2418 utf8::decode $_;
2234 /\.map$/ 2419 s/\.map$//; # TODO future compatibility hack
2420 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2421 ? ()
2235 ? normalise $_ 2422 : normalise $_
2236 : ()
2237 } @{ aio_readdir $UNIQUEDIR or [] } 2423 } @{ aio_readdir $UNIQUEDIR or [] }
2238 ] 2424 ]
2239} 2425}
2240 2426
2241package cf; 2427=item cf::map::static_maps
2428
2429Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2430file in the shared directory excluding F</styles> and F</editor>). May
2431block.
2432
2433=cut
2434
2435sub static_maps() {
2436 my @dirs = "";
2437 my @maps;
2438
2439 while (@dirs) {
2440 my $dir = shift @dirs;
2441
2442 next if $dir eq "/styles" || $dir eq "/editor";
2443
2444 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2445 or return;
2446
2447 for (@$files) {
2448 s/\.map$// or next;
2449 utf8::decode $_;
2450 push @maps, "$dir/$_";
2451 }
2452
2453 push @dirs, map "$dir/$_", @$dirs;
2454 }
2455
2456 \@maps
2457}
2242 2458
2243=back 2459=back
2244 2460
2245=head3 cf::object 2461=head3 cf::object
2246 2462
2250 2466
2251=over 4 2467=over 4
2252 2468
2253=item $ob->inv_recursive 2469=item $ob->inv_recursive
2254 2470
2255Returns the inventory of the object _and_ their inventories, recursively. 2471Returns the inventory of the object I<and> their inventories, recursively,
2472but I<not> the object itself.
2256 2473
2257=cut 2474=cut
2258 2475
2259sub inv_recursive_; 2476sub inv_recursive_;
2260sub inv_recursive_ { 2477sub inv_recursive_ {
2265 inv_recursive_ inv $_[0] 2482 inv_recursive_ inv $_[0]
2266} 2483}
2267 2484
2268=item $ref = $ob->ref 2485=item $ref = $ob->ref
2269 2486
2270creates and returns a persistent reference to an objetc that can be stored as a string. 2487Creates and returns a persistent reference to an object that can be stored as a string.
2271 2488
2272=item $ob = cf::object::deref ($refstring) 2489=item $ob = cf::object::deref ($refstring)
2273 2490
2274returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2491returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2275even if the object actually exists. May block. 2492even if the object actually exists. May block.
2307can be C<undef>. Does the right thing when the player is currently in a 2524can be C<undef>. Does the right thing when the player is currently in a
2308dialogue with the given NPC character. 2525dialogue with the given NPC character.
2309 2526
2310=cut 2527=cut
2311 2528
2529our $SAY_CHANNEL = {
2530 id => "say",
2531 title => "Map",
2532 reply => "say ",
2533 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2534};
2535
2536our $CHAT_CHANNEL = {
2537 id => "chat",
2538 title => "Chat",
2539 reply => "chat ",
2540 tooltip => "Player chat and shouts, global to the server.",
2541};
2542
2312# rough implementation of a future "reply" method that works 2543# rough implementation of a future "reply" method that works
2313# with dialog boxes. 2544# with dialog boxes.
2314#TODO: the first argument must go, split into a $npc->reply_to ( method 2545#TODO: the first argument must go, split into a $npc->reply_to ( method
2315sub cf::object::player::reply($$$;$) { 2546sub cf::object::player::reply($$$;$) {
2316 my ($self, $npc, $msg, $flags) = @_; 2547 my ($self, $npc, $msg, $flags) = @_;
2327 my $dialog = $pl->{npc_dialog}; 2558 my $dialog = $pl->{npc_dialog};
2328 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2559 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2329 2560
2330 } else { 2561 } else {
2331 $msg = $npc->name . " says: $msg" if $npc; 2562 $msg = $npc->name . " says: $msg" if $npc;
2332 $self->message ($msg, $flags); 2563 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2333 } 2564 }
2334 } 2565 }
2335} 2566}
2336 2567
2337=item $object->send_msg ($channel, $msg, $color, [extra...]) 2568=item $object->send_msg ($channel, $msg, $color, [extra...])
2362 2593
2363=item $player_object->enter_link 2594=item $player_object->enter_link
2364 2595
2365Freezes the player and moves him/her to a special map (C<{link}>). 2596Freezes the player and moves him/her to a special map (C<{link}>).
2366 2597
2367The player should be reasonably safe there for short amounts of time. You 2598The player should be reasonably safe there for short amounts of time (e.g.
2368I<MUST> call C<leave_link> as soon as possible, though. 2599for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2600though, as the player cannot control the character while it is on the link
2601map.
2369 2602
2370Will never block. 2603Will never block.
2371 2604
2372=item $player_object->leave_link ($map, $x, $y) 2605=item $player_object->leave_link ($map, $x, $y)
2373 2606
2393sub cf::object::player::enter_link { 2626sub cf::object::player::enter_link {
2394 my ($self) = @_; 2627 my ($self) = @_;
2395 2628
2396 $self->deactivate_recursive; 2629 $self->deactivate_recursive;
2397 2630
2631 ++$self->{_link_recursion};
2632
2398 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2633 return if UNIVERSAL::isa $self->map, "ext::map_link";
2399 2634
2400 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2635 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2401 if $self->map && $self->map->{path} ne "{link}"; 2636 if $self->map && $self->map->{path} ne "{link}";
2402 2637
2403 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2638 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2404} 2639}
2405 2640
2406sub cf::object::player::leave_link { 2641sub cf::object::player::leave_link {
2407 my ($self, $map, $x, $y) = @_; 2642 my ($self, $map, $x, $y) = @_;
2408 2643
2425 ($x, $y) = (-1, -1) 2660 ($x, $y) = (-1, -1)
2426 unless (defined $x) && (defined $y); 2661 unless (defined $x) && (defined $y);
2427 2662
2428 # use -1 or undef as default coordinates, not 0, 0 2663 # use -1 or undef as default coordinates, not 0, 0
2429 ($x, $y) = ($map->enter_x, $map->enter_y) 2664 ($x, $y) = ($map->enter_x, $map->enter_y)
2430 if $x <=0 && $y <= 0; 2665 if $x <= 0 && $y <= 0;
2431 2666
2432 $map->load; 2667 $map->load;
2433 $map->load_neighbours; 2668 $map->load_neighbours;
2434 2669
2435 return unless $self->contr->active; 2670 return unless $self->contr->active;
2436 $self->activate_recursive;
2437 2671
2438 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2672 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2439 $self->enter_map ($map, $x, $y); 2673 if ($self->enter_map ($map, $x, $y)) {
2440} 2674 # entering was successful
2675 delete $self->{_link_recursion};
2676 # only activate afterwards, to support waiting in hooks
2677 $self->activate_recursive;
2678 }
2441 2679
2680}
2681
2442=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2682=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2443 2683
2444Moves the player to the given map-path and coordinates by first freezing 2684Moves the player to the given map-path and coordinates by first freezing
2445her, loading and preparing them map, calling the provided $check callback 2685her, loading and preparing them map, calling the provided $check callback
2446that has to return the map if sucecssful, and then unfreezes the player on 2686that has to return the map if sucecssful, and then unfreezes the player on
2447the new (success) or old (failed) map position. In either case, $done will 2687the new (success) or old (failed) map position. In either case, $done will
2448be called at the end of this process. 2688be called at the end of this process.
2449 2689
2690Note that $check will be called with a potentially non-loaded map, so if
2691it needs a loaded map it has to call C<< ->load >>.
2692
2450=cut 2693=cut
2451 2694
2452our $GOTOGEN; 2695our $GOTOGEN;
2453 2696
2454sub cf::object::player::goto { 2697sub cf::object::player::goto {
2455 my ($self, $path, $x, $y, $check, $done) = @_; 2698 my ($self, $path, $x, $y, $check, $done) = @_;
2699
2700 if ($self->{_link_recursion} >= $MAX_LINKS) {
2701 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2702 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2703 ($path, $x, $y) = @$EMERGENCY_POSITION;
2704 }
2456 2705
2457 # do generation counting so two concurrent goto's will be executed in-order 2706 # do generation counting so two concurrent goto's will be executed in-order
2458 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2707 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2459 2708
2460 $self->enter_link; 2709 $self->enter_link;
2484 my $map = eval { 2733 my $map = eval {
2485 my $map = defined $path ? cf::map::find $path : undef; 2734 my $map = defined $path ? cf::map::find $path : undef;
2486 2735
2487 if ($map) { 2736 if ($map) {
2488 $map = $map->customise_for ($self); 2737 $map = $map->customise_for ($self);
2489 $map = $check->($map) if $check && $map; 2738 $map = $check->($map, $x, $y, $self) if $check && $map;
2490 } else { 2739 } else {
2491 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2740 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2492 } 2741 }
2493 2742
2494 $map 2743 $map
2502 if ($gen == $self->{_goto_generation}) { 2751 if ($gen == $self->{_goto_generation}) {
2503 delete $self->{_goto_generation}; 2752 delete $self->{_goto_generation};
2504 $self->leave_link ($map, $x, $y); 2753 $self->leave_link ($map, $x, $y);
2505 } 2754 }
2506 2755
2507 $done->() if $done; 2756 $done->($self) if $done;
2508 })->prio (1); 2757 })->prio (1);
2509} 2758}
2510 2759
2511=item $player_object->enter_exit ($exit_object) 2760=item $player_object->enter_exit ($exit_object)
2512 2761
2532} 2781}
2533 2782
2534sub prepare_random_map { 2783sub prepare_random_map {
2535 my ($exit) = @_; 2784 my ($exit) = @_;
2536 2785
2537 my $guard = cf::lock_acquire "exit_prepare:$exit";
2538
2539 # all this does is basically replace the /! path by 2786 # all this does is basically replace the /! path by
2540 # a new random map path (?random/...) with a seed 2787 # a new random map path (?random/...) with a seed
2541 # that depends on the exit object 2788 # that depends on the exit object
2542 2789
2543 my $rmp = parse_random_map_params $exit->msg; 2790 my $rmp = parse_random_map_params $exit->msg;
2545 if ($exit->map) { 2792 if ($exit->map) {
2546 $rmp->{region} = $exit->region->name; 2793 $rmp->{region} = $exit->region->name;
2547 $rmp->{origin_map} = $exit->map->path; 2794 $rmp->{origin_map} = $exit->map->path;
2548 $rmp->{origin_x} = $exit->x; 2795 $rmp->{origin_x} = $exit->x;
2549 $rmp->{origin_y} = $exit->y; 2796 $rmp->{origin_y} = $exit->y;
2797
2798 $exit->map->touch;
2550 } 2799 }
2551 2800
2552 $rmp->{random_seed} ||= $exit->random_seed; 2801 $rmp->{random_seed} ||= $exit->random_seed;
2553 2802
2554 my $data = cf::to_json $rmp; 2803 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2555 my $md5 = Digest::MD5::md5_hex $data; 2804 my $md5 = Digest::MD5::md5_hex $data;
2556 my $meta = "$RANDOMDIR/$md5.meta"; 2805 my $meta = "$RANDOMDIR/$md5.meta";
2557 2806
2558 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2807 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2559 aio_write $fh, 0, (length $data), $data, 0; 2808 aio_write $fh, 0, (length $data), $data, 0;
2560 undef $fh; 2809 undef $fh;
2561 aio_rename "$meta~", $meta; 2810 aio_rename "$meta~", $meta;
2562 2811
2812 my $slaying = "?random/$md5";
2813
2814 if ($exit->valid) {
2563 $exit->slaying ("?random/$md5"); 2815 $exit->slaying ("?random/$md5");
2564 $exit->msg (undef); 2816 $exit->msg (undef);
2817 }
2565 } 2818 }
2566} 2819}
2567 2820
2568sub cf::object::player::enter_exit { 2821sub cf::object::player::enter_exit {
2569 my ($self, $exit) = @_; 2822 my ($self, $exit) = @_;
2570 2823
2571 return unless $self->type == cf::PLAYER; 2824 return unless $self->type == cf::PLAYER;
2572 2825
2573 if ($exit->slaying eq "/!") {
2574 #TODO: this should de-fi-ni-te-ly not be a sync-job
2575 # the problem is that $exit might not survive long enough
2576 # so it needs to be done right now, right here
2577 cf::sync_job { prepare_random_map $exit };
2578 }
2579
2580 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2581 my $hp = $exit->stats->hp;
2582 my $sp = $exit->stats->sp;
2583
2584 $self->enter_link; 2826 $self->enter_link;
2585 2827
2586 # if exit is damned, update players death & WoR home-position
2587 $self->contr->savebed ($slaying, $hp, $sp)
2588 if $exit->flag (FLAG_DAMNED);
2589
2590 (async { 2828 (async {
2591 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2829 $Coro::current->{desc} = "enter_exit";
2592 2830
2593 $self->deactivate_recursive; # just to be sure
2594 unless (eval { 2831 unless (eval {
2832 $self->deactivate_recursive; # just to be sure
2833
2834 # random map handling
2835 {
2836 my $guard = cf::lock_acquire "exit_prepare:$exit";
2837
2838 prepare_random_map $exit
2839 if $exit->slaying eq "/!";
2840 }
2841
2842 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2843 my $x = $exit->stats->hp;
2844 my $y = $exit->stats->sp;
2845
2595 $self->goto ($slaying, $hp, $sp); 2846 $self->goto ($map, $x, $y);
2596 2847
2848 # if exit is damned, update players death & WoR home-position
2849 $self->contr->savebed ($map, $x, $y)
2850 if $exit->flag (cf::FLAG_DAMNED);
2851
2597 1; 2852 1
2598 }) { 2853 }) {
2599 $self->message ("Something went wrong deep within the crossfire server. " 2854 $self->message ("Something went wrong deep within the deliantra server. "
2600 . "I'll try to bring you back to the map you were before. " 2855 . "I'll try to bring you back to the map you were before. "
2601 . "Please report this to the dungeon master!", 2856 . "Please report this to the dungeon master!",
2602 cf::NDI_UNIQUE | cf::NDI_RED); 2857 cf::NDI_UNIQUE | cf::NDI_RED);
2603 2858
2604 warn "ERROR in enter_exit: $@"; 2859 error "ERROR in enter_exit: $@";
2605 $self->leave_link; 2860 $self->leave_link;
2606 } 2861 }
2607 })->prio (1); 2862 })->prio (1);
2608} 2863}
2609 2864
2621sub cf::client::send_drawinfo { 2876sub cf::client::send_drawinfo {
2622 my ($self, $text, $flags) = @_; 2877 my ($self, $text, $flags) = @_;
2623 2878
2624 utf8::encode $text; 2879 utf8::encode $text;
2625 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2880 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2881}
2882
2883=item $client->send_big_packet ($pkt)
2884
2885Like C<send_packet>, but tries to compress large packets, and fragments
2886them as required.
2887
2888=cut
2889
2890our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2891
2892sub cf::client::send_big_packet {
2893 my ($self, $pkt) = @_;
2894
2895 # try lzf for large packets
2896 $pkt = "lzf " . Compress::LZF::compress $pkt
2897 if 1024 <= length $pkt and $self->{can_lzf};
2898
2899 # split very large packets
2900 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2901 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2902 $pkt = "frag";
2903 }
2904
2905 $self->send_packet ($pkt);
2626} 2906}
2627 2907
2628=item $client->send_msg ($channel, $msg, $color, [extra...]) 2908=item $client->send_msg ($channel, $msg, $color, [extra...])
2629 2909
2630Send a drawinfo or msg packet to the client, formatting the msg for the 2910Send a drawinfo or msg packet to the client, formatting the msg for the
2632the message, with C<log> being the default. If C<$color> is negative, suppress 2912the message, with C<log> being the default. If C<$color> is negative, suppress
2633the message unless the client supports the msg packet. 2913the message unless the client supports the msg packet.
2634 2914
2635=cut 2915=cut
2636 2916
2917# non-persistent channels (usually the info channel)
2637our %CHANNEL = ( 2918our %CHANNEL = (
2919 "c/motd" => {
2920 id => "infobox",
2921 title => "MOTD",
2922 reply => undef,
2923 tooltip => "The message of the day",
2924 },
2638 "c/identify" => { 2925 "c/identify" => {
2639 id => "infobox", 2926 id => "infobox",
2640 title => "Identify", 2927 title => "Identify",
2641 reply => undef, 2928 reply => undef,
2642 tooltip => "Items recently identified", 2929 tooltip => "Items recently identified",
2645 id => "infobox", 2932 id => "infobox",
2646 title => "Examine", 2933 title => "Examine",
2647 reply => undef, 2934 reply => undef,
2648 tooltip => "Signs and other items you examined", 2935 tooltip => "Signs and other items you examined",
2649 }, 2936 },
2937 "c/shopinfo" => {
2938 id => "infobox",
2939 title => "Shop Info",
2940 reply => undef,
2941 tooltip => "What your bargaining skill tells you about the shop",
2942 },
2943 "c/book" => {
2944 id => "infobox",
2945 title => "Book",
2946 reply => undef,
2947 tooltip => "The contents of a note or book",
2948 },
2650 "c/lookat" => { 2949 "c/lookat" => {
2651 id => "infobox", 2950 id => "infobox",
2652 title => "Look", 2951 title => "Look",
2653 reply => undef, 2952 reply => undef,
2654 tooltip => "What you saw there", 2953 tooltip => "What you saw there",
2655 }, 2954 },
2955 "c/who" => {
2956 id => "infobox",
2957 title => "Players",
2958 reply => undef,
2959 tooltip => "Shows players who are currently online",
2960 },
2961 "c/body" => {
2962 id => "infobox",
2963 title => "Body Parts",
2964 reply => undef,
2965 tooltip => "Shows which body parts you posess and are available",
2966 },
2967 "c/statistics" => {
2968 id => "infobox",
2969 title => "Statistics",
2970 reply => undef,
2971 tooltip => "Shows your primary statistics",
2972 },
2973 "c/skills" => {
2974 id => "infobox",
2975 title => "Skills",
2976 reply => undef,
2977 tooltip => "Shows your experience per skill and item power",
2978 },
2979 "c/shopitems" => {
2980 id => "infobox",
2981 title => "Shop Items",
2982 reply => undef,
2983 tooltip => "Shows the items currently for sale in this shop",
2984 },
2985 "c/resistances" => {
2986 id => "infobox",
2987 title => "Resistances",
2988 reply => undef,
2989 tooltip => "Shows your resistances",
2990 },
2991 "c/pets" => {
2992 id => "infobox",
2993 title => "Pets",
2994 reply => undef,
2995 tooltip => "Shows information abotu your pets/a specific pet",
2996 },
2997 "c/perceiveself" => {
2998 id => "infobox",
2999 title => "Perceive Self",
3000 reply => undef,
3001 tooltip => "You gained detailed knowledge about yourself",
3002 },
3003 "c/uptime" => {
3004 id => "infobox",
3005 title => "Uptime",
3006 reply => undef,
3007 tooltip => "How long the server has been running since last restart",
3008 },
3009 "c/mapinfo" => {
3010 id => "infobox",
3011 title => "Map Info",
3012 reply => undef,
3013 tooltip => "Information related to the maps",
3014 },
3015 "c/party" => {
3016 id => "party",
3017 title => "Party",
3018 reply => "gsay ",
3019 tooltip => "Messages and chat related to your party",
3020 },
3021 "c/death" => {
3022 id => "death",
3023 title => "Death",
3024 reply => undef,
3025 tooltip => "Reason for and more info about your most recent death",
3026 },
3027 "c/say" => $SAY_CHANNEL,
3028 "c/chat" => $CHAT_CHANNEL,
2656); 3029);
2657 3030
2658sub cf::client::send_msg { 3031sub cf::client::send_msg {
2659 my ($self, $channel, $msg, $color, @extra) = @_; 3032 my ($self, $channel, $msg, $color, @extra) = @_;
2660 3033
2661 $msg = $self->pl->expand_cfpod ($msg); 3034 $msg = $self->pl->expand_cfpod ($msg)
3035 unless $color & cf::NDI_VERBATIM;
2662 3036
2663 $color &= cf::NDI_CLIENT_MASK; # just in case... 3037 $color &= cf::NDI_CLIENT_MASK; # just in case...
2664 3038
2665 # check predefined channels, for the benefit of C 3039 # check predefined channels, for the benefit of C
2666 if ($CHANNEL{$channel}) { 3040 if ($CHANNEL{$channel}) {
2667 $channel = $CHANNEL{$channel}; 3041 $channel = $CHANNEL{$channel};
2668 3042
2669 $self->ext_msg (channel_info => $channel) 3043 $self->ext_msg (channel_info => $channel);
2670 if $self->can_msg;
2671
2672 $channel = $channel->{id}; 3044 $channel = $channel->{id};
2673 3045
2674 } elsif (ref $channel) { 3046 } elsif (ref $channel) {
2675 # send meta info to client, if not yet sent 3047 # send meta info to client, if not yet sent
2676 unless (exists $self->{channel}{$channel->{id}}) { 3048 unless (exists $self->{channel}{$channel->{id}}) {
2677 $self->{channel}{$channel->{id}} = $channel; 3049 $self->{channel}{$channel->{id}} = $channel;
2678 $self->ext_msg (channel_info => $channel) 3050 $self->ext_msg (channel_info => $channel);
2679 if $self->can_msg;
2680 } 3051 }
2681 3052
2682 $channel = $channel->{id}; 3053 $channel = $channel->{id};
2683 } 3054 }
2684 3055
2685 return unless @extra || length $msg; 3056 return unless @extra || length $msg;
2686 3057
2687 if ($self->can_msg) {
2688 # default colour, mask it out 3058 # default colour, mask it out
2689 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3059 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2690 if $color & cf::NDI_DEF; 3060 if $color & cf::NDI_DEF;
2691 3061
2692 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3062 my $pkt = "msg "
3063 . $self->{json_coder}->encode (
2693 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3064 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2694 } else { 3065 );
2695 if ($color >= 0) {
2696 # replace some tags by gcfclient-compatible ones
2697 for ($msg) {
2698 1 while
2699 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2700 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2701 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2702 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2703 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2704 }
2705 3066
2706 $color &= cf::NDI_COLOR_MASK; 3067 $self->send_big_packet ($pkt);
2707
2708 utf8::encode $msg;
2709
2710 if (0 && $msg =~ /\[/) {
2711 # COMMAND/INFO
2712 $self->send_packet ("drawextinfo $color 10 8 $msg")
2713 } else {
2714 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2715 $self->send_packet ("drawinfo $color $msg")
2716 }
2717 }
2718 }
2719} 3068}
2720 3069
2721=item $client->ext_msg ($type, @msg) 3070=item $client->ext_msg ($type, @msg)
2722 3071
2723Sends an ext event to the client. 3072Sends an ext event to the client.
2726 3075
2727sub cf::client::ext_msg($$@) { 3076sub cf::client::ext_msg($$@) {
2728 my ($self, $type, @msg) = @_; 3077 my ($self, $type, @msg) = @_;
2729 3078
2730 if ($self->extcmd == 2) { 3079 if ($self->extcmd == 2) {
2731 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3080 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2732 } elsif ($self->extcmd == 1) { # TODO: remove 3081 } elsif ($self->extcmd == 1) { # TODO: remove
2733 push @msg, msgtype => "event_$type"; 3082 push @msg, msgtype => "event_$type";
2734 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3083 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2735 } 3084 }
2736} 3085}
2737 3086
2738=item $client->ext_reply ($msgid, @msg) 3087=item $client->ext_reply ($msgid, @msg)
2739 3088
2743 3092
2744sub cf::client::ext_reply($$@) { 3093sub cf::client::ext_reply($$@) {
2745 my ($self, $id, @msg) = @_; 3094 my ($self, $id, @msg) = @_;
2746 3095
2747 if ($self->extcmd == 2) { 3096 if ($self->extcmd == 2) {
2748 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3097 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2749 } elsif ($self->extcmd == 1) { 3098 } elsif ($self->extcmd == 1) {
2750 #TODO: version 1, remove 3099 #TODO: version 1, remove
2751 unshift @msg, msgtype => "reply", msgid => $id; 3100 unshift @msg, msgtype => "reply", msgid => $id;
2752 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3101 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2753 } 3102 }
2754} 3103}
2755 3104
2756=item $success = $client->query ($flags, "text", \&cb) 3105=item $success = $client->query ($flags, "text", \&cb)
2757 3106
2828 3177
2829 $ns->ext_reply ($reply, @reply) 3178 $ns->ext_reply ($reply, @reply)
2830 if $reply; 3179 if $reply;
2831 3180
2832 } else { 3181 } else {
2833 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3182 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2834 } 3183 }
2835 3184
2836 cf::override; 3185 cf::override;
2837 }, 3186 },
2838); 3187);
2858 3207
2859 $coro 3208 $coro
2860} 3209}
2861 3210
2862cf::client->attach ( 3211cf::client->attach (
2863 on_destroy => sub { 3212 on_client_destroy => sub {
2864 my ($ns) = @_; 3213 my ($ns) = @_;
2865 3214
2866 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3215 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2867 }, 3216 },
2868); 3217);
2884our $safe_hole = new Safe::Hole; 3233our $safe_hole = new Safe::Hole;
2885 3234
2886$SIG{FPE} = 'IGNORE'; 3235$SIG{FPE} = 'IGNORE';
2887 3236
2888$safe->permit_only (Opcode::opset qw( 3237$safe->permit_only (Opcode::opset qw(
2889 :base_core :base_mem :base_orig :base_math 3238 :base_core :base_mem :base_orig :base_math :base_loop
2890 grepstart grepwhile mapstart mapwhile 3239 grepstart grepwhile mapstart mapwhile
2891 sort time 3240 sort time
2892)); 3241));
2893 3242
2894# here we export the classes and methods available to script code 3243# here we export the classes and methods available to script code
2896=pod 3245=pod
2897 3246
2898The following functions and methods are available within a safe environment: 3247The following functions and methods are available within a safe environment:
2899 3248
2900 cf::object 3249 cf::object
2901 contr pay_amount pay_player map x y force_find force_add 3250 contr pay_amount pay_player map x y force_find force_add destroy
2902 insert remove name archname title slaying race decrease_ob_nr 3251 insert remove name archname title slaying race decrease split
3252 value
2903 3253
2904 cf::object::player 3254 cf::object::player
2905 player 3255 player
2906 3256
2907 cf::player 3257 cf::player
2912 3262
2913=cut 3263=cut
2914 3264
2915for ( 3265for (
2916 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3266 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2917 insert remove inv name archname title slaying race 3267 insert remove inv nrof name archname title slaying race
2918 decrease_ob_nr)], 3268 decrease split destroy change_exp value msg lore send_msg)],
2919 ["cf::object::player" => qw(player)], 3269 ["cf::object::player" => qw(player)],
2920 ["cf::player" => qw(peaceful)], 3270 ["cf::player" => qw(peaceful send_msg)],
2921 ["cf::map" => qw(trigger)], 3271 ["cf::map" => qw(trigger)],
2922) { 3272) {
2923 no strict 'refs'; 3273 no strict 'refs';
2924 my ($pkg, @funs) = @$_; 3274 my ($pkg, @funs) = @$_;
2925 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3275 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2943 3293
2944 my $qcode = $code; 3294 my $qcode = $code;
2945 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3295 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2946 $qcode =~ s/\n/\\n/g; 3296 $qcode =~ s/\n/\\n/g;
2947 3297
3298 %vars = (_dummy => 0) unless %vars;
3299
3300 my @res;
2948 local $_; 3301 local $_;
2949 local @safe::cf::_safe_eval_args = values %vars;
2950 3302
2951 my $eval = 3303 my $eval =
2952 "do {\n" 3304 "do {\n"
2953 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3305 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2954 . "#line 0 \"{$qcode}\"\n" 3306 . "#line 0 \"{$qcode}\"\n"
2955 . $code 3307 . $code
2956 . "\n}" 3308 . "\n}"
2957 ; 3309 ;
2958 3310
3311 if ($CFG{safe_eval}) {
2959 sub_generation_inc; 3312 sub_generation_inc;
3313 local @safe::cf::_safe_eval_args = values %vars;
2960 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3314 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2961 sub_generation_inc; 3315 sub_generation_inc;
3316 } else {
3317 local @cf::_safe_eval_args = values %vars;
3318 @res = wantarray ? eval eval : scalar eval $eval;
3319 }
2962 3320
2963 if ($@) { 3321 if ($@) {
2964 warn "$@"; 3322 warn "$@",
2965 warn "while executing safe code '$code'\n"; 3323 "while executing safe code '$code'\n",
2966 warn "with arguments " . (join " ", %vars) . "\n"; 3324 "with arguments " . (join " ", %vars) . "\n";
2967 } 3325 }
2968 3326
2969 wantarray ? @res : $res[0] 3327 wantarray ? @res : $res[0]
2970} 3328}
2971 3329
2985=cut 3343=cut
2986 3344
2987sub register_script_function { 3345sub register_script_function {
2988 my ($fun, $cb) = @_; 3346 my ($fun, $cb) = @_;
2989 3347
2990 no strict 'refs'; 3348 $fun = "safe::$fun" if $CFG{safe_eval};
2991 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3349 *$fun = $safe_hole->wrap ($cb);
2992} 3350}
2993 3351
2994=back 3352=back
2995 3353
2996=cut 3354=cut
3005 # for this (global event?) 3363 # for this (global event?)
3006 %ext::player_env::MUSIC_FACE_CACHE = (); 3364 %ext::player_env::MUSIC_FACE_CACHE = ();
3007 3365
3008 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3366 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3009 3367
3010 warn "loading facedata from $path\n"; 3368 trace "loading facedata from $path\n";
3011 3369
3012 my $facedata; 3370 my $facedata;
3013 0 < aio_load $path, $facedata 3371 0 < aio_load $path, $facedata
3014 or die "$path: $!"; 3372 or die "$path: $!";
3015 3373
3017 3375
3018 $facedata->{version} == 2 3376 $facedata->{version} == 2
3019 or cf::cleanup "$path: version mismatch, cannot proceed."; 3377 or cf::cleanup "$path: version mismatch, cannot proceed.";
3020 3378
3021 # patch in the exptable 3379 # patch in the exptable
3380 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3022 $facedata->{resource}{"res/exp_table"} = { 3381 $facedata->{resource}{"res/exp_table"} = {
3023 type => FT_RSRC, 3382 type => FT_RSRC,
3024 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3383 data => $exp_table,
3384 hash => (Digest::MD5::md5 $exp_table),
3025 }; 3385 };
3026 cf::cede_to_tick; 3386 cf::cede_to_tick;
3027 3387
3028 { 3388 {
3029 my $faces = $facedata->{faceinfo}; 3389 my $faces = $facedata->{faceinfo};
3030 3390
3031 while (my ($face, $info) = each %$faces) { 3391 while (my ($face, $info) = each %$faces) {
3032 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3392 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3393
3033 cf::face::set_visibility $idx, $info->{visibility}; 3394 cf::face::set_visibility $idx, $info->{visibility};
3034 cf::face::set_magicmap $idx, $info->{magicmap}; 3395 cf::face::set_magicmap $idx, $info->{magicmap};
3035 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3396 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3036 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3397 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3037 3398
3038 cf::cede_to_tick; 3399 cf::cede_to_tick;
3039 } 3400 }
3040 3401
3041 while (my ($face, $info) = each %$faces) { 3402 while (my ($face, $info) = each %$faces) {
3042 next unless $info->{smooth}; 3403 next unless $info->{smooth};
3404
3043 my $idx = cf::face::find $face 3405 my $idx = cf::face::find $face
3044 or next; 3406 or next;
3407
3045 if (my $smooth = cf::face::find $info->{smooth}) { 3408 if (my $smooth = cf::face::find $info->{smooth}) {
3046 cf::face::set_smooth $idx, $smooth; 3409 cf::face::set_smooth $idx, $smooth;
3047 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3410 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3048 } else { 3411 } else {
3049 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3412 error "smooth face '$info->{smooth}' not found for face '$face'";
3050 } 3413 }
3051 3414
3052 cf::cede_to_tick; 3415 cf::cede_to_tick;
3053 } 3416 }
3054 } 3417 }
3063 3426
3064 cf::anim::invalidate_all; # d'oh 3427 cf::anim::invalidate_all; # d'oh
3065 } 3428 }
3066 3429
3067 { 3430 {
3068 # TODO: for gcfclient pleasure, we should give resources
3069 # that gcfclient doesn't grok a >10000 face index.
3070 my $res = $facedata->{resource}; 3431 my $res = $facedata->{resource};
3071 3432
3072 my $soundconf = delete $res->{"res/sound.conf"};
3073
3074 while (my ($name, $info) = each %$res) { 3433 while (my ($name, $info) = each %$res) {
3434 if (defined $info->{type}) {
3075 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3435 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3076 my $data;
3077 3436
3078 if ($info->{type} & 1) { 3437 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3079 # prepend meta info 3438 cf::face::set_type $idx, $info->{type};
3080
3081 my $meta = $enc->encode ({
3082 name => $name,
3083 %{ $info->{meta} || {} },
3084 });
3085
3086 $data = pack "(w/a*)*", $meta, $info->{data};
3087 } else { 3439 } else {
3088 $data = $info->{data}; 3440 $RESOURCE{$name} = $info; # unused
3089 } 3441 }
3090 3442
3091 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3092 cf::face::set_type $idx, $info->{type};
3093
3094 cf::cede_to_tick; 3443 cf::cede_to_tick;
3095 } 3444 }
3096
3097 if ($soundconf) {
3098 $soundconf = $enc->decode (delete $soundconf->{data});
3099
3100 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3101 my $sound = $soundconf->{compat}[$_]
3102 or next;
3103
3104 my $face = cf::face::find "sound/$sound->[1]";
3105 cf::sound::set $sound->[0] => $face;
3106 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3107 }
3108
3109 while (my ($k, $v) = each %{$soundconf->{event}}) {
3110 my $face = cf::face::find "sound/$v";
3111 cf::sound::set $k => $face;
3112 }
3113 }
3114 } 3445 }
3446
3447 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3115 3448
3116 1 3449 1
3117} 3450}
3118 3451
3119register_exticmd fx_want => sub { 3452register_exticmd fx_want => sub {
3121 3454
3122 while (my ($k, $v) = each %$want) { 3455 while (my ($k, $v) = each %$want) {
3123 $ns->fx_want ($k, $v); 3456 $ns->fx_want ($k, $v);
3124 } 3457 }
3125}; 3458};
3459
3460sub load_resource_file($) {
3461 my $guard = lock_acquire "load_resource_file";
3462
3463 my $status = load_resource_file_ $_[0];
3464 get_slot 0.1, 100;
3465 cf::arch::commit_load;
3466
3467 $status
3468}
3126 3469
3127sub reload_regions { 3470sub reload_regions {
3128 # HACK to clear player env face cache, we need some signal framework 3471 # HACK to clear player env face cache, we need some signal framework
3129 # for this (global event?) 3472 # for this (global event?)
3130 %ext::player_env::MUSIC_FACE_CACHE = (); 3473 %ext::player_env::MUSIC_FACE_CACHE = ();
3144} 3487}
3145 3488
3146sub reload_archetypes { 3489sub reload_archetypes {
3147 load_resource_file "$DATADIR/archetypes" 3490 load_resource_file "$DATADIR/archetypes"
3148 or die "unable to load archetypes\n"; 3491 or die "unable to load archetypes\n";
3149 #d# NEED to laod twice to resolve forward references
3150 # this really needs to be done in an extra post-pass
3151 # (which needs to be synchronous, so solve it differently)
3152 load_resource_file "$DATADIR/archetypes"
3153 or die "unable to load archetypes\n";
3154} 3492}
3155 3493
3156sub reload_treasures { 3494sub reload_treasures {
3157 load_resource_file "$DATADIR/treasures" 3495 load_resource_file "$DATADIR/treasures"
3158 or die "unable to load treasurelists\n"; 3496 or die "unable to load treasurelists\n";
3159} 3497}
3160 3498
3499sub reload_sound {
3500 trace "loading sound config from $DATADIR/sound\n";
3501
3502 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3503 or die "$DATADIR/sound $!";
3504
3505 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3506
3507 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3508 my $sound = $soundconf->{compat}[$_]
3509 or next;
3510
3511 my $face = cf::face::find "sound/$sound->[1]";
3512 cf::sound::set $sound->[0] => $face;
3513 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3514 }
3515
3516 while (my ($k, $v) = each %{$soundconf->{event}}) {
3517 my $face = cf::face::find "sound/$v";
3518 cf::sound::set $k => $face;
3519 }
3520}
3521
3161sub reload_resources { 3522sub reload_resources {
3162 warn "reloading resource files...\n"; 3523 trace "reloading resource files...\n";
3163 3524
3525 reload_facedata;
3526 reload_sound;
3527 reload_archetypes;
3164 reload_regions; 3528 reload_regions;
3165 reload_facedata;
3166 #reload_archetypes;#d#
3167 reload_archetypes;
3168 reload_treasures; 3529 reload_treasures;
3169 3530
3170 warn "finished reloading resource files\n"; 3531 trace "finished reloading resource files\n";
3171}
3172
3173sub init {
3174 reload_resources;
3175} 3532}
3176 3533
3177sub reload_config { 3534sub reload_config {
3535 trace "reloading config file...\n";
3536
3178 open my $fh, "<:utf8", "$CONFDIR/config" 3537 open my $fh, "<:utf8", "$CONFDIR/config"
3179 or return; 3538 or return;
3180 3539
3181 local $/; 3540 local $/;
3182 *CFG = YAML::Syck::Load <$fh>; 3541 *CFG = YAML::XS::Load scalar <$fh>;
3183 3542
3184 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3543 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3185 3544
3186 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3545 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3187 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3546 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3188 3547
3189 if (exists $CFG{mlockall}) { 3548 if (exists $CFG{mlockall}) {
3191 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3550 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3192 and die "WARNING: m(un)lockall failed: $!\n"; 3551 and die "WARNING: m(un)lockall failed: $!\n";
3193 }; 3552 };
3194 warn $@ if $@; 3553 warn $@ if $@;
3195 } 3554 }
3555
3556 trace "finished reloading resource files\n";
3557}
3558
3559sub pidfile() {
3560 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3561 or die "$PIDFILE: $!";
3562 flock $fh, &Fcntl::LOCK_EX
3563 or die "$PIDFILE: flock: $!";
3564 $fh
3565}
3566
3567# make sure only one server instance is running at any one time
3568sub atomic {
3569 my $fh = pidfile;
3570
3571 my $pid = <$fh>;
3572 kill 9, $pid if $pid > 0;
3573
3574 seek $fh, 0, 0;
3575 print $fh $$;
3576}
3577
3578sub main_loop {
3579 trace "EV::loop starting\n";
3580 if (1) {
3581 EV::loop;
3582 }
3583 trace "EV::loop returned\n";
3584 goto &main_loop unless $REALLY_UNLOOP;
3196} 3585}
3197 3586
3198sub main { 3587sub main {
3588 cf::init_globals; # initialise logging
3589
3590 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3591 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3592 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3593 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3594
3595 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3596
3199 # we must not ever block the main coroutine 3597 # we must not ever block the main coroutine
3200 local $Coro::idle = sub { 3598 local $Coro::idle = sub {
3201 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3599 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3202 (async { 3600 (async {
3203 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3601 $Coro::current->{desc} = "IDLE BUG HANDLER";
3204 Event::one_event; 3602 EV::loop EV::LOOP_ONESHOT;
3205 })->prio (Coro::PRIO_MAX); 3603 })->prio (Coro::PRIO_MAX);
3206 }; 3604 };
3207 3605
3606 evthread_start IO::AIO::poll_fileno;
3607
3608 cf::sync_job {
3609 cf::init_experience;
3610 cf::init_anim;
3611 cf::init_attackmess;
3612 cf::init_dynamic;
3613
3614 cf::load_settings;
3615 cf::load_materials;
3616
3617 reload_resources;
3208 reload_config; 3618 reload_config;
3209 db_init; 3619 db_init;
3620
3621 cf::init_uuid;
3622 cf::init_signals;
3623 cf::init_skills;
3624
3625 cf::init_beforeplay;
3626
3627 atomic;
3628
3210 load_extensions; 3629 load_extensions;
3211 3630
3212 $TICK_WATCHER->start; 3631 utime time, time, $RUNTIMEFILE;
3213 Event::loop; 3632
3633 # no (long-running) fork's whatsoever before this point(!)
3634 use POSIX ();
3635 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3636
3637 (pop @POST_INIT)->(0) while @POST_INIT;
3638 };
3639
3640 cf::object::thawer::errors_are_fatal 0;
3641 info "parse errors in files are no longer fatal from this point on.\n";
3642
3643 main_loop;
3214} 3644}
3215 3645
3216############################################################################# 3646#############################################################################
3217# initialisation and cleanup 3647# initialisation and cleanup
3218 3648
3219# install some emergency cleanup handlers 3649# install some emergency cleanup handlers
3220BEGIN { 3650BEGIN {
3651 our %SIGWATCHER = ();
3221 for my $signal (qw(INT HUP TERM)) { 3652 for my $signal (qw(INT HUP TERM)) {
3222 Event->signal ( 3653 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3223 reentrant => 0,
3224 data => WF_AUTOCANCEL,
3225 signal => $signal,
3226 prio => 0,
3227 cb => sub {
3228 cf::cleanup "SIG$signal"; 3654 cf::cleanup "SIG$signal";
3229 },
3230 ); 3655 };
3231 } 3656 }
3232} 3657}
3233 3658
3234sub write_runtime { 3659sub write_runtime_sync {
3235 my $runtime = "$LOCALDIR/runtime"; 3660 my $t0 = AE::time;
3236 3661
3237 # first touch the runtime file to show we are still running: 3662 # first touch the runtime file to show we are still running:
3238 # the fsync below can take a very very long time. 3663 # the fsync below can take a very very long time.
3239 3664
3240 IO::AIO::aio_utime $runtime, undef, undef; 3665 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3241 3666
3242 my $guard = cf::lock_acquire "write_runtime"; 3667 my $guard = cf::lock_acquire "write_runtime";
3243 3668
3244 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3669 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3245 or return; 3670 or return;
3246 3671
3247 my $value = $cf::RUNTIME + 90 + 10; 3672 my $value = $cf::RUNTIME + 90 + 10;
3248 # 10 is the runtime save interval, for a monotonic clock 3673 # 10 is the runtime save interval, for a monotonic clock
3249 # 60 allows for the watchdog to kill the server. 3674 # 60 allows for the watchdog to kill the server.
3259 aio_utime $fh, undef, undef; 3684 aio_utime $fh, undef, undef;
3260 3685
3261 close $fh 3686 close $fh
3262 or return; 3687 or return;
3263 3688
3264 aio_rename "$runtime~", $runtime 3689 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3265 and return; 3690 and return;
3266 3691
3267 warn "runtime file written.\n"; 3692 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3268 3693
3269 1 3694 1
3695}
3696
3697our $uuid_lock;
3698our $uuid_skip;
3699
3700sub write_uuid_sync($) {
3701 $uuid_skip ||= $_[0];
3702
3703 return if $uuid_lock;
3704 local $uuid_lock = 1;
3705
3706 my $uuid = "$LOCALDIR/uuid";
3707
3708 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3709 or return;
3710
3711 my $value = uuid_seq uuid_cur;
3712
3713 unless ($value) {
3714 info "cowardly refusing to write zero uuid value!\n";
3715 return;
3716 }
3717
3718 my $value = uuid_str $value + $uuid_skip;
3719 $uuid_skip = 0;
3720
3721 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3722 and return;
3723
3724 # always fsync - this file is important
3725 aio_fsync $fh
3726 and return;
3727
3728 close $fh
3729 or return;
3730
3731 aio_rename "$uuid~", $uuid
3732 and return;
3733
3734 trace "uuid file written ($value).\n";
3735
3736 1
3737
3738}
3739
3740sub write_uuid($$) {
3741 my ($skip, $sync) = @_;
3742
3743 $sync ? write_uuid_sync $skip
3744 : async { write_uuid_sync $skip };
3270} 3745}
3271 3746
3272sub emergency_save() { 3747sub emergency_save() {
3273 my $freeze_guard = cf::freeze_mainloop; 3748 my $freeze_guard = cf::freeze_mainloop;
3274 3749
3275 warn "enter emergency perl save\n"; 3750 info "emergency_perl_save: enter\n";
3276 3751
3277 cf::sync_job { 3752 cf::sync_job {
3753 # this is a trade-off: we want to be very quick here, so
3754 # save all maps without fsync, and later call a global sync
3755 # (which in turn might be very very slow)
3756 local $USE_FSYNC = 0;
3757
3278 # use a peculiar iteration method to avoid tripping on perl 3758 # use a peculiar iteration method to avoid tripping on perl
3279 # refcount bugs in for. also avoids problems with players 3759 # refcount bugs in for. also avoids problems with players
3280 # and maps saved/destroyed asynchronously. 3760 # and maps saved/destroyed asynchronously.
3281 warn "begin emergency player save\n"; 3761 info "emergency_perl_save: begin player save\n";
3282 for my $login (keys %cf::PLAYER) { 3762 for my $login (keys %cf::PLAYER) {
3283 my $pl = $cf::PLAYER{$login} or next; 3763 my $pl = $cf::PLAYER{$login} or next;
3284 $pl->valid or next; 3764 $pl->valid or next;
3285 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3765 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3286 $pl->save; 3766 $pl->save;
3287 } 3767 }
3288 warn "end emergency player save\n"; 3768 info "emergency_perl_save: end player save\n";
3289 3769
3290 warn "begin emergency map save\n"; 3770 info "emergency_perl_save: begin map save\n";
3291 for my $path (keys %cf::MAP) { 3771 for my $path (keys %cf::MAP) {
3292 my $map = $cf::MAP{$path} or next; 3772 my $map = $cf::MAP{$path} or next;
3293 $map->valid or next; 3773 $map->valid or next;
3294 $map->save; 3774 $map->save;
3295 } 3775 }
3296 warn "end emergency map save\n"; 3776 info "emergency_perl_save: end map save\n";
3297 3777
3298 warn "begin emergency database checkpoint\n"; 3778 info "emergency_perl_save: begin database checkpoint\n";
3299 BDB::db_env_txn_checkpoint $DB_ENV; 3779 BDB::db_env_txn_checkpoint $DB_ENV;
3300 warn "end emergency database checkpoint\n"; 3780 info "emergency_perl_save: end database checkpoint\n";
3781
3782 info "emergency_perl_save: begin write uuid\n";
3783 write_uuid_sync 1;
3784 info "emergency_perl_save: end write uuid\n";
3301 }; 3785 };
3302 3786
3303 warn "leave emergency perl save\n"; 3787 info "emergency_perl_save: starting sync()\n";
3788 IO::AIO::aio_sync sub {
3789 info "emergency_perl_save: finished sync()\n";
3790 };
3791
3792 info "emergency_perl_save: leave\n";
3304} 3793}
3305 3794
3306sub post_cleanup { 3795sub post_cleanup {
3307 my ($make_core) = @_; 3796 my ($make_core) = @_;
3308 3797
3309 warn Carp::longmess "post_cleanup backtrace" 3798 error Carp::longmess "post_cleanup backtrace"
3310 if $make_core; 3799 if $make_core;
3800
3801 my $fh = pidfile;
3802 unlink $PIDFILE if <$fh> == $$;
3803}
3804
3805# a safer delete_package, copied from Symbol
3806sub clear_package($) {
3807 my $pkg = shift;
3808
3809 # expand to full symbol table name if needed
3810 unless ($pkg =~ /^main::.*::$/) {
3811 $pkg = "main$pkg" if $pkg =~ /^::/;
3812 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3813 $pkg .= '::' unless $pkg =~ /::$/;
3814 }
3815
3816 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3817 my $stem_symtab = *{$stem}{HASH};
3818
3819 defined $stem_symtab and exists $stem_symtab->{$leaf}
3820 or return;
3821
3822 # clear all symbols
3823 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3824 for my $name (keys %$leaf_symtab) {
3825 _gv_clear *{"$pkg$name"};
3826# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3827 }
3311} 3828}
3312 3829
3313sub do_reload_perl() { 3830sub do_reload_perl() {
3314 # can/must only be called in main 3831 # can/must only be called in main
3315 if ($Coro::current != $Coro::main) { 3832 if (in_main) {
3316 warn "can only reload from main coroutine"; 3833 error "can only reload from main coroutine";
3317 return; 3834 return;
3318 } 3835 }
3319 3836
3837 return if $RELOAD++;
3838
3839 my $t1 = AE::time;
3840
3841 while ($RELOAD) {
3320 warn "reloading..."; 3842 info "reloading...";
3321 3843
3322 warn "entering sync_job"; 3844 trace "entering sync_job";
3323 3845
3324 cf::sync_job { 3846 cf::sync_job {
3325 cf::write_runtime; # external watchdog should not bark 3847 cf::write_runtime_sync; # external watchdog should not bark
3326 cf::emergency_save; 3848 cf::emergency_save;
3327 cf::write_runtime; # external watchdog should not bark 3849 cf::write_runtime_sync; # external watchdog should not bark
3328 3850
3329 warn "syncing database to disk"; 3851 trace "syncing database to disk";
3330 BDB::db_env_txn_checkpoint $DB_ENV; 3852 BDB::db_env_txn_checkpoint $DB_ENV;
3331 3853
3332 # if anything goes wrong in here, we should simply crash as we already saved 3854 # if anything goes wrong in here, we should simply crash as we already saved
3333 3855
3334 warn "cancelling all WF_AUTOCANCEL watchers";
3335 for (Event::all_watchers) {
3336 $_->cancel if $_->data & WF_AUTOCANCEL;
3337 }
3338
3339 warn "flushing outstanding aio requests"; 3856 trace "flushing outstanding aio requests";
3340 for (;;) {
3341 BDB::flush;
3342 IO::AIO::flush;
3343 Coro::cede;
3344 last unless IO::AIO::nreqs || BDB::nreqs; 3857 while (IO::AIO::nreqs || BDB::nreqs) {
3345 warn "iterate..."; 3858 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3346 }
3347
3348 ++$RELOAD;
3349
3350 warn "cancelling all extension coros";
3351 $_->cancel for values %EXT_CORO;
3352 %EXT_CORO = ();
3353
3354 warn "removing commands";
3355 %COMMAND = ();
3356
3357 warn "removing ext/exti commands";
3358 %EXTCMD = ();
3359 %EXTICMD = ();
3360
3361 warn "unloading/nuking all extensions";
3362 for my $pkg (@EXTS) {
3363 warn "... unloading $pkg";
3364
3365 if (my $cb = $pkg->can ("unload")) {
3366 eval {
3367 $cb->($pkg);
3368 1
3369 } or warn "$pkg unloaded, but with errors: $@";
3370 } 3859 }
3371 3860
3372 warn "... nuking $pkg"; 3861 trace "cancelling all extension coros";
3373 Symbol::delete_package $pkg; 3862 $_->cancel for values %EXT_CORO;
3374 } 3863 %EXT_CORO = ();
3375 3864
3376 warn "unloading all perl modules loaded from $LIBDIR"; 3865 trace "removing commands";
3377 while (my ($k, $v) = each %INC) { 3866 %COMMAND = ();
3378 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3379 3867
3868 trace "removing ext/exti commands";
3869 %EXTCMD = ();
3870 %EXTICMD = ();
3871
3872 trace "unloading/nuking all extensions";
3873 for my $pkg (@EXTS) {
3380 warn "... unloading $k"; 3874 trace "... unloading $pkg";
3381 delete $INC{$k};
3382 3875
3383 $k =~ s/\.pm$//;
3384 $k =~ s/\//::/g;
3385
3386 if (my $cb = $k->can ("unload_module")) { 3876 if (my $cb = $pkg->can ("unload")) {
3877 eval {
3387 $cb->(); 3878 $cb->($pkg);
3879 1
3880 } or error "$pkg unloaded, but with errors: $@";
3881 }
3882
3883 trace "... clearing $pkg";
3884 clear_package $pkg;
3388 } 3885 }
3389 3886
3390 Symbol::delete_package $k; 3887 trace "unloading all perl modules loaded from $LIBDIR";
3888 while (my ($k, $v) = each %INC) {
3889 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3890
3891 trace "... unloading $k";
3892 delete $INC{$k};
3893
3894 $k =~ s/\.pm$//;
3895 $k =~ s/\//::/g;
3896
3897 if (my $cb = $k->can ("unload_module")) {
3898 $cb->();
3899 }
3900
3901 clear_package $k;
3391 } 3902 }
3392 3903
3393 warn "getting rid of safe::, as good as possible"; 3904 trace "getting rid of safe::, as good as possible";
3394 Symbol::delete_package "safe::$_" 3905 clear_package "safe::$_"
3395 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3906 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3396 3907
3397 warn "unloading cf.pm \"a bit\""; 3908 trace "unloading cf.pm \"a bit\"";
3398 delete $INC{"cf.pm"}; 3909 delete $INC{"cf.pm"};
3399 delete $INC{"cf/pod.pm"}; 3910 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3400 3911
3401 # don't, removes xs symbols, too, 3912 # don't, removes xs symbols, too,
3402 # and global variables created in xs 3913 # and global variables created in xs
3403 #Symbol::delete_package __PACKAGE__; 3914 #clear_package __PACKAGE__;
3404 3915
3405 warn "unload completed, starting to reload now"; 3916 info "unload completed, starting to reload now";
3406 3917
3407 warn "reloading cf.pm"; 3918 trace "reloading cf.pm";
3408 require cf; 3919 require cf;
3409 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3920 cf::_connect_to_perl_1;
3410 3921
3411 warn "loading config and database again"; 3922 trace "loading config and database again";
3412 cf::reload_config; 3923 cf::reload_config;
3413 3924
3414 warn "loading extensions"; 3925 trace "loading extensions";
3415 cf::load_extensions; 3926 cf::load_extensions;
3416 3927
3928 if ($REATTACH_ON_RELOAD) {
3417 warn "reattaching attachments to objects/players"; 3929 trace "reattaching attachments to objects/players";
3418 _global_reattach; # objects, sockets 3930 _global_reattach; # objects, sockets
3419 warn "reattaching attachments to maps"; 3931 trace "reattaching attachments to maps";
3420 reattach $_ for values %MAP; 3932 reattach $_ for values %MAP;
3421 warn "reattaching attachments to players"; 3933 trace "reattaching attachments to players";
3422 reattach $_ for values %PLAYER; 3934 reattach $_ for values %PLAYER;
3935 }
3423 3936
3937 trace "running post_init jobs";
3938 (pop @POST_INIT)->(1) while @POST_INIT;
3939
3424 warn "leaving sync_job"; 3940 trace "leaving sync_job";
3425 3941
3426 1 3942 1
3427 } or do { 3943 } or do {
3428 warn $@; 3944 error $@;
3429 warn "error while reloading, exiting."; 3945 cf::cleanup "error while reloading, exiting.";
3430 exit 1; 3946 };
3947
3948 info "reloaded";
3949 --$RELOAD;
3431 }; 3950 }
3432 3951
3433 warn "reloaded"; 3952 $t1 = AE::time - $t1;
3953 info "reload completed in ${t1}s\n";
3434}; 3954};
3435 3955
3436our $RELOAD_WATCHER; # used only during reload 3956our $RELOAD_WATCHER; # used only during reload
3437 3957
3438sub reload_perl() { 3958sub reload_perl() {
3439 # doing reload synchronously and two reloads happen back-to-back, 3959 # doing reload synchronously and two reloads happen back-to-back,
3440 # coro crashes during coro_state_free->destroy here. 3960 # coro crashes during coro_state_free->destroy here.
3441 3961
3442 $RELOAD_WATCHER ||= Event->timer ( 3962 $RELOAD_WATCHER ||= cf::async {
3443 reentrant => 0, 3963 Coro::AIO::aio_wait cache_extensions;
3444 after => 0, 3964
3445 data => WF_AUTOCANCEL, 3965 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3446 cb => sub {
3447 do_reload_perl; 3966 do_reload_perl;
3448 undef $RELOAD_WATCHER; 3967 undef $RELOAD_WATCHER;
3449 }, 3968 };
3450 ); 3969 };
3451} 3970}
3452 3971
3453register_command "reload" => sub { 3972register_command "reload" => sub {
3454 my ($who, $arg) = @_; 3973 my ($who, $arg) = @_;
3455 3974
3468 3987
3469our @WAIT_FOR_TICK; 3988our @WAIT_FOR_TICK;
3470our @WAIT_FOR_TICK_BEGIN; 3989our @WAIT_FOR_TICK_BEGIN;
3471 3990
3472sub wait_for_tick { 3991sub wait_for_tick {
3473 return unless $TICK_WATCHER->is_active;
3474 return if $Coro::current == $Coro::main; 3992 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3475 3993
3476 my $signal = new Coro::Signal; 3994 my $signal = new Coro::Signal;
3477 push @WAIT_FOR_TICK, $signal; 3995 push @WAIT_FOR_TICK, $signal;
3478 $signal->wait; 3996 $signal->wait;
3479} 3997}
3480 3998
3481sub wait_for_tick_begin { 3999sub wait_for_tick_begin {
3482 return unless $TICK_WATCHER->is_active;
3483 return if $Coro::current == $Coro::main; 4000 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3484 4001
3485 my $signal = new Coro::Signal; 4002 my $signal = new Coro::Signal;
3486 push @WAIT_FOR_TICK_BEGIN, $signal; 4003 push @WAIT_FOR_TICK_BEGIN, $signal;
3487 $signal->wait; 4004 $signal->wait;
3488} 4005}
3489 4006
3490$TICK_WATCHER = Event->timer ( 4007sub tick {
3491 reentrant => 0,
3492 parked => 1,
3493 prio => 0,
3494 at => $NEXT_TICK || $TICK,
3495 data => WF_AUTOCANCEL,
3496 cb => sub {
3497 if ($Coro::current != $Coro::main) { 4008 if ($Coro::current != $Coro::main) {
3498 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4009 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3499 unless ++$bug_warning > 10; 4010 unless ++$bug_warning > 10;
3500 return; 4011 return;
3501 } 4012 }
3502 4013
3503 $NOW = $tick_start = Event::time;
3504
3505 cf::server_tick; # one server iteration 4014 cf::server_tick; # one server iteration
3506 4015
3507 $RUNTIME += $TICK; 4016 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3508 $NEXT_TICK += $TICK;
3509 4017
3510 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4018 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3511 $NEXT_RUNTIME_WRITE = $NOW + 10; 4019 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3512 Coro::async_pool { 4020 Coro::async_pool {
3513 $Coro::current->{desc} = "runtime saver"; 4021 $Coro::current->{desc} = "runtime saver";
3514 write_runtime 4022 write_runtime_sync
3515 or warn "ERROR: unable to write runtime file: $!"; 4023 or error "ERROR: unable to write runtime file: $!";
3516 };
3517 } 4024 };
4025 }
3518 4026
3519 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4027 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3520 $sig->send; 4028 $sig->send;
3521 } 4029 }
3522 while (my $sig = shift @WAIT_FOR_TICK) { 4030 while (my $sig = shift @WAIT_FOR_TICK) {
3523 $sig->send; 4031 $sig->send;
3524 } 4032 }
3525 4033
3526 $NOW = Event::time; 4034 $LOAD = ($NOW - $TICK_START) / $TICK;
3527
3528 # if we are delayed by four ticks or more, skip them all
3529 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3530
3531 $TICK_WATCHER->at ($NEXT_TICK);
3532 $TICK_WATCHER->start;
3533
3534 $LOAD = ($NOW - $tick_start) / $TICK;
3535 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4035 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3536 4036
3537 _post_tick; 4037 if (0) {
4038 if ($NEXT_TICK) {
4039 my $jitter = $TICK_START - $NEXT_TICK;
4040 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4041 debug "jitter $JITTER\n";#d#
4042 }
3538 }, 4043 }
3539); 4044}
3540 4045
3541{ 4046{
4047 # configure BDB
4048
3542 BDB::min_parallel 8; 4049 BDB::min_parallel 16;
3543 BDB::max_poll_time $TICK * 0.1; 4050 BDB::max_poll_reqs $TICK * 0.1;
3544 $BDB_POLL_WATCHER = Event->io ( 4051 $AnyEvent::BDB::WATCHER->priority (1);
3545 reentrant => 0,
3546 fd => BDB::poll_fileno,
3547 poll => 'r',
3548 prio => 0,
3549 data => WF_AUTOCANCEL,
3550 cb => \&BDB::poll_cb,
3551 );
3552
3553 BDB::set_sync_prepare {
3554 my $status;
3555 my $current = $Coro::current;
3556 (
3557 sub {
3558 $status = $!;
3559 $current->ready; undef $current;
3560 },
3561 sub {
3562 Coro::schedule while defined $current;
3563 $! = $status;
3564 },
3565 )
3566 };
3567 4052
3568 unless ($DB_ENV) { 4053 unless ($DB_ENV) {
3569 $DB_ENV = BDB::db_env_create; 4054 $DB_ENV = BDB::db_env_create;
3570 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 4055 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3571 | BDB::LOG_AUTOREMOVE, 1); 4056 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4057 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3572 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4058 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3573 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4059 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3574 4060
4061 (Coro::async { # async to keep sync_job from complaining
3575 cf::sync_job { 4062 cf::sync_job {
3576 eval { 4063 eval {
3577 BDB::db_env_open 4064 BDB::db_env_open
3578 $DB_ENV, 4065 $DB_ENV,
3579 $BDBDIR, 4066 $BDBDIR,
3580 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 4067 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3581 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4068 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3582 0666; 4069 0666;
3583 4070
3584 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4071 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4072 };
4073
4074 cf::cleanup "db_env_open(db): $@" if $@;
3585 }; 4075 };
3586 4076 })->join;
3587 cf::cleanup "db_env_open(db): $@" if $@;
3588 };
3589 } 4077 }
3590 4078
3591 $BDB_DEADLOCK_WATCHER = Event->timer ( 4079 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3592 after => 3,
3593 interval => 1,
3594 hard => 1,
3595 prio => 0,
3596 data => WF_AUTOCANCEL,
3597 cb => sub {
3598 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 4080 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3599 },
3600 ); 4081 };
3601 $BDB_CHECKPOINT_WATCHER = Event->timer ( 4082 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3602 after => 11,
3603 interval => 60,
3604 hard => 1,
3605 prio => 0,
3606 data => WF_AUTOCANCEL,
3607 cb => sub {
3608 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4083 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3609 },
3610 ); 4084 };
3611 $BDB_TRICKLE_WATCHER = Event->timer ( 4085 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3612 after => 5,
3613 interval => 10,
3614 hard => 1,
3615 prio => 0,
3616 data => WF_AUTOCANCEL,
3617 cb => sub {
3618 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4086 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3619 },
3620 ); 4087 };
3621} 4088}
3622 4089
3623{ 4090{
4091 # configure IO::AIO
4092
3624 IO::AIO::min_parallel 8; 4093 IO::AIO::min_parallel 8;
3625
3626 undef $Coro::AIO::WATCHER;
3627 IO::AIO::max_poll_time $TICK * 0.1; 4094 IO::AIO::max_poll_time $TICK * 0.1;
3628 $AIO_POLL_WATCHER = Event->io ( 4095 undef $AnyEvent::AIO::WATCHER;
3629 reentrant => 0,
3630 data => WF_AUTOCANCEL,
3631 fd => IO::AIO::poll_fileno,
3632 poll => 'r',
3633 prio => 0,
3634 cb => \&IO::AIO::poll_cb,
3635 );
3636} 4096}
3637 4097
3638my $_log_backtrace; 4098my $_log_backtrace;
3639 4099
3640sub _log_backtrace { 4100sub _log_backtrace {
3643 $msg =~ s/\n//; 4103 $msg =~ s/\n//;
3644 4104
3645 # limit the # of concurrent backtraces 4105 # limit the # of concurrent backtraces
3646 if ($_log_backtrace < 2) { 4106 if ($_log_backtrace < 2) {
3647 ++$_log_backtrace; 4107 ++$_log_backtrace;
4108 my $perl_bt = Carp::longmess $msg;
3648 async { 4109 async {
3649 $Coro::current->{desc} = "abt $msg"; 4110 $Coro::current->{desc} = "abt $msg";
3650 4111
3651 my @bt = fork_call { 4112 my @bt = fork_call {
3652 @addr = map { sprintf "%x", $_ } @addr; 4113 @addr = map { sprintf "%x", $_ } @addr;
3663 } 4124 }
3664 4125
3665 @funcs 4126 @funcs
3666 }; 4127 };
3667 4128
3668 LOG llevInfo, "[ABT] $msg\n"; 4129 LOG llevInfo, "[ABT] $perl_bt\n";
4130 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3669 LOG llevInfo, "[ABT] $_\n" for @bt; 4131 LOG llevInfo, "[ABT] $_\n" for @bt;
3670 --$_log_backtrace; 4132 --$_log_backtrace;
3671 }; 4133 };
3672 } else { 4134 } else {
3673 LOG llevInfo, "[ABT] $msg\n"; 4135 LOG llevInfo, "[ABT] $msg\n";
3674 LOG llevInfo, "[ABT] [suppressed]\n"; 4136 LOG llevInfo, "[ABT] [suppressed]\n";
3675 } 4137 }
3676} 4138}
3677 4139
3678# load additional modules 4140# load additional modules
3679use cf::pod; 4141require "cf/$_.pm" for @EXTRA_MODULES;
4142cf::_connect_to_perl_2;
3680 4143
3681END { cf::emergency_save } 4144END { cf::emergency_save }
3682 4145
36831 41461
3684 4147

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines