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.350 by root, Sat Sep 1 08:03:45 2007 UTC vs.
Revision 1.439 by root, Mon Jul 14 16:42:49 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
3use utf8; 24use utf8;
4use strict; 25use strict;
5 26
6use Symbol; 27use Symbol;
7use List::Util; 28use List::Util;
8use Socket; 29use Socket;
9use Storable; 30use EV;
10use Event;
11use Opcode; 31use Opcode;
12use Safe; 32use Safe;
13use Safe::Hole; 33use Safe::Hole;
34use Storable ();
14 35
15use Coro 3.64 (); 36use Coro ();
16use Coro::State; 37use Coro::State;
17use Coro::Handle; 38use Coro::Handle;
18use Coro::Event; 39use Coro::AnyEvent;
19use Coro::Timer; 40use Coro::Timer;
20use Coro::Signal; 41use Coro::Signal;
21use Coro::Semaphore; 42use Coro::Semaphore;
43use Coro::AnyEvent;
22use Coro::AIO; 44use Coro::AIO;
45use Coro::BDB 1.6;
23use Coro::Storable; 46use Coro::Storable;
24use Coro::Util (); 47use Coro::Util ();
25 48
26use JSON::XS (); 49use JSON::XS 2.01 ();
27use BDB (); 50use BDB ();
28use Data::Dumper; 51use Data::Dumper;
29use Digest::MD5; 52use Digest::MD5;
30use Fcntl; 53use Fcntl;
31use YAML::Syck (); 54use YAML ();
32use IO::AIO 2.32 (); 55use IO::AIO ();
33use Time::HiRes; 56use Time::HiRes;
34use Compress::LZF; 57use Compress::LZF;
35use Digest::MD5 (); 58use Digest::MD5 ();
59
60AnyEvent::detect;
36 61
37# configure various modules to our taste 62# configure various modules to our taste
38# 63#
39$Storable::canonical = 1; # reduce rsync transfers 64$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 65Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 66Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
43$Event::Eval = 1; # no idea why this is required, but it is
44
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47 67
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 68$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 69
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 70sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 71
… …
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 90our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 91our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 92our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 93our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 94our $BDBDIR = "$LOCALDIR/db";
95our %RESOURCE;
75 96
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 97our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 98our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 99our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 100our $USE_FSYNC = 1; # use fsync to write maps - default off
83 101
102our $BDB_DEADLOCK_WATCHER;
103our $BDB_CHECKPOINT_WATCHER;
84our $BDB_POLL_WATCHER; 104our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 105our $DB_ENV;
86 106
87our %CFG; 107our %CFG;
88 108
89our $UPTIME; $UPTIME ||= time; 109our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 110our $RUNTIME;
111our $NOW;
91 112
92our %PLAYER; # all users 113our (%PLAYER, %PLAYER_LOADING); # all users
93our %MAP; # all maps 114our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 115our $LINK_MAP; # the special {link} map, which is always available
95 116
96# used to convert map paths into valid unix filenames by replacing / by ∕ 117# used to convert map paths into valid unix filenames by replacing / by ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 118our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98 119
99our $LOAD; # a number between 0 (idle) and 1 (too many objects) 120our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing 121our $LOADAVG; # same thing, but with alpha-smoothing
122our $JITTER; # average jitter
101our $tick_start; # for load detecting purposes 123our $TICK_START; # for load detecting purposes
102 124
103binmode STDOUT; 125binmode STDOUT;
104binmode STDERR; 126binmode STDERR;
105 127
106# read virtual server time, if available 128# read virtual server time, if available
… …
159 181
160The raw value load value from the last tick. 182The raw value load value from the last tick.
161 183
162=item %cf::CFG 184=item %cf::CFG
163 185
164Configuration for the server, loaded from C</etc/crossfire/config>, or 186Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 187from wherever your confdir points to.
166 188
167=item cf::wait_for_tick, cf::wait_for_tick_begin 189=item cf::wait_for_tick, cf::wait_for_tick_begin
168 190
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 191These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
187 $msg .= "\n" 209 $msg .= "\n"
188 unless $msg =~ /\n$/; 210 unless $msg =~ /\n$/;
189 211
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 212 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 213
192 utf8::encode $msg;
193 LOG llevError, $msg; 214 LOG llevError, $msg;
194 }; 215 };
195} 216}
217
218$Coro::State::DIEHOOK = sub {
219 return unless $^S eq 0; # "eq", not "=="
220
221 if ($Coro::current == $Coro::main) {#d#
222 warn "DIEHOOK called in main context, Coro bug?\n";#d#
223 return;#d#
224 }#d#
225
226 # kill coroutine otherwise
227 warn Carp::longmess $_[0];
228 Coro::terminate
229};
230
231$SIG{__DIE__} = sub { }; #d#?
196 232
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 233@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 234@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 235@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 236@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
213)) { 249)) {
214 no strict 'refs'; 250 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 251 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 252}
217 253
218$Event::DIED = sub { 254$EV::DIED = sub {
219 warn "error in event callback: @_"; 255 warn "error in event callback: @_";
220}; 256};
221 257
222############################################################################# 258#############################################################################
223 259
… …
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 282 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 283 $d
248 } || "[unable to dump $_[0]: '$@']"; 284 } || "[unable to dump $_[0]: '$@']";
249} 285}
250 286
251=item $ref = cf::from_json $json 287=item $ref = cf::decode_json $json
252 288
253Converts a JSON string into the corresponding perl data structure. 289Converts a JSON string into the corresponding perl data structure.
254 290
255=item $json = cf::to_json $ref 291=item $json = cf::encode_json $ref
256 292
257Converts a perl data structure into its JSON representation. 293Converts a perl data structure into its JSON representation.
258 294
259=cut 295=cut
260 296
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 297our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 298
263sub to_json ($) { $json_coder->encode ($_[0]) } 299sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 300sub decode_json($) { $json_coder->decode ($_[0]) }
265 301
266=item cf::lock_wait $string 302=item cf::lock_wait $string
267 303
268Wait until the given lock is available. See cf::lock_acquire. 304Wait until the given lock is available. See cf::lock_acquire.
269 305
… …
285Return true if the lock is currently active, i.e. somebody has locked it. 321Return true if the lock is currently active, i.e. somebody has locked it.
286 322
287=cut 323=cut
288 324
289our %LOCK; 325our %LOCK;
326our %LOCKER;#d#
290 327
291sub lock_wait($) { 328sub lock_wait($) {
292 my ($key) = @_; 329 my ($key) = @_;
330
331 if ($LOCKER{$key} == $Coro::current) {#d#
332 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
333 return;#d#
334 }#d#
293 335
294 # wait for lock, if any 336 # wait for lock, if any
295 while ($LOCK{$key}) { 337 while ($LOCK{$key}) {
296 push @{ $LOCK{$key} }, $Coro::current; 338 push @{ $LOCK{$key} }, $Coro::current;
297 Coro::schedule; 339 Coro::schedule;
… …
303 345
304 # wait, to be sure we are not locked 346 # wait, to be sure we are not locked
305 lock_wait $key; 347 lock_wait $key;
306 348
307 $LOCK{$key} = []; 349 $LOCK{$key} = [];
350 $LOCKER{$key} = $Coro::current;#d#
308 351
309 Coro::guard { 352 Coro::guard {
353 delete $LOCKER{$key};#d#
310 # wake up all waiters, to be on the safe side 354 # wake up all waiters, to be on the safe side
311 $_->ready for @{ delete $LOCK{$key} }; 355 $_->ready for @{ delete $LOCK{$key} };
312 } 356 }
313} 357}
314 358
… …
317 361
318 ! ! $LOCK{$key} 362 ! ! $LOCK{$key}
319} 363}
320 364
321sub freeze_mainloop { 365sub freeze_mainloop {
322 return unless $TICK_WATCHER->is_active; 366 tick_inhibit_inc;
323 367
324 my $guard = Coro::guard { 368 Coro::guard \&tick_inhibit_dec;
325 $TICK_WATCHER->start; 369}
326 }; 370
327 $TICK_WATCHER->stop; 371=item cf::periodic $interval, $cb
328 $guard 372
373Like EV::periodic, but randomly selects a starting point so that the actions
374get spread over timer.
375
376=cut
377
378sub periodic($$) {
379 my ($interval, $cb) = @_;
380
381 my $start = rand List::Util::min 180, $interval;
382
383 EV::periodic $start, $interval, 0, $cb
329} 384}
330 385
331=item cf::get_slot $time[, $priority[, $name]] 386=item cf::get_slot $time[, $priority[, $name]]
332 387
333Allocate $time seconds of blocking CPU time at priority C<$priority>: 388Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
344our @SLOT_QUEUE; 399our @SLOT_QUEUE;
345our $SLOT_QUEUE; 400our $SLOT_QUEUE;
346 401
347$SLOT_QUEUE->cancel if $SLOT_QUEUE; 402$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async { 403$SLOT_QUEUE = Coro::async {
404 $Coro::current->desc ("timeslot manager");
405
349 my $signal = new Coro::Signal; 406 my $signal = new Coro::Signal;
350 407
351 while () { 408 while () {
352 next_job: 409 next_job:
353 my $avail = cf::till_tick; 410 my $avail = cf::till_tick;
… …
361 } 418 }
362 } 419 }
363 } 420 }
364 421
365 if (@SLOT_QUEUE) { 422 if (@SLOT_QUEUE) {
366 # we do not use wait_For_tick() as it returns immediately when tick is inactive 423 # we do not use wait_for_tick() as it returns immediately when tick is inactive
367 push @cf::WAIT_FOR_TICK, $signal; 424 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait; 425 $signal->wait;
369 } else { 426 } else {
370 Coro::schedule; 427 Coro::schedule;
371 } 428 }
372 } 429 }
373}; 430};
374 431
375sub get_slot($;$$) { 432sub get_slot($;$$) {
433 return if tick_inhibit || $Coro::current == $Coro::main;
434
376 my ($time, $pri, $name) = @_; 435 my ($time, $pri, $name) = @_;
377 436
378 $time = $TICK * .6 if $time > $TICK * .6; 437 $time = $TICK * .6 if $time > $TICK * .6;
379 my $sig = new Coro::Signal; 438 my $sig = new Coro::Signal;
380 439
… …
394 453
395BEGIN { *async = \&Coro::async_pool } 454BEGIN { *async = \&Coro::async_pool }
396 455
397=item cf::sync_job { BLOCK } 456=item cf::sync_job { BLOCK }
398 457
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 458The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 459is always able to handle events or runnable, as Deliantra is only
401partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 460partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 461acceptable.
403 462
404If it must be done, put the blocking parts into C<sync_job>. This will run 463If it must be done, put the blocking parts into C<sync_job>. This will run
405the given BLOCK in another coroutine while waiting for the result. The 464the given BLOCK in another coroutine while waiting for the result. The
… …
410 469
411sub sync_job(&) { 470sub sync_job(&) {
412 my ($job) = @_; 471 my ($job) = @_;
413 472
414 if ($Coro::current == $Coro::main) { 473 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 474 my $time = EV::time;
416 475
417 # this is the main coro, too bad, we have to block 476 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 477 # till the operation succeeds, freezing the server :/
419 478
420 # TODO: use suspend/resume instead 479 LOG llevError, Carp::longmess "sync job";#d#
421 # (but this is cancel-safe) 480
422 my $freeze_guard = freeze_mainloop; 481 my $freeze_guard = freeze_mainloop;
423 482
424 my $busy = 1; 483 my $busy = 1;
425 my @res; 484 my @res;
426 485
427 (async { 486 (async {
487 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 488 @res = eval { $job->() };
429 warn $@ if $@; 489 warn $@ if $@;
430 undef $busy; 490 undef $busy;
431 })->prio (Coro::PRIO_MAX); 491 })->prio (Coro::PRIO_MAX);
432 492
433 while ($busy) { 493 while ($busy) {
434 Coro::cede or Event::one_event; 494 if (Coro::nready) {
495 Coro::cede_notself;
496 } else {
497 EV::loop EV::LOOP_ONESHOT;
435 } 498 }
499 }
436 500
437 $time = Event::time - $time; 501 my $time = EV::time - $time;
438 502
439 LOG llevError | logBacktrace, Carp::longmess "long sync job"
440 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
441
442 $tick_start += $time; # do not account sync jobs to server load 503 $TICK_START += $time; # do not account sync jobs to server load
443 504
444 wantarray ? @res : $res[0] 505 wantarray ? @res : $res[0]
445 } else { 506 } else {
446 # we are in another coroutine, how wonderful, everything just works 507 # we are in another coroutine, how wonderful, everything just works
447 508
… …
472=item fork_call { }, $args 533=item fork_call { }, $args
473 534
474Executes the given code block with the given arguments in a seperate 535Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 536process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 537Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 538never block itself or use any form of event handling.
478 539
479=cut 540=cut
480 541
481sub fork_call(&@) { 542sub fork_call(&@) {
482 my ($cb, @args) = @_; 543 my ($cb, @args) = @_;
483 544
484 # we seemingly have to make a local copy of the whole thing, 545 # we seemingly have to make a local copy of the whole thing,
485 # otherwise perl prematurely frees the stuff :/ 546 # otherwise perl prematurely frees the stuff :/
486 # TODO: investigate and fix (liekly this will be rather laborious) 547 # TODO: investigate and fix (likely this will be rather laborious)
487 548
488 my @res = Coro::Util::fork_eval { 549 my @res = Coro::Util::fork_eval {
489 reset_signals; 550 reset_signals;
490 &$cb 551 &$cb
491 }, @args; 552 }, @args;
492 553
493 wantarray ? @res : $res[-1] 554 wantarray ? @res : $res[-1]
494} 555}
495 556
557=item $coin = coin_from_name $name
558
559=cut
560
561our %coin_alias = (
562 "silver" => "silvercoin",
563 "silvercoin" => "silvercoin",
564 "silvercoins" => "silvercoin",
565 "gold" => "goldcoin",
566 "goldcoin" => "goldcoin",
567 "goldcoins" => "goldcoin",
568 "platinum" => "platinacoin",
569 "platinumcoin" => "platinacoin",
570 "platinumcoins" => "platinacoin",
571 "platina" => "platinacoin",
572 "platinacoin" => "platinacoin",
573 "platinacoins" => "platinacoin",
574 "royalty" => "royalty",
575 "royalties" => "royalty",
576);
577
578sub coin_from_name($) {
579 $coin_alias{$_[0]}
580 ? cf::arch::find $coin_alias{$_[0]}
581 : undef
582}
583
496=item $value = cf::db_get $family => $key 584=item $value = cf::db_get $family => $key
497 585
498Returns a single value from the environment database. 586Returns a single value from the environment database.
499 587
500=item cf::db_put $family => $key => $value 588=item cf::db_put $family => $key => $value
501 589
502Stores the given C<$value> in the family. It can currently store binary 590Stores the given C<$value> in the family. It can currently store binary
503data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 591data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504 592
593=item $db = cf::db_table "name"
594
595Create and/or open a new database table. The string must not be "db" and must be unique
596within each server.
597
505=cut 598=cut
599
600sub db_table($) {
601 my ($name) = @_;
602 my $db = BDB::db_create $DB_ENV;
603
604 eval {
605 $db->set_flags (BDB::CHKSUM);
606
607 utf8::encode $name;
608 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
609 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
610 cf::cleanup "db_open(db): $!" if $!;
611 };
612 cf::cleanup "db_open(db): $@" if $@;
613
614 $db
615}
506 616
507our $DB; 617our $DB;
508 618
509sub db_init { 619sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 620 cf::sync_job {
514 eval { 621 $DB ||= db_table "db";
515 $DB->set_flags (BDB::CHKSUM);
516
517 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
518 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
519 cf::cleanup "db_open(db): $!" if $!;
520 };
521 cf::cleanup "db_open(db): $@" if $@;
522 };
523 } 622 };
524} 623}
525 624
526sub db_get($$) { 625sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 626 my $key = "$_[0]/$_[1]";
528 627
… …
632attach callbacks/event handlers (a collection of which is called an "attachment") 731attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 732to it. All such attachable objects support the following methods.
634 733
635In the following description, CLASS can be any of C<global>, C<object> 734In the following description, CLASS can be any of C<global>, C<object>
636C<player>, C<client> or C<map> (i.e. the attachable objects in 735C<player>, C<client> or C<map> (i.e. the attachable objects in
637Crossfire TRT). 736Deliantra).
638 737
639=over 4 738=over 4
640 739
641=item $attachable->attach ($attachment, key => $value...) 740=item $attachable->attach ($attachment, key => $value...)
642 741
… …
924 } 1023 }
925 1024
926 0 1025 0
927} 1026}
928 1027
929=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1028=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
930 1029
931=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1030=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
932 1031
933Generate an object-specific event with the given arguments. 1032Generate an object-specific event with the given arguments.
934 1033
… …
940 1039
941=cut 1040=cut
942 1041
943############################################################################# 1042#############################################################################
944# object support 1043# object support
945#
946 1044
1045sub _object_equal($$);
1046sub _object_equal($$) {
1047 my ($a, $b) = @_;
1048
1049 return 0 unless (ref $a) eq (ref $b);
1050
1051 if ("HASH" eq ref $a) {
1052 my @ka = keys %$a;
1053 my @kb = keys %$b;
1054
1055 return 0 if @ka != @kb;
1056
1057 for (0 .. $#ka) {
1058 return 0 unless $ka[$_] eq $kb[$_];
1059 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1060 }
1061
1062 } elsif ("ARRAY" eq ref $a) {
1063
1064 return 0 if @$a != @$b;
1065
1066 for (0 .. $#$a) {
1067 return 0 unless _object_equal $a->[$_], $b->[$_];
1068 }
1069
1070 } elsif ($a ne $b) {
1071 return 0;
1072 }
1073
1074 1
1075}
1076
1077our $SLOW_MERGES;#d#
947sub _can_merge { 1078sub _can_merge {
948 my ($ob1, $ob2) = @_; 1079 my ($ob1, $ob2) = @_;
949 1080
950 local $Storable::canonical = 1; 1081 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1082
954 $fob1 eq $fob2 1083 # we do the slow way here
1084 return _object_equal $ob1, $ob2
955} 1085}
956 1086
957sub reattach { 1087sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1088 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1089 my ($obj) = @_;
… …
981cf::attachable->attach ( 1111cf::attachable->attach (
982 prio => -1000000, 1112 prio => -1000000,
983 on_instantiate => sub { 1113 on_instantiate => sub {
984 my ($obj, $data) = @_; 1114 my ($obj, $data) = @_;
985 1115
986 $data = from_json $data; 1116 $data = decode_json $data;
987 1117
988 for (@$data) { 1118 for (@$data) {
989 my ($name, $args) = @$_; 1119 my ($name, $args) = @$_;
990 1120
991 $obj->attach ($name, %{$args || {} }); 1121 $obj->attach ($name, %{$args || {} });
… …
1007sub object_freezer_save { 1137sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1138 my ($filename, $rdata, $objs) = @_;
1009 1139
1010 sync_job { 1140 sync_job {
1011 if (length $$rdata) { 1141 if (length $$rdata) {
1142 utf8::decode (my $decname = $filename);
1012 warn sprintf "saving %s (%d,%d)\n", 1143 warn sprintf "saving %s (%d,%d)\n",
1013 $filename, length $$rdata, scalar @$objs; 1144 $decname, length $$rdata, scalar @$objs;
1014 1145
1015 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1146 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1016 chmod SAVE_MODE, $fh; 1147 aio_chmod $fh, SAVE_MODE;
1017 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1148 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1018 aio_fsync $fh if $cf::USE_FSYNC; 1149 aio_fsync $fh if $cf::USE_FSYNC;
1019 close $fh; 1150 aio_close $fh;
1020 1151
1021 if (@$objs) { 1152 if (@$objs) {
1022 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1153 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1023 chmod SAVE_MODE, $fh; 1154 aio_chmod $fh, SAVE_MODE;
1024 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1155 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1025 aio_write $fh, 0, (length $data), $data, 0; 1156 aio_write $fh, 0, (length $data), $data, 0;
1026 aio_fsync $fh if $cf::USE_FSYNC; 1157 aio_fsync $fh if $cf::USE_FSYNC;
1027 close $fh; 1158 aio_close $fh;
1028 aio_rename "$filename.pst~", "$filename.pst"; 1159 aio_rename "$filename.pst~", "$filename.pst";
1029 } 1160 }
1030 } else { 1161 } else {
1031 aio_unlink "$filename.pst"; 1162 aio_unlink "$filename.pst";
1032 } 1163 }
… …
1037 } 1168 }
1038 } else { 1169 } else {
1039 aio_unlink $filename; 1170 aio_unlink $filename;
1040 aio_unlink "$filename.pst"; 1171 aio_unlink "$filename.pst";
1041 } 1172 }
1042 } 1173 };
1043} 1174}
1044 1175
1045sub object_freezer_as_string { 1176sub object_freezer_as_string {
1046 my ($rdata, $objs) = @_; 1177 my ($rdata, $objs) = @_;
1047 1178
… …
1059 or return; 1190 or return;
1060 1191
1061 unless (aio_stat "$filename.pst") { 1192 unless (aio_stat "$filename.pst") {
1062 (aio_load "$filename.pst", $av) >= 0 1193 (aio_load "$filename.pst", $av) >= 0
1063 or return; 1194 or return;
1195
1064 $av = eval { (Storable::thaw $av)->{objs} }; 1196 my $st = eval { Coro::Storable::thaw $av };
1197 $av = $st->{objs};
1065 } 1198 }
1066 1199
1200 utf8::decode (my $decname = $filename);
1067 warn sprintf "loading %s (%d)\n", 1201 warn sprintf "loading %s (%d,%d)\n",
1068 $filename, length $data, scalar @{$av || []}; 1202 $decname, length $data, scalar @{$av || []};
1203
1069 return ($data, $av); 1204 ($data, $av)
1070} 1205}
1071 1206
1072=head2 COMMAND CALLBACKS 1207=head2 COMMAND CALLBACKS
1073 1208
1074=over 4 1209=over 4
… …
1223 my $msg = $@ ? "$v->{path}: $@\n" 1358 my $msg = $@ ? "$v->{path}: $@\n"
1224 : "$v->{base}: extension inactive.\n"; 1359 : "$v->{base}: extension inactive.\n";
1225 1360
1226 if (exists $v->{meta}{mandatory}) { 1361 if (exists $v->{meta}{mandatory}) {
1227 warn $msg; 1362 warn $msg;
1228 warn "mandatory extension failed to load, exiting.\n"; 1363 cf::cleanup "mandatory extension failed to load, exiting.";
1229 exit 1;
1230 } 1364 }
1231 1365
1232 warn $msg; 1366 warn $msg;
1233 } 1367 }
1234 1368
… …
1259use Coro::AIO; 1393use Coro::AIO;
1260 1394
1261=head3 cf::player 1395=head3 cf::player
1262 1396
1263=over 4 1397=over 4
1398
1399=item cf::player::num_playing
1400
1401Returns the official number of playing players, as per the Crossfire metaserver rules.
1402
1403=cut
1404
1405sub num_playing {
1406 scalar grep
1407 $_->ob->map
1408 && !$_->hidden
1409 && !$_->ob->flag (cf::FLAG_WIZ),
1410 cf::player::list
1411}
1264 1412
1265=item cf::player::find $login 1413=item cf::player::find $login
1266 1414
1267Returns the given player object, loading it if necessary (might block). 1415Returns the given player object, loading it if necessary (might block).
1268 1416
… …
1304 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1452 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1305 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1453 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1306 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1454 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1307 aio_unlink +(playerdir $login) . "/$login.pl"; 1455 aio_unlink +(playerdir $login) . "/$login.pl";
1308 1456
1309 my $pl = load_pl path $login 1457 my $f = new_from_file cf::object::thawer path $login
1310 or return; 1458 or return;
1459
1460 my $pl = cf::player::load_pl $f
1461 or return;
1462
1463 local $cf::PLAYER_LOADING{$login} = $pl;
1464 $f->resolve_delayed_derefs;
1311 $cf::PLAYER{$login} = $pl 1465 $cf::PLAYER{$login} = $pl
1312 } 1466 }
1313 } 1467 }
1314} 1468}
1315 1469
… …
1323 1477
1324 return if $pl->{deny_save}; 1478 return if $pl->{deny_save};
1325 1479
1326 aio_mkdir playerdir $pl, 0770; 1480 aio_mkdir playerdir $pl, 0770;
1327 $pl->{last_save} = $cf::RUNTIME; 1481 $pl->{last_save} = $cf::RUNTIME;
1482
1483 cf::get_slot 0.01;
1328 1484
1329 $pl->save_pl ($path); 1485 $pl->save_pl ($path);
1330 cf::cede_to_tick; 1486 cf::cede_to_tick;
1331} 1487}
1332 1488
… …
1368 $pl->{deny_save} = 1; 1524 $pl->{deny_save} = 1;
1369 $pl->password ("*"); # this should lock out the player until we nuked the dir 1525 $pl->password ("*"); # this should lock out the player until we nuked the dir
1370 1526
1371 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1527 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1372 $pl->deactivate; 1528 $pl->deactivate;
1529 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1530 $pl->ob->check_score;
1373 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1531 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1374 $pl->ns->destroy if $pl->ns; 1532 $pl->ns->destroy if $pl->ns;
1375 1533
1376 my $path = playerdir $pl; 1534 my $path = playerdir $pl;
1377 my $temp = "$path~$cf::RUNTIME~deleting~"; 1535 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1413 or return []; 1571 or return [];
1414 1572
1415 my @logins; 1573 my @logins;
1416 1574
1417 for my $login (@$dirs) { 1575 for my $login (@$dirs) {
1576 my $path = path $login;
1577
1578 # a .pst is a dead give-away for a valid player
1579 # if no pst file found, open and chekc for blocked users
1580 if (aio_stat "$path.pst") {
1418 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1581 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1419 aio_read $fh, 0, 512, my $buf, 0 or next; 1582 aio_read $fh, 0, 512, my $buf, 0 or next;
1420 $buf !~ /^password -------------$/m or next; # official not-valid tag 1583 $buf !~ /^password -------------$/m or next; # official not-valid tag
1584 }
1421 1585
1422 utf8::decode $login; 1586 utf8::decode $login;
1423 push @logins, $login; 1587 push @logins, $login;
1424 } 1588 }
1425 1589
… …
1458 1622
1459Expand crossfire pod fragments into protocol xml. 1623Expand crossfire pod fragments into protocol xml.
1460 1624
1461=cut 1625=cut
1462 1626
1627use re 'eval';
1628
1629my $group;
1630my $interior; $interior = qr{
1631 # match a pod interior sequence sans C<< >>
1632 (?:
1633 \ (.*?)\ (?{ $group = $^N })
1634 | < (??{$interior}) >
1635 )
1636}x;
1637
1463sub expand_cfpod { 1638sub expand_cfpod {
1464 ((my $self), (local $_)) = @_; 1639 my ($self, $pod) = @_;
1465 1640
1466 # escape & and < 1641 my $xml;
1467 s/&/&amp;/g;
1468 s/(?<![BIUGH])</&lt;/g;
1469 1642
1470 # this is buggy, it needs to properly take care of nested <'s 1643 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1645 $group = $1;
1471 1646
1472 1 while 1647 $group =~ s/&/&amp;/g;
1473 # replace B<>, I<>, U<> etc. 1648 $group =~ s/</&lt;/g;
1474 s/B<([^\>]*)>/<b>$1<\/b>/ 1649
1475 || s/I<([^\>]*)>/<i>$1<\/i>/ 1650 $xml .= $group;
1476 || s/U<([^\>]*)>/<u>$1<\/u>/ 1651 } elsif ($pod =~ m%\G
1477 # replace G<male|female> tags 1652 ([BCGHITU])
1478 || s{G<([^>|]*)\|([^>]*)>}{ 1653 <
1479 $self->gender ? $2 : $1 1654 (?:
1480 }ge 1655 ([^<>]*) (?{ $group = $^N })
1481 # replace H<hint text> 1656 | < $interior >
1482 || s{H<([^\>]*)>} 1657 )
1658 >
1659 %gcsx
1483 { 1660 ) {
1661 my ($code, $data) = ($1, $group);
1662
1663 if ($code eq "B") {
1664 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1665 } elsif ($code eq "I") {
1666 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1667 } elsif ($code eq "U") {
1668 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1669 } elsif ($code eq "C") {
1670 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1671 } elsif ($code eq "T") {
1672 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1673 } elsif ($code eq "G") {
1674 my ($male, $female) = split /\|/, $data;
1675 $data = $self->gender ? $female : $male;
1676 $xml .= expand_cfpod ($self, $data);
1677 } elsif ($code eq "H") {
1484 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1678 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1485 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1486 "") 1680 "")
1487 [$self->{hintmode}] 1681 [$self->{hintmode}];
1682 } else {
1683 $xml .= "error processing '$code($data)' directive";
1488 }ge; 1684 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 }
1689 last;
1690 }
1691 }
1489 1692
1693 for ($xml) {
1490 # create single paragraphs (very hackish) 1694 # create single paragraphs (very hackish)
1491 s/(?<=\S)\n(?=\w)/ /g; 1695 s/(?<=\S)\n(?=\w)/ /g;
1492 1696
1493 # compress some whitespace 1697 # compress some whitespace
1494 s/\s+\n/\n/g; # ws line-ends 1698 s/\s+\n/\n/g; # ws line-ends
1495 s/\n\n+/\n/g; # double lines 1699 s/\n\n+/\n/g; # double lines
1496 s/^\n+//; # beginning lines 1700 s/^\n+//; # beginning lines
1497 s/\n+$//; # ending lines 1701 s/\n+$//; # ending lines
1702 }
1498 1703
1499 $_ 1704 $xml
1500} 1705}
1706
1707no re 'eval';
1501 1708
1502sub hintmode { 1709sub hintmode {
1503 $_[0]{hintmode} = $_[1] if @_ > 1; 1710 $_[0]{hintmode} = $_[1] if @_ > 1;
1504 $_[0]{hintmode} 1711 $_[0]{hintmode}
1505} 1712}
… …
1577our $MAX_RESET = 3600; 1784our $MAX_RESET = 3600;
1578our $DEFAULT_RESET = 3000; 1785our $DEFAULT_RESET = 3000;
1579 1786
1580sub generate_random_map { 1787sub generate_random_map {
1581 my ($self, $rmp) = @_; 1788 my ($self, $rmp) = @_;
1789
1790 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1791
1582 # mit "rum" bekleckern, nicht 1792 # mit "rum" bekleckern, nicht
1583 $self->_create_random_map ( 1793 $self->_create_random_map (
1584 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1794 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1585 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1795 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1586 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1796 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1708 1918
1709# the temporary/swap location 1919# the temporary/swap location
1710sub save_path { 1920sub save_path {
1711 my ($self) = @_; 1921 my ($self) = @_;
1712 1922
1713 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1923 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1714 "$TMPDIR/$path.map" 1924 "$TMPDIR/$path.map"
1715} 1925}
1716 1926
1717# the unique path, undef == no special unique path 1927# the unique path, undef == no special unique path
1718sub uniq_path { 1928sub uniq_path {
1719 my ($self) = @_; 1929 my ($self) = @_;
1720 1930
1721 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1931 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1722 "$UNIQUEDIR/$path" 1932 "$UNIQUEDIR/$path"
1723} 1933}
1724 1934
1725# and all this just because we cannot iterate over 1935# and all this just because we cannot iterate over
1726# all maps in C++... 1936# all maps in C++...
… …
1749 1959
1750sub load_header_from($) { 1960sub load_header_from($) {
1751 my ($self, $path) = @_; 1961 my ($self, $path) = @_;
1752 1962
1753 utf8::encode $path; 1963 utf8::encode $path;
1754 #aio_open $path, O_RDONLY, 0 1964 my $f = new_from_file cf::object::thawer $path
1755 # or return;
1756
1757 $self->_load_header ($path)
1758 or return; 1965 or return;
1966
1967 $self->_load_header ($f)
1968 or return;
1969
1970 local $MAP_LOADING{$self->{path}} = $self;
1971 $f->resolve_delayed_derefs;
1759 1972
1760 $self->{load_path} = $path; 1973 $self->{load_path} = $path;
1761 1974
1762 1 1975 1
1763} 1976}
… …
1817sub find { 2030sub find {
1818 my ($path, $origin) = @_; 2031 my ($path, $origin) = @_;
1819 2032
1820 $path = normalise $path, $origin && $origin->path; 2033 $path = normalise $path, $origin && $origin->path;
1821 2034
2035 cf::lock_wait "map_data:$path";#d#remove
1822 cf::lock_wait "map_find:$path"; 2036 cf::lock_wait "map_find:$path";
1823 2037
1824 $cf::MAP{$path} || do { 2038 $cf::MAP{$path} || do {
2039 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1825 my $guard = cf::lock_acquire "map_find:$path"; 2040 my $guard2 = cf::lock_acquire "map_find:$path";
2041
1826 my $map = new_from_path cf::map $path 2042 my $map = new_from_path cf::map $path
1827 or return; 2043 or return;
1828 2044
1829 $map->{last_save} = $cf::RUNTIME; 2045 $map->{last_save} = $cf::RUNTIME;
1830 2046
… …
1832 or return; 2048 or return;
1833 2049
1834 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2050 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1835 # doing this can freeze the server in a sync job, obviously 2051 # doing this can freeze the server in a sync job, obviously
1836 #$cf::WAIT_FOR_TICK->wait; 2052 #$cf::WAIT_FOR_TICK->wait;
2053 undef $guard2;
2054 undef $guard1;
1837 $map->reset; 2055 $map->reset;
1838 undef $guard;
1839 return find $path; 2056 return find $path;
1840 } 2057 }
1841 2058
1842 $cf::MAP{$path} = $map 2059 $cf::MAP{$path} = $map
1843 } 2060 }
… …
1852 local $self->{deny_reset} = 1; # loading can take a long time 2069 local $self->{deny_reset} = 1; # loading can take a long time
1853 2070
1854 my $path = $self->{path}; 2071 my $path = $self->{path};
1855 2072
1856 { 2073 {
1857 my $guard1 = cf::lock_acquire "map_data:$path"; 2074 my $guard = cf::lock_acquire "map_data:$path";
1858 my $guard2 = cf::lock_acquire "map_load:$path";
1859 2075
2076 return unless $self->valid;
1860 return if $self->in_memory != cf::MAP_SWAPPED; 2077 return unless $self->in_memory == cf::MAP_SWAPPED;
1861 2078
1862 $self->in_memory (cf::MAP_LOADING); 2079 $self->in_memory (cf::MAP_LOADING);
1863 2080
1864 $self->alloc; 2081 $self->alloc;
1865 2082
1866 $self->pre_load; 2083 $self->pre_load;
1867 cf::cede_to_tick; 2084 cf::cede_to_tick;
1868 2085
2086 my $f = new_from_file cf::object::thawer $self->{load_path};
2087 $f->skip_block;
1869 $self->_load_objects ($self->{load_path}, 1) 2088 $self->_load_objects ($f)
1870 or return; 2089 or return;
1871 2090
1872 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2091 $self->post_load_original
1873 if delete $self->{load_original}; 2092 if delete $self->{load_original};
1874 2093
1875 if (my $uniq = $self->uniq_path) { 2094 if (my $uniq = $self->uniq_path) {
1876 utf8::encode $uniq; 2095 utf8::encode $uniq;
1877 if (aio_open $uniq, O_RDONLY, 0) { 2096 unless (aio_stat $uniq) {
2097 if (my $f = new_from_file cf::object::thawer $uniq) {
1878 $self->clear_unique_items; 2098 $self->clear_unique_items;
1879 $self->_load_objects ($uniq, 0); 2099 $self->_load_objects ($f);
2100 $f->resolve_delayed_derefs;
2101 }
1880 } 2102 }
1881 } 2103 }
2104
2105 $f->resolve_delayed_derefs;
1882 2106
1883 cf::cede_to_tick; 2107 cf::cede_to_tick;
1884 # now do the right thing for maps 2108 # now do the right thing for maps
1885 $self->link_multipart_objects; 2109 $self->link_multipart_objects;
1886 $self->difficulty ($self->estimate_difficulty) 2110 $self->difficulty ($self->estimate_difficulty)
… …
1898 } 2122 }
1899 2123
1900 $self->{last_save} = $cf::RUNTIME; 2124 $self->{last_save} = $cf::RUNTIME;
1901 $self->last_access ($cf::RUNTIME); 2125 $self->last_access ($cf::RUNTIME);
1902 2126
1903 $self->in_memory (cf::MAP_IN_MEMORY); 2127 $self->in_memory (cf::MAP_ACTIVE);
1904 } 2128 }
1905 2129
1906 $self->post_load; 2130 $self->post_load;
1907} 2131}
1908 2132
… …
1966 my ($path, $origin, $load) = @_; 2190 my ($path, $origin, $load) = @_;
1967 2191
1968 $path = normalise $path, $origin && $origin->{path}; 2192 $path = normalise $path, $origin && $origin->{path};
1969 2193
1970 if (my $map = $cf::MAP{$path}) { 2194 if (my $map = $cf::MAP{$path}) {
1971 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2195 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1972 } 2196 }
1973 2197
1974 $MAP_PREFETCH{$path} |= $load; 2198 $MAP_PREFETCH{$path} |= $load;
1975 2199
1976 $MAP_PREFETCHER ||= cf::async { 2200 $MAP_PREFETCHER ||= cf::async {
2201 $Coro::current->{desc} = "map prefetcher";
2202
1977 while (%MAP_PREFETCH) { 2203 while (%MAP_PREFETCH) {
1978 while (my ($k, $v) = each %MAP_PREFETCH) { 2204 while (my ($k, $v) = each %MAP_PREFETCH) {
1979 if (my $map = find $k) { 2205 if (my $map = find $k) {
1980 $map->load if $v; 2206 $map->load if $v;
1981 } 2207 }
… …
2007 return if $self->{deny_save}; 2233 return if $self->{deny_save};
2008 2234
2009 local $self->{last_access} = $self->last_access;#d# 2235 local $self->{last_access} = $self->last_access;#d#
2010 2236
2011 cf::async { 2237 cf::async {
2238 $Coro::current->{desc} = "map player save";
2012 $_->contr->save for $self->players; 2239 $_->contr->save for $self->players;
2013 }; 2240 };
2241
2242 cf::get_slot 0.02;
2014 2243
2015 if ($uniq) { 2244 if ($uniq) {
2016 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2245 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2017 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2246 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2018 } else { 2247 } else {
… …
2027 $self->save; 2256 $self->save;
2028 2257
2029 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2258 my $lock = cf::lock_acquire "map_data:$self->{path}";
2030 2259
2031 return if $self->players; 2260 return if $self->players;
2032 return if $self->in_memory != cf::MAP_IN_MEMORY; 2261 return if $self->in_memory != cf::MAP_ACTIVE;
2033 return if $self->{deny_save}; 2262 return if $self->{deny_save};
2034 2263
2264 $self->in_memory (cf::MAP_SWAPPED);
2265
2266 $self->deactivate;
2267 $_->clear_links_to ($self) for values %cf::MAP;
2035 $self->clear; 2268 $self->clear;
2036 $self->in_memory (cf::MAP_SWAPPED);
2037} 2269}
2038 2270
2039sub reset_at { 2271sub reset_at {
2040 my ($self) = @_; 2272 my ($self) = @_;
2041 2273
… …
2073 if $uniq; 2305 if $uniq;
2074 } 2306 }
2075 2307
2076 delete $cf::MAP{$self->path}; 2308 delete $cf::MAP{$self->path};
2077 2309
2310 $self->deactivate;
2311 $_->clear_links_to ($self) for values %cf::MAP;
2078 $self->clear; 2312 $self->clear;
2079
2080 $_->clear_links_to ($self) for values %cf::MAP;
2081 2313
2082 $self->unlink_save; 2314 $self->unlink_save;
2083 $self->destroy; 2315 $self->destroy;
2084} 2316}
2085 2317
… …
2090 2322
2091 { 2323 {
2092 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2324 my $lock = cf::lock_acquire "map_data:$self->{path}";
2093 2325
2094 delete $cf::MAP{$self->path}; 2326 delete $cf::MAP{$self->path};
2327
2328 $self->unlink_save;
2095 2329
2096 bless $self, "cf::map"; 2330 bless $self, "cf::map";
2097 delete $self->{deny_reset}; 2331 delete $self->{deny_reset};
2098 $self->{deny_save} = 1; 2332 $self->{deny_save} = 1;
2099 $self->reset_timeout (1); 2333 $self->reset_timeout (1);
2100 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2334 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2101
2102 $self->unlink_save;
2103 2335
2104 $cf::MAP{$self->path} = $self; 2336 $cf::MAP{$self->path} = $self;
2105 } 2337 }
2106 2338
2107 $self->reset; # polite request, might not happen 2339 $self->reset; # polite request, might not happen
… …
2152 2384
2153sub unique_maps() { 2385sub unique_maps() {
2154 [ 2386 [
2155 map { 2387 map {
2156 utf8::decode $_; 2388 utf8::decode $_;
2157 /\.map$/ 2389 s/\.map$//; # TODO future compatibility hack
2390 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2391 ? ()
2158 ? normalise $_ 2392 : normalise $_
2159 : ()
2160 } @{ aio_readdir $UNIQUEDIR or [] } 2393 } @{ aio_readdir $UNIQUEDIR or [] }
2161 ] 2394 ]
2162} 2395}
2163 2396
2164package cf;
2165
2166=back 2397=back
2167 2398
2168=head3 cf::object 2399=head3 cf::object
2169 2400
2170=cut 2401=cut
… …
2173 2404
2174=over 4 2405=over 4
2175 2406
2176=item $ob->inv_recursive 2407=item $ob->inv_recursive
2177 2408
2178Returns the inventory of the object _and_ their inventories, recursively. 2409Returns the inventory of the object I<and> their inventories, recursively,
2410but I<not> the object itself.
2179 2411
2180=cut 2412=cut
2181 2413
2182sub inv_recursive_; 2414sub inv_recursive_;
2183sub inv_recursive_ { 2415sub inv_recursive_ {
… …
2186 2418
2187sub inv_recursive { 2419sub inv_recursive {
2188 inv_recursive_ inv $_[0] 2420 inv_recursive_ inv $_[0]
2189} 2421}
2190 2422
2423=item $ref = $ob->ref
2424
2425Creates and returns a persistent reference to an object that can be stored as a string.
2426
2427=item $ob = cf::object::deref ($refstring)
2428
2429returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2430even if the object actually exists. May block.
2431
2432=cut
2433
2434sub deref {
2435 my ($ref) = @_;
2436
2437 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2438 my ($uuid, $name) = ($1, $2);
2439 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2440 or return;
2441 $pl->ob->uuid eq $uuid
2442 or return;
2443
2444 $pl->ob
2445 } else {
2446 warn "$ref: cannot resolve object reference\n";
2447 undef
2448 }
2449}
2450
2191package cf; 2451package cf;
2192 2452
2193=back 2453=back
2194 2454
2195=head3 cf::object::player 2455=head3 cf::object::player
… …
2201Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2461Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2202can be C<undef>. Does the right thing when the player is currently in a 2462can be C<undef>. Does the right thing when the player is currently in a
2203dialogue with the given NPC character. 2463dialogue with the given NPC character.
2204 2464
2205=cut 2465=cut
2466
2467our $SAY_CHANNEL = {
2468 id => "say",
2469 title => "Map",
2470 reply => "say ",
2471 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2472};
2473
2474our $CHAT_CHANNEL = {
2475 id => "chat",
2476 title => "Chat",
2477 reply => "chat ",
2478 tooltip => "Player chat and shouts, global to the server.",
2479};
2206 2480
2207# rough implementation of a future "reply" method that works 2481# rough implementation of a future "reply" method that works
2208# with dialog boxes. 2482# with dialog boxes.
2209#TODO: the first argument must go, split into a $npc->reply_to ( method 2483#TODO: the first argument must go, split into a $npc->reply_to ( method
2210sub cf::object::player::reply($$$;$) { 2484sub cf::object::player::reply($$$;$) {
… …
2222 my $dialog = $pl->{npc_dialog}; 2496 my $dialog = $pl->{npc_dialog};
2223 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2497 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2224 2498
2225 } else { 2499 } else {
2226 $msg = $npc->name . " says: $msg" if $npc; 2500 $msg = $npc->name . " says: $msg" if $npc;
2227 $self->message ($msg, $flags); 2501 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2228 } 2502 }
2229 } 2503 }
2230} 2504}
2231 2505
2232=item $object->send_msg ($channel, $msg, $color, [extra...]) 2506=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2340her, loading and preparing them map, calling the provided $check callback 2614her, loading and preparing them map, calling the provided $check callback
2341that has to return the map if sucecssful, and then unfreezes the player on 2615that has to return the map if sucecssful, and then unfreezes the player on
2342the new (success) or old (failed) map position. In either case, $done will 2616the new (success) or old (failed) map position. In either case, $done will
2343be called at the end of this process. 2617be called at the end of this process.
2344 2618
2619Note that $check will be called with a potentially non-loaded map, so if
2620it needs a loaded map it has to call C<< ->load >>.
2621
2345=cut 2622=cut
2346 2623
2347our $GOTOGEN; 2624our $GOTOGEN;
2348 2625
2349sub cf::object::player::goto { 2626sub cf::object::player::goto {
… …
2353 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2630 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2354 2631
2355 $self->enter_link; 2632 $self->enter_link;
2356 2633
2357 (async { 2634 (async {
2635 $Coro::current->{desc} = "player::goto $path $x $y";
2636
2637 # *tag paths override both path and x|y
2638 if ($path =~ /^\*(.*)$/) {
2639 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2640 my $ob = $obs[rand @obs];
2641
2642 # see if we actually can go there
2643 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2644 $ob = $obs[rand @obs];
2645 } else {
2646 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2647 }
2648 # else put us there anyways for now #d#
2649
2650 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2651 } else {
2652 ($path, $x, $y) = (undef, undef, undef);
2653 }
2654 }
2655
2358 my $map = eval { 2656 my $map = eval {
2359 my $map = cf::map::find $path; 2657 my $map = defined $path ? cf::map::find $path : undef;
2360 2658
2361 if ($map) { 2659 if ($map) {
2362 $map = $map->customise_for ($self); 2660 $map = $map->customise_for ($self);
2363 $map = $check->($map) if $check && $map; 2661 $map = $check->($map) if $check && $map;
2364 } else { 2662 } else {
2365 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2663 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2366 } 2664 }
2367 2665
2368 $map 2666 $map
2369 }; 2667 };
2370 2668
… …
2406} 2704}
2407 2705
2408sub prepare_random_map { 2706sub prepare_random_map {
2409 my ($exit) = @_; 2707 my ($exit) = @_;
2410 2708
2411 my $guard = cf::lock_acquire "exit_prepare:$exit";
2412
2413 # all this does is basically replace the /! path by 2709 # all this does is basically replace the /! path by
2414 # a new random map path (?random/...) with a seed 2710 # a new random map path (?random/...) with a seed
2415 # that depends on the exit object 2711 # that depends on the exit object
2416 2712
2417 my $rmp = parse_random_map_params $exit->msg; 2713 my $rmp = parse_random_map_params $exit->msg;
… …
2419 if ($exit->map) { 2715 if ($exit->map) {
2420 $rmp->{region} = $exit->region->name; 2716 $rmp->{region} = $exit->region->name;
2421 $rmp->{origin_map} = $exit->map->path; 2717 $rmp->{origin_map} = $exit->map->path;
2422 $rmp->{origin_x} = $exit->x; 2718 $rmp->{origin_x} = $exit->x;
2423 $rmp->{origin_y} = $exit->y; 2719 $rmp->{origin_y} = $exit->y;
2720
2721 $exit->map->touch;
2424 } 2722 }
2425 2723
2426 $rmp->{random_seed} ||= $exit->random_seed; 2724 $rmp->{random_seed} ||= $exit->random_seed;
2427 2725
2428 my $data = cf::to_json $rmp; 2726 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2429 my $md5 = Digest::MD5::md5_hex $data; 2727 my $md5 = Digest::MD5::md5_hex $data;
2430 my $meta = "$RANDOMDIR/$md5.meta"; 2728 my $meta = "$RANDOMDIR/$md5.meta";
2431 2729
2432 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2730 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2433 aio_write $fh, 0, (length $data), $data, 0; 2731 aio_write $fh, 0, (length $data), $data, 0;
2434 undef $fh; 2732 undef $fh;
2435 aio_rename "$meta~", $meta; 2733 aio_rename "$meta~", $meta;
2436 2734
2735 my $slaying = "?random/$md5";
2736
2737 if ($exit->valid) {
2437 $exit->slaying ("?random/$md5"); 2738 $exit->slaying ("?random/$md5");
2438 $exit->msg (undef); 2739 $exit->msg (undef);
2740 }
2439 } 2741 }
2440} 2742}
2441 2743
2442sub cf::object::player::enter_exit { 2744sub cf::object::player::enter_exit {
2443 my ($self, $exit) = @_; 2745 my ($self, $exit) = @_;
2444 2746
2445 return unless $self->type == cf::PLAYER; 2747 return unless $self->type == cf::PLAYER;
2446 2748
2447 if ($exit->slaying eq "/!") {
2448 #TODO: this should de-fi-ni-te-ly not be a sync-job
2449 # the problem is that $exit might not survive long enough
2450 # so it needs to be done right now, right here
2451 cf::sync_job { prepare_random_map $exit };
2452 }
2453
2454 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2455 my $hp = $exit->stats->hp;
2456 my $sp = $exit->stats->sp;
2457
2458 $self->enter_link; 2749 $self->enter_link;
2459 2750
2460 # if exit is damned, update players death & WoR home-position
2461 $self->contr->savebed ($slaying, $hp, $sp)
2462 if $exit->flag (FLAG_DAMNED);
2463
2464 (async { 2751 (async {
2465 $self->deactivate_recursive; # just to be sure 2752 $Coro::current->{desc} = "enter_exit";
2753
2466 unless (eval { 2754 unless (eval {
2755 $self->deactivate_recursive; # just to be sure
2756
2757 # random map handling
2758 {
2759 my $guard = cf::lock_acquire "exit_prepare:$exit";
2760
2761 prepare_random_map $exit
2762 if $exit->slaying eq "/!";
2763 }
2764
2765 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2766 my $x = $exit->stats->hp;
2767 my $y = $exit->stats->sp;
2768
2467 $self->goto ($slaying, $hp, $sp); 2769 $self->goto ($map, $x, $y);
2468 2770
2771 # if exit is damned, update players death & WoR home-position
2772 $self->contr->savebed ($map, $x, $y)
2773 if $exit->flag (cf::FLAG_DAMNED);
2774
2469 1; 2775 1
2470 }) { 2776 }) {
2471 $self->message ("Something went wrong deep within the crossfire server. " 2777 $self->message ("Something went wrong deep within the crossfire server. "
2472 . "I'll try to bring you back to the map you were before. " 2778 . "I'll try to bring you back to the map you were before. "
2473 . "Please report this to the dungeon master!", 2779 . "Please report this to the dungeon master!",
2474 cf::NDI_UNIQUE | cf::NDI_RED); 2780 cf::NDI_UNIQUE | cf::NDI_RED);
… …
2504the message, with C<log> being the default. If C<$color> is negative, suppress 2810the message, with C<log> being the default. If C<$color> is negative, suppress
2505the message unless the client supports the msg packet. 2811the message unless the client supports the msg packet.
2506 2812
2507=cut 2813=cut
2508 2814
2815# non-persistent channels (usually the info channel)
2509our %CHANNEL = ( 2816our %CHANNEL = (
2510 "c/identify" => { 2817 "c/identify" => {
2511 id => "identify", 2818 id => "infobox",
2512 title => "Identify", 2819 title => "Identify",
2513 reply => undef, 2820 reply => undef,
2514 tooltip => "Items recently identified", 2821 tooltip => "Items recently identified",
2515 }, 2822 },
2823 "c/examine" => {
2824 id => "infobox",
2825 title => "Examine",
2826 reply => undef,
2827 tooltip => "Signs and other items you examined",
2828 },
2829 "c/book" => {
2830 id => "infobox",
2831 title => "Book",
2832 reply => undef,
2833 tooltip => "The contents of a note or book",
2834 },
2835 "c/lookat" => {
2836 id => "infobox",
2837 title => "Look",
2838 reply => undef,
2839 tooltip => "What you saw there",
2840 },
2841 "c/who" => {
2842 id => "infobox",
2843 title => "Players",
2844 reply => undef,
2845 tooltip => "Shows players who are currently online",
2846 },
2847 "c/body" => {
2848 id => "infobox",
2849 title => "Body Parts",
2850 reply => undef,
2851 tooltip => "Shows which body parts you posess and are available",
2852 },
2853 "c/uptime" => {
2854 id => "infobox",
2855 title => "Uptime",
2856 reply => undef,
2857 tooltip => "How long the server has been running since last restart",
2858 },
2859 "c/mapinfo" => {
2860 id => "infobox",
2861 title => "Map Info",
2862 reply => undef,
2863 tooltip => "Information related to the maps",
2864 },
2865 "c/party" => {
2866 id => "party",
2867 title => "Party",
2868 reply => "gsay ",
2869 tooltip => "Messages and chat related to your party",
2870 },
2516); 2871);
2517 2872
2518sub cf::client::send_msg { 2873sub cf::client::send_msg {
2519 my ($self, $channel, $msg, $color, @extra) = @_; 2874 my ($self, $channel, $msg, $color, @extra) = @_;
2520 2875
2521 $msg = $self->pl->expand_cfpod ($msg); 2876 $msg = $self->pl->expand_cfpod ($msg);
2522 2877
2523 $color &= cf::NDI_CLIENT_MASK; # just in case... 2878 $color &= cf::NDI_CLIENT_MASK; # just in case...
2524 2879
2525 # check predefined channels, for the benefit of C 2880 # check predefined channels, for the benefit of C
2526 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2881 if ($CHANNEL{$channel}) {
2882 $channel = $CHANNEL{$channel};
2527 2883
2884 $self->ext_msg (channel_info => $channel)
2885 if $self->can_msg;
2886
2887 $channel = $channel->{id};
2888
2528 if (ref $channel) { 2889 } elsif (ref $channel) {
2529 # send meta info to client, if not yet sent 2890 # send meta info to client, if not yet sent
2530 unless (exists $self->{channel}{$channel->{id}}) { 2891 unless (exists $self->{channel}{$channel->{id}}) {
2531 $self->{channel}{$channel->{id}} = $channel; 2892 $self->{channel}{$channel->{id}} = $channel;
2532 $self->ext_msg (channel_info => $channel); 2893 $self->ext_msg (channel_info => $channel)
2894 if $self->can_msg;
2533 } 2895 }
2534 2896
2535 $channel = $channel->{id}; 2897 $channel = $channel->{id};
2536 } 2898 }
2537 2899
… …
2749=pod 3111=pod
2750 3112
2751The following functions and methods are available within a safe environment: 3113The following functions and methods are available within a safe environment:
2752 3114
2753 cf::object 3115 cf::object
2754 contr pay_amount pay_player map x y force_find force_add 3116 contr pay_amount pay_player map x y force_find force_add destroy
2755 insert remove name archname title slaying race decrease_ob_nr 3117 insert remove name archname title slaying race decrease split
2756 3118
2757 cf::object::player 3119 cf::object::player
2758 player 3120 player
2759 3121
2760 cf::player 3122 cf::player
… …
2765 3127
2766=cut 3128=cut
2767 3129
2768for ( 3130for (
2769 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3131 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2770 insert remove inv name archname title slaying race 3132 insert remove inv nrof name archname title slaying race
2771 decrease_ob_nr)], 3133 decrease split destroy change_exp)],
2772 ["cf::object::player" => qw(player)], 3134 ["cf::object::player" => qw(player)],
2773 ["cf::player" => qw(peaceful)], 3135 ["cf::player" => qw(peaceful)],
2774 ["cf::map" => qw(trigger)], 3136 ["cf::map" => qw(trigger)],
2775) { 3137) {
2776 no strict 'refs'; 3138 no strict 'refs';
… …
2881 { 3243 {
2882 my $faces = $facedata->{faceinfo}; 3244 my $faces = $facedata->{faceinfo};
2883 3245
2884 while (my ($face, $info) = each %$faces) { 3246 while (my ($face, $info) = each %$faces) {
2885 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3247 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3248
2886 cf::face::set_visibility $idx, $info->{visibility}; 3249 cf::face::set_visibility $idx, $info->{visibility};
2887 cf::face::set_magicmap $idx, $info->{magicmap}; 3250 cf::face::set_magicmap $idx, $info->{magicmap};
2888 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3251 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2889 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3252 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2890 3253
2891 cf::cede_to_tick; 3254 cf::cede_to_tick;
2892 } 3255 }
2893 3256
2894 while (my ($face, $info) = each %$faces) { 3257 while (my ($face, $info) = each %$faces) {
2895 next unless $info->{smooth}; 3258 next unless $info->{smooth};
3259
2896 my $idx = cf::face::find $face 3260 my $idx = cf::face::find $face
2897 or next; 3261 or next;
3262
2898 if (my $smooth = cf::face::find $info->{smooth}) { 3263 if (my $smooth = cf::face::find $info->{smooth}) {
2899 cf::face::set_smooth $idx, $smooth; 3264 cf::face::set_smooth $idx, $smooth;
2900 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3265 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2901 } else { 3266 } else {
2902 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3267 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2920 { 3285 {
2921 # TODO: for gcfclient pleasure, we should give resources 3286 # TODO: for gcfclient pleasure, we should give resources
2922 # that gcfclient doesn't grok a >10000 face index. 3287 # that gcfclient doesn't grok a >10000 face index.
2923 my $res = $facedata->{resource}; 3288 my $res = $facedata->{resource};
2924 3289
2925 my $soundconf = delete $res->{"res/sound.conf"};
2926
2927 while (my ($name, $info) = each %$res) { 3290 while (my ($name, $info) = each %$res) {
3291 if (defined $info->{type}) {
2928 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3292 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2929 my $data; 3293 my $data;
2930 3294
2931 if ($info->{type} & 1) { 3295 if ($info->{type} & 1) {
2932 # prepend meta info 3296 # prepend meta info
2933 3297
2934 my $meta = $enc->encode ({ 3298 my $meta = $enc->encode ({
2935 name => $name, 3299 name => $name,
2936 %{ $info->{meta} || {} }, 3300 %{ $info->{meta} || {} },
2937 }); 3301 });
2938 3302
2939 $data = pack "(w/a*)*", $meta, $info->{data}; 3303 $data = pack "(w/a*)*", $meta, $info->{data};
3304 } else {
3305 $data = $info->{data};
3306 }
3307
3308 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3309 cf::face::set_type $idx, $info->{type};
2940 } else { 3310 } else {
2941 $data = $info->{data}; 3311 $RESOURCE{$name} = $info;
2942 } 3312 }
2943 3313
2944 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2945 cf::face::set_type $idx, $info->{type};
2946
2947 cf::cede_to_tick; 3314 cf::cede_to_tick;
2948 } 3315 }
2949
2950 if ($soundconf) {
2951 $soundconf = $enc->decode (delete $soundconf->{data});
2952
2953 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2954 my $sound = $soundconf->{compat}[$_]
2955 or next;
2956
2957 my $face = cf::face::find "sound/$sound->[1]";
2958 cf::sound::set $sound->[0] => $face;
2959 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2960 }
2961
2962 while (my ($k, $v) = each %{$soundconf->{event}}) {
2963 my $face = cf::face::find "sound/$v";
2964 cf::sound::set $k => $face;
2965 }
2966 }
2967 } 3316 }
3317
3318 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2968 3319
2969 1 3320 1
2970} 3321}
3322
3323cf::global->attach (on_resource_update => sub {
3324 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3325 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3326
3327 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3328 my $sound = $soundconf->{compat}[$_]
3329 or next;
3330
3331 my $face = cf::face::find "sound/$sound->[1]";
3332 cf::sound::set $sound->[0] => $face;
3333 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3334 }
3335
3336 while (my ($k, $v) = each %{$soundconf->{event}}) {
3337 my $face = cf::face::find "sound/$v";
3338 cf::sound::set $k => $face;
3339 }
3340 }
3341});
2971 3342
2972register_exticmd fx_want => sub { 3343register_exticmd fx_want => sub {
2973 my ($ns, $want) = @_; 3344 my ($ns, $want) = @_;
2974 3345
2975 while (my ($k, $v) = each %$want) { 3346 while (my ($k, $v) = each %$want) {
2976 $ns->fx_want ($k, $v); 3347 $ns->fx_want ($k, $v);
2977 } 3348 }
2978}; 3349};
3350
3351sub load_resource_file($) {
3352 my $guard = lock_acquire "load_resource_file";
3353
3354 my $status = load_resource_file_ $_[0];
3355 get_slot 0.1, 100;
3356 cf::arch::commit_load;
3357
3358 $status
3359}
2979 3360
2980sub reload_regions { 3361sub reload_regions {
2981 # HACK to clear player env face cache, we need some signal framework 3362 # HACK to clear player env face cache, we need some signal framework
2982 # for this (global event?) 3363 # for this (global event?)
2983 %ext::player_env::MUSIC_FACE_CACHE = (); 3364 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
2997} 3378}
2998 3379
2999sub reload_archetypes { 3380sub reload_archetypes {
3000 load_resource_file "$DATADIR/archetypes" 3381 load_resource_file "$DATADIR/archetypes"
3001 or die "unable to load archetypes\n"; 3382 or die "unable to load archetypes\n";
3002 #d# NEED to laod twice to resolve forward references
3003 # this really needs to be done in an extra post-pass
3004 # (which needs to be synchronous, so solve it differently)
3005 load_resource_file "$DATADIR/archetypes"
3006 or die "unable to load archetypes\n";
3007} 3383}
3008 3384
3009sub reload_treasures { 3385sub reload_treasures {
3010 load_resource_file "$DATADIR/treasures" 3386 load_resource_file "$DATADIR/treasures"
3011 or die "unable to load treasurelists\n"; 3387 or die "unable to load treasurelists\n";
3012} 3388}
3013 3389
3014sub reload_resources { 3390sub reload_resources {
3015 warn "reloading resource files...\n"; 3391 warn "reloading resource files...\n";
3016 3392
3393 reload_facedata;
3394 reload_archetypes;
3017 reload_regions; 3395 reload_regions;
3018 reload_facedata;
3019 #reload_archetypes;#d#
3020 reload_archetypes;
3021 reload_treasures; 3396 reload_treasures;
3022 3397
3023 warn "finished reloading resource files\n"; 3398 warn "finished reloading resource files\n";
3024} 3399}
3025 3400
3026sub init { 3401sub init {
3402 my $guard = freeze_mainloop;
3403
3404 evthread_start IO::AIO::poll_fileno;
3405
3027 reload_resources; 3406 reload_resources;
3028} 3407}
3029 3408
3030sub reload_config { 3409sub reload_config {
3031 open my $fh, "<:utf8", "$CONFDIR/config" 3410 open my $fh, "<:utf8", "$CONFDIR/config"
3032 or return; 3411 or return;
3033 3412
3034 local $/; 3413 local $/;
3035 *CFG = YAML::Syck::Load <$fh>; 3414 *CFG = YAML::Load <$fh>;
3036 3415
3037 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3416 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3038 3417
3039 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3418 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3040 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3419 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3051sub main { 3430sub main {
3052 # we must not ever block the main coroutine 3431 # we must not ever block the main coroutine
3053 local $Coro::idle = sub { 3432 local $Coro::idle = sub {
3054 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3433 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3055 (async { 3434 (async {
3056 Event::one_event; 3435 $Coro::current->{desc} = "IDLE BUG HANDLER";
3436 EV::loop EV::LOOP_ONESHOT;
3057 })->prio (Coro::PRIO_MAX); 3437 })->prio (Coro::PRIO_MAX);
3058 }; 3438 };
3059 3439
3440 {
3441 my $guard = freeze_mainloop;
3060 reload_config; 3442 reload_config;
3061 db_init; 3443 db_init;
3062 load_extensions; 3444 load_extensions;
3063 3445
3064 $TICK_WATCHER->start; 3446 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3447 }
3448
3065 Event::loop; 3449 EV::loop;
3066} 3450}
3067 3451
3068############################################################################# 3452#############################################################################
3069# initialisation and cleanup 3453# initialisation and cleanup
3070 3454
3071# install some emergency cleanup handlers 3455# install some emergency cleanup handlers
3072BEGIN { 3456BEGIN {
3457 our %SIGWATCHER = ();
3073 for my $signal (qw(INT HUP TERM)) { 3458 for my $signal (qw(INT HUP TERM)) {
3074 Event->signal ( 3459 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3075 reentrant => 0,
3076 data => WF_AUTOCANCEL,
3077 signal => $signal,
3078 prio => 0,
3079 cb => sub {
3080 cf::cleanup "SIG$signal"; 3460 cf::cleanup "SIG$signal";
3081 },
3082 ); 3461 };
3083 } 3462 }
3084} 3463}
3085 3464
3086sub write_runtime { 3465sub write_runtime_sync {
3087 my $runtime = "$LOCALDIR/runtime"; 3466 my $runtime = "$LOCALDIR/runtime";
3088 3467
3089 # first touch the runtime file to show we are still running: 3468 # first touch the runtime file to show we are still running:
3090 # the fsync below can take a very very long time. 3469 # the fsync below can take a very very long time.
3091 3470
… …
3117 and return; 3496 and return;
3118 3497
3119 warn "runtime file written.\n"; 3498 warn "runtime file written.\n";
3120 3499
3121 1 3500 1
3501}
3502
3503our $uuid_lock;
3504our $uuid_skip;
3505
3506sub write_uuid_sync($) {
3507 $uuid_skip ||= $_[0];
3508
3509 return if $uuid_lock;
3510 local $uuid_lock = 1;
3511
3512 my $uuid = "$LOCALDIR/uuid";
3513
3514 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3515 or return;
3516
3517 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3518 $uuid_skip = 0;
3519
3520 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3521 and return;
3522
3523 # always fsync - this file is important
3524 aio_fsync $fh
3525 and return;
3526
3527 close $fh
3528 or return;
3529
3530 aio_rename "$uuid~", $uuid
3531 and return;
3532
3533 warn "uuid file written ($value).\n";
3534
3535 1
3536
3537}
3538
3539sub write_uuid($$) {
3540 my ($skip, $sync) = @_;
3541
3542 $sync ? write_uuid_sync $skip
3543 : async { write_uuid_sync $skip };
3122} 3544}
3123 3545
3124sub emergency_save() { 3546sub emergency_save() {
3125 my $freeze_guard = cf::freeze_mainloop; 3547 my $freeze_guard = cf::freeze_mainloop;
3126 3548
… …
3132 # and maps saved/destroyed asynchronously. 3554 # and maps saved/destroyed asynchronously.
3133 warn "begin emergency player save\n"; 3555 warn "begin emergency player save\n";
3134 for my $login (keys %cf::PLAYER) { 3556 for my $login (keys %cf::PLAYER) {
3135 my $pl = $cf::PLAYER{$login} or next; 3557 my $pl = $cf::PLAYER{$login} or next;
3136 $pl->valid or next; 3558 $pl->valid or next;
3559 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3137 $pl->save; 3560 $pl->save;
3138 } 3561 }
3139 warn "end emergency player save\n"; 3562 warn "end emergency player save\n";
3140 3563
3141 warn "begin emergency map save\n"; 3564 warn "begin emergency map save\n";
… …
3147 warn "end emergency map save\n"; 3570 warn "end emergency map save\n";
3148 3571
3149 warn "begin emergency database checkpoint\n"; 3572 warn "begin emergency database checkpoint\n";
3150 BDB::db_env_txn_checkpoint $DB_ENV; 3573 BDB::db_env_txn_checkpoint $DB_ENV;
3151 warn "end emergency database checkpoint\n"; 3574 warn "end emergency database checkpoint\n";
3575
3576 warn "begin write uuid\n";
3577 write_uuid_sync 1;
3578 warn "end write uuid\n";
3152 }; 3579 };
3153 3580
3154 warn "leave emergency perl save\n"; 3581 warn "leave emergency perl save\n";
3155} 3582}
3156 3583
… …
3171 warn "reloading..."; 3598 warn "reloading...";
3172 3599
3173 warn "entering sync_job"; 3600 warn "entering sync_job";
3174 3601
3175 cf::sync_job { 3602 cf::sync_job {
3176 cf::write_runtime; # external watchdog should not bark 3603 cf::write_runtime_sync; # external watchdog should not bark
3177 cf::emergency_save; 3604 cf::emergency_save;
3178 cf::write_runtime; # external watchdog should not bark 3605 cf::write_runtime_sync; # external watchdog should not bark
3179 3606
3180 warn "syncing database to disk"; 3607 warn "syncing database to disk";
3181 BDB::db_env_txn_checkpoint $DB_ENV; 3608 BDB::db_env_txn_checkpoint $DB_ENV;
3182 3609
3183 # if anything goes wrong in here, we should simply crash as we already saved 3610 # if anything goes wrong in here, we should simply crash as we already saved
3184
3185 warn "cancelling all WF_AUTOCANCEL watchers";
3186 for (Event::all_watchers) {
3187 $_->cancel if $_->data & WF_AUTOCANCEL;
3188 }
3189 3611
3190 warn "flushing outstanding aio requests"; 3612 warn "flushing outstanding aio requests";
3191 for (;;) { 3613 for (;;) {
3192 BDB::flush; 3614 BDB::flush;
3193 IO::AIO::flush; 3615 IO::AIO::flush;
3194 Coro::cede; 3616 Coro::cede_notself;
3195 last unless IO::AIO::nreqs || BDB::nreqs; 3617 last unless IO::AIO::nreqs || BDB::nreqs;
3196 warn "iterate..."; 3618 warn "iterate...";
3197 } 3619 }
3198 3620
3199 ++$RELOAD; 3621 ++$RELOAD;
… …
3275 warn "leaving sync_job"; 3697 warn "leaving sync_job";
3276 3698
3277 1 3699 1
3278 } or do { 3700 } or do {
3279 warn $@; 3701 warn $@;
3280 warn "error while reloading, exiting."; 3702 cf::cleanup "error while reloading, exiting.";
3281 exit 1;
3282 }; 3703 };
3283 3704
3284 warn "reloaded"; 3705 warn "reloaded";
3285}; 3706};
3286 3707
… …
3288 3709
3289sub reload_perl() { 3710sub reload_perl() {
3290 # doing reload synchronously and two reloads happen back-to-back, 3711 # doing reload synchronously and two reloads happen back-to-back,
3291 # coro crashes during coro_state_free->destroy here. 3712 # coro crashes during coro_state_free->destroy here.
3292 3713
3293 $RELOAD_WATCHER ||= Event->timer ( 3714 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3294 reentrant => 0,
3295 after => 0,
3296 data => WF_AUTOCANCEL,
3297 cb => sub {
3298 do_reload_perl; 3715 do_reload_perl;
3299 undef $RELOAD_WATCHER; 3716 undef $RELOAD_WATCHER;
3300 },
3301 ); 3717 };
3302} 3718}
3303 3719
3304register_command "reload" => sub { 3720register_command "reload" => sub {
3305 my ($who, $arg) = @_; 3721 my ($who, $arg) = @_;
3306 3722
3307 if ($who->flag (FLAG_WIZ)) { 3723 if ($who->flag (FLAG_WIZ)) {
3308 $who->message ("reloading server."); 3724 $who->message ("reloading server.");
3725 async {
3726 $Coro::current->{desc} = "perl_reload";
3309 async { reload_perl }; 3727 reload_perl;
3728 };
3310 } 3729 }
3311}; 3730};
3312 3731
3313unshift @INC, $LIBDIR; 3732unshift @INC, $LIBDIR;
3314 3733
… …
3316 3735
3317our @WAIT_FOR_TICK; 3736our @WAIT_FOR_TICK;
3318our @WAIT_FOR_TICK_BEGIN; 3737our @WAIT_FOR_TICK_BEGIN;
3319 3738
3320sub wait_for_tick { 3739sub wait_for_tick {
3321 return unless $TICK_WATCHER->is_active;
3322 return if $Coro::current == $Coro::main; 3740 return if tick_inhibit || $Coro::current == $Coro::main;
3323 3741
3324 my $signal = new Coro::Signal; 3742 my $signal = new Coro::Signal;
3325 push @WAIT_FOR_TICK, $signal; 3743 push @WAIT_FOR_TICK, $signal;
3326 $signal->wait; 3744 $signal->wait;
3327} 3745}
3328 3746
3329sub wait_for_tick_begin { 3747sub wait_for_tick_begin {
3330 return unless $TICK_WATCHER->is_active;
3331 return if $Coro::current == $Coro::main; 3748 return if tick_inhibit || $Coro::current == $Coro::main;
3332 3749
3333 my $signal = new Coro::Signal; 3750 my $signal = new Coro::Signal;
3334 push @WAIT_FOR_TICK_BEGIN, $signal; 3751 push @WAIT_FOR_TICK_BEGIN, $signal;
3335 $signal->wait; 3752 $signal->wait;
3336} 3753}
3337 3754
3338 my $min = 1e6;#d# 3755sub tick {
3339 my $avg = 10;
3340$TICK_WATCHER = Event->timer (
3341 reentrant => 0,
3342 parked => 1,
3343 prio => 0,
3344 at => $NEXT_TICK || $TICK,
3345 data => WF_AUTOCANCEL,
3346 cb => sub {
3347 if ($Coro::current != $Coro::main) { 3756 if ($Coro::current != $Coro::main) {
3348 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3757 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3349 unless ++$bug_warning > 10; 3758 unless ++$bug_warning > 10;
3350 return; 3759 return;
3351 } 3760 }
3352 3761
3353 $NOW = $tick_start = Event::time;
3354
3355 cf::server_tick; # one server iteration 3762 cf::server_tick; # one server iteration
3356 3763
3357 0 && sync_job {#d# 3764 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3358 for(1..10) { 3765 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3359 my $t = Event::time; 3766 Coro::async_pool {
3360 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3767 $Coro::current->{desc} = "runtime saver";
3361 or die; 3768 write_runtime_sync
3362 3769 or warn "ERROR: unable to write runtime file: $!";
3363 $map->width (50);
3364 $map->height (50);
3365 $map->alloc;
3366 $map->_load_objects ("/tmp/x.map", 1);
3367 my $t = Event::time - $t;
3368
3369 #next unless $t < 0.0013;#d#
3370 if ($t < $min) {
3371 $min = $t;
3372 }
3373 $avg = $avg * 0.99 + $t * 0.01;
3374 }
3375 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3376 exit 0;
3377 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3378 }; 3770 };
3771 }
3379 3772
3380 $RUNTIME += $TICK;
3381 $NEXT_TICK += $TICK;
3382
3383 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3384 $NEXT_RUNTIME_WRITE = $NOW + 10;
3385 Coro::async_pool {
3386 write_runtime
3387 or warn "ERROR: unable to write runtime file: $!";
3388 };
3389 }
3390
3391# my $AFTER = Event::time;
3392# warn $AFTER - $NOW;#d#
3393
3394 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3773 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3395 $sig->send; 3774 $sig->send;
3396 } 3775 }
3397 while (my $sig = shift @WAIT_FOR_TICK) { 3776 while (my $sig = shift @WAIT_FOR_TICK) {
3398 $sig->send; 3777 $sig->send;
3399 } 3778 }
3400 3779
3401 $NOW = Event::time; 3780 $LOAD = ($NOW - $TICK_START) / $TICK;
3402
3403 # if we are delayed by four ticks or more, skip them all
3404 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3405
3406 $TICK_WATCHER->at ($NEXT_TICK);
3407 $TICK_WATCHER->start;
3408
3409 $LOAD = ($NOW - $tick_start) / $TICK;
3410 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3781 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3411 3782
3412 _post_tick; 3783 if (0) {
3413 3784 if ($NEXT_TICK) {
3414 3785 my $jitter = $TICK_START - $NEXT_TICK;
3786 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3787 warn "jitter $JITTER\n";#d#
3788 }
3415 }, 3789 }
3416); 3790}
3417 3791
3418{ 3792{
3419 BDB::max_poll_time $TICK * 0.1; 3793 # configure BDB
3420 $BDB_POLL_WATCHER = Event->io ( 3794
3421 reentrant => 0,
3422 fd => BDB::poll_fileno,
3423 poll => 'r',
3424 prio => 0,
3425 data => WF_AUTOCANCEL,
3426 cb => \&BDB::poll_cb,
3427 );
3428 BDB::min_parallel 8; 3795 BDB::min_parallel 8;
3429 3796 BDB::max_poll_reqs $TICK * 0.1;
3430 BDB::set_sync_prepare { 3797 $AnyEvent::BDB::WATCHER->priority (1);
3431 my $status;
3432 my $current = $Coro::current;
3433 (
3434 sub {
3435 $status = $!;
3436 $current->ready; undef $current;
3437 },
3438 sub {
3439 Coro::schedule while defined $current;
3440 $! = $status;
3441 },
3442 )
3443 };
3444 3798
3445 unless ($DB_ENV) { 3799 unless ($DB_ENV) {
3446 $DB_ENV = BDB::db_env_create; 3800 $DB_ENV = BDB::db_env_create;
3801 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3802 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3803 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3804 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3805 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3447 3806
3448 cf::sync_job { 3807 cf::sync_job {
3449 eval { 3808 eval {
3450 BDB::db_env_open 3809 BDB::db_env_open
3451 $DB_ENV, 3810 $DB_ENV,
… …
3453 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3812 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3454 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3813 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3455 0666; 3814 0666;
3456 3815
3457 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3816 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3458
3459 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3460 $DB_ENV->set_lk_detect;
3461 }; 3817 };
3462 3818
3463 cf::cleanup "db_env_open(db): $@" if $@; 3819 cf::cleanup "db_env_open(db): $@" if $@;
3464 }; 3820 };
3465 } 3821 }
3822
3823 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3824 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3825 };
3826 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3827 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3828 };
3829 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3830 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3831 };
3466} 3832}
3467 3833
3468{ 3834{
3835 # configure IO::AIO
3836
3469 IO::AIO::min_parallel 8; 3837 IO::AIO::min_parallel 8;
3470
3471 undef $Coro::AIO::WATCHER;
3472 IO::AIO::max_poll_time $TICK * 0.1; 3838 IO::AIO::max_poll_time $TICK * 0.1;
3473 $AIO_POLL_WATCHER = Event->io ( 3839 undef $AnyEvent::AIO::WATCHER;
3474 reentrant => 0,
3475 data => WF_AUTOCANCEL,
3476 fd => IO::AIO::poll_fileno,
3477 poll => 'r',
3478 prio => 6,
3479 cb => \&IO::AIO::poll_cb,
3480 );
3481} 3840}
3482 3841
3483my $_log_backtrace; 3842my $_log_backtrace;
3484 3843
3485sub _log_backtrace { 3844sub _log_backtrace {
… …
3489 3848
3490 # limit the # of concurrent backtraces 3849 # limit the # of concurrent backtraces
3491 if ($_log_backtrace < 2) { 3850 if ($_log_backtrace < 2) {
3492 ++$_log_backtrace; 3851 ++$_log_backtrace;
3493 async { 3852 async {
3853 $Coro::current->{desc} = "abt $msg";
3854
3494 my @bt = fork_call { 3855 my @bt = fork_call {
3495 @addr = map { sprintf "%x", $_ } @addr; 3856 @addr = map { sprintf "%x", $_ } @addr;
3496 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3857 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3497 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3858 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3498 or die "addr2line: $!"; 3859 or die "addr2line: $!";

Diff Legend

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