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.310 by elmex, Mon Jul 16 15:43:49 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
25use JSON::XS 1.4 (); 27use JSON::XS 2.01 ();
26use BDB (); 28use BDB ();
27use Data::Dumper; 29use Data::Dumper;
28use Digest::MD5; 30use Digest::MD5;
29use Fcntl; 31use Fcntl;
30use YAML::Syck (); 32use YAML ();
31use IO::AIO 2.32 (); 33use IO::AIO 2.51 ();
32use Time::HiRes; 34use Time::HiRes;
33use Compress::LZF; 35use Compress::LZF;
34use Digest::MD5 (); 36use Digest::MD5 ();
35 37
36# configure various modules to our taste 38# configure various modules to our taste
37# 39#
38$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
39Coro::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
40Compress::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
41
42$Event::Eval = 1; # no idea why this is required, but it is
43
44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
45$YAML::Syck::ImplicitUnicode = 1;
46 43
47$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
48 45
49sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 46sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
50 47
… …
69our $TMPDIR = "$LOCALDIR/" . tmpdir; 66our $TMPDIR = "$LOCALDIR/" . tmpdir;
70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
71our $PLAYERDIR = "$LOCALDIR/" . playerdir; 68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
72our $RANDOMDIR = "$LOCALDIR/random"; 69our $RANDOMDIR = "$LOCALDIR/random";
73our $BDBDIR = "$LOCALDIR/db"; 70our $BDBDIR = "$LOCALDIR/db";
71our %RESOURCE;
74 72
75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 73our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
76our $TICK_WATCHER; 74our $TICK_WATCHER;
77our $AIO_POLL_WATCHER; 75our $AIO_POLL_WATCHER;
78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 76our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
79our $NEXT_TICK; 77our $NEXT_TICK;
80our $NOW;
81our $USE_FSYNC = 1; # use fsync to write maps - default off 78our $USE_FSYNC = 1; # use fsync to write maps - default off
82 79
83our $BDB_POLL_WATCHER; 80our $BDB_POLL_WATCHER;
81our $BDB_DEADLOCK_WATCHER;
82our $BDB_CHECKPOINT_WATCHER;
83our $BDB_TRICKLE_WATCHER;
84our $DB_ENV; 84our $DB_ENV;
85 85
86our %CFG; 86our %CFG;
87 87
88our $UPTIME; $UPTIME ||= time; 88our $UPTIME; $UPTIME ||= time;
89our $RUNTIME; 89our $RUNTIME;
90our $NOW;
90 91
91our %PLAYER; # all users 92our (%PLAYER, %PLAYER_LOADING); # all users
92our %MAP; # all maps 93our (%MAP, %MAP_LOADING ); # all maps
93our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
94 95
95# 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 ∕
96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97 98
… …
158 159
159The raw value load value from the last tick. 160The raw value load value from the last tick.
160 161
161=item %cf::CFG 162=item %cf::CFG
162 163
163Configuration for the server, loaded from C</etc/crossfire/config>, or 164Configuration for the server, loaded from C</etc/deliantra-server/config>, or
164from wherever your confdir points to. 165from wherever your confdir points to.
165 166
166=item cf::wait_for_tick, cf::wait_for_tick_begin 167=item cf::wait_for_tick, cf::wait_for_tick_begin
167 168
168These 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
… …
186 $msg .= "\n" 187 $msg .= "\n"
187 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
188 189
189 $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;
190 191
191 utf8::encode $msg;
192 LOG llevError, $msg; 192 LOG llevError, $msg;
193 }; 193 };
194} 194}
195
196$Coro::State::DIEHOOK = sub {
197 warn Carp::longmess $_[0];
198 Coro::terminate;
199};
195 200
196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 201@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
197@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 202@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
198@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 203@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
199@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 204@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
212)) { 217)) {
213 no strict 'refs'; 218 no strict 'refs';
214 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 219 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
215} 220}
216 221
217$Event::DIED = sub { 222$EV::DIED = sub {
218 warn "error in event callback: @_"; 223 warn "error in event callback: @_";
219}; 224};
220 225
221############################################################################# 226#############################################################################
222 227
… …
245 $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;
246 $d 251 $d
247 } || "[unable to dump $_[0]: '$@']"; 252 } || "[unable to dump $_[0]: '$@']";
248} 253}
249 254
250=item $ref = cf::from_json $json 255=item $ref = cf::decode_json $json
251 256
252Converts a JSON string into the corresponding perl data structure. 257Converts a JSON string into the corresponding perl data structure.
253 258
254=item $json = cf::to_json $ref 259=item $json = cf::encode_json $ref
255 260
256Converts a perl data structure into its JSON representation. 261Converts a perl data structure into its JSON representation.
257 262
258=cut 263=cut
259 264
260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 265our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
261 266
262sub to_json ($) { $json_coder->encode ($_[0]) } 267sub encode_json($) { $json_coder->encode ($_[0]) }
263sub from_json ($) { $json_coder->decode ($_[0]) } 268sub decode_json($) { $json_coder->decode ($_[0]) }
264 269
265=item cf::lock_wait $string 270=item cf::lock_wait $string
266 271
267Wait until the given lock is available. See cf::lock_acquire. 272Wait until the given lock is available. See cf::lock_acquire.
268 273
… …
271Wait 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
272a 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,
273for example when the coroutine gets canceled), the lock is automatically 278for example when the coroutine gets canceled), the lock is automatically
274returned. 279returned.
275 280
281Locks are *not* recursive, locking from the same coro twice results in a
282deadlocked coro.
283
276Lock 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
277uses map_find and cf::map::load uses map_load). 285uses map_find and cf::map::load uses map_load).
278 286
279=item $locked = cf::lock_active $string 287=item $locked = cf::lock_active $string
280 288
281Return 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.
282 290
283=cut 291=cut
284 292
285our %LOCK; 293our %LOCK;
294our %LOCKER;#d#
286 295
287sub lock_wait($) { 296sub lock_wait($) {
288 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#
289 303
290 # wait for lock, if any 304 # wait for lock, if any
291 while ($LOCK{$key}) { 305 while ($LOCK{$key}) {
292 push @{ $LOCK{$key} }, $Coro::current; 306 push @{ $LOCK{$key} }, $Coro::current;
293 Coro::schedule; 307 Coro::schedule;
… …
299 313
300 # wait, to be sure we are not locked 314 # wait, to be sure we are not locked
301 lock_wait $key; 315 lock_wait $key;
302 316
303 $LOCK{$key} = []; 317 $LOCK{$key} = [];
318 $LOCKER{$key} = $Coro::current;#d#
304 319
305 Coro::guard { 320 Coro::guard {
321 delete $LOCKER{$key};#d#
306 # wake up all waiters, to be on the safe side 322 # wake up all waiters, to be on the safe side
307 $_->ready for @{ delete $LOCK{$key} }; 323 $_->ready for @{ delete $LOCK{$key} };
308 } 324 }
309} 325}
310 326
… …
322 }; 338 };
323 $TICK_WATCHER->stop; 339 $TICK_WATCHER->stop;
324 $guard 340 $guard
325} 341}
326 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
327=item cf::async { BLOCK } 416=item cf::async { BLOCK }
328 417
329Currently the same as Coro::async_pool, meaning you cannot use 418Currently the same as Coro::async_pool, meaning you cannot use
330C<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
331thing you are allowed to do is call C<prio> on it. 420thing you are allowed to do is call C<prio> on it.
… …
334 423
335BEGIN { *async = \&Coro::async_pool } 424BEGIN { *async = \&Coro::async_pool }
336 425
337=item cf::sync_job { BLOCK } 426=item cf::sync_job { BLOCK }
338 427
339The design of Crossfire TRT requires that the main coroutine ($Coro::main) 428The design of Deliantra requires that the main coroutine ($Coro::main)
340is always able to handle events or runnable, as Crossfire TRT is only 429is always able to handle events or runnable, as Deliantra is only
341partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 430partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
342acceptable. 431acceptable.
343 432
344If 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
345the given BLOCK in another coroutine while waiting for the result. The 434the given BLOCK in another coroutine while waiting for the result. The
… …
350 439
351sub sync_job(&) { 440sub sync_job(&) {
352 my ($job) = @_; 441 my ($job) = @_;
353 442
354 if ($Coro::current == $Coro::main) { 443 if ($Coro::current == $Coro::main) {
355 my $time = Event::time; 444 my $time = EV::time;
356 445
357 # this is the main coro, too bad, we have to block 446 # this is the main coro, too bad, we have to block
358 # till the operation succeeds, freezing the server :/ 447 # till the operation succeeds, freezing the server :/
359 448
449 LOG llevError, Carp::longmess "sync job";#d#
450
360 # TODO: use suspend/resume instead 451 # TODO: use suspend/resume instead
361 # (but this is cancel-safe) 452 # (but this is cancel-safe)
362 my $freeze_guard = freeze_mainloop; 453 my $freeze_guard = freeze_mainloop;
363 454
364 my $busy = 1; 455 my $busy = 1;
365 my @res; 456 my @res;
366 457
367 (async { 458 (async {
459 $Coro::current->desc ("sync job coro");
368 @res = eval { $job->() }; 460 @res = eval { $job->() };
369 warn $@ if $@; 461 warn $@ if $@;
370 undef $busy; 462 undef $busy;
371 })->prio (Coro::PRIO_MAX); 463 })->prio (Coro::PRIO_MAX);
372 464
373 while ($busy) { 465 while ($busy) {
374 Coro::cede or Event::one_event; 466 if (Coro::nready) {
467 Coro::cede_notself;
468 } else {
469 EV::loop EV::LOOP_ONESHOT;
375 } 470 }
471 }
376 472
377 $time = Event::time - $time; 473 $time = EV::time - $time;
378 474
379 LOG llevError | logBacktrace, Carp::longmess "long sync job" 475 LOG llevError | logBacktrace, Carp::longmess "long sync job"
380 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 476 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
381 477
382 $tick_start += $time; # do not account sync jobs to server load 478 $tick_start += $time; # do not account sync jobs to server load
… …
412=item fork_call { }, $args 508=item fork_call { }, $args
413 509
414Executes the given code block with the given arguments in a seperate 510Executes the given code block with the given arguments in a seperate
415process, returning the results. Everything must be serialisable with 511process, returning the results. Everything must be serialisable with
416Coro::Storable. May, of course, block. Note that the executed sub may 512Coro::Storable. May, of course, block. Note that the executed sub may
417never block itself or use any form of Event handling. 513never block itself or use any form of event handling.
418 514
419=cut 515=cut
420
421sub _store_scalar {
422 open my $fh, ">", \my $buf
423 or die "fork_call: cannot open fh-to-buf in child : $!";
424 Storable::store_fd $_[0], $fh;
425 close $fh;
426
427 $buf
428}
429 516
430sub fork_call(&@) { 517sub fork_call(&@) {
431 my ($cb, @args) = @_; 518 my ($cb, @args) = @_;
432 519
433# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 520 # we seemingly have to make a local copy of the whole thing,
434# or die "socketpair: $!"; 521 # otherwise perl prematurely frees the stuff :/
435 pipe my $fh1, my $fh2 522 # TODO: investigate and fix (likely this will be rather laborious)
436 or die "pipe: $!";
437 523
438 if (my $pid = fork) { 524 my @res = Coro::Util::fork_eval {
439 close $fh2;
440
441 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
442 warn "pst<$res>" unless $res =~ /^pst/;
443 $res = Coro::Storable::thaw $res;
444
445 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
446
447 Carp::confess $$res unless "ARRAY" eq ref $res;
448
449 return wantarray ? @$res : $res->[-1];
450 } else {
451 reset_signals; 525 reset_signals;
452 local $SIG{__WARN__}; 526 &$cb
453 local $SIG{__DIE__}; 527 }, @args;
454 # just in case, this hack effectively disables event
455 # in the child. cleaner and slower would be canceling all watchers,
456 # but this works for the time being.
457 local $Coro::idle;
458 $Coro::current->prio (Coro::PRIO_MAX);
459 528
460 eval { 529 wantarray ? @res : $res[-1]
461 close $fh1;
462
463 my @res = eval { $cb->(@args) };
464
465 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
466 close $fh2;
467 };
468
469 warn $@ if $@;
470 _exit 0;
471 }
472} 530}
473 531
474=item $value = cf::db_get $family => $key 532=item $value = cf::db_get $family => $key
475 533
476Returns a single value from the environment database. 534Returns a single value from the environment database.
… …
478=item cf::db_put $family => $key => $value 536=item cf::db_put $family => $key => $value
479 537
480Stores the given C<$value> in the family. It can currently store binary 538Stores the given C<$value> in the family. It can currently store binary
481data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 539data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
482 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
483=cut 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 $!;
559 };
560 cf::cleanup "db_open(db): $@" if $@;
561
562 $db
563}
484 564
485our $DB; 565our $DB;
486 566
487sub db_init { 567sub db_init {
488 unless ($DB) {
489 $DB = BDB::db_create $DB_ENV;
490
491 cf::sync_job { 568 cf::sync_job {
492 eval { 569 $DB ||= db_table "db";
493 $DB->set_flags (BDB::CHKSUM);
494
495 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
496 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
497 cf::cleanup "db_open(db): $!" if $!;
498 };
499 cf::cleanup "db_open(db): $@" if $@;
500 };
501 } 570 };
502} 571}
503 572
504sub db_get($$) { 573sub db_get($$) {
505 my $key = "$_[0]/$_[1]"; 574 my $key = "$_[0]/$_[1]";
506 575
… …
556 if (1) { 625 if (1) {
557 $md5 = 626 $md5 =
558 join "\x00", 627 join "\x00",
559 $processversion, 628 $processversion,
560 map { 629 map {
561 Coro::cede; 630 cf::cede_to_tick;
562 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 631 ($src->[$_], Digest::MD5::md5_hex $data[$_])
563 } 0.. $#$src; 632 } 0.. $#$src;
564 633
565 634
566 my $dbmd5 = db_get cache => "$id/md5"; 635 my $dbmd5 = db_get cache => "$id/md5";
… …
610attach callbacks/event handlers (a collection of which is called an "attachment") 679attach callbacks/event handlers (a collection of which is called an "attachment")
611to it. All such attachable objects support the following methods. 680to it. All such attachable objects support the following methods.
612 681
613In 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>
614C<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
615Crossfire TRT). 684Deliantra).
616 685
617=over 4 686=over 4
618 687
619=item $attachable->attach ($attachment, key => $value...) 688=item $attachable->attach ($attachment, key => $value...)
620 689
… …
902 } 971 }
903 972
904 0 973 0
905} 974}
906 975
907=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 976=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
908 977
909=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 978=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
910 979
911Generate an object-specific event with the given arguments. 980Generate an object-specific event with the given arguments.
912 981
… …
918 987
919=cut 988=cut
920 989
921############################################################################# 990#############################################################################
922# 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}
923 1034
924sub reattach { 1035sub reattach {
925 # basically do the same as instantiate, without calling instantiate 1036 # basically do the same as instantiate, without calling instantiate
926 my ($obj) = @_; 1037 my ($obj) = @_;
927 1038
… …
948cf::attachable->attach ( 1059cf::attachable->attach (
949 prio => -1000000, 1060 prio => -1000000,
950 on_instantiate => sub { 1061 on_instantiate => sub {
951 my ($obj, $data) = @_; 1062 my ($obj, $data) = @_;
952 1063
953 $data = from_json $data; 1064 $data = decode_json $data;
954 1065
955 for (@$data) { 1066 for (@$data) {
956 my ($name, $args) = @$_; 1067 my ($name, $args) = @$_;
957 1068
958 $obj->attach ($name, %{$args || {} }); 1069 $obj->attach ($name, %{$args || {} });
… …
974sub object_freezer_save { 1085sub object_freezer_save {
975 my ($filename, $rdata, $objs) = @_; 1086 my ($filename, $rdata, $objs) = @_;
976 1087
977 sync_job { 1088 sync_job {
978 if (length $$rdata) { 1089 if (length $$rdata) {
1090 utf8::decode (my $decname = $filename);
979 warn sprintf "saving %s (%d,%d)\n", 1091 warn sprintf "saving %s (%d,%d)\n",
980 $filename, length $$rdata, scalar @$objs; 1092 $decname, length $$rdata, scalar @$objs;
981 1093
982 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1094 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
983 chmod SAVE_MODE, $fh; 1095 chmod SAVE_MODE, $fh;
984 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1096 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
985 aio_fsync $fh if $cf::USE_FSYNC; 1097 aio_fsync $fh if $cf::USE_FSYNC;
986 close $fh; 1098 close $fh;
987 1099
988 if (@$objs) { 1100 if (@$objs) {
989 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) {
990 chmod SAVE_MODE, $fh; 1102 chmod SAVE_MODE, $fh;
991 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1103 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
992 aio_write $fh, 0, (length $data), $data, 0; 1104 aio_write $fh, 0, (length $data), $data, 0;
993 aio_fsync $fh if $cf::USE_FSYNC; 1105 aio_fsync $fh if $cf::USE_FSYNC;
994 close $fh; 1106 close $fh;
995 aio_rename "$filename.pst~", "$filename.pst"; 1107 aio_rename "$filename.pst~", "$filename.pst";
996 } 1108 }
… …
1004 } 1116 }
1005 } else { 1117 } else {
1006 aio_unlink $filename; 1118 aio_unlink $filename;
1007 aio_unlink "$filename.pst"; 1119 aio_unlink "$filename.pst";
1008 } 1120 }
1009 } 1121 };
1010} 1122}
1011 1123
1012sub object_freezer_as_string { 1124sub object_freezer_as_string {
1013 my ($rdata, $objs) = @_; 1125 my ($rdata, $objs) = @_;
1014 1126
… …
1026 or return; 1138 or return;
1027 1139
1028 unless (aio_stat "$filename.pst") { 1140 unless (aio_stat "$filename.pst") {
1029 (aio_load "$filename.pst", $av) >= 0 1141 (aio_load "$filename.pst", $av) >= 0
1030 or return; 1142 or return;
1143
1031 $av = eval { (Storable::thaw $av)->{objs} }; 1144 my $st = eval { Coro::Storable::thaw $av };
1145 $av = $st->{objs};
1032 } 1146 }
1033 1147
1148 utf8::decode (my $decname = $filename);
1034 warn sprintf "loading %s (%d)\n", 1149 warn sprintf "loading %s (%d,%d)\n",
1035 $filename, length $data, scalar @{$av || []}; 1150 $decname, length $data, scalar @{$av || []};
1151
1036 return ($data, $av); 1152 ($data, $av)
1037} 1153}
1038 1154
1039=head2 COMMAND CALLBACKS 1155=head2 COMMAND CALLBACKS
1040 1156
1041=over 4 1157=over 4
… …
1114 my ($pl, $buf) = @_; 1230 my ($pl, $buf) = @_;
1115 1231
1116 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1232 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1117 1233
1118 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
1119 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1242 if (my $cb = $EXTCMD{$type}) {
1120 if (my %reply = $cb->($pl, $msg)) { 1243 @reply = $cb->($pl, @payload);
1121 $pl->ext_reply ($msg->{msgid}, %reply);
1122 }
1123 } 1244 }
1245
1246 $pl->ext_reply ($reply, @reply)
1247 if $reply;
1248
1124 } else { 1249 } else {
1125 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1250 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1126 } 1251 }
1127 1252
1128 cf::override; 1253 cf::override;
… …
1218 1343
1219=head3 cf::player 1344=head3 cf::player
1220 1345
1221=over 4 1346=over 4
1222 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}
1361
1223=item cf::player::find $login 1362=item cf::player::find $login
1224 1363
1225Returns the given player object, loading it if necessary (might block). 1364Returns the given player object, loading it if necessary (might block).
1226 1365
1227=cut 1366=cut
… …
1262 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1401 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1263 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1402 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1264 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1403 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1265 aio_unlink +(playerdir $login) . "/$login.pl"; 1404 aio_unlink +(playerdir $login) . "/$login.pl";
1266 1405
1267 my $pl = load_pl path $login 1406 my $f = new_from_file cf::object::thawer path $login
1268 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;
1269 $cf::PLAYER{$login} = $pl 1413 $cf::PLAYER{$login} = $pl
1270 } 1414 }
1271 } 1415 }
1272} 1416}
1273 1417
… …
1283 1427
1284 aio_mkdir playerdir $pl, 0770; 1428 aio_mkdir playerdir $pl, 0770;
1285 $pl->{last_save} = $cf::RUNTIME; 1429 $pl->{last_save} = $cf::RUNTIME;
1286 1430
1287 $pl->save_pl ($path); 1431 $pl->save_pl ($path);
1288 Coro::cede; 1432 cf::cede_to_tick;
1289} 1433}
1290 1434
1291sub new($) { 1435sub new($) {
1292 my ($login) = @_; 1436 my ($login) = @_;
1293 1437
… …
1297 $self->{deny_save} = 1; 1441 $self->{deny_save} = 1;
1298 1442
1299 $cf::PLAYER{$login} = $self; 1443 $cf::PLAYER{$login} = $self;
1300 1444
1301 $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 (@_);
1302} 1456}
1303 1457
1304=item $pl->quit_character 1458=item $pl->quit_character
1305 1459
1306Nukes the player without looking back. If logged in, the connection will 1460Nukes the player without looking back. If logged in, the connection will
… …
1361 or return []; 1515 or return [];
1362 1516
1363 my @logins; 1517 my @logins;
1364 1518
1365 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") {
1366 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1524 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1367 aio_read $fh, 0, 512, my $buf, 0 or next; 1525 aio_read $fh, 0, 512, my $buf, 0 or next;
1368 $buf !~ /^password -------------$/m or next; # official not-valid tag 1526 $buf !~ /^password -------------$/m or next; # official not-valid tag
1527 }
1369 1528
1370 utf8::decode $login; 1529 utf8::decode $login;
1371 push @logins, $login; 1530 push @logins, $login;
1372 } 1531 }
1373 1532
… …
1406 1565
1407Expand crossfire pod fragments into protocol xml. 1566Expand crossfire pod fragments into protocol xml.
1408 1567
1409=cut 1568=cut
1410 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
1411sub expand_cfpod { 1581sub expand_cfpod {
1412 ((my $self), (local $_)) = @_; 1582 my ($self, $pod) = @_;
1413 1583
1414 # escape & and < 1584 my $xml;
1415 s/&/&amp;/g;
1416 s/(?<![BIUGH])</&lt;/g;
1417 1585
1418 # this is buggy, it needs to properly take care of nested <'s 1586 while () {
1587 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1588 $group = $1;
1419 1589
1420 1 while 1590 $group =~ s/&/&amp;/g;
1421 # replace B<>, I<>, U<> etc. 1591 $group =~ s/</&lt;/g;
1422 s/B<([^\>]*)>/<b>$1<\/b>/ 1592
1423 || s/I<([^\>]*)>/<i>$1<\/i>/ 1593 $xml .= $group;
1424 || s/U<([^\>]*)>/<u>$1<\/u>/ 1594 } elsif ($pod =~ m%\G
1425 # replace G<male|female> tags 1595 ([BCGHITU])
1426 || s{G<([^>|]*)\|([^>]*)>}{ 1596 <
1427 $self->gender ? $2 : $1 1597 (?:
1428 }ge 1598 ([^<>]*) (?{ $group = $^N })
1429 # replace H<hint text> 1599 | < $interior >
1430 || s{H<([^\>]*)>} 1600 )
1601 >
1602 %gcsx
1431 { 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") {
1432 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1621 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1433 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1622 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1434 "") 1623 "")
1435 [$self->{hintmode}] 1624 [$self->{hintmode}];
1625 } else {
1626 $xml .= "error processing '$code($data)' directive";
1436 }ge; 1627 }
1628 } else {
1629 if ($pod =~ /\G(.+)/) {
1630 warn "parse error while expanding $pod (at $1)";
1631 }
1632 last;
1633 }
1634 }
1437 1635
1636 for ($xml) {
1438 # create single paragraphs (very hackish) 1637 # create single paragraphs (very hackish)
1439 s/(?<=\S)\n(?=\w)/ /g; 1638 s/(?<=\S)\n(?=\w)/ /g;
1440 1639
1441 # compress some whitespace 1640 # compress some whitespace
1442 s/\s+\n/\n/g; # ws line-ends 1641 s/\s+\n/\n/g; # ws line-ends
1443 s/\n\n+/\n/g; # double lines 1642 s/\n\n+/\n/g; # double lines
1444 s/^\n+//; # beginning lines 1643 s/^\n+//; # beginning lines
1445 s/\n+$//; # ending lines 1644 s/\n+$//; # ending lines
1645 }
1446 1646
1447 $_ 1647 $xml
1448} 1648}
1649
1650no re 'eval';
1449 1651
1450sub hintmode { 1652sub hintmode {
1451 $_[0]{hintmode} = $_[1] if @_ > 1; 1653 $_[0]{hintmode} = $_[1] if @_ > 1;
1452 $_[0]{hintmode} 1654 $_[0]{hintmode}
1453} 1655}
1454 1656
1455=item $player->ext_reply ($msgid, %msg) 1657=item $player->ext_reply ($msgid, @msg)
1456 1658
1457Sends an ext reply to the player. 1659Sends an ext reply to the player.
1458 1660
1459=cut 1661=cut
1460 1662
1461sub ext_reply($$%) { 1663sub ext_reply($$@) {
1462 my ($self, $id, %msg) = @_; 1664 my ($self, $id, @msg) = @_;
1463 1665
1464 $msg{msgid} = $id; 1666 $self->ns->ext_reply ($id, @msg)
1465 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1466} 1667}
1467 1668
1468=item $player->ext_event ($type, %msg) 1669=item $player->ext_msg ($type, @msg)
1469 1670
1470Sends an ext event to the client. 1671Sends an ext event to the client.
1471 1672
1472=cut 1673=cut
1473 1674
1474sub ext_event($$%) { 1675sub ext_msg($$@) {
1475 my ($self, $type, %msg) = @_; 1676 my ($self, $type, @msg) = @_;
1476 1677
1477 $self->ns->ext_event ($type, %msg); 1678 $self->ns->ext_msg ($type, @msg);
1478} 1679}
1479 1680
1480=head3 cf::region 1681=head3 cf::region
1481 1682
1482=over 4 1683=over 4
… …
1698 1899
1699sub load_header_from($) { 1900sub load_header_from($) {
1700 my ($self, $path) = @_; 1901 my ($self, $path) = @_;
1701 1902
1702 utf8::encode $path; 1903 utf8::encode $path;
1703 #aio_open $path, O_RDONLY, 0 1904 my $f = new_from_file cf::object::thawer $path
1704 # or return;
1705
1706 $self->_load_header ($path)
1707 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;
1708 1912
1709 $self->{load_path} = $path; 1913 $self->{load_path} = $path;
1710 1914
1711 1 1915 1
1712} 1916}
… …
1766sub find { 1970sub find {
1767 my ($path, $origin) = @_; 1971 my ($path, $origin) = @_;
1768 1972
1769 $path = normalise $path, $origin && $origin->path; 1973 $path = normalise $path, $origin && $origin->path;
1770 1974
1975 cf::lock_wait "map_data:$path";#d#remove
1771 cf::lock_wait "map_find:$path"; 1976 cf::lock_wait "map_find:$path";
1772 1977
1773 $cf::MAP{$path} || do { 1978 $cf::MAP{$path} || do {
1774 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
1775 my $map = new_from_path cf::map $path 1982 my $map = new_from_path cf::map $path
1776 or return; 1983 or return;
1777 1984
1778 $map->{last_save} = $cf::RUNTIME; 1985 $map->{last_save} = $cf::RUNTIME;
1779 1986
… …
1781 or return; 1988 or return;
1782 1989
1783 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1990 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1784 # doing this can freeze the server in a sync job, obviously 1991 # doing this can freeze the server in a sync job, obviously
1785 #$cf::WAIT_FOR_TICK->wait; 1992 #$cf::WAIT_FOR_TICK->wait;
1993 undef $guard1;
1994 undef $guard2;
1786 $map->reset; 1995 $map->reset;
1787 undef $guard;
1788 return find $path; 1996 return find $path;
1789 } 1997 }
1790 1998
1791 $cf::MAP{$path} = $map 1999 $cf::MAP{$path} = $map
1792 } 2000 }
… …
1801 local $self->{deny_reset} = 1; # loading can take a long time 2009 local $self->{deny_reset} = 1; # loading can take a long time
1802 2010
1803 my $path = $self->{path}; 2011 my $path = $self->{path};
1804 2012
1805 { 2013 {
1806 my $guard = cf::lock_acquire "map_load:$path"; 2014 my $guard = cf::lock_acquire "map_data:$path";
1807 2015
2016 return unless $self->valid;
1808 return if $self->in_memory != cf::MAP_SWAPPED; 2017 return unless $self->in_memory == cf::MAP_SWAPPED;
1809 2018
1810 $self->in_memory (cf::MAP_LOADING); 2019 $self->in_memory (cf::MAP_LOADING);
1811 2020
1812 $self->alloc; 2021 $self->alloc;
1813 2022
1814 $self->pre_load; 2023 $self->pre_load;
1815 Coro::cede; 2024 cf::cede_to_tick;
1816 2025
2026 my $f = new_from_file cf::object::thawer $self->{load_path};
2027 $f->skip_block;
1817 $self->_load_objects ($self->{load_path}, 1) 2028 $self->_load_objects ($f)
1818 or return; 2029 or return;
1819 2030
1820 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2031 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1821 if delete $self->{load_original}; 2032 if delete $self->{load_original};
1822 2033
1823 if (my $uniq = $self->uniq_path) { 2034 if (my $uniq = $self->uniq_path) {
1824 utf8::encode $uniq; 2035 utf8::encode $uniq;
1825 if (aio_open $uniq, O_RDONLY, 0) { 2036 unless (aio_stat $uniq) {
2037 if (my $f = new_from_file cf::object::thawer $uniq) {
1826 $self->clear_unique_items; 2038 $self->clear_unique_items;
1827 $self->_load_objects ($uniq, 0); 2039 $self->_load_objects ($f);
2040 $f->resolve_delayed_derefs;
2041 }
1828 } 2042 }
1829 } 2043 }
1830 2044
1831 Coro::cede; 2045 $f->resolve_delayed_derefs;
2046
2047 cf::cede_to_tick;
1832 # now do the right thing for maps 2048 # now do the right thing for maps
1833 $self->link_multipart_objects; 2049 $self->link_multipart_objects;
1834 $self->difficulty ($self->estimate_difficulty) 2050 $self->difficulty ($self->estimate_difficulty)
1835 unless $self->difficulty; 2051 unless $self->difficulty;
1836 Coro::cede; 2052 cf::cede_to_tick;
1837 2053
1838 unless ($self->{deny_activate}) { 2054 unless ($self->{deny_activate}) {
1839 $self->decay_objects; 2055 $self->decay_objects;
1840 $self->fix_auto_apply; 2056 $self->fix_auto_apply;
1841 $self->update_buttons; 2057 $self->update_buttons;
1842 Coro::cede; 2058 cf::cede_to_tick;
1843 $self->set_darkness_map; 2059 $self->set_darkness_map;
1844 Coro::cede; 2060 cf::cede_to_tick;
1845 $self->activate; 2061 $self->activate;
1846 } 2062 }
2063
2064 $self->{last_save} = $cf::RUNTIME;
2065 $self->last_access ($cf::RUNTIME);
1847 2066
1848 $self->in_memory (cf::MAP_IN_MEMORY); 2067 $self->in_memory (cf::MAP_IN_MEMORY);
1849 } 2068 }
1850 2069
1851 $self->post_load; 2070 $self->post_load;
… …
1862 2081
1863 $self 2082 $self
1864} 2083}
1865 2084
1866# 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
1867sub load_diag { 2086sub load_neighbours {
1868 my ($map) = @_; 2087 my ($map) = @_;
1869 2088
1870 my @diag; # diagonal neighbours 2089 my @neigh; # diagonal neighbours
1871 2090
1872 for (0 .. 3) { 2091 for (0 .. 3) {
1873 my $neigh = $map->tile_path ($_) 2092 my $neigh = $map->tile_path ($_)
1874 or next; 2093 or next;
1875 $neigh = find $neigh, $map 2094 $neigh = find $neigh, $map
1876 or next; 2095 or next;
1877 $neigh->load; 2096 $neigh->load;
1878 2097
2098 push @neigh,
1879 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2099 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1880 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2100 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1881 } 2101 }
1882 2102
1883 for (@diag) { 2103 for (grep defined $_->[0], @neigh) {
2104 my ($path, $origin) = @$_;
1884 my $neigh = find @$_ 2105 my $neigh = find $path, $origin
1885 or next; 2106 or next;
1886 $neigh->load; 2107 $neigh->load;
1887 } 2108 }
1888} 2109}
1889 2110
… …
1894} 2115}
1895 2116
1896sub do_load_sync { 2117sub do_load_sync {
1897 my ($map) = @_; 2118 my ($map) = @_;
1898 2119
2120 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2121 if $Coro::current == $Coro::main;
2122
1899 cf::sync_job { $map->load }; 2123 cf::sync_job { $map->load };
1900} 2124}
1901 2125
1902our %MAP_PREFETCH; 2126our %MAP_PREFETCH;
1903our $MAP_PREFETCHER = undef; 2127our $MAP_PREFETCHER = undef;
1904 2128
1905sub find_async { 2129sub find_async {
1906 my ($path, $origin) = @_; 2130 my ($path, $origin, $load) = @_;
1907 2131
1908 $path = normalise $path, $origin && $origin->{path}; 2132 $path = normalise $path, $origin && $origin->{path};
1909 2133
1910 if (my $map = $cf::MAP{$path}) { 2134 if (my $map = $cf::MAP{$path}) {
1911 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2135 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1912 } 2136 }
1913 2137
1914 undef $MAP_PREFETCH{$path}; 2138 $MAP_PREFETCH{$path} |= $load;
2139
1915 $MAP_PREFETCHER ||= cf::async { 2140 $MAP_PREFETCHER ||= cf::async {
2141 $Coro::current->{desc} = "map prefetcher";
2142
1916 while (%MAP_PREFETCH) { 2143 while (%MAP_PREFETCH) {
1917 for my $path (keys %MAP_PREFETCH) { 2144 while (my ($k, $v) = each %MAP_PREFETCH) {
1918 if (my $map = find $path) { 2145 if (my $map = find $k) {
1919 $map->load; 2146 $map->load if $v;
1920 } 2147 }
1921 2148
1922 delete $MAP_PREFETCH{$path}; 2149 delete $MAP_PREFETCH{$k};
1923 } 2150 }
1924 } 2151 }
1925 undef $MAP_PREFETCHER; 2152 undef $MAP_PREFETCHER;
1926 }; 2153 };
1927 $MAP_PREFETCHER->prio (6); 2154 $MAP_PREFETCHER->prio (6);
… …
1930} 2157}
1931 2158
1932sub save { 2159sub save {
1933 my ($self) = @_; 2160 my ($self) = @_;
1934 2161
1935 my $lock = cf::lock_acquire "map_data:" . $self->path; 2162 my $lock = cf::lock_acquire "map_data:$self->{path}";
1936 2163
1937 $self->{last_save} = $cf::RUNTIME; 2164 $self->{last_save} = $cf::RUNTIME;
1938 2165
1939 return unless $self->dirty; 2166 return unless $self->dirty;
1940 2167
… …
1946 return if $self->{deny_save}; 2173 return if $self->{deny_save};
1947 2174
1948 local $self->{last_access} = $self->last_access;#d# 2175 local $self->{last_access} = $self->last_access;#d#
1949 2176
1950 cf::async { 2177 cf::async {
2178 $Coro::current->{desc} = "map player save";
1951 $_->contr->save for $self->players; 2179 $_->contr->save for $self->players;
1952 }; 2180 };
1953 2181
1954 if ($uniq) { 2182 if ($uniq) {
1955 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2183 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1963 my ($self) = @_; 2191 my ($self) = @_;
1964 2192
1965 # save first because save cedes 2193 # save first because save cedes
1966 $self->save; 2194 $self->save;
1967 2195
1968 my $lock = cf::lock_acquire "map_data:" . $self->path; 2196 my $lock = cf::lock_acquire "map_data:$self->{path}";
1969 2197
1970 return if $self->players; 2198 return if $self->players;
1971 return if $self->in_memory != cf::MAP_IN_MEMORY; 2199 return if $self->in_memory != cf::MAP_IN_MEMORY;
1972 return if $self->{deny_save}; 2200 return if $self->{deny_save};
1973 2201
2202 $self->in_memory (cf::MAP_SWAPPED);
2203
2204 $self->deactivate;
2205 $_->clear_links_to ($self) for values %cf::MAP;
1974 $self->clear; 2206 $self->clear;
1975 $self->in_memory (cf::MAP_SWAPPED);
1976} 2207}
1977 2208
1978sub reset_at { 2209sub reset_at {
1979 my ($self) = @_; 2210 my ($self) = @_;
1980 2211
… …
2012 if $uniq; 2243 if $uniq;
2013 } 2244 }
2014 2245
2015 delete $cf::MAP{$self->path}; 2246 delete $cf::MAP{$self->path};
2016 2247
2248 $self->deactivate;
2249 $_->clear_links_to ($self) for values %cf::MAP;
2017 $self->clear; 2250 $self->clear;
2018
2019 $_->clear_links_to ($self) for values %cf::MAP;
2020 2251
2021 $self->unlink_save; 2252 $self->unlink_save;
2022 $self->destroy; 2253 $self->destroy;
2023} 2254}
2024 2255
2025my $nuke_counter = "aaaa"; 2256my $nuke_counter = "aaaa";
2026 2257
2027sub nuke { 2258sub nuke {
2028 my ($self) = @_; 2259 my ($self) = @_;
2029 2260
2261 {
2262 my $lock = cf::lock_acquire "map_data:$self->{path}";
2263
2030 delete $cf::MAP{$self->path}; 2264 delete $cf::MAP{$self->path};
2031 2265
2032 $self->unlink_save; 2266 $self->unlink_save;
2033 2267
2034 bless $self, "cf::map"; 2268 bless $self, "cf::map";
2035 delete $self->{deny_reset}; 2269 delete $self->{deny_reset};
2036 $self->{deny_save} = 1; 2270 $self->{deny_save} = 1;
2037 $self->reset_timeout (1); 2271 $self->reset_timeout (1);
2038 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2272 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2039 2273
2040 $cf::MAP{$self->path} = $self; 2274 $cf::MAP{$self->path} = $self;
2275 }
2041 2276
2042 $self->reset; # polite request, might not happen 2277 $self->reset; # polite request, might not happen
2043} 2278}
2044 2279
2045=item $maps = cf::map::tmp_maps 2280=item $maps = cf::map::tmp_maps
… …
2121 2356
2122sub inv_recursive { 2357sub inv_recursive {
2123 inv_recursive_ inv $_[0] 2358 inv_recursive_ inv $_[0]
2124} 2359}
2125 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 }
2387}
2388
2126package cf; 2389package cf;
2127 2390
2128=back 2391=back
2129 2392
2130=head3 cf::object::player 2393=head3 cf::object::player
… …
2152 2415
2153 } else { 2416 } else {
2154 my $pl = $self->contr; 2417 my $pl = $self->contr;
2155 2418
2156 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2419 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2157 my $diag = $pl->{npc_dialog}; 2420 my $dialog = $pl->{npc_dialog};
2158 $diag->{pl}->ext_reply ( 2421 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2159 $diag->{id},
2160 msgtype => "reply",
2161 msg => $diag->{pl}->expand_cfpod ($msg),
2162 add_topics => []
2163 );
2164 2422
2165 } else { 2423 } else {
2166 $msg = $npc->name . " says: $msg" if $npc; 2424 $msg = $npc->name . " says: $msg" if $npc;
2167 $self->message ($msg, $flags); 2425 $self->message ($msg, $flags);
2168 } 2426 }
2169 } 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 (@_);
2170} 2438}
2171 2439
2172=item $player_object->may ("access") 2440=item $player_object->may ("access")
2173 2441
2174Returns wether the given player is authorized to access resource "access" 2442Returns wether the given player is authorized to access resource "access"
… …
2253 # use -1 or undef as default coordinates, not 0, 0 2521 # use -1 or undef as default coordinates, not 0, 0
2254 ($x, $y) = ($map->enter_x, $map->enter_y) 2522 ($x, $y) = ($map->enter_x, $map->enter_y)
2255 if $x <=0 && $y <= 0; 2523 if $x <=0 && $y <= 0;
2256 2524
2257 $map->load; 2525 $map->load;
2258 $map->load_diag; 2526 $map->load_neighbours;
2259 2527
2260 return unless $self->contr->active; 2528 return unless $self->contr->active;
2261 $self->activate_recursive; 2529 $self->activate_recursive;
2262 2530
2263 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2531 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
… …
2283 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2551 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2284 2552
2285 $self->enter_link; 2553 $self->enter_link;
2286 2554
2287 (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
2288 my $map = eval { 2577 my $map = eval {
2289 my $map = cf::map::find $path; 2578 my $map = defined $path ? cf::map::find $path : undef;
2290 2579
2291 if ($map) { 2580 if ($map) {
2292 $map = $map->customise_for ($self); 2581 $map = $map->customise_for ($self);
2293 $map = $check->($map) if $check && $map; 2582 $map = $check->($map) if $check && $map;
2294 } else { 2583 } else {
2295 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2584 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2296 } 2585 }
2297 2586
2298 $map 2587 $map
2299 }; 2588 };
2300 2589
… …
2353 $rmp->{origin_y} = $exit->y; 2642 $rmp->{origin_y} = $exit->y;
2354 } 2643 }
2355 2644
2356 $rmp->{random_seed} ||= $exit->random_seed; 2645 $rmp->{random_seed} ||= $exit->random_seed;
2357 2646
2358 my $data = cf::to_json $rmp; 2647 my $data = cf::encode_json $rmp;
2359 my $md5 = Digest::MD5::md5_hex $data; 2648 my $md5 = Digest::MD5::md5_hex $data;
2360 my $meta = "$RANDOMDIR/$md5.meta"; 2649 my $meta = "$RANDOMDIR/$md5.meta";
2361 2650
2362 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2651 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2363 aio_write $fh, 0, (length $data), $data, 0; 2652 aio_write $fh, 0, (length $data), $data, 0;
… …
2390 # if exit is damned, update players death & WoR home-position 2679 # if exit is damned, update players death & WoR home-position
2391 $self->contr->savebed ($slaying, $hp, $sp) 2680 $self->contr->savebed ($slaying, $hp, $sp)
2392 if $exit->flag (FLAG_DAMNED); 2681 if $exit->flag (FLAG_DAMNED);
2393 2682
2394 (async { 2683 (async {
2684 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2685
2395 $self->deactivate_recursive; # just to be sure 2686 $self->deactivate_recursive; # just to be sure
2396 unless (eval { 2687 unless (eval {
2397 $self->goto ($slaying, $hp, $sp); 2688 $self->goto ($slaying, $hp, $sp);
2398 2689
2399 1; 2690 1;
… …
2425 2716
2426 utf8::encode $text; 2717 utf8::encode $text;
2427 $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);
2428} 2719}
2429 2720
2430=item $client->send_msg ($color, $type, $msg, [extra...]) 2721=item $client->send_msg ($channel, $msg, $color, [extra...])
2431 2722
2432Send a drawinfo or msg packet to the client, formatting the msg for the 2723Send a drawinfo or msg packet to the client, formatting the msg for the
2433client if neccessary. C<$type> should be a string identifying the type of 2724client if neccessary. C<$type> should be a string identifying the type of
2434the message, with C<log> being the default. If C<$color> is negative, suppress 2725the message, with C<log> being the default. If C<$color> is negative, suppress
2435the message unless the client supports the msg packet. 2726the message unless the client supports the msg packet.
2436 2727
2437=cut 2728=cut
2438 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
2439sub cf::client::send_msg { 2782sub cf::client::send_msg {
2440 my ($self, $color, $type, $msg, @extra) = @_; 2783 my ($self, $channel, $msg, $color, @extra) = @_;
2441 2784
2442 $msg = $self->pl->expand_cfpod ($msg); 2785 $msg = $self->pl->expand_cfpod ($msg);
2443 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
2444 return unless @extra || length $msg; 2809 return unless @extra || length $msg;
2445 2810
2446 if ($self->can_msg) { 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
2447 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra])); 2816 $self->send_packet ("msg " . $self->{json_coder}->encode (
2817 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2448 } else { 2818 } else {
2449 # replace some tags by gcfclient-compatible ones
2450 for ($msg) {
2451 1 while
2452 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2453 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2454 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2455 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2456 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2457 }
2458
2459 if ($color >= 0) { 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
2460 if (0 && $msg =~ /\[/) { 2834 if (0 && $msg =~ /\[/) {
2835 # COMMAND/INFO
2461 $self->send_packet ("drawextinfo $color 4 0 $msg") 2836 $self->send_packet ("drawextinfo $color 10 8 $msg")
2462 } else { 2837 } else {
2463 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2838 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2464 $self->send_packet ("drawinfo $color $msg") 2839 $self->send_packet ("drawinfo $color $msg")
2465 } 2840 }
2466 } 2841 }
2467 } 2842 }
2468} 2843}
2469 2844
2470=item $client->ext_event ($type, %msg) 2845=item $client->ext_msg ($type, @msg)
2471 2846
2472Sends an ext event to the client. 2847Sends an ext event to the client.
2473 2848
2474=cut 2849=cut
2475 2850
2476sub cf::client::ext_event($$%) { 2851sub cf::client::ext_msg($$@) {
2477 my ($self, $type, %msg) = @_; 2852 my ($self, $type, @msg) = @_;
2478 2853
2479 return unless $self->extcmd; 2854 if ($self->extcmd == 2) {
2480 2855 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2856 } elsif ($self->extcmd == 1) { # TODO: remove
2481 $msg{msgtype} = "event_$type"; 2857 push @msg, msgtype => "event_$type";
2482 $self->send_packet ("ext " . $self->{json_coder}->encode (\%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 }
2483} 2878}
2484 2879
2485=item $success = $client->query ($flags, "text", \&cb) 2880=item $success = $client->query ($flags, "text", \&cb)
2486 2881
2487Queues a query to the client, calling the given callback with 2882Queues a query to the client, calling the given callback with
… …
2542 my ($ns, $buf) = @_; 2937 my ($ns, $buf) = @_;
2543 2938
2544 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 2939 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2545 2940
2546 if (ref $msg) { 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
2547 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2949 if (my $cb = $EXTICMD{$type}) {
2548 if (my %reply = $cb->($ns, $msg)) { 2950 @reply = $cb->($ns, @payload);
2549 $reply{msgid} = $msg->{msgid};
2550 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2551 }
2552 } 2951 }
2952
2953 $ns->ext_reply ($reply, @reply)
2954 if $reply;
2955
2553 } else { 2956 } else {
2554 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2957 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2555 } 2958 }
2556 2959
2557 cf::override; 2960 cf::override;
… …
2604our $safe = new Safe "safe"; 3007our $safe = new Safe "safe";
2605our $safe_hole = new Safe::Hole; 3008our $safe_hole = new Safe::Hole;
2606 3009
2607$SIG{FPE} = 'IGNORE'; 3010$SIG{FPE} = 'IGNORE';
2608 3011
2609$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));
2610 3017
2611# here we export the classes and methods available to script code 3018# here we export the classes and methods available to script code
2612 3019
2613=pod 3020=pod
2614 3021
2615The following functions and methods are available within a safe environment: 3022The following functions and methods are available within a safe environment:
2616 3023
2617 cf::object 3024 cf::object
2618 contr pay_amount pay_player map x y force_find force_add 3025 contr pay_amount pay_player map x y force_find force_add destroy
2619 insert remove 3026 insert remove name archname title slaying race decrease_ob_nr
2620 3027
2621 cf::object::player 3028 cf::object::player
2622 player 3029 player
2623 3030
2624 cf::player 3031 cf::player
… …
2629 3036
2630=cut 3037=cut
2631 3038
2632for ( 3039for (
2633 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 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
2634 insert remove)], 3042 decrease_ob_nr destroy)],
2635 ["cf::object::player" => qw(player)], 3043 ["cf::object::player" => qw(player)],
2636 ["cf::player" => qw(peaceful)], 3044 ["cf::player" => qw(peaceful)],
2637 ["cf::map" => qw(trigger)], 3045 ["cf::map" => qw(trigger)],
2638) { 3046) {
2639 no strict 'refs'; 3047 no strict 'refs';
… …
2715# the server's init and main functions 3123# the server's init and main functions
2716 3124
2717sub load_facedata($) { 3125sub load_facedata($) {
2718 my ($path) = @_; 3126 my ($path) = @_;
2719 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;
3133
2720 warn "loading facedata from $path\n"; 3134 warn "loading facedata from $path\n";
2721 3135
2722 my $facedata; 3136 my $facedata;
2723 0 < aio_load $path, $facedata 3137 0 < aio_load $path, $facedata
2724 or die "$path: $!"; 3138 or die "$path: $!";
… …
2726 $facedata = Coro::Storable::thaw $facedata; 3140 $facedata = Coro::Storable::thaw $facedata;
2727 3141
2728 $facedata->{version} == 2 3142 $facedata->{version} == 2
2729 or cf::cleanup "$path: version mismatch, cannot proceed."; 3143 or cf::cleanup "$path: version mismatch, cannot proceed.";
2730 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
2731 { 3152 {
2732 my $faces = $facedata->{faceinfo}; 3153 my $faces = $facedata->{faceinfo};
2733 3154
2734 while (my ($face, $info) = each %$faces) { 3155 while (my ($face, $info) = each %$faces) {
2735 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3156 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3157
2736 cf::face::set_visibility $idx, $info->{visibility}; 3158 cf::face::set_visibility $idx, $info->{visibility};
2737 cf::face::set_magicmap $idx, $info->{magicmap}; 3159 cf::face::set_magicmap $idx, $info->{magicmap};
2738 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3160 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2739 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3161 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2740 3162
2741 cf::cede_to_tick; 3163 cf::cede_to_tick;
2742 } 3164 }
2743 3165
2744 while (my ($face, $info) = each %$faces) { 3166 while (my ($face, $info) = each %$faces) {
2745 next unless $info->{smooth}; 3167 next unless $info->{smooth};
3168
2746 my $idx = cf::face::find $face 3169 my $idx = cf::face::find $face
2747 or next; 3170 or next;
3171
2748 if (my $smooth = cf::face::find $info->{smooth}) { 3172 if (my $smooth = cf::face::find $info->{smooth}) {
2749 cf::face::set_smooth $idx, $smooth; 3173 cf::face::set_smooth $idx, $smooth;
2750 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3174 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2751 } else { 3175 } else {
2752 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3176 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2769 3193
2770 { 3194 {
2771 # TODO: for gcfclient pleasure, we should give resources 3195 # TODO: for gcfclient pleasure, we should give resources
2772 # that gcfclient doesn't grok a >10000 face index. 3196 # that gcfclient doesn't grok a >10000 face index.
2773 my $res = $facedata->{resource}; 3197 my $res = $facedata->{resource};
2774 my $enc = JSON::XS->new->utf8->canonical;
2775 3198
2776 while (my ($name, $info) = each %$res) { 3199 while (my ($name, $info) = each %$res) {
2777 my $meta = $enc->encode ({ 3200 if (defined $info->{type}) {
2778 name => $name,
2779 type => $info->{type},
2780 copyright => $info->{copyright}, #TODO#
2781 });
2782
2783 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3201 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3202 my $data;
2784 3203
2785 if ($name =~ /\.jpg$/) { 3204 if ($info->{type} & 1) {
2786 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack 3205 # prepend meta info
2787 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack 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};
2788 } else { 3219 } else {
2789 my $data = pack "(w/a*)*", $meta, $info->{data}; 3220 $RESOURCE{$name} = $info;
2790 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2791
2792 cf::face::set_type $idx, 1;
2793 cf::face::set_data $idx, 0, $data, $chk;
2794 } 3221 }
2795 3222
2796 cf::cede_to_tick; 3223 cf::cede_to_tick;
2797 } 3224 }
2798 } 3225 }
2799 3226
3227 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3228
2800 1 3229 1
2801} 3230}
2802 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
2803sub 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
2804 load_resource_file "$MAPDIR/regions" 3265 load_resource_file "$MAPDIR/regions"
2805 or die "unable to load regions file\n"; 3266 or die "unable to load regions file\n";
2806 3267
2807 for (cf::region::list) { 3268 for (cf::region::list) {
2808 $_->{match} = qr/$_->{match}/ 3269 $_->{match} = qr/$_->{match}/
… …
2844 3305
2845sub init { 3306sub init {
2846 reload_resources; 3307 reload_resources;
2847} 3308}
2848 3309
2849sub cfg_load { 3310sub reload_config {
2850 open my $fh, "<:utf8", "$CONFDIR/config" 3311 open my $fh, "<:utf8", "$CONFDIR/config"
2851 or return; 3312 or return;
2852 3313
2853 local $/; 3314 local $/;
2854 *CFG = YAML::Syck::Load <$fh>; 3315 *CFG = YAML::Load <$fh>;
2855 3316
2856 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3317 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2857 3318
2858 $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};
2859 $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};
… …
2870sub main { 3331sub main {
2871 # we must not ever block the main coroutine 3332 # we must not ever block the main coroutine
2872 local $Coro::idle = sub { 3333 local $Coro::idle = sub {
2873 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#
2874 (async { 3335 (async {
2875 Event::one_event; 3336 $Coro::current->{desc} = "IDLE BUG HANDLER";
3337 EV::loop EV::LOOP_ONESHOT;
2876 })->prio (Coro::PRIO_MAX); 3338 })->prio (Coro::PRIO_MAX);
2877 }; 3339 };
2878 3340
2879 cfg_load; 3341 reload_config;
2880 db_init; 3342 db_init;
2881 load_extensions; 3343 load_extensions;
2882 3344
2883 $TICK_WATCHER->start; 3345 $TICK_WATCHER->start;
3346 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
2884 Event::loop; 3347 EV::loop;
2885} 3348}
2886 3349
2887############################################################################# 3350#############################################################################
2888# initialisation and cleanup 3351# initialisation and cleanup
2889 3352
2890# install some emergency cleanup handlers 3353# install some emergency cleanup handlers
2891BEGIN { 3354BEGIN {
3355 our %SIGWATCHER = ();
2892 for my $signal (qw(INT HUP TERM)) { 3356 for my $signal (qw(INT HUP TERM)) {
2893 Event->signal ( 3357 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2894 reentrant => 0,
2895 data => WF_AUTOCANCEL,
2896 signal => $signal,
2897 prio => 0,
2898 cb => sub {
2899 cf::cleanup "SIG$signal"; 3358 cf::cleanup "SIG$signal";
2900 },
2901 ); 3359 };
2902 } 3360 }
2903} 3361}
2904 3362
2905sub write_runtime { 3363sub write_runtime {
2906 my $runtime = "$LOCALDIR/runtime"; 3364 my $runtime = "$LOCALDIR/runtime";
… …
2951 # and maps saved/destroyed asynchronously. 3409 # and maps saved/destroyed asynchronously.
2952 warn "begin emergency player save\n"; 3410 warn "begin emergency player save\n";
2953 for my $login (keys %cf::PLAYER) { 3411 for my $login (keys %cf::PLAYER) {
2954 my $pl = $cf::PLAYER{$login} or next; 3412 my $pl = $cf::PLAYER{$login} or next;
2955 $pl->valid or next; 3413 $pl->valid or next;
3414 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2956 $pl->save; 3415 $pl->save;
2957 } 3416 }
2958 warn "end emergency player save\n"; 3417 warn "end emergency player save\n";
2959 3418
2960 warn "begin emergency map save\n"; 3419 warn "begin emergency map save\n";
… …
2999 warn "syncing database to disk"; 3458 warn "syncing database to disk";
3000 BDB::db_env_txn_checkpoint $DB_ENV; 3459 BDB::db_env_txn_checkpoint $DB_ENV;
3001 3460
3002 # 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
3003 3462
3004 warn "cancelling all WF_AUTOCANCEL watchers";
3005 for (Event::all_watchers) {
3006 $_->cancel if $_->data & WF_AUTOCANCEL;
3007 }
3008
3009 warn "flushing outstanding aio requests"; 3463 warn "flushing outstanding aio requests";
3010 for (;;) { 3464 for (;;) {
3011 BDB::flush; 3465 BDB::flush;
3012 IO::AIO::flush; 3466 IO::AIO::flush;
3013 Coro::cede; 3467 Coro::cede_notself;
3014 last unless IO::AIO::nreqs || BDB::nreqs; 3468 last unless IO::AIO::nreqs || BDB::nreqs;
3015 warn "iterate..."; 3469 warn "iterate...";
3016 } 3470 }
3017 3471
3018 ++$RELOAD; 3472 ++$RELOAD;
… …
3077 warn "reloading cf.pm"; 3531 warn "reloading cf.pm";
3078 require cf; 3532 require cf;
3079 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3533 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3080 3534
3081 warn "loading config and database again"; 3535 warn "loading config and database again";
3082 cf::cfg_load; 3536 cf::reload_config;
3083 3537
3084 warn "loading extensions"; 3538 warn "loading extensions";
3085 cf::load_extensions; 3539 cf::load_extensions;
3086 3540
3087 warn "reattaching attachments to objects/players"; 3541 warn "reattaching attachments to objects/players";
… …
3107 3561
3108sub reload_perl() { 3562sub reload_perl() {
3109 # doing reload synchronously and two reloads happen back-to-back, 3563 # doing reload synchronously and two reloads happen back-to-back,
3110 # coro crashes during coro_state_free->destroy here. 3564 # coro crashes during coro_state_free->destroy here.
3111 3565
3112 $RELOAD_WATCHER ||= Event->timer ( 3566 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3113 reentrant => 0,
3114 after => 0,
3115 data => WF_AUTOCANCEL,
3116 cb => sub {
3117 do_reload_perl; 3567 do_reload_perl;
3118 undef $RELOAD_WATCHER; 3568 undef $RELOAD_WATCHER;
3119 },
3120 ); 3569 };
3121} 3570}
3122 3571
3123register_command "reload" => sub { 3572register_command "reload" => sub {
3124 my ($who, $arg) = @_; 3573 my ($who, $arg) = @_;
3125 3574
3126 if ($who->flag (FLAG_WIZ)) { 3575 if ($who->flag (FLAG_WIZ)) {
3127 $who->message ("reloading server."); 3576 $who->message ("reloading server.");
3577 async {
3578 $Coro::current->{desc} = "perl_reload";
3128 async { reload_perl }; 3579 reload_perl;
3580 };
3129 } 3581 }
3130}; 3582};
3131 3583
3132unshift @INC, $LIBDIR; 3584unshift @INC, $LIBDIR;
3133 3585
… …
3152 my $signal = new Coro::Signal; 3604 my $signal = new Coro::Signal;
3153 push @WAIT_FOR_TICK_BEGIN, $signal; 3605 push @WAIT_FOR_TICK_BEGIN, $signal;
3154 $signal->wait; 3606 $signal->wait;
3155} 3607}
3156 3608
3157 my $min = 1e6;#d# 3609$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3158 my $avg = 10;
3159$TICK_WATCHER = Event->timer (
3160 reentrant => 0,
3161 parked => 1,
3162 prio => 0,
3163 at => $NEXT_TICK || $TICK,
3164 data => WF_AUTOCANCEL,
3165 cb => sub {
3166 if ($Coro::current != $Coro::main) { 3610 if ($Coro::current != $Coro::main) {
3167 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"
3168 unless ++$bug_warning > 10; 3612 unless ++$bug_warning > 10;
3169 return; 3613 return;
3170 } 3614 }
3171 3615
3172 $NOW = $tick_start = Event::time; 3616 $NOW = $tick_start = EV::now;
3173 3617
3174 cf::server_tick; # one server iteration 3618 cf::server_tick; # one server iteration
3175 3619
3176 0 && sync_job {#d# 3620 $RUNTIME += $TICK;
3177 for(1..10) { 3621 $NEXT_TICK = $_[0]->at;
3178 my $t = Event::time;
3179 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3180 or die;
3181 3622
3182 $map->width (50); 3623 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3183 $map->height (50); 3624 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3184 $map->alloc; 3625 Coro::async_pool {
3185 $map->_load_objects ("/tmp/x.map", 1); 3626 $Coro::current->{desc} = "runtime saver";
3186 my $t = Event::time - $t; 3627 write_runtime
3187 3628 or warn "ERROR: unable to write runtime file: $!";
3188 #next unless $t < 0.0013;#d#
3189 if ($t < $min) {
3190 $min = $t;
3191 }
3192 $avg = $avg * 0.99 + $t * 0.01;
3193 }
3194 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3195 exit 0;
3196 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3197 }; 3629 };
3630 }
3198 3631
3199 $RUNTIME += $TICK;
3200 $NEXT_TICK += $TICK;
3201
3202 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3203 $NEXT_RUNTIME_WRITE = $NOW + 10;
3204 Coro::async_pool {
3205 write_runtime
3206 or warn "ERROR: unable to write runtime file: $!";
3207 };
3208 }
3209
3210# my $AFTER = Event::time;
3211# warn $AFTER - $NOW;#d#
3212
3213 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3632 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3214 $sig->send; 3633 $sig->send;
3215 } 3634 }
3216 while (my $sig = shift @WAIT_FOR_TICK) { 3635 while (my $sig = shift @WAIT_FOR_TICK) {
3217 $sig->send; 3636 $sig->send;
3218 } 3637 }
3219 3638
3220 $NOW = Event::time;
3221
3222 # if we are delayed by four ticks or more, skip them all
3223 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3224
3225 $TICK_WATCHER->at ($NEXT_TICK);
3226 $TICK_WATCHER->start;
3227
3228 $LOAD = ($NOW - $tick_start) / $TICK; 3639 $LOAD = ($NOW - $tick_start) / $TICK;
3229 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3640 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3230 3641
3231 _post_tick; 3642 _post_tick;
3232 3643};
3233 3644$TICK_WATCHER->priority (EV::MAXPRI);
3234 },
3235);
3236 3645
3237{ 3646{
3238 BDB::max_poll_time $TICK * 0.1; 3647 # configure BDB
3239 $BDB_POLL_WATCHER = Event->io ( 3648
3240 reentrant => 0,
3241 fd => BDB::poll_fileno,
3242 poll => 'r',
3243 prio => 0,
3244 data => WF_AUTOCANCEL,
3245 cb => \&BDB::poll_cb,
3246 );
3247 BDB::min_parallel 8; 3649 BDB::min_parallel 8;
3248 3650 BDB::max_poll_reqs $TICK * 0.1;
3249 BDB::set_sync_prepare { 3651 $Coro::BDB::WATCHER->priority (1);
3250 my $status;
3251 my $current = $Coro::current;
3252 (
3253 sub {
3254 $status = $!;
3255 $current->ready; undef $current;
3256 },
3257 sub {
3258 Coro::schedule while defined $current;
3259 $! = $status;
3260 },
3261 )
3262 };
3263 3652
3264 unless ($DB_ENV) { 3653 unless ($DB_ENV) {
3265 $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);
3266 3659
3267 cf::sync_job { 3660 cf::sync_job {
3268 eval { 3661 eval {
3269 BDB::db_env_open 3662 BDB::db_env_open
3270 $DB_ENV, 3663 $DB_ENV,
… …
3272 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
3273 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3666 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3274 0666; 3667 0666;
3275 3668
3276 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3669 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3277
3278 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3279 $DB_ENV->set_lk_detect;
3280 }; 3670 };
3281 3671
3282 cf::cleanup "db_env_open(db): $@" if $@; 3672 cf::cleanup "db_env_open(db): $@" if $@;
3283 }; 3673 };
3284 } 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 };
3285} 3685}
3286 3686
3287{ 3687{
3688 # configure IO::AIO
3689
3288 IO::AIO::min_parallel 8; 3690 IO::AIO::min_parallel 8;
3289
3290 undef $Coro::AIO::WATCHER;
3291 IO::AIO::max_poll_time $TICK * 0.1; 3691 IO::AIO::max_poll_time $TICK * 0.1;
3292 $AIO_POLL_WATCHER = Event->io ( 3692 $Coro::AIO::WATCHER->priority (1);
3293 reentrant => 0,
3294 data => WF_AUTOCANCEL,
3295 fd => IO::AIO::poll_fileno,
3296 poll => 'r',
3297 prio => 6,
3298 cb => \&IO::AIO::poll_cb,
3299 );
3300} 3693}
3301 3694
3302my $_log_backtrace; 3695my $_log_backtrace;
3303 3696
3304sub _log_backtrace { 3697sub _log_backtrace {
… …
3308 3701
3309 # limit the # of concurrent backtraces 3702 # limit the # of concurrent backtraces
3310 if ($_log_backtrace < 2) { 3703 if ($_log_backtrace < 2) {
3311 ++$_log_backtrace; 3704 ++$_log_backtrace;
3312 async { 3705 async {
3706 $Coro::current->{desc} = "abt $msg";
3707
3313 my @bt = fork_call { 3708 my @bt = fork_call {
3314 @addr = map { sprintf "%x", $_ } @addr; 3709 @addr = map { sprintf "%x", $_ } @addr;
3315 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3710 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3316 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 |"
3317 or die "addr2line: $!"; 3712 or die "addr2line: $!";

Diff Legend

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