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.266 by root, Fri May 18 01:01:02 2007 UTC vs.
Revision 1.409 by root, Mon Jan 14 11:41:48 2008 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable; 9use EV 1.86;
10use Event;
11use Opcode; 10use Opcode;
12use Safe; 11use Safe;
13use Safe::Hole; 12use Safe::Hole;
13use Storable ();
14 14
15use Coro 3.61 (); 15use Coro 4.32 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::EV;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::BDB;
23use Coro::Storable; 24use Coro::Storable;
25use Coro::Util ();
24 26
27use JSON::XS 2.01 ();
25use BDB (); 28use BDB ();
26use Data::Dumper; 29use Data::Dumper;
27use Digest::MD5; 30use Digest::MD5;
28use Fcntl; 31use Fcntl;
29use YAML::Syck (); 32use YAML ();
30use IO::AIO 2.32 (); 33use IO::AIO 2.51 ();
31use Time::HiRes; 34use Time::HiRes;
32use Compress::LZF; 35use Compress::LZF;
36use Digest::MD5 ();
33 37
34# configure various modules to our taste 38# configure various modules to our taste
35# 39#
36$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 41Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 42Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39 43
40$Event::Eval = 1; # no idea why this is required, but it is
41
42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
43$YAML::Syck::ImplicitUnicode = 1;
44
45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 44$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46 45
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 46sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
48 47
49our %COMMAND = (); 48our %COMMAND = ();
50our %COMMAND_TIME = (); 49our %COMMAND_TIME = ();
51 50
52our @EXTS = (); # list of extension package names 51our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 52our %EXTCMD = ();
53our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 54our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 55our %EXT_MAP = (); # pluggable maps
56 56
57our $RELOAD; # number of reloads so far 57our $RELOAD; # number of reloads so far
58our @EVENT; 58our @EVENT;
… …
66our $TMPDIR = "$LOCALDIR/" . tmpdir; 66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir; 68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random"; 69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db"; 70our $BDBDIR = "$LOCALDIR/db";
71our %RESOURCE;
71 72
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 73our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
73our $TICK_WATCHER; 74our $TICK_WATCHER;
74our $AIO_POLL_WATCHER; 75our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 76our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
76our $NEXT_TICK; 77our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 78our $USE_FSYNC = 1; # use fsync to write maps - default off
79 79
80our $BDB_POLL_WATCHER; 80our $BDB_POLL_WATCHER;
81our $BDB_DEADLOCK_WATCHER;
82our $BDB_CHECKPOINT_WATCHER;
83our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 84our $DB_ENV;
82 85
83our %CFG; 86our %CFG;
84 87
85our $UPTIME; $UPTIME ||= time; 88our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 89our $RUNTIME;
90our $NOW;
87 91
88our %PLAYER; # all users 92our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 93our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
91 95
92# used to convert map paths into valid unix filenames by replacing / by ∕ 96# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 98
… …
155 159
156The raw value load value from the last tick. 160The raw value load value from the last tick.
157 161
158=item %cf::CFG 162=item %cf::CFG
159 163
160Configuration for the server, loaded from C</etc/crossfire/config>, or 164Configuration for the server, loaded from C</etc/deliantra-server/config>, or
161from wherever your confdir points to. 165from wherever your confdir points to.
162 166
163=item cf::wait_for_tick, cf::wait_for_tick_begin 167=item cf::wait_for_tick, cf::wait_for_tick_begin
164 168
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166returns directly I<after> the tick processing (and consequently, can only wake one process 170returns directly I<after> the tick processing (and consequently, can only wake one process
167per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 171per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168 172
173=item @cf::INVOKE_RESULTS
174
175This array contains the results of the last C<invoke ()> call. When
176C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
177that call.
178
169=back 179=back
170 180
171=cut 181=cut
172 182
173BEGIN { 183BEGIN {
… …
177 $msg .= "\n" 187 $msg .= "\n"
178 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
179 189
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181 191
182 utf8::encode $msg;
183 LOG llevError, $msg; 192 LOG llevError, $msg;
184 }; 193 };
185} 194}
195
196$Coro::State::DIEHOOK = sub {
197 warn Carp::longmess $_[0];
198 Coro::terminate;
199};
186 200
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 201@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 202@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 203@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 204@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 205@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
206@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
192@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 207@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
193 208
194# we bless all objects into (empty) derived classes to force a method lookup 209# we bless all objects into (empty) derived classes to force a method lookup
195# within the Safe compartment. 210# within the Safe compartment.
196for my $pkg (qw( 211for my $pkg (qw(
197 cf::global cf::attachable 212 cf::global cf::attachable
… …
202)) { 217)) {
203 no strict 'refs'; 218 no strict 'refs';
204 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 219 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
205} 220}
206 221
207$Event::DIED = sub { 222$EV::DIED = sub {
208 warn "error in event callback: @_"; 223 warn "error in event callback: @_";
209}; 224};
225
226#############################################################################
210 227
211=head2 UTILITY FUNCTIONS 228=head2 UTILITY FUNCTIONS
212 229
213=over 4 230=over 4
214 231
… …
233 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 250 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
234 $d 251 $d
235 } || "[unable to dump $_[0]: '$@']"; 252 } || "[unable to dump $_[0]: '$@']";
236} 253}
237 254
238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
239
240=item $ref = cf::from_json $json 255=item $ref = cf::decode_json $json
241 256
242Converts a JSON string into the corresponding perl data structure. 257Converts a JSON string into the corresponding perl data structure.
243 258
244=item $json = cf::to_json $ref 259=item $json = cf::encode_json $ref
245 260
246Converts a perl data structure into its JSON representation. 261Converts a perl data structure into its JSON representation.
262
263=cut
264
265our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
266
267sub encode_json($) { $json_coder->encode ($_[0]) }
268sub decode_json($) { $json_coder->decode ($_[0]) }
247 269
248=item cf::lock_wait $string 270=item cf::lock_wait $string
249 271
250Wait until the given lock is available. See cf::lock_acquire. 272Wait until the given lock is available. See cf::lock_acquire.
251 273
… …
254Wait until the given lock is available and then acquires it and returns 276Wait until the given lock is available and then acquires it and returns
255a Coro::guard object. If the guard object gets destroyed (goes out of scope, 277a Coro::guard object. If the guard object gets destroyed (goes out of scope,
256for example when the coroutine gets canceled), the lock is automatically 278for example when the coroutine gets canceled), the lock is automatically
257returned. 279returned.
258 280
281Locks are *not* recursive, locking from the same coro twice results in a
282deadlocked coro.
283
259Lock names should begin with a unique identifier (for example, cf::map::find 284Lock names should begin with a unique identifier (for example, cf::map::find
260uses map_find and cf::map::load uses map_load). 285uses map_find and cf::map::load uses map_load).
261 286
262=item $locked = cf::lock_active $string 287=item $locked = cf::lock_active $string
263 288
264Return true if the lock is currently active, i.e. somebody has locked it. 289Return true if the lock is currently active, i.e. somebody has locked it.
265 290
266=cut 291=cut
267 292
268our %LOCK; 293our %LOCK;
294our %LOCKER;#d#
269 295
270sub lock_wait($) { 296sub lock_wait($) {
271 my ($key) = @_; 297 my ($key) = @_;
298
299 if ($LOCKER{$key} == $Coro::current) {#d#
300 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
301 return;#d#
302 }#d#
272 303
273 # wait for lock, if any 304 # wait for lock, if any
274 while ($LOCK{$key}) { 305 while ($LOCK{$key}) {
275 push @{ $LOCK{$key} }, $Coro::current; 306 push @{ $LOCK{$key} }, $Coro::current;
276 Coro::schedule; 307 Coro::schedule;
… …
282 313
283 # wait, to be sure we are not locked 314 # wait, to be sure we are not locked
284 lock_wait $key; 315 lock_wait $key;
285 316
286 $LOCK{$key} = []; 317 $LOCK{$key} = [];
318 $LOCKER{$key} = $Coro::current;#d#
287 319
288 Coro::guard { 320 Coro::guard {
321 delete $LOCKER{$key};#d#
289 # wake up all waiters, to be on the safe side 322 # wake up all waiters, to be on the safe side
290 $_->ready for @{ delete $LOCK{$key} }; 323 $_->ready for @{ delete $LOCK{$key} };
291 } 324 }
292} 325}
293 326
… …
305 }; 338 };
306 $TICK_WATCHER->stop; 339 $TICK_WATCHER->stop;
307 $guard 340 $guard
308} 341}
309 342
343=item cf::periodic $interval, $cb
344
345Like EV::periodic, but randomly selects a starting point so that the actions
346get spread over timer.
347
348=cut
349
350sub periodic($$) {
351 my ($interval, $cb) = @_;
352
353 my $start = rand List::Util::min 180, $interval;
354
355 EV::periodic $start, $interval, 0, $cb
356}
357
358=item cf::get_slot $time[, $priority[, $name]]
359
360Allocate $time seconds of blocking CPU time at priority C<$priority>:
361This call blocks and returns only when you have at least C<$time> seconds
362of cpu time till the next tick. The slot is only valid till the next cede.
363
364The optional C<$name> can be used to identify the job to run. It might be
365used for statistical purposes and should identify the same time-class.
366
367Useful for short background jobs.
368
369=cut
370
371our @SLOT_QUEUE;
372our $SLOT_QUEUE;
373
374$SLOT_QUEUE->cancel if $SLOT_QUEUE;
375$SLOT_QUEUE = Coro::async {
376 $Coro::current->desc ("timeslot manager");
377
378 my $signal = new Coro::Signal;
379
380 while () {
381 next_job:
382 my $avail = cf::till_tick;
383 if ($avail > 0.01) {
384 for (0 .. $#SLOT_QUEUE) {
385 if ($SLOT_QUEUE[$_][0] < $avail) {
386 my $job = splice @SLOT_QUEUE, $_, 1, ();
387 $job->[2]->send;
388 Coro::cede;
389 goto next_job;
390 }
391 }
392 }
393
394 if (@SLOT_QUEUE) {
395 # we do not use wait_for_tick() as it returns immediately when tick is inactive
396 push @cf::WAIT_FOR_TICK, $signal;
397 $signal->wait;
398 } else {
399 Coro::schedule;
400 }
401 }
402};
403
404sub get_slot($;$$) {
405 my ($time, $pri, $name) = @_;
406
407 $time = $TICK * .6 if $time > $TICK * .6;
408 my $sig = new Coro::Signal;
409
410 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
411 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
412 $SLOT_QUEUE->ready;
413 $sig->wait;
414}
415
310=item cf::async { BLOCK } 416=item cf::async { BLOCK }
311 417
312Currently the same as Coro::async_pool, meaning you cannot use 418Currently the same as Coro::async_pool, meaning you cannot use
313C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 419C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
314thing you are allowed to do is call C<prio> on it. 420thing you are allowed to do is call C<prio> on it.
… …
317 423
318BEGIN { *async = \&Coro::async_pool } 424BEGIN { *async = \&Coro::async_pool }
319 425
320=item cf::sync_job { BLOCK } 426=item cf::sync_job { BLOCK }
321 427
322The design of crossfire+ requires that the main coro ($Coro::main) is 428The design of Deliantra requires that the main coroutine ($Coro::main)
323always able to handle events or runnable, as crossfire+ is only partly 429is always able to handle events or runnable, as Deliantra is only
324reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 430partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
431acceptable.
325 432
326If it must be done, put the blocking parts into C<sync_job>. This will run 433If it must be done, put the blocking parts into C<sync_job>. This will run
327the given BLOCK in another coroutine while waiting for the result. The 434the given BLOCK in another coroutine while waiting for the result. The
328server will be frozen during this time, so the block should either finish 435server will be frozen during this time, so the block should either finish
329fast or be very important. 436fast or be very important.
… …
332 439
333sub sync_job(&) { 440sub sync_job(&) {
334 my ($job) = @_; 441 my ($job) = @_;
335 442
336 if ($Coro::current == $Coro::main) { 443 if ($Coro::current == $Coro::main) {
337 my $time = Event::time; 444 my $time = EV::time;
338 445
339 # this is the main coro, too bad, we have to block 446 # this is the main coro, too bad, we have to block
340 # till the operation succeeds, freezing the server :/ 447 # till the operation succeeds, freezing the server :/
341 448
449 LOG llevError, Carp::longmess "sync job";#d#
450
342 # TODO: use suspend/resume instead 451 # TODO: use suspend/resume instead
343 # (but this is cancel-safe) 452 # (but this is cancel-safe)
344 my $freeze_guard = freeze_mainloop; 453 my $freeze_guard = freeze_mainloop;
345 454
346 my $busy = 1; 455 my $busy = 1;
347 my @res; 456 my @res;
348 457
349 (async { 458 (async {
459 $Coro::current->desc ("sync job coro");
350 @res = eval { $job->() }; 460 @res = eval { $job->() };
351 warn $@ if $@; 461 warn $@ if $@;
352 undef $busy; 462 undef $busy;
353 })->prio (Coro::PRIO_MAX); 463 })->prio (Coro::PRIO_MAX);
354 464
355 while ($busy) { 465 while ($busy) {
356 Coro::cede or Event::one_event; 466 if (Coro::nready) {
467 Coro::cede_notself;
468 } else {
469 EV::loop EV::LOOP_ONESHOT;
357 } 470 }
471 }
358 472
359 $time = Event::time - $time; 473 $time = EV::time - $time;
360 474
361 LOG llevError | logBacktrace, Carp::longmess "long sync job" 475 LOG llevError | logBacktrace, Carp::longmess "long sync job"
362 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 476 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
363 477
364 $tick_start += $time; # do not account sync jobs to server load 478 $tick_start += $time; # do not account sync jobs to server load
… …
389 $EXT_CORO{$coro+0} = $coro; 503 $EXT_CORO{$coro+0} = $coro;
390 504
391 $coro 505 $coro
392} 506}
393 507
394sub write_runtime { 508=item fork_call { }, $args
395 my $runtime = "$LOCALDIR/runtime";
396 509
397 # first touch the runtime file to show we are still running: 510Executes the given code block with the given arguments in a seperate
398 # the fsync below can take a very very long time. 511process, returning the results. Everything must be serialisable with
512Coro::Storable. May, of course, block. Note that the executed sub may
513never block itself or use any form of event handling.
399 514
400 if (my $fh = aio_open $runtime, O_WRONLY, 0) { 515=cut
401 utime undef, undef, $fh; 516
517sub fork_call(&@) {
518 my ($cb, @args) = @_;
519
520 # we seemingly have to make a local copy of the whole thing,
521 # otherwise perl prematurely frees the stuff :/
522 # TODO: investigate and fix (likely this will be rather laborious)
523
524 my @res = Coro::Util::fork_eval {
525 reset_signals;
526 &$cb
527 }, @args;
528
529 wantarray ? @res : $res[-1]
530}
531
532=item $value = cf::db_get $family => $key
533
534Returns a single value from the environment database.
535
536=item cf::db_put $family => $key => $value
537
538Stores the given C<$value> in the family. It can currently store binary
539data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
540
541=item $db = cf::db_table "name"
542
543Create and/or open a new database table. The string must not be "db" and must be unique
544within each server.
545
546=cut
547
548sub db_table($) {
549 my ($name) = @_;
550 my $db = BDB::db_create $DB_ENV;
551
552 eval {
553 $db->set_flags (BDB::CHKSUM);
554
555 utf8::encode $name;
556 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
557 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
558 cf::cleanup "db_open(db): $!" if $!;
402 } 559 };
560 cf::cleanup "db_open(db): $@" if $@;
403 561
404 my $guard = cf::lock_acquire "write_runtime"; 562 $db
563}
405 564
406 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 565our $DB;
407 or return;
408 566
409 my $value = $cf::RUNTIME + 90 + 10; 567sub db_init {
410 # 10 is the runtime save interval, for a monotonic clock 568 cf::sync_job {
411 # 60 allows for the watchdog to kill the server. 569 $DB ||= db_table "db";
570 };
571}
412 572
413 (aio_write $fh, 0, (length $value), $value, 0) <= 0 573sub db_get($$) {
414 and return; 574 my $key = "$_[0]/$_[1]";
415 575
416 # always fsync - this file is important 576 cf::sync_job {
417 aio_fsync $fh 577 BDB::db_get $DB, undef, $key, my $data;
418 and return;
419 578
420 # touch it again to show we are up-to-date 579 $! ? ()
421 utime undef, undef, $fh; 580 : $data
422
423 close $fh
424 or return;
425
426 aio_rename "$runtime~", $runtime
427 and return;
428
429 warn "runtime file written.\n";#d#
430
431 1 581 }
582}
583
584sub db_put($$$) {
585 BDB::dbreq_pri 4;
586 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
587}
588
589=item cf::cache $id => [$paths...], $processversion => $process
590
591Generic caching function that returns the value of the resource $id,
592caching and regenerating as required.
593
594This function can block.
595
596=cut
597
598sub cache {
599 my ($id, $src, $processversion, $process) = @_;
600
601 my $meta =
602 join "\x00",
603 $processversion,
604 map {
605 aio_stat $_
606 and Carp::croak "$_: $!";
607
608 ($_, (stat _)[7,9])
609 } @$src;
610
611 my $dbmeta = db_get cache => "$id/meta";
612 if ($dbmeta ne $meta) {
613 # changed, we may need to process
614
615 my @data;
616 my $md5;
617
618 for (0 .. $#$src) {
619 0 <= aio_load $src->[$_], $data[$_]
620 or Carp::croak "$src->[$_]: $!";
621 }
622
623 # if processing is expensive, check
624 # checksum first
625 if (1) {
626 $md5 =
627 join "\x00",
628 $processversion,
629 map {
630 cf::cede_to_tick;
631 ($src->[$_], Digest::MD5::md5_hex $data[$_])
632 } 0.. $#$src;
633
634
635 my $dbmd5 = db_get cache => "$id/md5";
636 if ($dbmd5 eq $md5) {
637 db_put cache => "$id/meta", $meta;
638
639 return db_get cache => "$id/data";
640 }
641 }
642
643 my $t1 = Time::HiRes::time;
644 my $data = $process->(\@data);
645 my $t2 = Time::HiRes::time;
646
647 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
648
649 db_put cache => "$id/data", $data;
650 db_put cache => "$id/md5" , $md5;
651 db_put cache => "$id/meta", $meta;
652
653 return $data;
654 }
655
656 db_get cache => "$id/data"
432} 657}
433 658
434=item cf::datalog type => key => value, ... 659=item cf::datalog type => key => value, ...
435 660
436Log a datalog packet of the given type with the given key-value pairs. 661Log a datalog packet of the given type with the given key-value pairs.
… …
454attach callbacks/event handlers (a collection of which is called an "attachment") 679attach callbacks/event handlers (a collection of which is called an "attachment")
455to it. All such attachable objects support the following methods. 680to it. All such attachable objects support the following methods.
456 681
457In the following description, CLASS can be any of C<global>, C<object> 682In the following description, CLASS can be any of C<global>, C<object>
458C<player>, C<client> or C<map> (i.e. the attachable objects in 683C<player>, C<client> or C<map> (i.e. the attachable objects in
459crossfire+). 684Deliantra).
460 685
461=over 4 686=over 4
462 687
463=item $attachable->attach ($attachment, key => $value...) 688=item $attachable->attach ($attachment, key => $value...)
464 689
… …
627 $registry = $CB_TYPE[$object_type] ||= []; 852 $registry = $CB_TYPE[$object_type] ||= [];
628 853
629 } elsif ($type eq "subtype") { 854 } elsif ($type eq "subtype") {
630 defined $object_type or Carp::croak "subtype specified without type"; 855 defined $object_type or Carp::croak "subtype specified without type";
631 my $object_subtype = shift @arg; 856 my $object_subtype = shift @arg;
632 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 857 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
633 858
634 } elsif ($type eq "package") { 859 } elsif ($type eq "package") {
635 my $pkg = shift @arg; 860 my $pkg = shift @arg;
636 861
637 while (my ($name, $id) = each %cb_id) { 862 while (my ($name, $id) = each %cb_id) {
… …
666 _attach $registry, $klass, @attach; 891 _attach $registry, $klass, @attach;
667 } 892 }
668 893
669 $obj->{$name} = \%arg; 894 $obj->{$name} = \%arg;
670 } else { 895 } else {
671 warn "object uses attachment '$name' that is not available, postponing.\n"; 896 warn "object uses attachment '$name' which is not available, postponing.\n";
672 } 897 }
673 898
674 $obj->{_attachment}{$name} = undef; 899 $obj->{_attachment}{$name} = undef;
675} 900}
676 901
… …
678 if (ref $_[0]) { 903 if (ref $_[0]) {
679 _object_attach @_; 904 _object_attach @_;
680 } else { 905 } else {
681 _attach shift->_attach_registry, @_; 906 _attach shift->_attach_registry, @_;
682 } 907 }
908 _recalc_want;
683}; 909};
684 910
685# all those should be optimised 911# all those should be optimised
686sub cf::attachable::detach { 912sub cf::attachable::detach {
687 my ($obj, $name) = @_; 913 my ($obj, $name) = @_;
… …
690 delete $obj->{_attachment}{$name}; 916 delete $obj->{_attachment}{$name};
691 reattach ($obj); 917 reattach ($obj);
692 } else { 918 } else {
693 Carp::croak "cannot, currently, detach class attachments"; 919 Carp::croak "cannot, currently, detach class attachments";
694 } 920 }
921 _recalc_want;
695}; 922};
696 923
697sub cf::attachable::attached { 924sub cf::attachable::attached {
698 my ($obj, $name) = @_; 925 my ($obj, $name) = @_;
699 926
… …
714 "; 941 ";
715 die if $@; 942 die if $@;
716} 943}
717 944
718our $override; 945our $override;
719our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 946our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
720 947
721sub override { 948sub override {
722 $override = 1; 949 $override = 1;
723 @invoke_results = (); 950 @INVOKE_RESULTS = (@_);
724} 951}
725 952
726sub do_invoke { 953sub do_invoke {
727 my $event = shift; 954 my $event = shift;
728 my $callbacks = shift; 955 my $callbacks = shift;
729 956
730 @invoke_results = (); 957 @INVOKE_RESULTS = ();
731 958
732 local $override; 959 local $override;
733 960
734 for (@$callbacks) { 961 for (@$callbacks) {
735 eval { &{$_->[1]} }; 962 eval { &{$_->[1]} };
… …
744 } 971 }
745 972
746 0 973 0
747} 974}
748 975
749=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 976=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
750 977
751=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 978=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
752 979
753Generate an object-specific event with the given arguments. 980Generate an object-specific event with the given arguments.
754 981
755This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 982This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
756removed in future versions), and there is no public API to access override 983removed in future versions), and there is no public API to access override
757results (if you must, access C<@cf::invoke_results> directly). 984results (if you must, access C<@cf::INVOKE_RESULTS> directly).
758 985
759=back 986=back
760 987
761=cut 988=cut
762 989
763############################################################################# 990#############################################################################
764# object support 991# object support
992
993sub _object_equal($$);
994sub _object_equal($$) {
995 my ($a, $b) = @_;
996
997 return 0 unless (ref $a) eq (ref $b);
998
999 if ("HASH" eq ref $a) {
1000 my @ka = keys %$a;
1001 my @kb = keys %$b;
1002
1003 return 0 if @ka != @kb;
1004
1005 for (0 .. $#ka) {
1006 return 0 unless $ka[$_] eq $kb[$_];
1007 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1008 }
1009
1010 } elsif ("ARRAY" eq ref $a) {
1011
1012 return 0 if @$a != @$b;
1013
1014 for (0 .. $#$a) {
1015 return 0 unless _object_equal $a->[$_], $b->[$_];
1016 }
1017
1018 } elsif ($a ne $b) {
1019 return 0;
1020 }
1021
1022 1
1023}
1024
1025our $SLOW_MERGES;#d#
1026sub _can_merge {
1027 my ($ob1, $ob2) = @_;
1028
1029 ++$SLOW_MERGES;#d#
1030
1031 # we do the slow way here
1032 return _object_equal $ob1, $ob2
1033}
765 1034
766sub reattach { 1035sub reattach {
767 # basically do the same as instantiate, without calling instantiate 1036 # basically do the same as instantiate, without calling instantiate
768 my ($obj) = @_; 1037 my ($obj) = @_;
769 1038
… …
790cf::attachable->attach ( 1059cf::attachable->attach (
791 prio => -1000000, 1060 prio => -1000000,
792 on_instantiate => sub { 1061 on_instantiate => sub {
793 my ($obj, $data) = @_; 1062 my ($obj, $data) = @_;
794 1063
795 $data = from_json $data; 1064 $data = decode_json $data;
796 1065
797 for (@$data) { 1066 for (@$data) {
798 my ($name, $args) = @$_; 1067 my ($name, $args) = @$_;
799 1068
800 $obj->attach ($name, %{$args || {} }); 1069 $obj->attach ($name, %{$args || {} });
… …
816sub object_freezer_save { 1085sub object_freezer_save {
817 my ($filename, $rdata, $objs) = @_; 1086 my ($filename, $rdata, $objs) = @_;
818 1087
819 sync_job { 1088 sync_job {
820 if (length $$rdata) { 1089 if (length $$rdata) {
1090 utf8::decode (my $decname = $filename);
821 warn sprintf "saving %s (%d,%d)\n", 1091 warn sprintf "saving %s (%d,%d)\n",
822 $filename, length $$rdata, scalar @$objs; 1092 $decname, length $$rdata, scalar @$objs;
823 1093
824 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1094 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
825 chmod SAVE_MODE, $fh; 1095 chmod SAVE_MODE, $fh;
826 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1096 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
827 aio_fsync $fh if $cf::USE_FSYNC; 1097 aio_fsync $fh if $cf::USE_FSYNC;
828 close $fh; 1098 close $fh;
829 1099
830 if (@$objs) { 1100 if (@$objs) {
831 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1101 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
832 chmod SAVE_MODE, $fh; 1102 chmod SAVE_MODE, $fh;
833 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1103 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
834 aio_write $fh, 0, (length $data), $data, 0; 1104 aio_write $fh, 0, (length $data), $data, 0;
835 aio_fsync $fh if $cf::USE_FSYNC; 1105 aio_fsync $fh if $cf::USE_FSYNC;
836 close $fh; 1106 close $fh;
837 aio_rename "$filename.pst~", "$filename.pst"; 1107 aio_rename "$filename.pst~", "$filename.pst";
838 } 1108 }
… …
846 } 1116 }
847 } else { 1117 } else {
848 aio_unlink $filename; 1118 aio_unlink $filename;
849 aio_unlink "$filename.pst"; 1119 aio_unlink "$filename.pst";
850 } 1120 }
851 } 1121 };
852} 1122}
853 1123
854sub object_freezer_as_string { 1124sub object_freezer_as_string {
855 my ($rdata, $objs) = @_; 1125 my ($rdata, $objs) = @_;
856 1126
… …
868 or return; 1138 or return;
869 1139
870 unless (aio_stat "$filename.pst") { 1140 unless (aio_stat "$filename.pst") {
871 (aio_load "$filename.pst", $av) >= 0 1141 (aio_load "$filename.pst", $av) >= 0
872 or return; 1142 or return;
1143
873 $av = eval { (Storable::thaw $av)->{objs} }; 1144 my $st = eval { Coro::Storable::thaw $av };
1145 $av = $st->{objs};
874 } 1146 }
875 1147
1148 utf8::decode (my $decname = $filename);
876 warn sprintf "loading %s (%d)\n", 1149 warn sprintf "loading %s (%d,%d)\n",
877 $filename, length $data, scalar @{$av || []};#d# 1150 $decname, length $data, scalar @{$av || []};
1151
878 return ($data, $av); 1152 ($data, $av)
879} 1153}
1154
1155=head2 COMMAND CALLBACKS
1156
1157=over 4
1158
1159=cut
880 1160
881############################################################################# 1161#############################################################################
882# command handling &c 1162# command handling &c
883 1163
884=item cf::register_command $name => \&callback($ob,$args); 1164=item cf::register_command $name => \&callback($ob,$args);
… …
897 push @{ $COMMAND{$name} }, [$caller, $cb]; 1177 push @{ $COMMAND{$name} }, [$caller, $cb];
898} 1178}
899 1179
900=item cf::register_extcmd $name => \&callback($pl,$packet); 1180=item cf::register_extcmd $name => \&callback($pl,$packet);
901 1181
902Register a callbackf ro execution when the client sends an extcmd packet. 1182Register a callback for execution when the client sends an (synchronous)
1183extcmd packet. Ext commands will be processed in the order they are
1184received by the server, like other user commands. The first argument is
1185the logged-in player. Ext commands can only be processed after a player
1186has logged in successfully.
903 1187
904If the callback returns something, it is sent back as if reply was being 1188If the callback returns something, it is sent back as if reply was being
905called. 1189called.
906 1190
1191=item cf::register_exticmd $name => \&callback($ns,$packet);
1192
1193Register a callback for execution when the client sends an (asynchronous)
1194exticmd packet. Exti commands are processed by the server as soon as they
1195are received, i.e. out of order w.r.t. other commands. The first argument
1196is a client socket. Exti commands can be received anytime, even before
1197log-in.
1198
1199If the callback returns something, it is sent back as if reply was being
1200called.
1201
907=cut 1202=cut
908 1203
909sub register_extcmd { 1204sub register_extcmd {
910 my ($name, $cb) = @_; 1205 my ($name, $cb) = @_;
911 1206
912 $EXTCMD{$name} = $cb; 1207 $EXTCMD{$name} = $cb;
1208}
1209
1210sub register_exticmd {
1211 my ($name, $cb) = @_;
1212
1213 $EXTICMD{$name} = $cb;
913} 1214}
914 1215
915cf::player->attach ( 1216cf::player->attach (
916 on_command => sub { 1217 on_command => sub {
917 my ($pl, $name, $params) = @_; 1218 my ($pl, $name, $params) = @_;
… …
926 cf::override; 1227 cf::override;
927 }, 1228 },
928 on_extcmd => sub { 1229 on_extcmd => sub {
929 my ($pl, $buf) = @_; 1230 my ($pl, $buf) = @_;
930 1231
931 my $msg = eval { from_json $buf }; 1232 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
932 1233
933 if (ref $msg) { 1234 if (ref $msg) {
1235 my ($type, $reply, @payload) =
1236 "ARRAY" eq ref $msg
1237 ? @$msg
1238 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1239
1240 my @reply;
1241
934 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1242 if (my $cb = $EXTCMD{$type}) {
935 if (my %reply = $cb->($pl, $msg)) { 1243 @reply = $cb->($pl, @payload);
936 $pl->ext_reply ($msg->{msgid}, %reply);
937 }
938 } 1244 }
1245
1246 $pl->ext_reply ($reply, @reply)
1247 if $reply;
1248
939 } else { 1249 } else {
940 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1250 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
941 } 1251 }
942 1252
943 cf::override; 1253 cf::override;
944 }, 1254 },
945); 1255);
946 1256
947sub load_extension {
948 my ($path) = @_;
949
950 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
951 my $base = $1;
952 my $pkg = $1;
953 $pkg =~ s/[^[:word:]]/_/g;
954 $pkg = "ext::$pkg";
955
956 warn "... loading '$path' into '$pkg'\n";
957
958 open my $fh, "<:utf8", $path
959 or die "$path: $!";
960
961 my $source =
962 "package $pkg; use strict; use utf8;\n"
963 . "#line 1 \"$path\"\n{\n"
964 . (do { local $/; <$fh> })
965 . "\n};\n1";
966
967 unless (eval $source) {
968 my $msg = $@ ? "$path: $@\n"
969 : "extension disabled.\n";
970 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
971 warn $@;
972 warn "mandatory extension failed to load, exiting.\n";
973 exit 1;
974 }
975 die $@;
976 }
977
978 push @EXTS, $pkg;
979}
980
981sub load_extensions { 1257sub load_extensions {
1258 cf::sync_job {
1259 my %todo;
1260
982 for my $ext (<$LIBDIR/*.ext>) { 1261 for my $path (<$LIBDIR/*.ext>) {
983 next unless -r $ext; 1262 next unless -r $path;
984 eval { 1263
985 load_extension $ext; 1264 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1265 my $base = $1;
1266 my $pkg = $1;
1267 $pkg =~ s/[^[:word:]]/_/g;
1268 $pkg = "ext::$pkg";
1269
1270 open my $fh, "<:utf8", $path
1271 or die "$path: $!";
1272
1273 my $source = do { local $/; <$fh> };
1274
1275 my %ext = (
1276 path => $path,
1277 base => $base,
1278 pkg => $pkg,
1279 );
1280
1281 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1282 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1283
1284 $ext{source} =
1285 "package $pkg; use strict; use utf8;\n"
1286 . "#line 1 \"$path\"\n{\n"
1287 . $source
1288 . "\n};\n1";
1289
1290 $todo{$base} = \%ext;
1291 }
1292
1293 my %done;
1294 while (%todo) {
1295 my $progress;
1296
1297 while (my ($k, $v) = each %todo) {
1298 for (split /,\s*/, $v->{meta}{depends}) {
1299 goto skip
1300 unless exists $done{$_};
1301 }
1302
1303 warn "... loading '$k' into '$v->{pkg}'\n";
1304
1305 unless (eval $v->{source}) {
1306 my $msg = $@ ? "$v->{path}: $@\n"
1307 : "$v->{base}: extension inactive.\n";
1308
1309 if (exists $v->{meta}{mandatory}) {
1310 warn $msg;
1311 warn "mandatory extension failed to load, exiting.\n";
1312 exit 1;
1313 }
1314
1315 warn $msg;
1316 }
1317
1318 $done{$k} = delete $todo{$k};
1319 push @EXTS, $v->{pkg};
1320 $progress = 1;
986 1 1321 }
987 } or warn "$ext not loaded: $@"; 1322
1323 skip:
1324 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1325 unless $progress;
1326 }
988 } 1327 };
989} 1328}
990 1329
991############################################################################# 1330#############################################################################
992 1331
1332=back
1333
993=head2 CORE EXTENSIONS 1334=head2 CORE EXTENSIONS
994 1335
995Functions and methods that extend core crossfire objects. 1336Functions and methods that extend core crossfire objects.
996 1337
997=cut 1338=cut
… …
1001use Coro::AIO; 1342use Coro::AIO;
1002 1343
1003=head3 cf::player 1344=head3 cf::player
1004 1345
1005=over 4 1346=over 4
1347
1348=item cf::player::num_playing
1349
1350Returns the official number of playing players, as per the Crossfire metaserver rules.
1351
1352=cut
1353
1354sub num_playing {
1355 scalar grep
1356 $_->ob->map
1357 && !$_->hidden
1358 && !$_->ob->flag (cf::FLAG_WIZ),
1359 cf::player::list
1360}
1006 1361
1007=item cf::player::find $login 1362=item cf::player::find $login
1008 1363
1009Returns the given player object, loading it if necessary (might block). 1364Returns the given player object, loading it if necessary (might block).
1010 1365
… …
1046 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1401 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1047 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1402 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1048 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1403 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1049 aio_unlink +(playerdir $login) . "/$login.pl"; 1404 aio_unlink +(playerdir $login) . "/$login.pl";
1050 1405
1051 my $pl = load_pl path $login 1406 my $f = new_from_file cf::object::thawer path $login
1052 or return; 1407 or return;
1408
1409 my $pl = cf::player::load_pl $f
1410 or return;
1411 local $cf::PLAYER_LOADING{$login} = $pl;
1412 $f->resolve_delayed_derefs;
1053 $cf::PLAYER{$login} = $pl 1413 $cf::PLAYER{$login} = $pl
1054 } 1414 }
1055 } 1415 }
1056} 1416}
1057 1417
… …
1067 1427
1068 aio_mkdir playerdir $pl, 0770; 1428 aio_mkdir playerdir $pl, 0770;
1069 $pl->{last_save} = $cf::RUNTIME; 1429 $pl->{last_save} = $cf::RUNTIME;
1070 1430
1071 $pl->save_pl ($path); 1431 $pl->save_pl ($path);
1072 Coro::cede; 1432 cf::cede_to_tick;
1073} 1433}
1074 1434
1075sub new($) { 1435sub new($) {
1076 my ($login) = @_; 1436 my ($login) = @_;
1077 1437
… …
1081 $self->{deny_save} = 1; 1441 $self->{deny_save} = 1;
1082 1442
1083 $cf::PLAYER{$login} = $self; 1443 $cf::PLAYER{$login} = $self;
1084 1444
1085 $self 1445 $self
1446}
1447
1448=item $player->send_msg ($channel, $msg, $color, [extra...])
1449
1450=cut
1451
1452sub send_msg {
1453 my $ns = shift->ns
1454 or return;
1455 $ns->send_msg (@_);
1086} 1456}
1087 1457
1088=item $pl->quit_character 1458=item $pl->quit_character
1089 1459
1090Nukes the player without looking back. If logged in, the connection will 1460Nukes the player without looking back. If logged in, the connection will
… …
1145 or return []; 1515 or return [];
1146 1516
1147 my @logins; 1517 my @logins;
1148 1518
1149 for my $login (@$dirs) { 1519 for my $login (@$dirs) {
1520 my $path = path $login;
1521
1522 # a .pst is a dead give-away for a valid player
1523 unless (-e "$path.pst") {
1150 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1524 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1151 aio_read $fh, 0, 512, my $buf, 0 or next; 1525 aio_read $fh, 0, 512, my $buf, 0 or next;
1152 $buf !~ /^password -------------$/m or next; # official not-valid tag 1526 $buf !~ /^password -------------$/m or next; # official not-valid tag
1527 }
1153 1528
1154 utf8::decode $login; 1529 utf8::decode $login;
1155 push @logins, $login; 1530 push @logins, $login;
1156 } 1531 }
1157 1532
… …
1184 } 1559 }
1185 1560
1186 \@paths 1561 \@paths
1187} 1562}
1188 1563
1564=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1565
1566Expand crossfire pod fragments into protocol xml.
1567
1568=cut
1569
1570use re 'eval';
1571
1572my $group;
1573my $interior; $interior = qr{
1574 # match a pod interior sequence sans C<< >>
1575 (?:
1576 \ (.*?)\ (?{ $group = $^N })
1577 | < (??{$interior}) >
1578 )
1579}x;
1580
1581sub expand_cfpod {
1582 my ($self, $pod) = @_;
1583
1584 my $xml;
1585
1586 while () {
1587 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1588 $group = $1;
1589
1590 $group =~ s/&/&amp;/g;
1591 $group =~ s/</&lt;/g;
1592
1593 $xml .= $group;
1594 } elsif ($pod =~ m%\G
1595 ([BCGHITU])
1596 <
1597 (?:
1598 ([^<>]*) (?{ $group = $^N })
1599 | < $interior >
1600 )
1601 >
1602 %gcsx
1603 ) {
1604 my ($code, $data) = ($1, $group);
1605
1606 if ($code eq "B") {
1607 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1608 } elsif ($code eq "I") {
1609 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1610 } elsif ($code eq "U") {
1611 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1612 } elsif ($code eq "C") {
1613 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1614 } elsif ($code eq "T") {
1615 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1616 } elsif ($code eq "G") {
1617 my ($male, $female) = split /\|/, $data;
1618 $data = $self->gender ? $female : $male;
1619 $xml .= expand_cfpod ($self, $data);
1620 } elsif ($code eq "H") {
1621 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1622 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1623 "")
1624 [$self->{hintmode}];
1625 } else {
1626 $xml .= "error processing '$code($data)' directive";
1627 }
1628 } else {
1629 if ($pod =~ /\G(.+)/) {
1630 warn "parse error while expanding $pod (at $1)";
1631 }
1632 last;
1633 }
1634 }
1635
1636 for ($xml) {
1637 # create single paragraphs (very hackish)
1638 s/(?<=\S)\n(?=\w)/ /g;
1639
1640 # compress some whitespace
1641 s/\s+\n/\n/g; # ws line-ends
1642 s/\n\n+/\n/g; # double lines
1643 s/^\n+//; # beginning lines
1644 s/\n+$//; # ending lines
1645 }
1646
1647 $xml
1648}
1649
1650no re 'eval';
1651
1652sub hintmode {
1653 $_[0]{hintmode} = $_[1] if @_ > 1;
1654 $_[0]{hintmode}
1655}
1656
1189=item $player->ext_reply ($msgid, %msg) 1657=item $player->ext_reply ($msgid, @msg)
1190 1658
1191Sends an ext reply to the player. 1659Sends an ext reply to the player.
1192 1660
1193=cut 1661=cut
1194 1662
1195sub ext_reply($$%) { 1663sub ext_reply($$@) {
1196 my ($self, $id, %msg) = @_; 1664 my ($self, $id, @msg) = @_;
1197 1665
1198 $msg{msgid} = $id; 1666 $self->ns->ext_reply ($id, @msg)
1199
1200 $self->send ("ext " . cf::to_json \%msg);
1201} 1667}
1202 1668
1203=item $player->ext_event ($type, %msg) 1669=item $player->ext_msg ($type, @msg)
1204 1670
1205Sends an ext event to the client. 1671Sends an ext event to the client.
1206 1672
1207=cut 1673=cut
1208 1674
1209sub ext_event($$%) { 1675sub ext_msg($$@) {
1210 my ($self, $type, %msg) = @_; 1676 my ($self, $type, @msg) = @_;
1211 1677
1212 $self->ns->ext_event ($type, %msg); 1678 $self->ns->ext_msg ($type, @msg);
1213} 1679}
1214 1680
1215=head3 cf::region 1681=head3 cf::region
1216 1682
1217=over 4 1683=over 4
… …
1220 1686
1221package cf::region; 1687package cf::region;
1222 1688
1223=item cf::region::find_by_path $path 1689=item cf::region::find_by_path $path
1224 1690
1225Tries to decuce the probable region for a map knowing only its path. 1691Tries to decuce the likely region for a map knowing only its path.
1226 1692
1227=cut 1693=cut
1228 1694
1229sub find_by_path($) { 1695sub find_by_path($) {
1230 my ($path) = @_; 1696 my ($path) = @_;
1231 1697
1232 my ($match, $specificity); 1698 my ($match, $specificity);
1233 1699
1234 for my $region (list) { 1700 for my $region (list) {
1235 if ($region->match && $path =~ $region->match) { 1701 if ($region->{match} && $path =~ $region->{match}) {
1236 ($match, $specificity) = ($region, $region->specificity) 1702 ($match, $specificity) = ($region, $region->specificity)
1237 if $region->specificity > $specificity; 1703 if $region->specificity > $specificity;
1238 } 1704 }
1239 } 1705 }
1240 1706
… …
1304 my ($self, $merge) = @_; 1770 my ($self, $merge) = @_;
1305 1771
1306 # we have to keep some variables in memory intact 1772 # we have to keep some variables in memory intact
1307 local $self->{path}; 1773 local $self->{path};
1308 local $self->{load_path}; 1774 local $self->{load_path};
1309 local $self->{deny_save};
1310 local $self->{deny_reset};
1311 1775
1312 $self->SUPER::thawer_merge ($merge); 1776 $self->SUPER::thawer_merge ($merge);
1313} 1777}
1314 1778
1315sub normalise { 1779sub normalise {
… …
1362 $self->init; # pass $1 etc. 1826 $self->init; # pass $1 etc.
1363 return $self; 1827 return $self;
1364 } 1828 }
1365 } 1829 }
1366 1830
1367 Carp::carp "unable to resolve path '$path' (base '$base')."; 1831 Carp::cluck "unable to resolve path '$path' (base '$base').";
1368 () 1832 ()
1369} 1833}
1370 1834
1371sub init { 1835sub init {
1372 my ($self) = @_; 1836 my ($self) = @_;
… …
1415 1879
1416 $_->change_map_light ($change) 1880 $_->change_map_light ($change)
1417 for grep $_->outdoor, values %cf::MAP; 1881 for grep $_->outdoor, values %cf::MAP;
1418} 1882}
1419 1883
1884sub decay_objects {
1885 my ($self) = @_;
1886
1887 return if $self->{deny_reset};
1888
1889 $self->do_decay_objects;
1890}
1891
1420sub unlink_save { 1892sub unlink_save {
1421 my ($self) = @_; 1893 my ($self) = @_;
1422 1894
1423 utf8::encode (my $save = $self->save_path); 1895 utf8::encode (my $save = $self->save_path);
1424 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1896 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1427 1899
1428sub load_header_from($) { 1900sub load_header_from($) {
1429 my ($self, $path) = @_; 1901 my ($self, $path) = @_;
1430 1902
1431 utf8::encode $path; 1903 utf8::encode $path;
1432 #aio_open $path, O_RDONLY, 0 1904 my $f = new_from_file cf::object::thawer $path
1433 # or return;
1434
1435 $self->_load_header ($path)
1436 or return; 1905 or return;
1906
1907 $self->_load_header ($f)
1908 or return;
1909
1910 local $MAP_LOADING{$self->{path}} = $self;
1911 $f->resolve_delayed_derefs;
1437 1912
1438 $self->{load_path} = $path; 1913 $self->{load_path} = $path;
1439 1914
1440 1 1915 1
1441} 1916}
… …
1480 $self->load_header_orig 1955 $self->load_header_orig
1481 or return; 1956 or return;
1482 $self->prepare_orig; 1957 $self->prepare_orig;
1483 } 1958 }
1484 1959
1960 $self->{deny_reset} = 1
1961 if $self->no_reset;
1962
1485 $self->default_region (cf::region::find_by_path $self->{path}) 1963 $self->default_region (cf::region::find_by_path $self->{path})
1486 unless $self->default_region; 1964 unless $self->default_region;
1487 1965
1488 1 1966 1
1489} 1967}
… …
1492sub find { 1970sub find {
1493 my ($path, $origin) = @_; 1971 my ($path, $origin) = @_;
1494 1972
1495 $path = normalise $path, $origin && $origin->path; 1973 $path = normalise $path, $origin && $origin->path;
1496 1974
1975 cf::lock_wait "map_data:$path";#d#remove
1497 cf::lock_wait "map_find:$path"; 1976 cf::lock_wait "map_find:$path";
1498 1977
1499 $cf::MAP{$path} || do { 1978 $cf::MAP{$path} || do {
1500 my $guard = cf::lock_acquire "map_find:$path"; 1979 my $guard1 = cf::lock_acquire "map_find:$path";
1980 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1981
1501 my $map = new_from_path cf::map $path 1982 my $map = new_from_path cf::map $path
1502 or return; 1983 or return;
1503 1984
1504 $map->{last_save} = $cf::RUNTIME; 1985 $map->{last_save} = $cf::RUNTIME;
1505 1986
1506 $map->load_header 1987 $map->load_header
1507 or return; 1988 or return;
1508 1989
1509 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1990 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1510 # doing this can freeze the server in a sync job, obviously 1991 # doing this can freeze the server in a sync job, obviously
1511 #$cf::WAIT_FOR_TICK->wait; 1992 #$cf::WAIT_FOR_TICK->wait;
1993 undef $guard1;
1994 undef $guard2;
1512 $map->reset; 1995 $map->reset;
1513 undef $guard;
1514 return find $path; 1996 return find $path;
1515 } 1997 }
1516 1998
1517 $cf::MAP{$path} = $map 1999 $cf::MAP{$path} = $map
1518 } 2000 }
… …
1527 local $self->{deny_reset} = 1; # loading can take a long time 2009 local $self->{deny_reset} = 1; # loading can take a long time
1528 2010
1529 my $path = $self->{path}; 2011 my $path = $self->{path};
1530 2012
1531 { 2013 {
1532 my $guard = cf::lock_acquire "map_load:$path"; 2014 my $guard = cf::lock_acquire "map_data:$path";
1533 2015
2016 return unless $self->valid;
1534 return if $self->in_memory != cf::MAP_SWAPPED; 2017 return unless $self->in_memory == cf::MAP_SWAPPED;
1535 2018
1536 $self->in_memory (cf::MAP_LOADING); 2019 $self->in_memory (cf::MAP_LOADING);
1537 2020
1538 $self->alloc; 2021 $self->alloc;
1539 2022
1540 $self->pre_load; 2023 $self->pre_load;
1541 Coro::cede; 2024 cf::cede_to_tick;
1542 2025
2026 my $f = new_from_file cf::object::thawer $self->{load_path};
2027 $f->skip_block;
1543 $self->_load_objects ($self->{load_path}, 1) 2028 $self->_load_objects ($f)
1544 or return; 2029 or return;
1545 2030
1546 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2031 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1547 if delete $self->{load_original}; 2032 if delete $self->{load_original};
1548 2033
1549 if (my $uniq = $self->uniq_path) { 2034 if (my $uniq = $self->uniq_path) {
1550 utf8::encode $uniq; 2035 utf8::encode $uniq;
1551 if (aio_open $uniq, O_RDONLY, 0) { 2036 unless (aio_stat $uniq) {
2037 if (my $f = new_from_file cf::object::thawer $uniq) {
1552 $self->clear_unique_items; 2038 $self->clear_unique_items;
1553 $self->_load_objects ($uniq, 0); 2039 $self->_load_objects ($f);
2040 $f->resolve_delayed_derefs;
2041 }
1554 } 2042 }
1555 } 2043 }
1556 2044
1557 Coro::cede; 2045 $f->resolve_delayed_derefs;
2046
2047 cf::cede_to_tick;
1558 # now do the right thing for maps 2048 # now do the right thing for maps
1559 $self->link_multipart_objects; 2049 $self->link_multipart_objects;
1560 $self->difficulty ($self->estimate_difficulty) 2050 $self->difficulty ($self->estimate_difficulty)
1561 unless $self->difficulty; 2051 unless $self->difficulty;
1562 Coro::cede; 2052 cf::cede_to_tick;
1563 2053
1564 unless ($self->{deny_activate}) { 2054 unless ($self->{deny_activate}) {
1565 $self->decay_objects; 2055 $self->decay_objects;
1566 $self->fix_auto_apply; 2056 $self->fix_auto_apply;
1567 $self->update_buttons; 2057 $self->update_buttons;
1568 Coro::cede; 2058 cf::cede_to_tick;
1569 $self->set_darkness_map; 2059 $self->set_darkness_map;
1570 Coro::cede; 2060 cf::cede_to_tick;
1571 $self->activate; 2061 $self->activate;
1572 } 2062 }
2063
2064 $self->{last_save} = $cf::RUNTIME;
2065 $self->last_access ($cf::RUNTIME);
1573 2066
1574 $self->in_memory (cf::MAP_IN_MEMORY); 2067 $self->in_memory (cf::MAP_IN_MEMORY);
1575 } 2068 }
1576 2069
1577 $self->post_load; 2070 $self->post_load;
… …
1581 my ($self, $ob) = @_; 2074 my ($self, $ob) = @_;
1582 2075
1583 return find "~" . $ob->name . "/" . $self->{path} 2076 return find "~" . $ob->name . "/" . $self->{path}
1584 if $self->per_player; 2077 if $self->per_player;
1585 2078
2079# return find "?party/" . $ob->name . "/" . $self->{path}
2080# if $self->per_party;
2081
1586 $self 2082 $self
1587} 2083}
1588 2084
1589# find and load all maps in the 3x3 area around a map 2085# find and load all maps in the 3x3 area around a map
1590sub load_diag { 2086sub load_neighbours {
1591 my ($map) = @_; 2087 my ($map) = @_;
1592 2088
1593 my @diag; # diagonal neighbours 2089 my @neigh; # diagonal neighbours
1594 2090
1595 for (0 .. 3) { 2091 for (0 .. 3) {
1596 my $neigh = $map->tile_path ($_) 2092 my $neigh = $map->tile_path ($_)
1597 or next; 2093 or next;
1598 $neigh = find $neigh, $map 2094 $neigh = find $neigh, $map
1599 or next; 2095 or next;
1600 $neigh->load; 2096 $neigh->load;
1601 2097
2098 push @neigh,
1602 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2099 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1603 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2100 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1604 } 2101 }
1605 2102
1606 for (@diag) { 2103 for (grep defined $_->[0], @neigh) {
2104 my ($path, $origin) = @$_;
1607 my $neigh = find @$_ 2105 my $neigh = find $path, $origin
1608 or next; 2106 or next;
1609 $neigh->load; 2107 $neigh->load;
1610 } 2108 }
1611} 2109}
1612 2110
… …
1617} 2115}
1618 2116
1619sub do_load_sync { 2117sub do_load_sync {
1620 my ($map) = @_; 2118 my ($map) = @_;
1621 2119
2120 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2121 if $Coro::current == $Coro::main;
2122
1622 cf::sync_job { $map->load }; 2123 cf::sync_job { $map->load };
1623} 2124}
1624 2125
1625our %MAP_PREFETCH; 2126our %MAP_PREFETCH;
1626our $MAP_PREFETCHER = undef; 2127our $MAP_PREFETCHER = undef;
1627 2128
1628sub find_async { 2129sub find_async {
1629 my ($path, $origin) = @_; 2130 my ($path, $origin, $load) = @_;
1630 2131
1631 $path = normalise $path, $origin && $origin->{path}; 2132 $path = normalise $path, $origin && $origin->{path};
1632 2133
1633 if (my $map = $cf::MAP{$path}) { 2134 if (my $map = $cf::MAP{$path}) {
1634 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2135 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1635 } 2136 }
1636 2137
1637 undef $MAP_PREFETCH{$path}; 2138 $MAP_PREFETCH{$path} |= $load;
2139
1638 $MAP_PREFETCHER ||= cf::async { 2140 $MAP_PREFETCHER ||= cf::async {
2141 $Coro::current->{desc} = "map prefetcher";
2142
1639 while (%MAP_PREFETCH) { 2143 while (%MAP_PREFETCH) {
1640 for my $path (keys %MAP_PREFETCH) { 2144 while (my ($k, $v) = each %MAP_PREFETCH) {
1641 my $map = find $path 2145 if (my $map = find $k) {
1642 or next;
1643 $map->load; 2146 $map->load if $v;
2147 }
1644 2148
1645 delete $MAP_PREFETCH{$path}; 2149 delete $MAP_PREFETCH{$k};
1646 } 2150 }
1647 } 2151 }
1648 undef $MAP_PREFETCHER; 2152 undef $MAP_PREFETCHER;
1649 }; 2153 };
1650 $MAP_PREFETCHER->prio (6); 2154 $MAP_PREFETCHER->prio (6);
… …
1653} 2157}
1654 2158
1655sub save { 2159sub save {
1656 my ($self) = @_; 2160 my ($self) = @_;
1657 2161
1658 my $lock = cf::lock_acquire "map_data:" . $self->path; 2162 my $lock = cf::lock_acquire "map_data:$self->{path}";
1659 2163
1660 $self->{last_save} = $cf::RUNTIME; 2164 $self->{last_save} = $cf::RUNTIME;
1661 2165
1662 return unless $self->dirty; 2166 return unless $self->dirty;
1663 2167
… …
1669 return if $self->{deny_save}; 2173 return if $self->{deny_save};
1670 2174
1671 local $self->{last_access} = $self->last_access;#d# 2175 local $self->{last_access} = $self->last_access;#d#
1672 2176
1673 cf::async { 2177 cf::async {
2178 $Coro::current->{desc} = "map player save";
1674 $_->contr->save for $self->players; 2179 $_->contr->save for $self->players;
1675 }; 2180 };
1676 2181
1677 if ($uniq) { 2182 if ($uniq) {
1678 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2183 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1686 my ($self) = @_; 2191 my ($self) = @_;
1687 2192
1688 # save first because save cedes 2193 # save first because save cedes
1689 $self->save; 2194 $self->save;
1690 2195
1691 my $lock = cf::lock_acquire "map_data:" . $self->path; 2196 my $lock = cf::lock_acquire "map_data:$self->{path}";
1692 2197
1693 return if $self->players; 2198 return if $self->players;
1694 return if $self->in_memory != cf::MAP_IN_MEMORY; 2199 return if $self->in_memory != cf::MAP_IN_MEMORY;
1695 return if $self->{deny_save}; 2200 return if $self->{deny_save};
1696 2201
2202 $self->in_memory (cf::MAP_SWAPPED);
2203
2204 $self->deactivate;
2205 $_->clear_links_to ($self) for values %cf::MAP;
1697 $self->clear; 2206 $self->clear;
1698 $self->in_memory (cf::MAP_SWAPPED);
1699} 2207}
1700 2208
1701sub reset_at { 2209sub reset_at {
1702 my ($self) = @_; 2210 my ($self) = @_;
1703 2211
1704 # TODO: safety, remove and allow resettable per-player maps 2212 # TODO: safety, remove and allow resettable per-player maps
1705 return 1e99 if $self->isa ("ext::map_per_player");#d#
1706 return 1e99 if $self->{deny_reset}; 2213 return 1e99 if $self->{deny_reset};
1707 2214
1708 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2215 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1709 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2216 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1710 2217
… …
1721 my ($self) = @_; 2228 my ($self) = @_;
1722 2229
1723 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2230 my $lock = cf::lock_acquire "map_data:$self->{path}";
1724 2231
1725 return if $self->players; 2232 return if $self->players;
1726 return if $self->isa ("ext::map_per_player");#d#
1727 2233
1728 warn "resetting map ", $self->path;#d# 2234 warn "resetting map ", $self->path;
1729 2235
1730 $self->in_memory (cf::MAP_SWAPPED); 2236 $self->in_memory (cf::MAP_SWAPPED);
1731 2237
1732 # need to save uniques path 2238 # need to save uniques path
1733 unless ($self->{deny_save}) { 2239 unless ($self->{deny_save}) {
… …
1737 if $uniq; 2243 if $uniq;
1738 } 2244 }
1739 2245
1740 delete $cf::MAP{$self->path}; 2246 delete $cf::MAP{$self->path};
1741 2247
2248 $self->deactivate;
2249 $_->clear_links_to ($self) for values %cf::MAP;
1742 $self->clear; 2250 $self->clear;
1743
1744 $_->clear_links_to ($self) for values %cf::MAP;
1745 2251
1746 $self->unlink_save; 2252 $self->unlink_save;
1747 $self->destroy; 2253 $self->destroy;
1748} 2254}
1749 2255
1750my $nuke_counter = "aaaa"; 2256my $nuke_counter = "aaaa";
1751 2257
1752sub nuke { 2258sub nuke {
1753 my ($self) = @_; 2259 my ($self) = @_;
1754 2260
2261 {
2262 my $lock = cf::lock_acquire "map_data:$self->{path}";
2263
1755 delete $cf::MAP{$self->path}; 2264 delete $cf::MAP{$self->path};
1756 2265
1757 $self->unlink_save; 2266 $self->unlink_save;
1758 2267
1759 bless $self, "cf::map"; 2268 bless $self, "cf::map";
1760 delete $self->{deny_reset}; 2269 delete $self->{deny_reset};
1761 $self->{deny_save} = 1; 2270 $self->{deny_save} = 1;
1762 $self->reset_timeout (1); 2271 $self->reset_timeout (1);
1763 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2272 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1764 2273
1765 $cf::MAP{$self->path} = $self; 2274 $cf::MAP{$self->path} = $self;
2275 }
1766 2276
1767 $self->reset; # polite request, might not happen 2277 $self->reset; # polite request, might not happen
2278}
2279
2280=item $maps = cf::map::tmp_maps
2281
2282Returns an arrayref with all map paths of currently instantiated and saved
2283maps. May block.
2284
2285=cut
2286
2287sub tmp_maps() {
2288 [
2289 map {
2290 utf8::decode $_;
2291 /\.map$/
2292 ? normalise $_
2293 : ()
2294 } @{ aio_readdir $TMPDIR or [] }
2295 ]
2296}
2297
2298=item $maps = cf::map::random_maps
2299
2300Returns an arrayref with all map paths of currently instantiated and saved
2301random maps. May block.
2302
2303=cut
2304
2305sub random_maps() {
2306 [
2307 map {
2308 utf8::decode $_;
2309 /\.map$/
2310 ? normalise "?random/$_"
2311 : ()
2312 } @{ aio_readdir $RANDOMDIR or [] }
2313 ]
1768} 2314}
1769 2315
1770=item cf::map::unique_maps 2316=item cf::map::unique_maps
1771 2317
1772Returns an arrayref of paths of all shared maps that have 2318Returns an arrayref of paths of all shared maps that have
1773instantiated unique items. May block. 2319instantiated unique items. May block.
1774 2320
1775=cut 2321=cut
1776 2322
1777sub unique_maps() { 2323sub unique_maps() {
1778 my $files = aio_readdir $UNIQUEDIR 2324 [
1779 or return; 2325 map {
1780
1781 my @paths;
1782
1783 for (@$files) {
1784 utf8::decode $_; 2326 utf8::decode $_;
1785 next if /\.pst$/; 2327 /\.map$/
1786 next unless /^$PATH_SEP/o; 2328 ? normalise $_
1787 2329 : ()
1788 push @paths, cf::map::normalise $_; 2330 } @{ aio_readdir $UNIQUEDIR or [] }
1789 } 2331 ]
1790
1791 \@paths
1792} 2332}
1793 2333
1794package cf; 2334package cf;
1795 2335
1796=back 2336=back
… …
1814 map { $_, inv_recursive_ $_->inv } @_ 2354 map { $_, inv_recursive_ $_->inv } @_
1815} 2355}
1816 2356
1817sub inv_recursive { 2357sub inv_recursive {
1818 inv_recursive_ inv $_[0] 2358 inv_recursive_ inv $_[0]
2359}
2360
2361=item $ref = $ob->ref
2362
2363creates and returns a persistent reference to an objetc that can be stored as a string.
2364
2365=item $ob = cf::object::deref ($refstring)
2366
2367returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2368even if the object actually exists. May block.
2369
2370=cut
2371
2372sub deref {
2373 my ($ref) = @_;
2374
2375 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2376 my ($uuid, $name) = ($1, $2);
2377 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2378 or return;
2379 $pl->ob->uuid eq $uuid
2380 or return;
2381
2382 $pl->ob
2383 } else {
2384 warn "$ref: cannot resolve object reference\n";
2385 undef
2386 }
1819} 2387}
1820 2388
1821package cf; 2389package cf;
1822 2390
1823=back 2391=back
… …
1842 2410
1843 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2411 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1844 2412
1845 if ($self->{record_replies}) { 2413 if ($self->{record_replies}) {
1846 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2414 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2415
1847 } else { 2416 } else {
2417 my $pl = $self->contr;
2418
2419 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2420 my $dialog = $pl->{npc_dialog};
2421 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2422
2423 } else {
1848 $msg = $npc->name . " says: $msg" if $npc; 2424 $msg = $npc->name . " says: $msg" if $npc;
1849 $self->message ($msg, $flags); 2425 $self->message ($msg, $flags);
2426 }
1850 } 2427 }
2428}
2429
2430=item $object->send_msg ($channel, $msg, $color, [extra...])
2431
2432=cut
2433
2434sub cf::object::send_msg {
2435 my $pl = shift->contr
2436 or return;
2437 $pl->send_msg (@_);
1851} 2438}
1852 2439
1853=item $player_object->may ("access") 2440=item $player_object->may ("access")
1854 2441
1855Returns wether the given player is authorized to access resource "access" 2442Returns wether the given player is authorized to access resource "access"
… …
1902 $self->deactivate_recursive; 2489 $self->deactivate_recursive;
1903 2490
1904 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2491 return if UNIVERSAL::isa $self->map, "ext::map_link";
1905 2492
1906 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2493 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1907 if $self->map; 2494 if $self->map && $self->map->{path} ne "{link}";
1908 2495
1909 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2496 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1910} 2497}
1911 2498
1912sub cf::object::player::leave_link { 2499sub cf::object::player::leave_link {
1913 my ($self, $map, $x, $y) = @_; 2500 my ($self, $map, $x, $y) = @_;
2501
2502 return unless $self->contr->active;
1914 2503
1915 my $link_pos = delete $self->{_link_pos}; 2504 my $link_pos = delete $self->{_link_pos};
1916 2505
1917 unless ($map) { 2506 unless ($map) {
1918 # restore original map position 2507 # restore original map position
… …
1932 # use -1 or undef as default coordinates, not 0, 0 2521 # use -1 or undef as default coordinates, not 0, 0
1933 ($x, $y) = ($map->enter_x, $map->enter_y) 2522 ($x, $y) = ($map->enter_x, $map->enter_y)
1934 if $x <=0 && $y <= 0; 2523 if $x <=0 && $y <= 0;
1935 2524
1936 $map->load; 2525 $map->load;
1937 $map->load_diag; 2526 $map->load_neighbours;
1938 2527
1939 return unless $self->contr->active; 2528 return unless $self->contr->active;
1940 $self->activate_recursive; 2529 $self->activate_recursive;
1941 2530
1942 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2531 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1943 $self->enter_map ($map, $x, $y); 2532 $self->enter_map ($map, $x, $y);
1944} 2533}
1945 2534
1946cf::player->attach ( 2535=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1947 on_logout => sub {
1948 my ($pl) = @_;
1949 2536
1950 # abort map switching before logout 2537Moves the player to the given map-path and coordinates by first freezing
1951 if ($pl->ob->{_link_pos}) { 2538her, loading and preparing them map, calling the provided $check callback
1952 cf::sync_job { 2539that has to return the map if sucecssful, and then unfreezes the player on
1953 $pl->ob->leave_link 2540the new (success) or old (failed) map position. In either case, $done will
1954 }; 2541be called at the end of this process.
1955 }
1956 },
1957 on_login => sub {
1958 my ($pl) = @_;
1959 2542
1960 # try to abort aborted map switching on player login :)
1961 # should happen only on crashes
1962 if ($pl->ob->{_link_pos}) {
1963 $pl->ob->enter_link;
1964 (async {
1965 $pl->ob->reply (undef,
1966 "There was an internal problem at your last logout, "
1967 . "the server will try to bring you to your intended destination in a second.",
1968 cf::NDI_RED);
1969 # we need this sleep as the login has a concurrent enter_exit running
1970 # and this sleep increases chances of the player not ending up in scorn
1971 Coro::Timer::sleep 1;
1972 $pl->ob->leave_link;
1973 })->prio (2);
1974 }
1975 },
1976);
1977
1978=item $player_object->goto ($path, $x, $y)
1979
1980=cut 2543=cut
2544
2545our $GOTOGEN;
1981 2546
1982sub cf::object::player::goto { 2547sub cf::object::player::goto {
1983 my ($self, $path, $x, $y) = @_; 2548 my ($self, $path, $x, $y, $check, $done) = @_;
2549
2550 # do generation counting so two concurrent goto's will be executed in-order
2551 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1984 2552
1985 $self->enter_link; 2553 $self->enter_link;
1986 2554
1987 (async { 2555 (async {
2556 $Coro::current->{desc} = "player::goto $path $x $y";
2557
2558 # *tag paths override both path and x|y
2559 if ($path =~ /^\*(.*)$/) {
2560 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2561 my $ob = $obs[rand @obs];
2562
2563 # see if we actually can go there
2564 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2565 $ob = $obs[rand @obs];
2566 } else {
2567 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2568 }
2569 # else put us there anyways for now #d#
2570
2571 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2572 } else {
2573 ($path, $x, $y) = (undef, undef, undef);
2574 }
2575 }
2576
1988 my $map = eval { 2577 my $map = eval {
1989 my $map = cf::map::find $path; 2578 my $map = defined $path ? cf::map::find $path : undef;
2579
2580 if ($map) {
1990 $map = $map->customise_for ($self) if $map; 2581 $map = $map->customise_for ($self);
2582 $map = $check->($map) if $check && $map;
2583 } else {
2584 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2585 }
2586
1991 $map 2587 $map
2588 };
2589
2590 if ($@) {
2591 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2592 LOG llevError | logBacktrace, Carp::longmess $@;
1992 } or 2593 }
1993 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1994 2594
2595 if ($gen == $self->{_goto_generation}) {
2596 delete $self->{_goto_generation};
1995 $self->leave_link ($map, $x, $y); 2597 $self->leave_link ($map, $x, $y);
2598 }
2599
2600 $done->() if $done;
1996 })->prio (1); 2601 })->prio (1);
1997} 2602}
1998 2603
1999=item $player_object->enter_exit ($exit_object) 2604=item $player_object->enter_exit ($exit_object)
2000 2605
… …
2037 $rmp->{origin_y} = $exit->y; 2642 $rmp->{origin_y} = $exit->y;
2038 } 2643 }
2039 2644
2040 $rmp->{random_seed} ||= $exit->random_seed; 2645 $rmp->{random_seed} ||= $exit->random_seed;
2041 2646
2042 my $data = cf::to_json $rmp; 2647 my $data = cf::encode_json $rmp;
2043 my $md5 = Digest::MD5::md5_hex $data; 2648 my $md5 = Digest::MD5::md5_hex $data;
2044 my $meta = "$RANDOMDIR/$md5.meta"; 2649 my $meta = "$RANDOMDIR/$md5.meta";
2045 2650
2046 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2651 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2047 aio_write $fh, 0, (length $data), $data, 0; 2652 aio_write $fh, 0, (length $data), $data, 0;
… …
2069 my $hp = $exit->stats->hp; 2674 my $hp = $exit->stats->hp;
2070 my $sp = $exit->stats->sp; 2675 my $sp = $exit->stats->sp;
2071 2676
2072 $self->enter_link; 2677 $self->enter_link;
2073 2678
2679 # if exit is damned, update players death & WoR home-position
2680 $self->contr->savebed ($slaying, $hp, $sp)
2681 if $exit->flag (FLAG_DAMNED);
2682
2074 (async { 2683 (async {
2684 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2685
2075 $self->deactivate_recursive; # just to be sure 2686 $self->deactivate_recursive; # just to be sure
2076 unless (eval { 2687 unless (eval {
2077 $self->goto ($slaying, $hp, $sp); 2688 $self->goto ($slaying, $hp, $sp);
2078 2689
2079 1; 2690 1;
… …
2105 2716
2106 utf8::encode $text; 2717 utf8::encode $text;
2107 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2718 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2108} 2719}
2109 2720
2721=item $client->send_msg ($channel, $msg, $color, [extra...])
2722
2723Send a drawinfo or msg packet to the client, formatting the msg for the
2724client if neccessary. C<$type> should be a string identifying the type of
2725the message, with C<log> being the default. If C<$color> is negative, suppress
2726the message unless the client supports the msg packet.
2727
2728=cut
2729
2730# non-persistent channels (usually the info channel)
2731our %CHANNEL = (
2732 "c/identify" => {
2733 id => "infobox",
2734 title => "Identify",
2735 reply => undef,
2736 tooltip => "Items recently identified",
2737 },
2738 "c/examine" => {
2739 id => "infobox",
2740 title => "Examine",
2741 reply => undef,
2742 tooltip => "Signs and other items you examined",
2743 },
2744 "c/book" => {
2745 id => "infobox",
2746 title => "Book",
2747 reply => undef,
2748 tooltip => "The contents of a note or book",
2749 },
2750 "c/lookat" => {
2751 id => "infobox",
2752 title => "Look",
2753 reply => undef,
2754 tooltip => "What you saw there",
2755 },
2756 "c/who" => {
2757 id => "infobox",
2758 title => "Players",
2759 reply => undef,
2760 tooltip => "Shows players who are currently online",
2761 },
2762 "c/body" => {
2763 id => "infobox",
2764 title => "Body Parts",
2765 reply => undef,
2766 tooltip => "Shows which body parts you posess and are available",
2767 },
2768 "c/uptime" => {
2769 id => "infobox",
2770 title => "Uptime",
2771 reply => undef,
2772 tooltip => "How long the server has been running since last restart",
2773 },
2774 "c/mapinfo" => {
2775 id => "infobox",
2776 title => "Map Info",
2777 reply => undef,
2778 tooltip => "Information related to the maps",
2779 },
2780);
2781
2782sub cf::client::send_msg {
2783 my ($self, $channel, $msg, $color, @extra) = @_;
2784
2785 $msg = $self->pl->expand_cfpod ($msg);
2786
2787 $color &= cf::NDI_CLIENT_MASK; # just in case...
2788
2789 # check predefined channels, for the benefit of C
2790 if ($CHANNEL{$channel}) {
2791 $channel = $CHANNEL{$channel};
2792
2793 $self->ext_msg (channel_info => $channel)
2794 if $self->can_msg;
2795
2796 $channel = $channel->{id};
2797
2798 } elsif (ref $channel) {
2799 # send meta info to client, if not yet sent
2800 unless (exists $self->{channel}{$channel->{id}}) {
2801 $self->{channel}{$channel->{id}} = $channel;
2802 $self->ext_msg (channel_info => $channel)
2803 if $self->can_msg;
2804 }
2805
2806 $channel = $channel->{id};
2807 }
2808
2809 return unless @extra || length $msg;
2810
2811 if ($self->can_msg) {
2812 # default colour, mask it out
2813 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2814 if $color & cf::NDI_DEF;
2815
2816 $self->send_packet ("msg " . $self->{json_coder}->encode (
2817 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2818 } else {
2819 if ($color >= 0) {
2820 # replace some tags by gcfclient-compatible ones
2821 for ($msg) {
2822 1 while
2823 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2824 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2825 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2826 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2827 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2828 }
2829
2830 $color &= cf::NDI_COLOR_MASK;
2831
2832 utf8::encode $msg;
2833
2834 if (0 && $msg =~ /\[/) {
2835 # COMMAND/INFO
2836 $self->send_packet ("drawextinfo $color 10 8 $msg")
2837 } else {
2838 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2839 $self->send_packet ("drawinfo $color $msg")
2840 }
2841 }
2842 }
2843}
2844
2110=item $client->ext_event ($type, %msg) 2845=item $client->ext_msg ($type, @msg)
2111 2846
2112Sends an exti event to the client. 2847Sends an ext event to the client.
2113 2848
2114=cut 2849=cut
2115 2850
2116sub cf::client::ext_event($$%) { 2851sub cf::client::ext_msg($$@) {
2117 my ($self, $type, %msg) = @_; 2852 my ($self, $type, @msg) = @_;
2118 2853
2854 if ($self->extcmd == 2) {
2855 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2856 } elsif ($self->extcmd == 1) { # TODO: remove
2119 $msg{msgtype} = "event_$type"; 2857 push @msg, msgtype => "event_$type";
2120 $self->send_packet ("ext " . cf::to_json \%msg); 2858 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2859 }
2860}
2861
2862=item $client->ext_reply ($msgid, @msg)
2863
2864Sends an ext reply to the client.
2865
2866=cut
2867
2868sub cf::client::ext_reply($$@) {
2869 my ($self, $id, @msg) = @_;
2870
2871 if ($self->extcmd == 2) {
2872 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2873 } elsif ($self->extcmd == 1) {
2874 #TODO: version 1, remove
2875 unshift @msg, msgtype => "reply", msgid => $id;
2876 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2877 }
2121} 2878}
2122 2879
2123=item $success = $client->query ($flags, "text", \&cb) 2880=item $success = $client->query ($flags, "text", \&cb)
2124 2881
2125Queues a query to the client, calling the given callback with 2882Queues a query to the client, calling the given callback with
2126the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2883the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2127C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2884C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2128 2885
2129Queries can fail, so check the return code. Or don't, as queries will become 2886Queries can fail, so check the return code. Or don't, as queries will
2130reliable at some point in the future. 2887become reliable at some point in the future.
2131 2888
2132=cut 2889=cut
2133 2890
2134sub cf::client::query { 2891sub cf::client::query {
2135 my ($self, $flags, $text, $cb) = @_; 2892 my ($self, $flags, $text, $cb) = @_;
… …
2143 utf8::encode $text; 2900 utf8::encode $text;
2144 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2901 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2145 2902
2146 $self->send_packet ($self->{query_queue}[0][0]) 2903 $self->send_packet ($self->{query_queue}[0][0])
2147 if @{ $self->{query_queue} } == 1; 2904 if @{ $self->{query_queue} } == 1;
2905
2906 1
2148} 2907}
2149 2908
2150cf::client->attach ( 2909cf::client->attach (
2910 on_connect => sub {
2911 my ($ns) = @_;
2912
2913 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2914 },
2151 on_reply => sub { 2915 on_reply => sub {
2152 my ($ns, $msg) = @_; 2916 my ($ns, $msg) = @_;
2153 2917
2154 # this weird shuffling is so that direct followup queries 2918 # this weird shuffling is so that direct followup queries
2155 # get handled first 2919 # get handled first
… …
2167 } else { 2931 } else {
2168 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2932 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2169 } 2933 }
2170 } 2934 }
2171 }, 2935 },
2936 on_exticmd => sub {
2937 my ($ns, $buf) = @_;
2938
2939 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2940
2941 if (ref $msg) {
2942 my ($type, $reply, @payload) =
2943 "ARRAY" eq ref $msg
2944 ? @$msg
2945 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2946
2947 my @reply;
2948
2949 if (my $cb = $EXTICMD{$type}) {
2950 @reply = $cb->($ns, @payload);
2951 }
2952
2953 $ns->ext_reply ($reply, @reply)
2954 if $reply;
2955
2956 } else {
2957 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2958 }
2959
2960 cf::override;
2961 },
2172); 2962);
2173 2963
2174=item $client->async (\&cb) 2964=item $client->async (\&cb)
2175 2965
2176Create a new coroutine, running the specified callback. The coroutine will 2966Create a new coroutine, running the specified callback. The coroutine will
… …
2217our $safe = new Safe "safe"; 3007our $safe = new Safe "safe";
2218our $safe_hole = new Safe::Hole; 3008our $safe_hole = new Safe::Hole;
2219 3009
2220$SIG{FPE} = 'IGNORE'; 3010$SIG{FPE} = 'IGNORE';
2221 3011
2222$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3012$safe->permit_only (Opcode::opset qw(
3013 :base_core :base_mem :base_orig :base_math
3014 grepstart grepwhile mapstart mapwhile
3015 sort time
3016));
2223 3017
2224# here we export the classes and methods available to script code 3018# here we export the classes and methods available to script code
2225 3019
2226=pod 3020=pod
2227 3021
2228The following functions and methods are available within a safe environment: 3022The following functions and methods are available within a safe environment:
2229 3023
2230 cf::object contr pay_amount pay_player map 3024 cf::object
3025 contr pay_amount pay_player map x y force_find force_add destroy
3026 insert remove name archname title slaying race decrease_ob_nr
3027
2231 cf::object::player player 3028 cf::object::player
2232 cf::player peaceful 3029 player
2233 cf::map trigger 3030
3031 cf::player
3032 peaceful
3033
3034 cf::map
3035 trigger
2234 3036
2235=cut 3037=cut
2236 3038
2237for ( 3039for (
2238 ["cf::object" => qw(contr pay_amount pay_player map)], 3040 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3041 insert remove inv name archname title slaying race
3042 decrease_ob_nr destroy)],
2239 ["cf::object::player" => qw(player)], 3043 ["cf::object::player" => qw(player)],
2240 ["cf::player" => qw(peaceful)], 3044 ["cf::player" => qw(peaceful)],
2241 ["cf::map" => qw(trigger)], 3045 ["cf::map" => qw(trigger)],
2242) { 3046) {
2243 no strict 'refs'; 3047 no strict 'refs';
… …
2314=back 3118=back
2315 3119
2316=cut 3120=cut
2317 3121
2318############################################################################# 3122#############################################################################
2319
2320=head2 EXTENSION DATABASE SUPPORT
2321
2322Crossfire maintains a very simple database for extension use. It can
2323currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2324convert to/from binary).
2325
2326The parameter C<$family> should best start with the name of the extension
2327using it, it should be unique.
2328
2329=over 4
2330
2331=item $value = cf::db_get $family => $key
2332
2333Returns a single value from the database.
2334
2335=item cf::db_put $family => $key => $value
2336
2337Stores the given C<$value> in the family.
2338
2339=cut
2340
2341our $DB;
2342
2343sub db_init {
2344 unless ($DB) {
2345 $DB = BDB::db_create $DB_ENV;
2346
2347 cf::sync_job {
2348 eval {
2349 $DB->set_flags (BDB::CHKSUM);
2350
2351 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2352 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2353 cf::cleanup "db_open(db): $!" if $!;
2354 };
2355 cf::cleanup "db_open(db): $@" if $@;
2356 };
2357 }
2358}
2359
2360sub db_get($$) {
2361 my $key = "$_[0]/$_[1]";
2362
2363 cf::sync_job {
2364 BDB::db_get $DB, undef, $key, my $data;
2365
2366 $! ? ()
2367 : $data
2368 }
2369}
2370
2371sub db_put($$$) {
2372 BDB::dbreq_pri 4;
2373 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2374}
2375
2376=item cf::cache $id => [$paths...], $processversion => $process
2377
2378Generic caching function that returns the value of the resource $id,
2379caching and regenerating as required.
2380
2381This function can block.
2382
2383=cut
2384
2385sub cache {
2386 my ($id, $src, $processversion, $process) = @_;
2387
2388 my $meta =
2389 join "\x00",
2390 $processversion,
2391 map {
2392 aio_stat $_
2393 and Carp::croak "$_: $!";
2394
2395 ($_, (stat _)[7,9])
2396 } @$src;
2397
2398 my $dbmeta = db_get cache => "$id/meta";
2399 if ($dbmeta ne $meta) {
2400 # changed, we may need to process
2401
2402 my @data;
2403 my $md5;
2404
2405 for (0 .. $#$src) {
2406 0 <= aio_load $src->[$_], $data[$_]
2407 or Carp::croak "$src->[$_]: $!";
2408 }
2409
2410 # if processing is expensive, check
2411 # checksum first
2412 if (1) {
2413 $md5 =
2414 join "\x00",
2415 $processversion,
2416 map {
2417 Coro::cede;
2418 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2419 } 0.. $#$src;
2420
2421
2422 my $dbmd5 = db_get cache => "$id/md5";
2423 if ($dbmd5 eq $md5) {
2424 db_put cache => "$id/meta", $meta;
2425
2426 return db_get cache => "$id/data";
2427 }
2428 }
2429
2430 my $t1 = Time::HiRes::time;
2431 my $data = $process->(\@data);
2432 my $t2 = Time::HiRes::time;
2433
2434 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2435
2436 db_put cache => "$id/data", $data;
2437 db_put cache => "$id/md5" , $md5;
2438 db_put cache => "$id/meta", $meta;
2439
2440 return $data;
2441 }
2442
2443 db_get cache => "$id/data"
2444}
2445
2446=item fork_call { }, $args
2447
2448Executes the given code block with the given arguments in a seperate
2449process, returning the results. Everything must be serialisable with
2450Coro::Storable. May, of course, block. Note that the executed sub may
2451never block itself or use any form of Event handling.
2452
2453=cut
2454
2455sub fork_call(&@) {
2456 my ($cb, @args) = @_;
2457
2458# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2459# or die "socketpair: $!";
2460 pipe my $fh1, my $fh2
2461 or die "pipe: $!";
2462
2463 if (my $pid = fork) {
2464 close $fh2;
2465
2466 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2467 $res = Coro::Storable::thaw $res;
2468
2469 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2470
2471 die $$res unless "ARRAY" eq ref $res;
2472
2473 return wantarray ? @$res : $res->[-1];
2474 } else {
2475 reset_signals;
2476 local $SIG{__WARN__};
2477 local $SIG{__DIE__};
2478 eval {
2479 close $fh1;
2480
2481 my @res = eval { $cb->(@args) };
2482 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2483 };
2484
2485 warn $@ if $@;
2486 _exit 0;
2487 }
2488}
2489
2490
2491
2492#############################################################################
2493# the server's init and main functions 3123# the server's init and main functions
2494 3124
2495sub load_facedata($) { 3125sub load_facedata($) {
2496 my ($path) = @_; 3126 my ($path) = @_;
3127
3128 # HACK to clear player env face cache, we need some signal framework
3129 # for this (global event?)
3130 %ext::player_env::MUSIC_FACE_CACHE = ();
3131
3132 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2497 3133
2498 warn "loading facedata from $path\n"; 3134 warn "loading facedata from $path\n";
2499 3135
2500 my $facedata; 3136 my $facedata;
2501 0 < aio_load $path, $facedata 3137 0 < aio_load $path, $facedata
… …
2504 $facedata = Coro::Storable::thaw $facedata; 3140 $facedata = Coro::Storable::thaw $facedata;
2505 3141
2506 $facedata->{version} == 2 3142 $facedata->{version} == 2
2507 or cf::cleanup "$path: version mismatch, cannot proceed."; 3143 or cf::cleanup "$path: version mismatch, cannot proceed.";
2508 3144
3145 # patch in the exptable
3146 $facedata->{resource}{"res/exp_table"} = {
3147 type => FT_RSRC,
3148 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3149 };
3150 cf::cede_to_tick;
3151
2509 { 3152 {
2510 my $faces = $facedata->{faceinfo}; 3153 my $faces = $facedata->{faceinfo};
2511 3154
2512 while (my ($face, $info) = each %$faces) { 3155 while (my ($face, $info) = each %$faces) {
2513 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3156 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3157
2514 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3158 cf::face::set_visibility $idx, $info->{visibility};
3159 cf::face::set_magicmap $idx, $info->{magicmap};
2515 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3160 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2516 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3161 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2517 Coro::cede; 3162
3163 cf::cede_to_tick;
2518 } 3164 }
2519 3165
2520 while (my ($face, $info) = each %$faces) { 3166 while (my ($face, $info) = each %$faces) {
2521 next unless $info->{smooth}; 3167 next unless $info->{smooth};
3168
2522 my $idx = cf::face::find $face 3169 my $idx = cf::face::find $face
2523 or next; 3170 or next;
3171
2524 if (my $smooth = cf::face::find $info->{smooth}) { 3172 if (my $smooth = cf::face::find $info->{smooth}) {
3173 cf::face::set_smooth $idx, $smooth;
2525 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3174 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2526 } else { 3175 } else {
2527 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3176 warn "smooth face '$info->{smooth}' not found for face '$face'";
2528 } 3177 }
2529 Coro::cede; 3178
3179 cf::cede_to_tick;
2530 } 3180 }
2531 } 3181 }
2532 3182
2533 { 3183 {
2534 my $anims = $facedata->{animinfo}; 3184 my $anims = $facedata->{animinfo};
2535 3185
2536 while (my ($anim, $info) = each %$anims) { 3186 while (my ($anim, $info) = each %$anims) {
2537 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3187 cf::anim::set $anim, $info->{frames}, $info->{facings};
2538 Coro::cede; 3188 cf::cede_to_tick;
2539 } 3189 }
2540 3190
2541 cf::anim::invalidate_all; # d'oh 3191 cf::anim::invalidate_all; # d'oh
2542 } 3192 }
2543 3193
3194 {
3195 # TODO: for gcfclient pleasure, we should give resources
3196 # that gcfclient doesn't grok a >10000 face index.
3197 my $res = $facedata->{resource};
3198
3199 while (my ($name, $info) = each %$res) {
3200 if (defined $info->{type}) {
3201 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3202 my $data;
3203
3204 if ($info->{type} & 1) {
3205 # prepend meta info
3206
3207 my $meta = $enc->encode ({
3208 name => $name,
3209 %{ $info->{meta} || {} },
3210 });
3211
3212 $data = pack "(w/a*)*", $meta, $info->{data};
3213 } else {
3214 $data = $info->{data};
3215 }
3216
3217 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3218 cf::face::set_type $idx, $info->{type};
3219 } else {
3220 $RESOURCE{$name} = $info;
3221 }
3222
3223 cf::cede_to_tick;
3224 }
3225 }
3226
3227 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3228
2544 1 3229 1
2545} 3230}
2546 3231
3232cf::global->attach (on_resource_update => sub {
3233 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3234 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3235
3236 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3237 my $sound = $soundconf->{compat}[$_]
3238 or next;
3239
3240 my $face = cf::face::find "sound/$sound->[1]";
3241 cf::sound::set $sound->[0] => $face;
3242 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3243 }
3244
3245 while (my ($k, $v) = each %{$soundconf->{event}}) {
3246 my $face = cf::face::find "sound/$v";
3247 cf::sound::set $k => $face;
3248 }
3249 }
3250});
3251
3252register_exticmd fx_want => sub {
3253 my ($ns, $want) = @_;
3254
3255 while (my ($k, $v) = each %$want) {
3256 $ns->fx_want ($k, $v);
3257 }
3258};
3259
2547sub reload_regions { 3260sub reload_regions {
3261 # HACK to clear player env face cache, we need some signal framework
3262 # for this (global event?)
3263 %ext::player_env::MUSIC_FACE_CACHE = ();
3264
2548 load_resource_file "$MAPDIR/regions" 3265 load_resource_file "$MAPDIR/regions"
2549 or die "unable to load regions file\n"; 3266 or die "unable to load regions file\n";
3267
3268 for (cf::region::list) {
3269 $_->{match} = qr/$_->{match}/
3270 if exists $_->{match};
3271 }
2550} 3272}
2551 3273
2552sub reload_facedata { 3274sub reload_facedata {
2553 load_facedata "$DATADIR/facedata" 3275 load_facedata "$DATADIR/facedata"
2554 or die "unable to load facedata\n"; 3276 or die "unable to load facedata\n";
2555} 3277}
2556 3278
2557sub reload_archetypes { 3279sub reload_archetypes {
2558 load_resource_file "$DATADIR/archetypes" 3280 load_resource_file "$DATADIR/archetypes"
2559 or die "unable to load archetypes\n"; 3281 or die "unable to load archetypes\n";
3282 #d# NEED to laod twice to resolve forward references
3283 # this really needs to be done in an extra post-pass
3284 # (which needs to be synchronous, so solve it differently)
3285 load_resource_file "$DATADIR/archetypes"
3286 or die "unable to load archetypes\n";
2560} 3287}
2561 3288
2562sub reload_treasures { 3289sub reload_treasures {
2563 load_resource_file "$DATADIR/treasures" 3290 load_resource_file "$DATADIR/treasures"
2564 or die "unable to load treasurelists\n"; 3291 or die "unable to load treasurelists\n";
… …
2567sub reload_resources { 3294sub reload_resources {
2568 warn "reloading resource files...\n"; 3295 warn "reloading resource files...\n";
2569 3296
2570 reload_regions; 3297 reload_regions;
2571 reload_facedata; 3298 reload_facedata;
3299 #reload_archetypes;#d#
2572 reload_archetypes; 3300 reload_archetypes;
2573 reload_treasures; 3301 reload_treasures;
2574 3302
2575 warn "finished reloading resource files\n"; 3303 warn "finished reloading resource files\n";
2576} 3304}
2577 3305
2578sub init { 3306sub init {
2579 reload_resources; 3307 reload_resources;
2580} 3308}
2581 3309
2582sub cfg_load { 3310sub reload_config {
2583 open my $fh, "<:utf8", "$CONFDIR/config" 3311 open my $fh, "<:utf8", "$CONFDIR/config"
2584 or return; 3312 or return;
2585 3313
2586 local $/; 3314 local $/;
2587 *CFG = YAML::Syck::Load <$fh>; 3315 *CFG = YAML::Load <$fh>;
2588 3316
2589 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3317 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2590 3318
2591 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3319 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2592 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3320 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2603sub main { 3331sub main {
2604 # we must not ever block the main coroutine 3332 # we must not ever block the main coroutine
2605 local $Coro::idle = sub { 3333 local $Coro::idle = sub {
2606 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3334 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2607 (async { 3335 (async {
2608 Event::one_event; 3336 $Coro::current->{desc} = "IDLE BUG HANDLER";
3337 EV::loop EV::LOOP_ONESHOT;
2609 })->prio (Coro::PRIO_MAX); 3338 })->prio (Coro::PRIO_MAX);
2610 }; 3339 };
2611 3340
2612 cfg_load; 3341 reload_config;
2613 db_init; 3342 db_init;
2614 load_extensions; 3343 load_extensions;
2615 3344
2616 $TICK_WATCHER->start; 3345 $TICK_WATCHER->start;
3346 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
2617 Event::loop; 3347 EV::loop;
2618} 3348}
2619 3349
2620############################################################################# 3350#############################################################################
2621# initialisation and cleanup 3351# initialisation and cleanup
2622 3352
2623# install some emergency cleanup handlers 3353# install some emergency cleanup handlers
2624BEGIN { 3354BEGIN {
3355 our %SIGWATCHER = ();
2625 for my $signal (qw(INT HUP TERM)) { 3356 for my $signal (qw(INT HUP TERM)) {
2626 Event->signal ( 3357 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2627 reentrant => 0,
2628 data => WF_AUTOCANCEL,
2629 signal => $signal,
2630 prio => 0,
2631 cb => sub {
2632 cf::cleanup "SIG$signal"; 3358 cf::cleanup "SIG$signal";
2633 },
2634 ); 3359 };
3360 }
3361}
3362
3363sub write_runtime {
3364 my $runtime = "$LOCALDIR/runtime";
3365
3366 # first touch the runtime file to show we are still running:
3367 # the fsync below can take a very very long time.
3368
3369 IO::AIO::aio_utime $runtime, undef, undef;
3370
3371 my $guard = cf::lock_acquire "write_runtime";
3372
3373 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3374 or return;
3375
3376 my $value = $cf::RUNTIME + 90 + 10;
3377 # 10 is the runtime save interval, for a monotonic clock
3378 # 60 allows for the watchdog to kill the server.
3379
3380 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3381 and return;
3382
3383 # always fsync - this file is important
3384 aio_fsync $fh
3385 and return;
3386
3387 # touch it again to show we are up-to-date
3388 aio_utime $fh, undef, undef;
3389
3390 close $fh
3391 or return;
3392
3393 aio_rename "$runtime~", $runtime
3394 and return;
3395
3396 warn "runtime file written.\n";
3397
2635 } 3398 1
2636} 3399}
2637 3400
2638sub emergency_save() { 3401sub emergency_save() {
2639 my $freeze_guard = cf::freeze_mainloop; 3402 my $freeze_guard = cf::freeze_mainloop;
2640 3403
… …
2646 # and maps saved/destroyed asynchronously. 3409 # and maps saved/destroyed asynchronously.
2647 warn "begin emergency player save\n"; 3410 warn "begin emergency player save\n";
2648 for my $login (keys %cf::PLAYER) { 3411 for my $login (keys %cf::PLAYER) {
2649 my $pl = $cf::PLAYER{$login} or next; 3412 my $pl = $cf::PLAYER{$login} or next;
2650 $pl->valid or next; 3413 $pl->valid or next;
3414 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2651 $pl->save; 3415 $pl->save;
2652 } 3416 }
2653 warn "end emergency player save\n"; 3417 warn "end emergency player save\n";
2654 3418
2655 warn "begin emergency map save\n"; 3419 warn "begin emergency map save\n";
… …
2694 warn "syncing database to disk"; 3458 warn "syncing database to disk";
2695 BDB::db_env_txn_checkpoint $DB_ENV; 3459 BDB::db_env_txn_checkpoint $DB_ENV;
2696 3460
2697 # if anything goes wrong in here, we should simply crash as we already saved 3461 # if anything goes wrong in here, we should simply crash as we already saved
2698 3462
2699 warn "cancelling all WF_AUTOCANCEL watchers";
2700 for (Event::all_watchers) {
2701 $_->cancel if $_->data & WF_AUTOCANCEL;
2702 }
2703
2704 warn "flushing outstanding aio requests"; 3463 warn "flushing outstanding aio requests";
2705 for (;;) { 3464 for (;;) {
2706 BDB::flush; 3465 BDB::flush;
2707 IO::AIO::flush; 3466 IO::AIO::flush;
2708 Coro::cede; 3467 Coro::cede_notself;
2709 last unless IO::AIO::nreqs || BDB::nreqs; 3468 last unless IO::AIO::nreqs || BDB::nreqs;
2710 warn "iterate..."; 3469 warn "iterate...";
2711 } 3470 }
2712 3471
2713 ++$RELOAD; 3472 ++$RELOAD;
… …
2717 %EXT_CORO = (); 3476 %EXT_CORO = ();
2718 3477
2719 warn "removing commands"; 3478 warn "removing commands";
2720 %COMMAND = (); 3479 %COMMAND = ();
2721 3480
2722 warn "removing ext commands"; 3481 warn "removing ext/exti commands";
2723 %EXTCMD = (); 3482 %EXTCMD = ();
3483 %EXTICMD = ();
2724 3484
2725 warn "unloading/nuking all extensions"; 3485 warn "unloading/nuking all extensions";
2726 for my $pkg (@EXTS) { 3486 for my $pkg (@EXTS) {
2727 warn "... unloading $pkg"; 3487 warn "... unloading $pkg";
2728 3488
… …
2771 warn "reloading cf.pm"; 3531 warn "reloading cf.pm";
2772 require cf; 3532 require cf;
2773 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3533 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2774 3534
2775 warn "loading config and database again"; 3535 warn "loading config and database again";
2776 cf::cfg_load; 3536 cf::reload_config;
2777 3537
2778 warn "loading extensions"; 3538 warn "loading extensions";
2779 cf::load_extensions; 3539 cf::load_extensions;
2780 3540
2781 warn "reattaching attachments to objects/players"; 3541 warn "reattaching attachments to objects/players";
… …
2801 3561
2802sub reload_perl() { 3562sub reload_perl() {
2803 # doing reload synchronously and two reloads happen back-to-back, 3563 # doing reload synchronously and two reloads happen back-to-back,
2804 # coro crashes during coro_state_free->destroy here. 3564 # coro crashes during coro_state_free->destroy here.
2805 3565
2806 $RELOAD_WATCHER ||= Event->timer ( 3566 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
2807 reentrant => 0,
2808 after => 0,
2809 data => WF_AUTOCANCEL,
2810 cb => sub {
2811 do_reload_perl; 3567 do_reload_perl;
2812 undef $RELOAD_WATCHER; 3568 undef $RELOAD_WATCHER;
2813 },
2814 ); 3569 };
2815} 3570}
2816 3571
2817register_command "reload" => sub { 3572register_command "reload" => sub {
2818 my ($who, $arg) = @_; 3573 my ($who, $arg) = @_;
2819 3574
2820 if ($who->flag (FLAG_WIZ)) { 3575 if ($who->flag (FLAG_WIZ)) {
2821 $who->message ("reloading server."); 3576 $who->message ("reloading server.");
3577 async {
3578 $Coro::current->{desc} = "perl_reload";
2822 async { reload_perl }; 3579 reload_perl;
3580 };
2823 } 3581 }
2824}; 3582};
2825 3583
2826unshift @INC, $LIBDIR; 3584unshift @INC, $LIBDIR;
2827 3585
… …
2846 my $signal = new Coro::Signal; 3604 my $signal = new Coro::Signal;
2847 push @WAIT_FOR_TICK_BEGIN, $signal; 3605 push @WAIT_FOR_TICK_BEGIN, $signal;
2848 $signal->wait; 3606 $signal->wait;
2849} 3607}
2850 3608
2851$TICK_WATCHER = Event->timer ( 3609$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
2852 reentrant => 0,
2853 parked => 1,
2854 prio => 0,
2855 at => $NEXT_TICK || $TICK,
2856 data => WF_AUTOCANCEL,
2857 cb => sub {
2858 if ($Coro::current != $Coro::main) { 3610 if ($Coro::current != $Coro::main) {
2859 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3611 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2860 unless ++$bug_warning > 10; 3612 unless ++$bug_warning > 10;
2861 return; 3613 return;
2862 } 3614 }
2863 3615
2864 $NOW = $tick_start = Event::time; 3616 $NOW = $tick_start = EV::now;
2865 3617
2866 cf::server_tick; # one server iteration 3618 cf::server_tick; # one server iteration
2867 3619
2868 $RUNTIME += $TICK; 3620 $RUNTIME += $TICK;
2869 $NEXT_TICK += $TICK; 3621 $NEXT_TICK = $_[0]->at;
2870 3622
2871 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3623 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2872 $NEXT_RUNTIME_WRITE = $NOW + 10; 3624 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2873 Coro::async_pool { 3625 Coro::async_pool {
3626 $Coro::current->{desc} = "runtime saver";
2874 write_runtime 3627 write_runtime
2875 or warn "ERROR: unable to write runtime file: $!"; 3628 or warn "ERROR: unable to write runtime file: $!";
2876 };
2877 } 3629 };
3630 }
2878 3631
2879# my $AFTER = Event::time;
2880# warn $AFTER - $NOW;#d#
2881
2882 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3632 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2883 $sig->send; 3633 $sig->send;
2884 } 3634 }
2885 while (my $sig = shift @WAIT_FOR_TICK) { 3635 while (my $sig = shift @WAIT_FOR_TICK) {
2886 $sig->send; 3636 $sig->send;
2887 } 3637 }
2888 3638
2889 $NOW = Event::time;
2890
2891 # if we are delayed by four ticks or more, skip them all
2892 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2893
2894 $TICK_WATCHER->at ($NEXT_TICK);
2895 $TICK_WATCHER->start;
2896
2897 $LOAD = ($NOW - $tick_start) / $TICK; 3639 $LOAD = ($NOW - $tick_start) / $TICK;
2898 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3640 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2899 3641
2900 _post_tick; 3642 _post_tick;
2901 3643};
2902 3644$TICK_WATCHER->priority (EV::MAXPRI);
2903 },
2904);
2905 3645
2906{ 3646{
2907 BDB::max_poll_time $TICK * 0.1; 3647 # configure BDB
2908 $BDB_POLL_WATCHER = Event->io ( 3648
2909 reentrant => 0,
2910 fd => BDB::poll_fileno,
2911 poll => 'r',
2912 prio => 0,
2913 data => WF_AUTOCANCEL,
2914 cb => \&BDB::poll_cb,
2915 );
2916 BDB::min_parallel 8; 3649 BDB::min_parallel 8;
2917 3650 BDB::max_poll_reqs $TICK * 0.1;
2918 BDB::set_sync_prepare { 3651 $Coro::BDB::WATCHER->priority (1);
2919 my $status;
2920 my $current = $Coro::current;
2921 (
2922 sub {
2923 $status = $!;
2924 $current->ready; undef $current;
2925 },
2926 sub {
2927 Coro::schedule while defined $current;
2928 $! = $status;
2929 },
2930 )
2931 };
2932 3652
2933 unless ($DB_ENV) { 3653 unless ($DB_ENV) {
2934 $DB_ENV = BDB::db_env_create; 3654 $DB_ENV = BDB::db_env_create;
3655 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3656 | BDB::LOG_AUTOREMOVE, 1);
3657 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3658 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2935 3659
2936 cf::sync_job { 3660 cf::sync_job {
2937 eval { 3661 eval {
2938 BDB::db_env_open 3662 BDB::db_env_open
2939 $DB_ENV, 3663 $DB_ENV,
… …
2941 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3665 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2942 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3666 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2943 0666; 3667 0666;
2944 3668
2945 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3669 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2946
2947 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2948 $DB_ENV->set_lk_detect;
2949 }; 3670 };
2950 3671
2951 cf::cleanup "db_env_open(db): $@" if $@; 3672 cf::cleanup "db_env_open(db): $@" if $@;
2952 }; 3673 };
2953 } 3674 }
3675
3676 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3677 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3678 };
3679 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3680 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3681 };
3682 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3683 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3684 };
2954} 3685}
2955 3686
2956{ 3687{
3688 # configure IO::AIO
3689
2957 IO::AIO::min_parallel 8; 3690 IO::AIO::min_parallel 8;
2958
2959 undef $Coro::AIO::WATCHER;
2960 IO::AIO::max_poll_time $TICK * 0.1; 3691 IO::AIO::max_poll_time $TICK * 0.1;
2961 $AIO_POLL_WATCHER = Event->io ( 3692 $Coro::AIO::WATCHER->priority (1);
2962 reentrant => 0,
2963 data => WF_AUTOCANCEL,
2964 fd => IO::AIO::poll_fileno,
2965 poll => 'r',
2966 prio => 6,
2967 cb => \&IO::AIO::poll_cb,
2968 );
2969} 3693}
2970 3694
2971my $_log_backtrace; 3695my $_log_backtrace;
2972 3696
2973sub _log_backtrace { 3697sub _log_backtrace {
… …
2977 3701
2978 # limit the # of concurrent backtraces 3702 # limit the # of concurrent backtraces
2979 if ($_log_backtrace < 2) { 3703 if ($_log_backtrace < 2) {
2980 ++$_log_backtrace; 3704 ++$_log_backtrace;
2981 async { 3705 async {
3706 $Coro::current->{desc} = "abt $msg";
3707
2982 my @bt = fork_call { 3708 my @bt = fork_call {
2983 @addr = map { sprintf "%x", $_ } @addr; 3709 @addr = map { sprintf "%x", $_ } @addr;
2984 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3710 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
2985 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3711 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
2986 or die "addr2line: $!"; 3712 or die "addr2line: $!";

Diff Legend

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