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.300 by root, Tue Jul 10 06:44:29 2007 UTC vs.
Revision 1.400 by root, Mon Dec 17 06:36:34 2007 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;
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::Syck ();
31use IO::AIO 2.32 (); 33use IO::AIO 2.51 ();
32use Time::HiRes; 34use Time::HiRes;
33use Compress::LZF; 35use Compress::LZF;
36use Digest::MD5 ();
34 37
35# configure various modules to our taste 38# configure various modules to our taste
36# 39#
37$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
38Coro::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
39Compress::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
40
41$Event::Eval = 1; # no idea why this is required, but it is
42 43
43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
44$YAML::Syck::ImplicitUnicode = 1; 45$YAML::Syck::ImplicitUnicode = 1;
45 46
46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
… …
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
75our $TICK_WATCHER; 76our $TICK_WATCHER;
76our $AIO_POLL_WATCHER; 77our $AIO_POLL_WATCHER;
77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
78our $NEXT_TICK; 79our $NEXT_TICK;
79our $NOW;
80our $USE_FSYNC = 1; # use fsync to write maps - default off 80our $USE_FSYNC = 1; # use fsync to write maps - default off
81 81
82our $BDB_POLL_WATCHER; 82our $BDB_POLL_WATCHER;
83our $BDB_DEADLOCK_WATCHER;
84our $BDB_CHECKPOINT_WATCHER;
85our $BDB_TRICKLE_WATCHER;
83our $DB_ENV; 86our $DB_ENV;
84 87
85our %CFG; 88our %CFG;
86 89
87our $UPTIME; $UPTIME ||= time; 90our $UPTIME; $UPTIME ||= time;
88our $RUNTIME; 91our $RUNTIME;
92our $NOW;
89 93
90our %PLAYER; # all users 94our (%PLAYER, %PLAYER_LOADING); # all users
91our %MAP; # all maps 95our (%MAP, %MAP_LOADING ); # all maps
92our $LINK_MAP; # the special {link} map, which is always available 96our $LINK_MAP; # the special {link} map, which is always available
93 97
94# used to convert map paths into valid unix filenames by replacing / by ∕ 98# used to convert map paths into valid unix filenames by replacing / by ∕
95our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 99our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
96 100
… …
157 161
158The raw value load value from the last tick. 162The raw value load value from the last tick.
159 163
160=item %cf::CFG 164=item %cf::CFG
161 165
162Configuration for the server, loaded from C</etc/crossfire/config>, or 166Configuration for the server, loaded from C</etc/deliantra-server/config>, or
163from wherever your confdir points to. 167from wherever your confdir points to.
164 168
165=item cf::wait_for_tick, cf::wait_for_tick_begin 169=item cf::wait_for_tick, cf::wait_for_tick_begin
166 170
167These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 171These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
168returns directly I<after> the tick processing (and consequently, can only wake one process 172returns directly I<after> the tick processing (and consequently, can only wake one process
169per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 173per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
170 174
175=item @cf::INVOKE_RESULTS
176
177This array contains the results of the last C<invoke ()> call. When
178C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
179that call.
180
171=back 181=back
172 182
173=cut 183=cut
174 184
175BEGIN { 185BEGIN {
… …
179 $msg .= "\n" 189 $msg .= "\n"
180 unless $msg =~ /\n$/; 190 unless $msg =~ /\n$/;
181 191
182 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 192 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
183 193
184 utf8::encode $msg;
185 LOG llevError, $msg; 194 LOG llevError, $msg;
186 }; 195 };
187} 196}
188 197
189@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 198@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
205)) { 214)) {
206 no strict 'refs'; 215 no strict 'refs';
207 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 216 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
208} 217}
209 218
210$Event::DIED = sub { 219$EV::DIED = sub {
211 warn "error in event callback: @_"; 220 warn "error in event callback: @_";
212}; 221};
213 222
214############################################################################# 223#############################################################################
215 224
… …
238 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 247 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
239 $d 248 $d
240 } || "[unable to dump $_[0]: '$@']"; 249 } || "[unable to dump $_[0]: '$@']";
241} 250}
242 251
243=item $ref = cf::from_json $json 252=item $ref = cf::decode_json $json
244 253
245Converts a JSON string into the corresponding perl data structure. 254Converts a JSON string into the corresponding perl data structure.
246 255
247=item $json = cf::to_json $ref 256=item $json = cf::encode_json $ref
248 257
249Converts a perl data structure into its JSON representation. 258Converts a perl data structure into its JSON representation.
250 259
251=cut 260=cut
252 261
253our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 262our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
254 263
255sub to_json ($) { $json_coder->encode ($_[0]) } 264sub encode_json($) { $json_coder->encode ($_[0]) }
256sub from_json ($) { $json_coder->decode ($_[0]) } 265sub decode_json($) { $json_coder->decode ($_[0]) }
257 266
258=item cf::lock_wait $string 267=item cf::lock_wait $string
259 268
260Wait until the given lock is available. See cf::lock_acquire. 269Wait until the given lock is available. See cf::lock_acquire.
261 270
… …
264Wait until the given lock is available and then acquires it and returns 273Wait until the given lock is available and then acquires it and returns
265a Coro::guard object. If the guard object gets destroyed (goes out of scope, 274a Coro::guard object. If the guard object gets destroyed (goes out of scope,
266for example when the coroutine gets canceled), the lock is automatically 275for example when the coroutine gets canceled), the lock is automatically
267returned. 276returned.
268 277
278Locks are *not* recursive, locking from the same coro twice results in a
279deadlocked coro.
280
269Lock names should begin with a unique identifier (for example, cf::map::find 281Lock names should begin with a unique identifier (for example, cf::map::find
270uses map_find and cf::map::load uses map_load). 282uses map_find and cf::map::load uses map_load).
271 283
272=item $locked = cf::lock_active $string 284=item $locked = cf::lock_active $string
273 285
274Return true if the lock is currently active, i.e. somebody has locked it. 286Return true if the lock is currently active, i.e. somebody has locked it.
275 287
276=cut 288=cut
277 289
278our %LOCK; 290our %LOCK;
291our %LOCKER;#d#
279 292
280sub lock_wait($) { 293sub lock_wait($) {
281 my ($key) = @_; 294 my ($key) = @_;
295
296 if ($LOCKER{$key} == $Coro::current) {#d#
297 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
298 return;#d#
299 }#d#
282 300
283 # wait for lock, if any 301 # wait for lock, if any
284 while ($LOCK{$key}) { 302 while ($LOCK{$key}) {
285 push @{ $LOCK{$key} }, $Coro::current; 303 push @{ $LOCK{$key} }, $Coro::current;
286 Coro::schedule; 304 Coro::schedule;
… …
292 310
293 # wait, to be sure we are not locked 311 # wait, to be sure we are not locked
294 lock_wait $key; 312 lock_wait $key;
295 313
296 $LOCK{$key} = []; 314 $LOCK{$key} = [];
315 $LOCKER{$key} = $Coro::current;#d#
297 316
298 Coro::guard { 317 Coro::guard {
318 delete $LOCKER{$key};#d#
299 # wake up all waiters, to be on the safe side 319 # wake up all waiters, to be on the safe side
300 $_->ready for @{ delete $LOCK{$key} }; 320 $_->ready for @{ delete $LOCK{$key} };
301 } 321 }
302} 322}
303 323
… …
315 }; 335 };
316 $TICK_WATCHER->stop; 336 $TICK_WATCHER->stop;
317 $guard 337 $guard
318} 338}
319 339
340=item cf::periodic $interval, $cb
341
342Like EV::periodic, but randomly selects a starting point so that the actions
343get spread over timer.
344
345=cut
346
347sub periodic($$) {
348 my ($interval, $cb) = @_;
349
350 my $start = rand List::Util::min 180, $interval;
351
352 EV::periodic $start, $interval, 0, $cb
353}
354
355=item cf::get_slot $time[, $priority[, $name]]
356
357Allocate $time seconds of blocking CPU time at priority C<$priority>:
358This call blocks and returns only when you have at least C<$time> seconds
359of cpu time till the next tick. The slot is only valid till the next cede.
360
361The optional C<$name> can be used to identify the job to run. It might be
362used for statistical purposes and should identify the same time-class.
363
364Useful for short background jobs.
365
366=cut
367
368our @SLOT_QUEUE;
369our $SLOT_QUEUE;
370
371$SLOT_QUEUE->cancel if $SLOT_QUEUE;
372$SLOT_QUEUE = Coro::async {
373 $Coro::current->desc ("timeslot manager");
374
375 my $signal = new Coro::Signal;
376
377 while () {
378 next_job:
379 my $avail = cf::till_tick;
380 if ($avail > 0.01) {
381 for (0 .. $#SLOT_QUEUE) {
382 if ($SLOT_QUEUE[$_][0] < $avail) {
383 my $job = splice @SLOT_QUEUE, $_, 1, ();
384 $job->[2]->send;
385 Coro::cede;
386 goto next_job;
387 }
388 }
389 }
390
391 if (@SLOT_QUEUE) {
392 # we do not use wait_for_tick() as it returns immediately when tick is inactive
393 push @cf::WAIT_FOR_TICK, $signal;
394 $signal->wait;
395 } else {
396 Coro::schedule;
397 }
398 }
399};
400
401sub get_slot($;$$) {
402 my ($time, $pri, $name) = @_;
403
404 $time = $TICK * .6 if $time > $TICK * .6;
405 my $sig = new Coro::Signal;
406
407 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
408 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
409 $SLOT_QUEUE->ready;
410 $sig->wait;
411}
412
320=item cf::async { BLOCK } 413=item cf::async { BLOCK }
321 414
322Currently the same as Coro::async_pool, meaning you cannot use 415Currently the same as Coro::async_pool, meaning you cannot use
323C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 416C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
324thing you are allowed to do is call C<prio> on it. 417thing you are allowed to do is call C<prio> on it.
… …
327 420
328BEGIN { *async = \&Coro::async_pool } 421BEGIN { *async = \&Coro::async_pool }
329 422
330=item cf::sync_job { BLOCK } 423=item cf::sync_job { BLOCK }
331 424
332The design of Crossfire TRT requires that the main coroutine ($Coro::main) 425The design of Deliantra requires that the main coroutine ($Coro::main)
333is always able to handle events or runnable, as Crossfire TRT is only 426is always able to handle events or runnable, as Deliantra is only
334partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 427partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
335acceptable. 428acceptable.
336 429
337If it must be done, put the blocking parts into C<sync_job>. This will run 430If it must be done, put the blocking parts into C<sync_job>. This will run
338the given BLOCK in another coroutine while waiting for the result. The 431the given BLOCK in another coroutine while waiting for the result. The
… …
343 436
344sub sync_job(&) { 437sub sync_job(&) {
345 my ($job) = @_; 438 my ($job) = @_;
346 439
347 if ($Coro::current == $Coro::main) { 440 if ($Coro::current == $Coro::main) {
348 my $time = Event::time; 441 my $time = EV::time;
349 442
350 # this is the main coro, too bad, we have to block 443 # this is the main coro, too bad, we have to block
351 # till the operation succeeds, freezing the server :/ 444 # till the operation succeeds, freezing the server :/
352 445
446 LOG llevError, Carp::longmess "sync job";#d#
447
353 # TODO: use suspend/resume instead 448 # TODO: use suspend/resume instead
354 # (but this is cancel-safe) 449 # (but this is cancel-safe)
355 my $freeze_guard = freeze_mainloop; 450 my $freeze_guard = freeze_mainloop;
356 451
357 my $busy = 1; 452 my $busy = 1;
358 my @res; 453 my @res;
359 454
360 (async { 455 (async {
456 $Coro::current->desc ("sync job coro");
361 @res = eval { $job->() }; 457 @res = eval { $job->() };
362 warn $@ if $@; 458 warn $@ if $@;
363 undef $busy; 459 undef $busy;
364 })->prio (Coro::PRIO_MAX); 460 })->prio (Coro::PRIO_MAX);
365 461
366 while ($busy) { 462 while ($busy) {
367 Coro::cede or Event::one_event; 463 if (Coro::nready) {
464 Coro::cede_notself;
465 } else {
466 EV::loop EV::LOOP_ONESHOT;
368 } 467 }
468 }
369 469
370 $time = Event::time - $time; 470 $time = EV::time - $time;
371 471
372 LOG llevError | logBacktrace, Carp::longmess "long sync job" 472 LOG llevError | logBacktrace, Carp::longmess "long sync job"
373 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 473 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
374 474
375 $tick_start += $time; # do not account sync jobs to server load 475 $tick_start += $time; # do not account sync jobs to server load
… …
405=item fork_call { }, $args 505=item fork_call { }, $args
406 506
407Executes the given code block with the given arguments in a seperate 507Executes the given code block with the given arguments in a seperate
408process, returning the results. Everything must be serialisable with 508process, returning the results. Everything must be serialisable with
409Coro::Storable. May, of course, block. Note that the executed sub may 509Coro::Storable. May, of course, block. Note that the executed sub may
410never block itself or use any form of Event handling. 510never block itself or use any form of event handling.
411 511
412=cut 512=cut
413
414sub _store_scalar {
415 open my $fh, ">", \my $buf
416 or die "fork_call: cannot open fh-to-buf in child : $!";
417 Storable::store_fd $_[0], $fh;
418 close $fh;
419
420 $buf
421}
422 513
423sub fork_call(&@) { 514sub fork_call(&@) {
424 my ($cb, @args) = @_; 515 my ($cb, @args) = @_;
425 516
426# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 517 # we seemingly have to make a local copy of the whole thing,
427# or die "socketpair: $!"; 518 # otherwise perl prematurely frees the stuff :/
428 pipe my $fh1, my $fh2 519 # TODO: investigate and fix (likely this will be rather laborious)
429 or die "pipe: $!";
430 520
431 if (my $pid = fork) { 521 my @res = Coro::Util::fork_eval {
432 close $fh2;
433
434 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
435 warn "pst<$res>" unless $res =~ /^pst/;
436 $res = Coro::Storable::thaw $res;
437
438 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
439
440 Carp::confess $$res unless "ARRAY" eq ref $res;
441
442 return wantarray ? @$res : $res->[-1];
443 } else {
444 reset_signals; 522 reset_signals;
445 local $SIG{__WARN__}; 523 &$cb
446 local $SIG{__DIE__}; 524 }, @args;
447 # just in case, this hack effectively disables event
448 # in the child. cleaner and slower would be canceling all watchers,
449 # but this works for the time being.
450 local $Coro::idle;
451 $Coro::current->prio (Coro::PRIO_MAX);
452 525
453 eval { 526 wantarray ? @res : $res[-1]
454 close $fh1;
455
456 my @res = eval { $cb->(@args) };
457
458 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
459 close $fh2;
460 };
461
462 warn $@ if $@;
463 _exit 0;
464 }
465} 527}
466 528
467=item $value = cf::db_get $family => $key 529=item $value = cf::db_get $family => $key
468 530
469Returns a single value from the environment database. 531Returns a single value from the environment database.
… …
471=item cf::db_put $family => $key => $value 533=item cf::db_put $family => $key => $value
472 534
473Stores the given C<$value> in the family. It can currently store binary 535Stores the given C<$value> in the family. It can currently store binary
474data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 536data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
475 537
538=item $db = cf::db_table "name"
539
540Create and/or open a new database table. The string must not be "db" and must be unique
541within each server.
542
476=cut 543=cut
544
545sub db_table($) {
546 my ($name) = @_;
547 my $db = BDB::db_create $DB_ENV;
548
549 eval {
550 $db->set_flags (BDB::CHKSUM);
551
552 utf8::encode $name;
553 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
554 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
555 cf::cleanup "db_open(db): $!" if $!;
556 };
557 cf::cleanup "db_open(db): $@" if $@;
558
559 $db
560}
477 561
478our $DB; 562our $DB;
479 563
480sub db_init { 564sub db_init {
481 unless ($DB) {
482 $DB = BDB::db_create $DB_ENV;
483
484 cf::sync_job { 565 cf::sync_job {
485 eval { 566 $DB ||= db_table "db";
486 $DB->set_flags (BDB::CHKSUM);
487
488 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
489 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
490 cf::cleanup "db_open(db): $!" if $!;
491 };
492 cf::cleanup "db_open(db): $@" if $@;
493 };
494 } 567 };
495} 568}
496 569
497sub db_get($$) { 570sub db_get($$) {
498 my $key = "$_[0]/$_[1]"; 571 my $key = "$_[0]/$_[1]";
499 572
… …
549 if (1) { 622 if (1) {
550 $md5 = 623 $md5 =
551 join "\x00", 624 join "\x00",
552 $processversion, 625 $processversion,
553 map { 626 map {
554 Coro::cede; 627 cf::cede_to_tick;
555 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 628 ($src->[$_], Digest::MD5::md5_hex $data[$_])
556 } 0.. $#$src; 629 } 0.. $#$src;
557 630
558 631
559 my $dbmd5 = db_get cache => "$id/md5"; 632 my $dbmd5 = db_get cache => "$id/md5";
… …
603attach callbacks/event handlers (a collection of which is called an "attachment") 676attach callbacks/event handlers (a collection of which is called an "attachment")
604to it. All such attachable objects support the following methods. 677to it. All such attachable objects support the following methods.
605 678
606In the following description, CLASS can be any of C<global>, C<object> 679In the following description, CLASS can be any of C<global>, C<object>
607C<player>, C<client> or C<map> (i.e. the attachable objects in 680C<player>, C<client> or C<map> (i.e. the attachable objects in
608Crossfire TRT). 681Deliantra).
609 682
610=over 4 683=over 4
611 684
612=item $attachable->attach ($attachment, key => $value...) 685=item $attachable->attach ($attachment, key => $value...)
613 686
… …
865 "; 938 ";
866 die if $@; 939 die if $@;
867} 940}
868 941
869our $override; 942our $override;
870our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 943our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
871 944
872sub override { 945sub override {
873 $override = 1; 946 $override = 1;
874 @invoke_results = (); 947 @INVOKE_RESULTS = (@_);
875} 948}
876 949
877sub do_invoke { 950sub do_invoke {
878 my $event = shift; 951 my $event = shift;
879 my $callbacks = shift; 952 my $callbacks = shift;
880 953
881 @invoke_results = (); 954 @INVOKE_RESULTS = ();
882 955
883 local $override; 956 local $override;
884 957
885 for (@$callbacks) { 958 for (@$callbacks) {
886 eval { &{$_->[1]} }; 959 eval { &{$_->[1]} };
… …
903 976
904Generate an object-specific event with the given arguments. 977Generate an object-specific event with the given arguments.
905 978
906This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 979This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
907removed in future versions), and there is no public API to access override 980removed in future versions), and there is no public API to access override
908results (if you must, access C<@cf::invoke_results> directly). 981results (if you must, access C<@cf::INVOKE_RESULTS> directly).
909 982
910=back 983=back
911 984
912=cut 985=cut
913 986
914############################################################################# 987#############################################################################
915# object support 988# object support
989
990sub _object_equal($$);
991sub _object_equal($$) {
992 my ($a, $b) = @_;
993
994 return 0 unless (ref $a) eq (ref $b);
995
996 if ("HASH" eq ref $a) {
997 my @ka = keys %$a;
998 my @kb = keys %$b;
999
1000 return 0 if @ka != @kb;
1001
1002 for (0 .. $#ka) {
1003 return 0 unless $ka[$_] eq $kb[$_];
1004 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1005 }
1006
1007 } elsif ("ARRAY" eq ref $a) {
1008
1009 return 0 if @$a != @$b;
1010
1011 for (0 .. $#$a) {
1012 return 0 unless _object_equal $a->[$_], $b->[$_];
1013 }
1014
1015 } elsif ($a ne $b) {
1016 return 0;
1017 }
1018
1019 1
1020}
1021
1022our $SLOW_MERGES;#d#
1023sub _can_merge {
1024 my ($ob1, $ob2) = @_;
1025
1026 ++$SLOW_MERGES;#d#
1027
1028 # we do the slow way here
1029 return _object_equal $ob1, $ob2
1030}
916 1031
917sub reattach { 1032sub reattach {
918 # basically do the same as instantiate, without calling instantiate 1033 # basically do the same as instantiate, without calling instantiate
919 my ($obj) = @_; 1034 my ($obj) = @_;
920 1035
… …
941cf::attachable->attach ( 1056cf::attachable->attach (
942 prio => -1000000, 1057 prio => -1000000,
943 on_instantiate => sub { 1058 on_instantiate => sub {
944 my ($obj, $data) = @_; 1059 my ($obj, $data) = @_;
945 1060
946 $data = from_json $data; 1061 $data = decode_json $data;
947 1062
948 for (@$data) { 1063 for (@$data) {
949 my ($name, $args) = @$_; 1064 my ($name, $args) = @$_;
950 1065
951 $obj->attach ($name, %{$args || {} }); 1066 $obj->attach ($name, %{$args || {} });
… …
967sub object_freezer_save { 1082sub object_freezer_save {
968 my ($filename, $rdata, $objs) = @_; 1083 my ($filename, $rdata, $objs) = @_;
969 1084
970 sync_job { 1085 sync_job {
971 if (length $$rdata) { 1086 if (length $$rdata) {
1087 utf8::decode (my $decname = $filename);
972 warn sprintf "saving %s (%d,%d)\n", 1088 warn sprintf "saving %s (%d,%d)\n",
973 $filename, length $$rdata, scalar @$objs; 1089 $decname, length $$rdata, scalar @$objs;
974 1090
975 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1091 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
976 chmod SAVE_MODE, $fh; 1092 chmod SAVE_MODE, $fh;
977 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1093 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
978 aio_fsync $fh if $cf::USE_FSYNC; 1094 aio_fsync $fh if $cf::USE_FSYNC;
979 close $fh; 1095 close $fh;
980 1096
981 if (@$objs) { 1097 if (@$objs) {
982 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1098 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
983 chmod SAVE_MODE, $fh; 1099 chmod SAVE_MODE, $fh;
984 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1100 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
985 aio_write $fh, 0, (length $data), $data, 0; 1101 aio_write $fh, 0, (length $data), $data, 0;
986 aio_fsync $fh if $cf::USE_FSYNC; 1102 aio_fsync $fh if $cf::USE_FSYNC;
987 close $fh; 1103 close $fh;
988 aio_rename "$filename.pst~", "$filename.pst"; 1104 aio_rename "$filename.pst~", "$filename.pst";
989 } 1105 }
… …
997 } 1113 }
998 } else { 1114 } else {
999 aio_unlink $filename; 1115 aio_unlink $filename;
1000 aio_unlink "$filename.pst"; 1116 aio_unlink "$filename.pst";
1001 } 1117 }
1002 } 1118 };
1003} 1119}
1004 1120
1005sub object_freezer_as_string { 1121sub object_freezer_as_string {
1006 my ($rdata, $objs) = @_; 1122 my ($rdata, $objs) = @_;
1007 1123
… …
1019 or return; 1135 or return;
1020 1136
1021 unless (aio_stat "$filename.pst") { 1137 unless (aio_stat "$filename.pst") {
1022 (aio_load "$filename.pst", $av) >= 0 1138 (aio_load "$filename.pst", $av) >= 0
1023 or return; 1139 or return;
1140
1024 $av = eval { (Storable::thaw $av)->{objs} }; 1141 my $st = eval { Coro::Storable::thaw $av };
1142 $av = $st->{objs};
1025 } 1143 }
1026 1144
1145 utf8::decode (my $decname = $filename);
1027 warn sprintf "loading %s (%d)\n", 1146 warn sprintf "loading %s (%d,%d)\n",
1028 $filename, length $data, scalar @{$av || []}; 1147 $decname, length $data, scalar @{$av || []};
1148
1029 return ($data, $av); 1149 ($data, $av)
1030} 1150}
1031 1151
1032=head2 COMMAND CALLBACKS 1152=head2 COMMAND CALLBACKS
1033 1153
1034=over 4 1154=over 4
… …
1107 my ($pl, $buf) = @_; 1227 my ($pl, $buf) = @_;
1108 1228
1109 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1229 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1110 1230
1111 if (ref $msg) { 1231 if (ref $msg) {
1232 my ($type, $reply, @payload) =
1233 "ARRAY" eq ref $msg
1234 ? @$msg
1235 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1236
1237 my @reply;
1238
1112 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1239 if (my $cb = $EXTCMD{$type}) {
1113 if (my %reply = $cb->($pl, $msg)) { 1240 @reply = $cb->($pl, @payload);
1114 $pl->ext_reply ($msg->{msgid}, %reply);
1115 }
1116 } 1241 }
1242
1243 $pl->ext_reply ($reply, @reply)
1244 if $reply;
1245
1117 } else { 1246 } else {
1118 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1247 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1119 } 1248 }
1120 1249
1121 cf::override; 1250 cf::override;
… …
1211 1340
1212=head3 cf::player 1341=head3 cf::player
1213 1342
1214=over 4 1343=over 4
1215 1344
1345=item cf::player::num_playing
1346
1347Returns the official number of playing players, as per the Crossfire metaserver rules.
1348
1349=cut
1350
1351sub num_playing {
1352 scalar grep
1353 $_->ob->map
1354 && !$_->hidden
1355 && !$_->ob->flag (cf::FLAG_WIZ),
1356 cf::player::list
1357}
1358
1216=item cf::player::find $login 1359=item cf::player::find $login
1217 1360
1218Returns the given player object, loading it if necessary (might block). 1361Returns the given player object, loading it if necessary (might block).
1219 1362
1220=cut 1363=cut
… …
1255 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1398 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1256 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1399 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1257 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1400 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1258 aio_unlink +(playerdir $login) . "/$login.pl"; 1401 aio_unlink +(playerdir $login) . "/$login.pl";
1259 1402
1260 my $pl = load_pl path $login 1403 my $f = new_from_file cf::object::thawer path $login
1261 or return; 1404 or return;
1405
1406 my $pl = cf::player::load_pl $f
1407 or return;
1408 local $cf::PLAYER_LOADING{$login} = $pl;
1409 $f->resolve_delayed_derefs;
1262 $cf::PLAYER{$login} = $pl 1410 $cf::PLAYER{$login} = $pl
1263 } 1411 }
1264 } 1412 }
1265} 1413}
1266 1414
… …
1276 1424
1277 aio_mkdir playerdir $pl, 0770; 1425 aio_mkdir playerdir $pl, 0770;
1278 $pl->{last_save} = $cf::RUNTIME; 1426 $pl->{last_save} = $cf::RUNTIME;
1279 1427
1280 $pl->save_pl ($path); 1428 $pl->save_pl ($path);
1281 Coro::cede; 1429 cf::cede_to_tick;
1282} 1430}
1283 1431
1284sub new($) { 1432sub new($) {
1285 my ($login) = @_; 1433 my ($login) = @_;
1286 1434
… …
1290 $self->{deny_save} = 1; 1438 $self->{deny_save} = 1;
1291 1439
1292 $cf::PLAYER{$login} = $self; 1440 $cf::PLAYER{$login} = $self;
1293 1441
1294 $self 1442 $self
1443}
1444
1445=item $player->send_msg ($channel, $msg, $color, [extra...])
1446
1447=cut
1448
1449sub send_msg {
1450 my $ns = shift->ns
1451 or return;
1452 $ns->send_msg (@_);
1295} 1453}
1296 1454
1297=item $pl->quit_character 1455=item $pl->quit_character
1298 1456
1299Nukes the player without looking back. If logged in, the connection will 1457Nukes the player without looking back. If logged in, the connection will
… …
1354 or return []; 1512 or return [];
1355 1513
1356 my @logins; 1514 my @logins;
1357 1515
1358 for my $login (@$dirs) { 1516 for my $login (@$dirs) {
1517 my $path = path $login;
1518
1519 # a .pst is a dead give-away for a valid player
1520 unless (-e "$path.pst") {
1359 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1521 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1360 aio_read $fh, 0, 512, my $buf, 0 or next; 1522 aio_read $fh, 0, 512, my $buf, 0 or next;
1361 $buf !~ /^password -------------$/m or next; # official not-valid tag 1523 $buf !~ /^password -------------$/m or next; # official not-valid tag
1524 }
1362 1525
1363 utf8::decode $login; 1526 utf8::decode $login;
1364 push @logins, $login; 1527 push @logins, $login;
1365 } 1528 }
1366 1529
… …
1399 1562
1400Expand crossfire pod fragments into protocol xml. 1563Expand crossfire pod fragments into protocol xml.
1401 1564
1402=cut 1565=cut
1403 1566
1567use re 'eval';
1568
1569my $group;
1570my $interior; $interior = qr{
1571 # match a pod interior sequence sans C<< >>
1572 (?:
1573 \ (.*?)\ (?{ $group = $^N })
1574 | < (??{$interior}) >
1575 )
1576}x;
1577
1404sub expand_cfpod { 1578sub expand_cfpod {
1405 ((my $self), (local $_)) = @_; 1579 my ($self, $pod) = @_;
1406 1580
1407 # escape & and < 1581 my $xml;
1408 s/&/&amp;/g;
1409 s/(?<![BIUGH])</&lt;/g;
1410 1582
1411 # this is buggy, it needs to properly take care of nested <'s 1583 while () {
1584 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1585 $group = $1;
1412 1586
1413 1 while 1587 $group =~ s/&/&amp;/g;
1414 # replace B<>, I<>, U<> etc. 1588 $group =~ s/</&lt;/g;
1415 s/B<([^\>]*)>/<b>$1<\/b>/ 1589
1416 || s/I<([^\>]*)>/<i>$1<\/i>/ 1590 $xml .= $group;
1417 || s/U<([^\>]*)>/<u>$1<\/u>/ 1591 } elsif ($pod =~ m%\G
1418 # replace G<male|female> tags 1592 ([BCGHITU])
1419 || s{G<([^>|]*)\|([^>]*)>}{ 1593 <
1420 $self->gender ? $2 : $1 1594 (?:
1421 }ge 1595 ([^<>]*) (?{ $group = $^N })
1422 # replace H<hint text> 1596 | < $interior >
1423 || s{H<([^\>]*)>} 1597 )
1598 >
1599 %gcsx
1424 { 1600 ) {
1601 my ($code, $data) = ($1, $group);
1602
1603 if ($code eq "B") {
1604 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1605 } elsif ($code eq "I") {
1606 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1607 } elsif ($code eq "U") {
1608 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1609 } elsif ($code eq "C") {
1610 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1611 } elsif ($code eq "T") {
1612 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1613 } elsif ($code eq "G") {
1614 my ($male, $female) = split /\|/, $data;
1615 $data = $self->gender ? $female : $male;
1616 $xml .= expand_cfpod ($self, $data);
1617 } elsif ($code eq "H") {
1425 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1618 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1426 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1619 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1427 "") 1620 "")
1428 [$self->{hintmode}] 1621 [$self->{hintmode}];
1622 } else {
1623 $xml .= "error processing '$code($data)' directive";
1429 }ge; 1624 }
1625 } else {
1626 if ($pod =~ /\G(.+)/) {
1627 warn "parse error while expanding $pod (at $1)";
1628 }
1629 last;
1630 }
1631 }
1430 1632
1633 for ($xml) {
1431 # create single paragraphs (very hackish) 1634 # create single paragraphs (very hackish)
1432 s/(?<=\S)\n(?=\w)/ /g; 1635 s/(?<=\S)\n(?=\w)/ /g;
1433 1636
1434 # compress some whitespace 1637 # compress some whitespace
1435 s/\s+\n/\n/g; # ws line-ends 1638 s/\s+\n/\n/g; # ws line-ends
1436 s/\n\n+/\n/g; # double lines 1639 s/\n\n+/\n/g; # double lines
1437 s/^\n+//; # beginning lines 1640 s/^\n+//; # beginning lines
1438 s/\n+$//; # ending lines 1641 s/\n+$//; # ending lines
1642 }
1439 1643
1440 warn $_;#d# 1644 $xml
1441 $_
1442} 1645}
1646
1647no re 'eval';
1443 1648
1444sub hintmode { 1649sub hintmode {
1445 $_[0]{hintmode} = $_[1] if @_ > 1; 1650 $_[0]{hintmode} = $_[1] if @_ > 1;
1446 $_[0]{hintmode} 1651 $_[0]{hintmode}
1447} 1652}
1448 1653
1449=item $player->ext_reply ($msgid, %msg) 1654=item $player->ext_reply ($msgid, @msg)
1450 1655
1451Sends an ext reply to the player. 1656Sends an ext reply to the player.
1452 1657
1453=cut 1658=cut
1454 1659
1455sub ext_reply($$%) { 1660sub ext_reply($$@) {
1456 my ($self, $id, %msg) = @_; 1661 my ($self, $id, @msg) = @_;
1457 1662
1458 $msg{msgid} = $id; 1663 $self->ns->ext_reply ($id, @msg)
1459 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1460} 1664}
1461 1665
1462=item $player->ext_event ($type, %msg) 1666=item $player->ext_msg ($type, @msg)
1463 1667
1464Sends an ext event to the client. 1668Sends an ext event to the client.
1465 1669
1466=cut 1670=cut
1467 1671
1468sub ext_event($$%) { 1672sub ext_msg($$@) {
1469 my ($self, $type, %msg) = @_; 1673 my ($self, $type, @msg) = @_;
1470 1674
1471 $self->ns->ext_event ($type, %msg); 1675 $self->ns->ext_msg ($type, @msg);
1472} 1676}
1473 1677
1474=head3 cf::region 1678=head3 cf::region
1475 1679
1476=over 4 1680=over 4
… …
1489 my ($path) = @_; 1693 my ($path) = @_;
1490 1694
1491 my ($match, $specificity); 1695 my ($match, $specificity);
1492 1696
1493 for my $region (list) { 1697 for my $region (list) {
1494 if ($region->match && $path =~ $region->match) { 1698 if ($region->{match} && $path =~ $region->{match}) {
1495 ($match, $specificity) = ($region, $region->specificity) 1699 ($match, $specificity) = ($region, $region->specificity)
1496 if $region->specificity > $specificity; 1700 if $region->specificity > $specificity;
1497 } 1701 }
1498 } 1702 }
1499 1703
… …
1619 $self->init; # pass $1 etc. 1823 $self->init; # pass $1 etc.
1620 return $self; 1824 return $self;
1621 } 1825 }
1622 } 1826 }
1623 1827
1624 Carp::carp "unable to resolve path '$path' (base '$base')."; 1828 Carp::cluck "unable to resolve path '$path' (base '$base').";
1625 () 1829 ()
1626} 1830}
1627 1831
1628sub init { 1832sub init {
1629 my ($self) = @_; 1833 my ($self) = @_;
… …
1692 1896
1693sub load_header_from($) { 1897sub load_header_from($) {
1694 my ($self, $path) = @_; 1898 my ($self, $path) = @_;
1695 1899
1696 utf8::encode $path; 1900 utf8::encode $path;
1697 #aio_open $path, O_RDONLY, 0 1901 my $f = new_from_file cf::object::thawer $path
1698 # or return;
1699
1700 $self->_load_header ($path)
1701 or return; 1902 or return;
1903
1904 $self->_load_header ($f)
1905 or return;
1906
1907 local $MAP_LOADING{$self->{path}} = $self;
1908 $f->resolve_delayed_derefs;
1702 1909
1703 $self->{load_path} = $path; 1910 $self->{load_path} = $path;
1704 1911
1705 1 1912 1
1706} 1913}
… …
1760sub find { 1967sub find {
1761 my ($path, $origin) = @_; 1968 my ($path, $origin) = @_;
1762 1969
1763 $path = normalise $path, $origin && $origin->path; 1970 $path = normalise $path, $origin && $origin->path;
1764 1971
1972 cf::lock_wait "map_data:$path";#d#remove
1765 cf::lock_wait "map_find:$path"; 1973 cf::lock_wait "map_find:$path";
1766 1974
1767 $cf::MAP{$path} || do { 1975 $cf::MAP{$path} || do {
1768 my $guard = cf::lock_acquire "map_find:$path"; 1976 my $guard1 = cf::lock_acquire "map_find:$path";
1977 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1978
1769 my $map = new_from_path cf::map $path 1979 my $map = new_from_path cf::map $path
1770 or return; 1980 or return;
1771 1981
1772 $map->{last_save} = $cf::RUNTIME; 1982 $map->{last_save} = $cf::RUNTIME;
1773 1983
… …
1775 or return; 1985 or return;
1776 1986
1777 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1987 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1778 # doing this can freeze the server in a sync job, obviously 1988 # doing this can freeze the server in a sync job, obviously
1779 #$cf::WAIT_FOR_TICK->wait; 1989 #$cf::WAIT_FOR_TICK->wait;
1990 undef $guard1;
1991 undef $guard2;
1780 $map->reset; 1992 $map->reset;
1781 undef $guard;
1782 return find $path; 1993 return find $path;
1783 } 1994 }
1784 1995
1785 $cf::MAP{$path} = $map 1996 $cf::MAP{$path} = $map
1786 } 1997 }
… …
1795 local $self->{deny_reset} = 1; # loading can take a long time 2006 local $self->{deny_reset} = 1; # loading can take a long time
1796 2007
1797 my $path = $self->{path}; 2008 my $path = $self->{path};
1798 2009
1799 { 2010 {
1800 my $guard = cf::lock_acquire "map_load:$path"; 2011 my $guard = cf::lock_acquire "map_data:$path";
1801 2012
2013 return unless $self->valid;
1802 return if $self->in_memory != cf::MAP_SWAPPED; 2014 return unless $self->in_memory == cf::MAP_SWAPPED;
1803 2015
1804 $self->in_memory (cf::MAP_LOADING); 2016 $self->in_memory (cf::MAP_LOADING);
1805 2017
1806 $self->alloc; 2018 $self->alloc;
1807 2019
1808 $self->pre_load; 2020 $self->pre_load;
1809 Coro::cede; 2021 cf::cede_to_tick;
1810 2022
2023 my $f = new_from_file cf::object::thawer $self->{load_path};
2024 $f->skip_block;
1811 $self->_load_objects ($self->{load_path}, 1) 2025 $self->_load_objects ($f)
1812 or return; 2026 or return;
1813 2027
1814 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2028 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1815 if delete $self->{load_original}; 2029 if delete $self->{load_original};
1816 2030
1817 if (my $uniq = $self->uniq_path) { 2031 if (my $uniq = $self->uniq_path) {
1818 utf8::encode $uniq; 2032 utf8::encode $uniq;
1819 if (aio_open $uniq, O_RDONLY, 0) { 2033 unless (aio_stat $uniq) {
2034 if (my $f = new_from_file cf::object::thawer $uniq) {
1820 $self->clear_unique_items; 2035 $self->clear_unique_items;
1821 $self->_load_objects ($uniq, 0); 2036 $self->_load_objects ($f);
2037 $f->resolve_delayed_derefs;
2038 }
1822 } 2039 }
1823 } 2040 }
1824 2041
1825 Coro::cede; 2042 $f->resolve_delayed_derefs;
2043
2044 cf::cede_to_tick;
1826 # now do the right thing for maps 2045 # now do the right thing for maps
1827 $self->link_multipart_objects; 2046 $self->link_multipart_objects;
1828 $self->difficulty ($self->estimate_difficulty) 2047 $self->difficulty ($self->estimate_difficulty)
1829 unless $self->difficulty; 2048 unless $self->difficulty;
1830 Coro::cede; 2049 cf::cede_to_tick;
1831 2050
1832 unless ($self->{deny_activate}) { 2051 unless ($self->{deny_activate}) {
1833 $self->decay_objects; 2052 $self->decay_objects;
1834 $self->fix_auto_apply; 2053 $self->fix_auto_apply;
1835 $self->update_buttons; 2054 $self->update_buttons;
1836 Coro::cede; 2055 cf::cede_to_tick;
1837 $self->set_darkness_map; 2056 $self->set_darkness_map;
1838 Coro::cede; 2057 cf::cede_to_tick;
1839 $self->activate; 2058 $self->activate;
1840 } 2059 }
2060
2061 $self->{last_save} = $cf::RUNTIME;
2062 $self->last_access ($cf::RUNTIME);
1841 2063
1842 $self->in_memory (cf::MAP_IN_MEMORY); 2064 $self->in_memory (cf::MAP_IN_MEMORY);
1843 } 2065 }
1844 2066
1845 $self->post_load; 2067 $self->post_load;
… …
1856 2078
1857 $self 2079 $self
1858} 2080}
1859 2081
1860# find and load all maps in the 3x3 area around a map 2082# find and load all maps in the 3x3 area around a map
1861sub load_diag { 2083sub load_neighbours {
1862 my ($map) = @_; 2084 my ($map) = @_;
1863 2085
1864 my @diag; # diagonal neighbours 2086 my @neigh; # diagonal neighbours
1865 2087
1866 for (0 .. 3) { 2088 for (0 .. 3) {
1867 my $neigh = $map->tile_path ($_) 2089 my $neigh = $map->tile_path ($_)
1868 or next; 2090 or next;
1869 $neigh = find $neigh, $map 2091 $neigh = find $neigh, $map
1870 or next; 2092 or next;
1871 $neigh->load; 2093 $neigh->load;
1872 2094
2095 push @neigh,
1873 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2096 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1874 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2097 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1875 } 2098 }
1876 2099
1877 for (@diag) { 2100 for (grep defined $_->[0], @neigh) {
2101 my ($path, $origin) = @$_;
1878 my $neigh = find @$_ 2102 my $neigh = find $path, $origin
1879 or next; 2103 or next;
1880 $neigh->load; 2104 $neigh->load;
1881 } 2105 }
1882} 2106}
1883 2107
… …
1888} 2112}
1889 2113
1890sub do_load_sync { 2114sub do_load_sync {
1891 my ($map) = @_; 2115 my ($map) = @_;
1892 2116
2117 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2118 if $Coro::current == $Coro::main;
2119
1893 cf::sync_job { $map->load }; 2120 cf::sync_job { $map->load };
1894} 2121}
1895 2122
1896our %MAP_PREFETCH; 2123our %MAP_PREFETCH;
1897our $MAP_PREFETCHER = undef; 2124our $MAP_PREFETCHER = undef;
1898 2125
1899sub find_async { 2126sub find_async {
1900 my ($path, $origin) = @_; 2127 my ($path, $origin, $load) = @_;
1901 2128
1902 $path = normalise $path, $origin && $origin->{path}; 2129 $path = normalise $path, $origin && $origin->{path};
1903 2130
1904 if (my $map = $cf::MAP{$path}) { 2131 if (my $map = $cf::MAP{$path}) {
1905 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2132 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1906 } 2133 }
1907 2134
1908 undef $MAP_PREFETCH{$path}; 2135 $MAP_PREFETCH{$path} |= $load;
2136
1909 $MAP_PREFETCHER ||= cf::async { 2137 $MAP_PREFETCHER ||= cf::async {
2138 $Coro::current->{desc} = "map prefetcher";
2139
1910 while (%MAP_PREFETCH) { 2140 while (%MAP_PREFETCH) {
1911 for my $path (keys %MAP_PREFETCH) { 2141 while (my ($k, $v) = each %MAP_PREFETCH) {
1912 my $map = find $path 2142 if (my $map = find $k) {
1913 or next;
1914 $map->load; 2143 $map->load if $v;
2144 }
1915 2145
1916 delete $MAP_PREFETCH{$path}; 2146 delete $MAP_PREFETCH{$k};
1917 } 2147 }
1918 } 2148 }
1919 undef $MAP_PREFETCHER; 2149 undef $MAP_PREFETCHER;
1920 }; 2150 };
1921 $MAP_PREFETCHER->prio (6); 2151 $MAP_PREFETCHER->prio (6);
… …
1924} 2154}
1925 2155
1926sub save { 2156sub save {
1927 my ($self) = @_; 2157 my ($self) = @_;
1928 2158
1929 my $lock = cf::lock_acquire "map_data:" . $self->path; 2159 my $lock = cf::lock_acquire "map_data:$self->{path}";
1930 2160
1931 $self->{last_save} = $cf::RUNTIME; 2161 $self->{last_save} = $cf::RUNTIME;
1932 2162
1933 return unless $self->dirty; 2163 return unless $self->dirty;
1934 2164
… …
1940 return if $self->{deny_save}; 2170 return if $self->{deny_save};
1941 2171
1942 local $self->{last_access} = $self->last_access;#d# 2172 local $self->{last_access} = $self->last_access;#d#
1943 2173
1944 cf::async { 2174 cf::async {
2175 $Coro::current->{desc} = "map player save";
1945 $_->contr->save for $self->players; 2176 $_->contr->save for $self->players;
1946 }; 2177 };
1947 2178
1948 if ($uniq) { 2179 if ($uniq) {
1949 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2180 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1957 my ($self) = @_; 2188 my ($self) = @_;
1958 2189
1959 # save first because save cedes 2190 # save first because save cedes
1960 $self->save; 2191 $self->save;
1961 2192
1962 my $lock = cf::lock_acquire "map_data:" . $self->path; 2193 my $lock = cf::lock_acquire "map_data:$self->{path}";
1963 2194
1964 return if $self->players; 2195 return if $self->players;
1965 return if $self->in_memory != cf::MAP_IN_MEMORY; 2196 return if $self->in_memory != cf::MAP_IN_MEMORY;
1966 return if $self->{deny_save}; 2197 return if $self->{deny_save};
1967 2198
2199 $self->in_memory (cf::MAP_SWAPPED);
2200
2201 $self->deactivate;
2202 $_->clear_links_to ($self) for values %cf::MAP;
1968 $self->clear; 2203 $self->clear;
1969 $self->in_memory (cf::MAP_SWAPPED);
1970} 2204}
1971 2205
1972sub reset_at { 2206sub reset_at {
1973 my ($self) = @_; 2207 my ($self) = @_;
1974 2208
… …
2006 if $uniq; 2240 if $uniq;
2007 } 2241 }
2008 2242
2009 delete $cf::MAP{$self->path}; 2243 delete $cf::MAP{$self->path};
2010 2244
2245 $self->deactivate;
2246 $_->clear_links_to ($self) for values %cf::MAP;
2011 $self->clear; 2247 $self->clear;
2012
2013 $_->clear_links_to ($self) for values %cf::MAP;
2014 2248
2015 $self->unlink_save; 2249 $self->unlink_save;
2016 $self->destroy; 2250 $self->destroy;
2017} 2251}
2018 2252
2019my $nuke_counter = "aaaa"; 2253my $nuke_counter = "aaaa";
2020 2254
2021sub nuke { 2255sub nuke {
2022 my ($self) = @_; 2256 my ($self) = @_;
2023 2257
2258 {
2259 my $lock = cf::lock_acquire "map_data:$self->{path}";
2260
2024 delete $cf::MAP{$self->path}; 2261 delete $cf::MAP{$self->path};
2025 2262
2026 $self->unlink_save; 2263 $self->unlink_save;
2027 2264
2028 bless $self, "cf::map"; 2265 bless $self, "cf::map";
2029 delete $self->{deny_reset}; 2266 delete $self->{deny_reset};
2030 $self->{deny_save} = 1; 2267 $self->{deny_save} = 1;
2031 $self->reset_timeout (1); 2268 $self->reset_timeout (1);
2032 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2269 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2033 2270
2034 $cf::MAP{$self->path} = $self; 2271 $cf::MAP{$self->path} = $self;
2272 }
2035 2273
2036 $self->reset; # polite request, might not happen 2274 $self->reset; # polite request, might not happen
2037} 2275}
2038 2276
2039=item $maps = cf::map::tmp_maps 2277=item $maps = cf::map::tmp_maps
… …
2115 2353
2116sub inv_recursive { 2354sub inv_recursive {
2117 inv_recursive_ inv $_[0] 2355 inv_recursive_ inv $_[0]
2118} 2356}
2119 2357
2358=item $ref = $ob->ref
2359
2360creates and returns a persistent reference to an objetc that can be stored as a string.
2361
2362=item $ob = cf::object::deref ($refstring)
2363
2364returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2365even if the object actually exists. May block.
2366
2367=cut
2368
2369sub deref {
2370 my ($ref) = @_;
2371
2372 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2373 my ($uuid, $name) = ($1, $2);
2374 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2375 or return;
2376 $pl->ob->uuid eq $uuid
2377 or return;
2378
2379 $pl->ob
2380 } else {
2381 warn "$ref: cannot resolve object reference\n";
2382 undef
2383 }
2384}
2385
2120package cf; 2386package cf;
2121 2387
2122=back 2388=back
2123 2389
2124=head3 cf::object::player 2390=head3 cf::object::player
… …
2146 2412
2147 } else { 2413 } else {
2148 my $pl = $self->contr; 2414 my $pl = $self->contr;
2149 2415
2150 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2416 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151 my $diag = $pl->{npc_dialog}; 2417 my $dialog = $pl->{npc_dialog};
2152 $diag->{pl}->ext_reply ( 2418 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2153 $diag->{id},
2154 msgtype => "reply",
2155 msg => $diag->{pl}->expand_cfpod ($msg),
2156 add_topics => []
2157 );
2158 2419
2159 } else { 2420 } else {
2160 $msg = $npc->name . " says: $msg" if $npc; 2421 $msg = $npc->name . " says: $msg" if $npc;
2161 $self->message ($msg, $flags); 2422 $self->message ($msg, $flags);
2162 } 2423 }
2163 } 2424 }
2425}
2426
2427=item $object->send_msg ($channel, $msg, $color, [extra...])
2428
2429=cut
2430
2431sub cf::object::send_msg {
2432 my $pl = shift->contr
2433 or return;
2434 $pl->send_msg (@_);
2164} 2435}
2165 2436
2166=item $player_object->may ("access") 2437=item $player_object->may ("access")
2167 2438
2168Returns wether the given player is authorized to access resource "access" 2439Returns wether the given player is authorized to access resource "access"
… …
2247 # use -1 or undef as default coordinates, not 0, 0 2518 # use -1 or undef as default coordinates, not 0, 0
2248 ($x, $y) = ($map->enter_x, $map->enter_y) 2519 ($x, $y) = ($map->enter_x, $map->enter_y)
2249 if $x <=0 && $y <= 0; 2520 if $x <=0 && $y <= 0;
2250 2521
2251 $map->load; 2522 $map->load;
2252 $map->load_diag; 2523 $map->load_neighbours;
2253 2524
2254 return unless $self->contr->active; 2525 return unless $self->contr->active;
2255 $self->activate_recursive; 2526 $self->activate_recursive;
2256 2527
2257 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2528 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2258 $self->enter_map ($map, $x, $y); 2529 $self->enter_map ($map, $x, $y);
2259} 2530}
2260 2531
2261=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2532=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2262 2533
2263Moves the player to the given map-path and coordinates by first freezing 2534Moves the player to the given map-path and coordinates by first freezing
2264her, loading and preparing them map, calling the provided $check callback 2535her, loading and preparing them map, calling the provided $check callback
2265that has to return the map if sucecssful, and then unfreezes the player on 2536that has to return the map if sucecssful, and then unfreezes the player on
2266the new (success) or old (failed) map position. 2537the new (success) or old (failed) map position. In either case, $done will
2538be called at the end of this process.
2267 2539
2268=cut 2540=cut
2269 2541
2270our $GOTOGEN; 2542our $GOTOGEN;
2271 2543
2272sub cf::object::player::goto { 2544sub cf::object::player::goto {
2273 my ($self, $path, $x, $y, $check) = @_; 2545 my ($self, $path, $x, $y, $check, $done) = @_;
2274 2546
2275 # do generation counting so two concurrent goto's will be executed in-order 2547 # do generation counting so two concurrent goto's will be executed in-order
2276 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2548 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2277 2549
2278 $self->enter_link; 2550 $self->enter_link;
2279 2551
2280 (async { 2552 (async {
2553 $Coro::current->{desc} = "player::goto $path $x $y";
2554
2555 # *tag paths override both path and x|y
2556 if ($path =~ /^\*(.*)$/) {
2557 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2558 my $ob = $obs[rand @obs];
2559
2560 # see if we actually can go there
2561 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2562 $ob = $obs[rand @obs];
2563 } else {
2564 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2565 }
2566 # else put us there anyways for now #d#
2567
2568 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2569 } else {
2570 ($path, $x, $y) = (undef, undef, undef);
2571 }
2572 }
2573
2281 my $map = eval { 2574 my $map = eval {
2282 my $map = cf::map::find $path; 2575 my $map = defined $path ? cf::map::find $path : undef;
2283 2576
2284 if ($map) { 2577 if ($map) {
2285 $map = $map->customise_for ($self); 2578 $map = $map->customise_for ($self);
2286 $map = $check->($map) if $check && $map; 2579 $map = $check->($map) if $check && $map;
2287 } else { 2580 } else {
2288 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2581 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2289 } 2582 }
2290 2583
2291 $map 2584 $map
2292 }; 2585 };
2293 2586
… …
2298 2591
2299 if ($gen == $self->{_goto_generation}) { 2592 if ($gen == $self->{_goto_generation}) {
2300 delete $self->{_goto_generation}; 2593 delete $self->{_goto_generation};
2301 $self->leave_link ($map, $x, $y); 2594 $self->leave_link ($map, $x, $y);
2302 } 2595 }
2596
2597 $done->() if $done;
2303 })->prio (1); 2598 })->prio (1);
2304} 2599}
2305 2600
2306=item $player_object->enter_exit ($exit_object) 2601=item $player_object->enter_exit ($exit_object)
2307 2602
… …
2344 $rmp->{origin_y} = $exit->y; 2639 $rmp->{origin_y} = $exit->y;
2345 } 2640 }
2346 2641
2347 $rmp->{random_seed} ||= $exit->random_seed; 2642 $rmp->{random_seed} ||= $exit->random_seed;
2348 2643
2349 my $data = cf::to_json $rmp; 2644 my $data = cf::encode_json $rmp;
2350 my $md5 = Digest::MD5::md5_hex $data; 2645 my $md5 = Digest::MD5::md5_hex $data;
2351 my $meta = "$RANDOMDIR/$md5.meta"; 2646 my $meta = "$RANDOMDIR/$md5.meta";
2352 2647
2353 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2648 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2354 aio_write $fh, 0, (length $data), $data, 0; 2649 aio_write $fh, 0, (length $data), $data, 0;
… …
2381 # if exit is damned, update players death & WoR home-position 2676 # if exit is damned, update players death & WoR home-position
2382 $self->contr->savebed ($slaying, $hp, $sp) 2677 $self->contr->savebed ($slaying, $hp, $sp)
2383 if $exit->flag (FLAG_DAMNED); 2678 if $exit->flag (FLAG_DAMNED);
2384 2679
2385 (async { 2680 (async {
2681 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2682
2386 $self->deactivate_recursive; # just to be sure 2683 $self->deactivate_recursive; # just to be sure
2387 unless (eval { 2684 unless (eval {
2388 $self->goto ($slaying, $hp, $sp); 2685 $self->goto ($slaying, $hp, $sp);
2389 2686
2390 1; 2687 1;
… …
2416 2713
2417 utf8::encode $text; 2714 utf8::encode $text;
2418 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2715 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2419} 2716}
2420 2717
2421=item $client->send_msg ($color, $type, $msg, [extra...]) 2718=item $client->send_msg ($channel, $msg, $color, [extra...])
2422 2719
2423Send a drawinfo or msg packet to the client, formatting the msg for the 2720Send a drawinfo or msg packet to the client, formatting the msg for the
2424client if neccessary. C<$type> should be a string identifying the type of 2721client if neccessary. C<$type> should be a string identifying the type of
2425the message, with C<log> being the default. If C<$color> is negative, suppress 2722the message, with C<log> being the default. If C<$color> is negative, suppress
2426the message unless the client supports the msg packet. 2723the message unless the client supports the msg packet.
2427 2724
2428=cut 2725=cut
2429 2726
2727# non-persistent channels (usually the info channel)
2728our %CHANNEL = (
2729 "c/identify" => {
2730 id => "infobox",
2731 title => "Identify",
2732 reply => undef,
2733 tooltip => "Items recently identified",
2734 },
2735 "c/examine" => {
2736 id => "infobox",
2737 title => "Examine",
2738 reply => undef,
2739 tooltip => "Signs and other items you examined",
2740 },
2741 "c/book" => {
2742 id => "infobox",
2743 title => "Book",
2744 reply => undef,
2745 tooltip => "The contents of a note or book",
2746 },
2747 "c/lookat" => {
2748 id => "infobox",
2749 title => "Look",
2750 reply => undef,
2751 tooltip => "What you saw there",
2752 },
2753 "c/who" => {
2754 id => "infobox",
2755 title => "Players",
2756 reply => undef,
2757 tooltip => "Shows players who are currently online",
2758 },
2759 "c/body" => {
2760 id => "infobox",
2761 title => "Body Parts",
2762 reply => undef,
2763 tooltip => "Shows which body parts you posess and are available",
2764 },
2765 "c/uptime" => {
2766 id => "infobox",
2767 title => "Uptime",
2768 reply => undef,
2769 tooltip => "How long the server has been running since last restart",
2770 },
2771 "c/mapinfo" => {
2772 id => "infobox",
2773 title => "Map Info",
2774 reply => undef,
2775 tooltip => "Information related to the maps",
2776 },
2777);
2778
2430sub cf::client::send_msg { 2779sub cf::client::send_msg {
2431 my ($self, $color, $type, $msg, @extra) = @_; 2780 my ($self, $channel, $msg, $color, @extra) = @_;
2432 2781
2433 $msg = $self->pl->expand_cfpod ($msg); 2782 $msg = $self->pl->expand_cfpod ($msg);
2434 2783
2784 $color &= cf::NDI_CLIENT_MASK; # just in case...
2785
2786 # check predefined channels, for the benefit of C
2787 if ($CHANNEL{$channel}) {
2788 $channel = $CHANNEL{$channel};
2789
2790 $self->ext_msg (channel_info => $channel)
2791 if $self->can_msg;
2792
2793 $channel = $channel->{id};
2794
2795 } elsif (ref $channel) {
2796 # send meta info to client, if not yet sent
2797 unless (exists $self->{channel}{$channel->{id}}) {
2798 $self->{channel}{$channel->{id}} = $channel;
2799 $self->ext_msg (channel_info => $channel)
2800 if $self->can_msg;
2801 }
2802
2803 $channel = $channel->{id};
2804 }
2805
2435 return unless @extra || length $msg; 2806 return unless @extra || length $msg;
2436 2807
2437 if ($self->can_msg) { 2808 if ($self->can_msg) {
2809 # default colour, mask it out
2810 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2811 if $color & cf::NDI_DEF;
2812
2438 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra])); 2813 $self->send_packet ("msg " . $self->{json_coder}->encode (
2814 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2439 } else { 2815 } else {
2440 # replace some tags by gcfclient-compatible ones
2441 for ($msg) {
2442 1 while
2443 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2444 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2445 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2446 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2447 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2448 }
2449
2450 if ($color >= 0) { 2816 if ($color >= 0) {
2817 # replace some tags by gcfclient-compatible ones
2818 for ($msg) {
2819 1 while
2820 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2821 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2822 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2823 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2824 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2825 }
2826
2827 $color &= cf::NDI_COLOR_MASK;
2828
2829 utf8::encode $msg;
2830
2451 if (0 && $msg =~ /\[/) { 2831 if (0 && $msg =~ /\[/) {
2832 # COMMAND/INFO
2452 $self->send_packet ("drawextinfo $color 4 0 $msg") 2833 $self->send_packet ("drawextinfo $color 10 8 $msg")
2453 } else { 2834 } else {
2454 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2835 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2455 $self->send_packet ("drawinfo $color $msg") 2836 $self->send_packet ("drawinfo $color $msg")
2456 } 2837 }
2457 } 2838 }
2458 } 2839 }
2459} 2840}
2460 2841
2461=item $client->ext_event ($type, %msg) 2842=item $client->ext_msg ($type, @msg)
2462 2843
2463Sends an ext event to the client. 2844Sends an ext event to the client.
2464 2845
2465=cut 2846=cut
2466 2847
2467sub cf::client::ext_event($$%) { 2848sub cf::client::ext_msg($$@) {
2468 my ($self, $type, %msg) = @_; 2849 my ($self, $type, @msg) = @_;
2469 2850
2851 if ($self->extcmd == 2) {
2852 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2853 } elsif ($self->extcmd == 1) { # TODO: remove
2470 $msg{msgtype} = "event_$type"; 2854 push @msg, msgtype => "event_$type";
2471 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2855 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2856 }
2857}
2858
2859=item $client->ext_reply ($msgid, @msg)
2860
2861Sends an ext reply to the client.
2862
2863=cut
2864
2865sub cf::client::ext_reply($$@) {
2866 my ($self, $id, @msg) = @_;
2867
2868 if ($self->extcmd == 2) {
2869 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2870 } elsif ($self->extcmd == 1) {
2871 #TODO: version 1, remove
2872 unshift @msg, msgtype => "reply", msgid => $id;
2873 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2874 }
2472} 2875}
2473 2876
2474=item $success = $client->query ($flags, "text", \&cb) 2877=item $success = $client->query ($flags, "text", \&cb)
2475 2878
2476Queues a query to the client, calling the given callback with 2879Queues a query to the client, calling the given callback with
… …
2531 my ($ns, $buf) = @_; 2934 my ($ns, $buf) = @_;
2532 2935
2533 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 2936 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2534 2937
2535 if (ref $msg) { 2938 if (ref $msg) {
2939 my ($type, $reply, @payload) =
2940 "ARRAY" eq ref $msg
2941 ? @$msg
2942 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2943
2944 my @reply;
2945
2536 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2946 if (my $cb = $EXTICMD{$type}) {
2537 if (my %reply = $cb->($ns, $msg)) { 2947 @reply = $cb->($ns, @payload);
2538 $reply{msgid} = $msg->{msgid};
2539 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2540 }
2541 } 2948 }
2949
2950 $ns->ext_reply ($reply, @reply)
2951 if $reply;
2952
2542 } else { 2953 } else {
2543 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2954 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2544 } 2955 }
2545 2956
2546 cf::override; 2957 cf::override;
… …
2593our $safe = new Safe "safe"; 3004our $safe = new Safe "safe";
2594our $safe_hole = new Safe::Hole; 3005our $safe_hole = new Safe::Hole;
2595 3006
2596$SIG{FPE} = 'IGNORE'; 3007$SIG{FPE} = 'IGNORE';
2597 3008
2598$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3009$safe->permit_only (Opcode::opset qw(
3010 :base_core :base_mem :base_orig :base_math
3011 grepstart grepwhile mapstart mapwhile
3012 sort time
3013));
2599 3014
2600# here we export the classes and methods available to script code 3015# here we export the classes and methods available to script code
2601 3016
2602=pod 3017=pod
2603 3018
2604The following functions and methods are available within a safe environment: 3019The following functions and methods are available within a safe environment:
2605 3020
2606 cf::object 3021 cf::object
2607 contr pay_amount pay_player map x y force_find force_add 3022 contr pay_amount pay_player map x y force_find force_add destroy
2608 insert remove 3023 insert remove name archname title slaying race decrease_ob_nr
2609 3024
2610 cf::object::player 3025 cf::object::player
2611 player 3026 player
2612 3027
2613 cf::player 3028 cf::player
… …
2618 3033
2619=cut 3034=cut
2620 3035
2621for ( 3036for (
2622 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3037 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3038 insert remove inv name archname title slaying race
2623 insert remove)], 3039 decrease_ob_nr destroy)],
2624 ["cf::object::player" => qw(player)], 3040 ["cf::object::player" => qw(player)],
2625 ["cf::player" => qw(peaceful)], 3041 ["cf::player" => qw(peaceful)],
2626 ["cf::map" => qw(trigger)], 3042 ["cf::map" => qw(trigger)],
2627) { 3043) {
2628 no strict 'refs'; 3044 no strict 'refs';
… …
2704# the server's init and main functions 3120# the server's init and main functions
2705 3121
2706sub load_facedata($) { 3122sub load_facedata($) {
2707 my ($path) = @_; 3123 my ($path) = @_;
2708 3124
3125 # HACK to clear player env face cache, we need some signal framework
3126 # for this (global event?)
3127 %ext::player_env::MUSIC_FACE_CACHE = ();
3128
3129 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3130
2709 warn "loading facedata from $path\n"; 3131 warn "loading facedata from $path\n";
2710 3132
2711 my $facedata; 3133 my $facedata;
2712 0 < aio_load $path, $facedata 3134 0 < aio_load $path, $facedata
2713 or die "$path: $!"; 3135 or die "$path: $!";
… …
2715 $facedata = Coro::Storable::thaw $facedata; 3137 $facedata = Coro::Storable::thaw $facedata;
2716 3138
2717 $facedata->{version} == 2 3139 $facedata->{version} == 2
2718 or cf::cleanup "$path: version mismatch, cannot proceed."; 3140 or cf::cleanup "$path: version mismatch, cannot proceed.";
2719 3141
3142 # patch in the exptable
3143 $facedata->{resource}{"res/exp_table"} = {
3144 type => FT_RSRC,
3145 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3146 };
3147 cf::cede_to_tick;
3148
2720 { 3149 {
2721 my $faces = $facedata->{faceinfo}; 3150 my $faces = $facedata->{faceinfo};
2722 3151
2723 while (my ($face, $info) = each %$faces) { 3152 while (my ($face, $info) = each %$faces) {
2724 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3153 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2725 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3154 cf::face::set_visibility $idx, $info->{visibility};
3155 cf::face::set_magicmap $idx, $info->{magicmap};
2726 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3156 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2727 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3157 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2728 Coro::cede; 3158
3159 cf::cede_to_tick;
2729 } 3160 }
2730 3161
2731 while (my ($face, $info) = each %$faces) { 3162 while (my ($face, $info) = each %$faces) {
2732 next unless $info->{smooth}; 3163 next unless $info->{smooth};
2733 my $idx = cf::face::find $face 3164 my $idx = cf::face::find $face
2734 or next; 3165 or next;
2735 if (my $smooth = cf::face::find $info->{smooth}) { 3166 if (my $smooth = cf::face::find $info->{smooth}) {
3167 cf::face::set_smooth $idx, $smooth;
2736 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3168 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2737 } else { 3169 } else {
2738 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3170 warn "smooth face '$info->{smooth}' not found for face '$face'";
2739 } 3171 }
2740 Coro::cede; 3172
3173 cf::cede_to_tick;
2741 } 3174 }
2742 } 3175 }
2743 3176
2744 { 3177 {
2745 my $anims = $facedata->{animinfo}; 3178 my $anims = $facedata->{animinfo};
2746 3179
2747 while (my ($anim, $info) = each %$anims) { 3180 while (my ($anim, $info) = each %$anims) {
2748 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3181 cf::anim::set $anim, $info->{frames}, $info->{facings};
2749 Coro::cede; 3182 cf::cede_to_tick;
2750 } 3183 }
2751 3184
2752 cf::anim::invalidate_all; # d'oh 3185 cf::anim::invalidate_all; # d'oh
2753 } 3186 }
2754 3187
3188 {
3189 # TODO: for gcfclient pleasure, we should give resources
3190 # that gcfclient doesn't grok a >10000 face index.
3191 my $res = $facedata->{resource};
3192
3193 my $soundconf = delete $res->{"res/sound.conf"};
3194
3195 while (my ($name, $info) = each %$res) {
3196 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3197 my $data;
3198
3199 if ($info->{type} & 1) {
3200 # prepend meta info
3201
3202 my $meta = $enc->encode ({
3203 name => $name,
3204 %{ $info->{meta} || {} },
3205 });
3206
3207 $data = pack "(w/a*)*", $meta, $info->{data};
3208 } else {
3209 $data = $info->{data};
3210 }
3211
3212 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3213 cf::face::set_type $idx, $info->{type};
3214
3215 cf::cede_to_tick;
3216 }
3217
3218 if ($soundconf) {
3219 $soundconf = $enc->decode (delete $soundconf->{data});
3220
3221 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3222 my $sound = $soundconf->{compat}[$_]
3223 or next;
3224
3225 my $face = cf::face::find "sound/$sound->[1]";
3226 cf::sound::set $sound->[0] => $face;
3227 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3228 }
3229
3230 while (my ($k, $v) = each %{$soundconf->{event}}) {
3231 my $face = cf::face::find "sound/$v";
3232 cf::sound::set $k => $face;
3233 }
3234 }
3235 }
3236
2755 1 3237 1
2756} 3238}
2757 3239
3240register_exticmd fx_want => sub {
3241 my ($ns, $want) = @_;
3242
3243 while (my ($k, $v) = each %$want) {
3244 $ns->fx_want ($k, $v);
3245 }
3246};
3247
2758sub reload_regions { 3248sub reload_regions {
3249 # HACK to clear player env face cache, we need some signal framework
3250 # for this (global event?)
3251 %ext::player_env::MUSIC_FACE_CACHE = ();
3252
2759 load_resource_file "$MAPDIR/regions" 3253 load_resource_file "$MAPDIR/regions"
2760 or die "unable to load regions file\n"; 3254 or die "unable to load regions file\n";
3255
3256 for (cf::region::list) {
3257 $_->{match} = qr/$_->{match}/
3258 if exists $_->{match};
3259 }
2761} 3260}
2762 3261
2763sub reload_facedata { 3262sub reload_facedata {
2764 load_facedata "$DATADIR/facedata" 3263 load_facedata "$DATADIR/facedata"
2765 or die "unable to load facedata\n"; 3264 or die "unable to load facedata\n";
… …
2794 3293
2795sub init { 3294sub init {
2796 reload_resources; 3295 reload_resources;
2797} 3296}
2798 3297
2799sub cfg_load { 3298sub reload_config {
2800 open my $fh, "<:utf8", "$CONFDIR/config" 3299 open my $fh, "<:utf8", "$CONFDIR/config"
2801 or return; 3300 or return;
2802 3301
2803 local $/; 3302 local $/;
2804 *CFG = YAML::Syck::Load <$fh>; 3303 *CFG = YAML::Syck::Load <$fh>;
… …
2820sub main { 3319sub main {
2821 # we must not ever block the main coroutine 3320 # we must not ever block the main coroutine
2822 local $Coro::idle = sub { 3321 local $Coro::idle = sub {
2823 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3322 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2824 (async { 3323 (async {
2825 Event::one_event; 3324 $Coro::current->{desc} = "IDLE BUG HANDLER";
3325 EV::loop EV::LOOP_ONESHOT;
2826 })->prio (Coro::PRIO_MAX); 3326 })->prio (Coro::PRIO_MAX);
2827 }; 3327 };
2828 3328
2829 cfg_load; 3329 reload_config;
2830 db_init; 3330 db_init;
2831 load_extensions; 3331 load_extensions;
2832 3332
2833 $TICK_WATCHER->start; 3333 $TICK_WATCHER->start;
3334 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
2834 Event::loop; 3335 EV::loop;
2835} 3336}
2836 3337
2837############################################################################# 3338#############################################################################
2838# initialisation and cleanup 3339# initialisation and cleanup
2839 3340
2840# install some emergency cleanup handlers 3341# install some emergency cleanup handlers
2841BEGIN { 3342BEGIN {
3343 our %SIGWATCHER = ();
2842 for my $signal (qw(INT HUP TERM)) { 3344 for my $signal (qw(INT HUP TERM)) {
2843 Event->signal ( 3345 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2844 reentrant => 0,
2845 data => WF_AUTOCANCEL,
2846 signal => $signal,
2847 prio => 0,
2848 cb => sub {
2849 cf::cleanup "SIG$signal"; 3346 cf::cleanup "SIG$signal";
2850 },
2851 ); 3347 };
2852 } 3348 }
2853} 3349}
2854 3350
2855sub write_runtime { 3351sub write_runtime {
2856 my $runtime = "$LOCALDIR/runtime"; 3352 my $runtime = "$LOCALDIR/runtime";
… …
2901 # and maps saved/destroyed asynchronously. 3397 # and maps saved/destroyed asynchronously.
2902 warn "begin emergency player save\n"; 3398 warn "begin emergency player save\n";
2903 for my $login (keys %cf::PLAYER) { 3399 for my $login (keys %cf::PLAYER) {
2904 my $pl = $cf::PLAYER{$login} or next; 3400 my $pl = $cf::PLAYER{$login} or next;
2905 $pl->valid or next; 3401 $pl->valid or next;
3402 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2906 $pl->save; 3403 $pl->save;
2907 } 3404 }
2908 warn "end emergency player save\n"; 3405 warn "end emergency player save\n";
2909 3406
2910 warn "begin emergency map save\n"; 3407 warn "begin emergency map save\n";
… …
2949 warn "syncing database to disk"; 3446 warn "syncing database to disk";
2950 BDB::db_env_txn_checkpoint $DB_ENV; 3447 BDB::db_env_txn_checkpoint $DB_ENV;
2951 3448
2952 # if anything goes wrong in here, we should simply crash as we already saved 3449 # if anything goes wrong in here, we should simply crash as we already saved
2953 3450
2954 warn "cancelling all WF_AUTOCANCEL watchers";
2955 for (Event::all_watchers) {
2956 $_->cancel if $_->data & WF_AUTOCANCEL;
2957 }
2958
2959 warn "flushing outstanding aio requests"; 3451 warn "flushing outstanding aio requests";
2960 for (;;) { 3452 for (;;) {
2961 BDB::flush; 3453 BDB::flush;
2962 IO::AIO::flush; 3454 IO::AIO::flush;
2963 Coro::cede; 3455 Coro::cede_notself;
2964 last unless IO::AIO::nreqs || BDB::nreqs; 3456 last unless IO::AIO::nreqs || BDB::nreqs;
2965 warn "iterate..."; 3457 warn "iterate...";
2966 } 3458 }
2967 3459
2968 ++$RELOAD; 3460 ++$RELOAD;
… …
3027 warn "reloading cf.pm"; 3519 warn "reloading cf.pm";
3028 require cf; 3520 require cf;
3029 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3521 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3030 3522
3031 warn "loading config and database again"; 3523 warn "loading config and database again";
3032 cf::cfg_load; 3524 cf::reload_config;
3033 3525
3034 warn "loading extensions"; 3526 warn "loading extensions";
3035 cf::load_extensions; 3527 cf::load_extensions;
3036 3528
3037 warn "reattaching attachments to objects/players"; 3529 warn "reattaching attachments to objects/players";
… …
3057 3549
3058sub reload_perl() { 3550sub reload_perl() {
3059 # doing reload synchronously and two reloads happen back-to-back, 3551 # doing reload synchronously and two reloads happen back-to-back,
3060 # coro crashes during coro_state_free->destroy here. 3552 # coro crashes during coro_state_free->destroy here.
3061 3553
3062 $RELOAD_WATCHER ||= Event->timer ( 3554 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3063 reentrant => 0,
3064 after => 0,
3065 data => WF_AUTOCANCEL,
3066 cb => sub {
3067 do_reload_perl;
3068 undef $RELOAD_WATCHER; 3555 undef $RELOAD_WATCHER;
3069 }, 3556 do_reload_perl;
3070 ); 3557 };
3071} 3558}
3072 3559
3073register_command "reload" => sub { 3560register_command "reload" => sub {
3074 my ($who, $arg) = @_; 3561 my ($who, $arg) = @_;
3075 3562
3076 if ($who->flag (FLAG_WIZ)) { 3563 if ($who->flag (FLAG_WIZ)) {
3077 $who->message ("reloading server."); 3564 $who->message ("reloading server.");
3565 async {
3566 $Coro::current->{desc} = "perl_reload";
3078 async { reload_perl }; 3567 reload_perl;
3568 };
3079 } 3569 }
3080}; 3570};
3081 3571
3082unshift @INC, $LIBDIR; 3572unshift @INC, $LIBDIR;
3083 3573
… …
3102 my $signal = new Coro::Signal; 3592 my $signal = new Coro::Signal;
3103 push @WAIT_FOR_TICK_BEGIN, $signal; 3593 push @WAIT_FOR_TICK_BEGIN, $signal;
3104 $signal->wait; 3594 $signal->wait;
3105} 3595}
3106 3596
3107 my $min = 1e6;#d# 3597$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3108 my $avg = 10;
3109$TICK_WATCHER = Event->timer (
3110 reentrant => 0,
3111 parked => 1,
3112 prio => 0,
3113 at => $NEXT_TICK || $TICK,
3114 data => WF_AUTOCANCEL,
3115 cb => sub {
3116 if ($Coro::current != $Coro::main) { 3598 if ($Coro::current != $Coro::main) {
3117 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3599 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3118 unless ++$bug_warning > 10; 3600 unless ++$bug_warning > 10;
3119 return; 3601 return;
3120 } 3602 }
3121 3603
3122 $NOW = $tick_start = Event::time; 3604 $NOW = $tick_start = EV::now;
3123 3605
3124 cf::server_tick; # one server iteration 3606 cf::server_tick; # one server iteration
3125 3607
3126 0 && sync_job {#d# 3608 $RUNTIME += $TICK;
3127 for(1..10) { 3609 $NEXT_TICK += $TICK;
3128 my $t = Event::time;
3129 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3130 or die;
3131 3610
3132 $map->width (50); 3611 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3133 $map->height (50); 3612 $NEXT_RUNTIME_WRITE = $NOW + 10;
3134 $map->alloc; 3613 Coro::async_pool {
3135 $map->_load_objects ("/tmp/x.map", 1); 3614 $Coro::current->{desc} = "runtime saver";
3136 my $t = Event::time - $t; 3615 write_runtime
3137 3616 or warn "ERROR: unable to write runtime file: $!";
3138 #next unless $t < 0.0013;#d#
3139 if ($t < $min) {
3140 $min = $t;
3141 }
3142 $avg = $avg * 0.99 + $t * 0.01;
3143 }
3144 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3145 exit 0;
3146 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3147 }; 3617 };
3618 }
3148 3619
3149 $RUNTIME += $TICK;
3150 $NEXT_TICK += $TICK;
3151
3152 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3153 $NEXT_RUNTIME_WRITE = $NOW + 10;
3154 Coro::async_pool {
3155 write_runtime
3156 or warn "ERROR: unable to write runtime file: $!";
3157 };
3158 }
3159
3160# my $AFTER = Event::time;
3161# warn $AFTER - $NOW;#d#
3162
3163 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3620 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3164 $sig->send; 3621 $sig->send;
3165 } 3622 }
3166 while (my $sig = shift @WAIT_FOR_TICK) { 3623 while (my $sig = shift @WAIT_FOR_TICK) {
3167 $sig->send; 3624 $sig->send;
3168 } 3625 }
3169 3626
3170 $NOW = Event::time;
3171
3172 # if we are delayed by four ticks or more, skip them all
3173 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3174
3175 $TICK_WATCHER->at ($NEXT_TICK);
3176 $TICK_WATCHER->start;
3177
3178 $LOAD = ($NOW - $tick_start) / $TICK; 3627 $LOAD = ($NOW - $tick_start) / $TICK;
3179 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3628 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3180 3629
3181 _post_tick; 3630 _post_tick;
3182 3631};
3183 3632$TICK_WATCHER->priority (EV::MAXPRI);
3184 },
3185);
3186 3633
3187{ 3634{
3188 BDB::max_poll_time $TICK * 0.1;
3189 $BDB_POLL_WATCHER = Event->io (
3190 reentrant => 0,
3191 fd => BDB::poll_fileno,
3192 poll => 'r',
3193 prio => 0,
3194 data => WF_AUTOCANCEL,
3195 cb => \&BDB::poll_cb,
3196 );
3197 BDB::min_parallel 8; 3635 BDB::min_parallel 8;
3198 3636 BDB::max_poll_reqs $TICK * 0.1;
3199 BDB::set_sync_prepare {
3200 my $status;
3201 my $current = $Coro::current;
3202 (
3203 sub {
3204 $status = $!;
3205 $current->ready; undef $current;
3206 },
3207 sub {
3208 Coro::schedule while defined $current;
3209 $! = $status;
3210 },
3211 )
3212 };
3213 3637
3214 unless ($DB_ENV) { 3638 unless ($DB_ENV) {
3215 $DB_ENV = BDB::db_env_create; 3639 $DB_ENV = BDB::db_env_create;
3640 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3641 | BDB::LOG_AUTOREMOVE, 1);
3642 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3643 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3216 3644
3217 cf::sync_job { 3645 cf::sync_job {
3218 eval { 3646 eval {
3219 BDB::db_env_open 3647 BDB::db_env_open
3220 $DB_ENV, 3648 $DB_ENV,
… …
3222 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3650 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3223 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3651 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3224 0666; 3652 0666;
3225 3653
3226 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3654 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3227
3228 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3229 $DB_ENV->set_lk_detect;
3230 }; 3655 };
3231 3656
3232 cf::cleanup "db_env_open(db): $@" if $@; 3657 cf::cleanup "db_env_open(db): $@" if $@;
3233 }; 3658 };
3234 } 3659 }
3660
3661 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3662 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3663 };
3664 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3665 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3666 };
3667 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3668 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3669 };
3235} 3670}
3236 3671
3237{ 3672{
3238 IO::AIO::min_parallel 8; 3673 IO::AIO::min_parallel 8;
3239 3674
3240 undef $Coro::AIO::WATCHER; 3675 undef $Coro::AIO::WATCHER;
3241 IO::AIO::max_poll_time $TICK * 0.1; 3676 IO::AIO::max_poll_time $TICK * 0.1;
3242 $AIO_POLL_WATCHER = Event->io ( 3677 $AIO_POLL_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
3243 reentrant => 0,
3244 data => WF_AUTOCANCEL,
3245 fd => IO::AIO::poll_fileno,
3246 poll => 'r',
3247 prio => 6,
3248 cb => \&IO::AIO::poll_cb,
3249 );
3250} 3678}
3251 3679
3252my $_log_backtrace; 3680my $_log_backtrace;
3253 3681
3254sub _log_backtrace { 3682sub _log_backtrace {
… …
3258 3686
3259 # limit the # of concurrent backtraces 3687 # limit the # of concurrent backtraces
3260 if ($_log_backtrace < 2) { 3688 if ($_log_backtrace < 2) {
3261 ++$_log_backtrace; 3689 ++$_log_backtrace;
3262 async { 3690 async {
3691 $Coro::current->{desc} = "abt $msg";
3692
3263 my @bt = fork_call { 3693 my @bt = fork_call {
3264 @addr = map { sprintf "%x", $_ } @addr; 3694 @addr = map { sprintf "%x", $_ } @addr;
3265 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3695 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3266 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3696 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3267 or die "addr2line: $!"; 3697 or die "addr2line: $!";

Diff Legend

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