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.318 by root, Tue Jul 24 04:55:34 2007 UTC vs.
Revision 1.386 by root, Mon Oct 15 17:50:27 2007 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable;
10use Event; 9use 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.1 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
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::Storable; 23use Coro::Storable;
24use Coro::Util ();
24 25
25use JSON::XS 1.4 (); 26use JSON::XS ();
26use BDB (); 27use BDB ();
27use Data::Dumper; 28use Data::Dumper;
28use Digest::MD5; 29use Digest::MD5;
29use Fcntl; 30use Fcntl;
30use YAML::Syck (); 31use YAML::Syck ();
31use IO::AIO 2.32 (); 32use IO::AIO 2.51 ();
32use Time::HiRes; 33use Time::HiRes;
33use Compress::LZF; 34use Compress::LZF;
34use Digest::MD5 (); 35use Digest::MD5 ();
35 36
36# configure various modules to our taste 37# configure various modules to our taste
… …
79our $NEXT_TICK; 80our $NEXT_TICK;
80our $NOW; 81our $NOW;
81our $USE_FSYNC = 1; # use fsync to write maps - default off 82our $USE_FSYNC = 1; # use fsync to write maps - default off
82 83
83our $BDB_POLL_WATCHER; 84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER;
84our $DB_ENV; 88our $DB_ENV;
85 89
86our %CFG; 90our %CFG;
87 91
88our $UPTIME; $UPTIME ||= time; 92our $UPTIME; $UPTIME ||= time;
89our $RUNTIME; 93our $RUNTIME;
90 94
91our %PLAYER; # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
92our %MAP; # all maps 96our (%MAP, %MAP_LOADING ); # all maps
93our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
94 98
95# used to convert map paths into valid unix filenames by replacing / by ∕ 99# used to convert map paths into valid unix filenames by replacing / by ∕
96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97 101
… …
186 $msg .= "\n" 190 $msg .= "\n"
187 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
188 192
189 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190 194
191 utf8::encode $msg;
192 LOG llevError, $msg; 195 LOG llevError, $msg;
193 }; 196 };
194} 197}
195 198
196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
271Wait until the given lock is available and then acquires it and returns 274Wait until the given lock is available and then acquires it and returns
272a Coro::guard object. If the guard object gets destroyed (goes out of scope, 275a Coro::guard object. If the guard object gets destroyed (goes out of scope,
273for example when the coroutine gets canceled), the lock is automatically 276for example when the coroutine gets canceled), the lock is automatically
274returned. 277returned.
275 278
279Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro.
281
276Lock names should begin with a unique identifier (for example, cf::map::find 282Lock names should begin with a unique identifier (for example, cf::map::find
277uses map_find and cf::map::load uses map_load). 283uses map_find and cf::map::load uses map_load).
278 284
279=item $locked = cf::lock_active $string 285=item $locked = cf::lock_active $string
280 286
281Return true if the lock is currently active, i.e. somebody has locked it. 287Return true if the lock is currently active, i.e. somebody has locked it.
282 288
283=cut 289=cut
284 290
285our %LOCK; 291our %LOCK;
292our %LOCKER;#d#
286 293
287sub lock_wait($) { 294sub lock_wait($) {
288 my ($key) = @_; 295 my ($key) = @_;
296
297 if ($LOCKER{$key} == $Coro::current) {#d#
298 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
299 return;#d#
300 }#d#
289 301
290 # wait for lock, if any 302 # wait for lock, if any
291 while ($LOCK{$key}) { 303 while ($LOCK{$key}) {
292 push @{ $LOCK{$key} }, $Coro::current; 304 push @{ $LOCK{$key} }, $Coro::current;
293 Coro::schedule; 305 Coro::schedule;
… …
299 311
300 # wait, to be sure we are not locked 312 # wait, to be sure we are not locked
301 lock_wait $key; 313 lock_wait $key;
302 314
303 $LOCK{$key} = []; 315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
304 317
305 Coro::guard { 318 Coro::guard {
319 delete $LOCKER{$key};#d#
306 # wake up all waiters, to be on the safe side 320 # wake up all waiters, to be on the safe side
307 $_->ready for @{ delete $LOCK{$key} }; 321 $_->ready for @{ delete $LOCK{$key} };
308 } 322 }
309} 323}
310 324
… …
340our @SLOT_QUEUE; 354our @SLOT_QUEUE;
341our $SLOT_QUEUE; 355our $SLOT_QUEUE;
342 356
343$SLOT_QUEUE->cancel if $SLOT_QUEUE; 357$SLOT_QUEUE->cancel if $SLOT_QUEUE;
344$SLOT_QUEUE = Coro::async { 358$SLOT_QUEUE = Coro::async {
359 $Coro::current->desc ("timeslot manager");
360
345 my $signal = new Coro::Signal; 361 my $signal = new Coro::Signal;
346 362
347 while () { 363 while () {
348 next_job: 364 next_job:
349 my $avail = cf::till_tick; 365 my $avail = cf::till_tick;
… …
357 } 373 }
358 } 374 }
359 } 375 }
360 376
361 if (@SLOT_QUEUE) { 377 if (@SLOT_QUEUE) {
362 # we do not use wait_For_tick() as it returns immediately when tick is inactive 378 # we do not use wait_for_tick() as it returns immediately when tick is inactive
363 push @cf::WAIT_FOR_TICK, $signal; 379 push @cf::WAIT_FOR_TICK, $signal;
364 $signal->wait; 380 $signal->wait;
365 } else { 381 } else {
366 Coro::schedule; 382 Coro::schedule;
367 } 383 }
… …
411 my $time = Event::time; 427 my $time = Event::time;
412 428
413 # this is the main coro, too bad, we have to block 429 # this is the main coro, too bad, we have to block
414 # till the operation succeeds, freezing the server :/ 430 # till the operation succeeds, freezing the server :/
415 431
432 LOG llevError, Carp::longmess "sync job";#d#
433
416 # TODO: use suspend/resume instead 434 # TODO: use suspend/resume instead
417 # (but this is cancel-safe) 435 # (but this is cancel-safe)
418 my $freeze_guard = freeze_mainloop; 436 my $freeze_guard = freeze_mainloop;
419 437
420 my $busy = 1; 438 my $busy = 1;
421 my @res; 439 my @res;
422 440
423 (async { 441 (async {
442 $Coro::current->desc ("sync job coro");
424 @res = eval { $job->() }; 443 @res = eval { $job->() };
425 warn $@ if $@; 444 warn $@ if $@;
426 undef $busy; 445 undef $busy;
427 })->prio (Coro::PRIO_MAX); 446 })->prio (Coro::PRIO_MAX);
428 447
… …
472Coro::Storable. May, of course, block. Note that the executed sub may 491Coro::Storable. May, of course, block. Note that the executed sub may
473never block itself or use any form of Event handling. 492never block itself or use any form of Event handling.
474 493
475=cut 494=cut
476 495
477sub _store_scalar {
478 open my $fh, ">", \my $buf
479 or die "fork_call: cannot open fh-to-buf in child : $!";
480 Storable::store_fd $_[0], $fh;
481 close $fh;
482
483 $buf
484}
485
486sub fork_call(&@) { 496sub fork_call(&@) {
487 my ($cb, @args) = @_; 497 my ($cb, @args) = @_;
488 498
489# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 499 # we seemingly have to make a local copy of the whole thing,
490# or die "socketpair: $!"; 500 # otherwise perl prematurely frees the stuff :/
491 pipe my $fh1, my $fh2 501 # TODO: investigate and fix (likely this will be rather laborious)
492 or die "pipe: $!";
493 502
494 if (my $pid = fork) { 503 my @res = Coro::Util::fork_eval {
495 close $fh2;
496
497 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
498 warn "pst<$res>" unless $res =~ /^pst/;
499 $res = Coro::Storable::thaw $res;
500
501 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
502
503 Carp::confess $$res unless "ARRAY" eq ref $res;
504
505 return wantarray ? @$res : $res->[-1];
506 } else {
507 reset_signals; 504 reset_signals;
508 local $SIG{__WARN__}; 505 &$cb
509 local $SIG{__DIE__}; 506 }, @args;
510 # just in case, this hack effectively disables event
511 # in the child. cleaner and slower would be canceling all watchers,
512 # but this works for the time being.
513 local $Coro::idle;
514 $Coro::current->prio (Coro::PRIO_MAX);
515 507
516 eval { 508 wantarray ? @res : $res[-1]
517 close $fh1;
518
519 my @res = eval { $cb->(@args) };
520
521 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
522 close $fh2;
523 };
524
525 warn $@ if $@;
526 _exit 0;
527 }
528} 509}
529 510
530=item $value = cf::db_get $family => $key 511=item $value = cf::db_get $family => $key
531 512
532Returns a single value from the environment database. 513Returns a single value from the environment database.
… …
534=item cf::db_put $family => $key => $value 515=item cf::db_put $family => $key => $value
535 516
536Stores the given C<$value> in the family. It can currently store binary 517Stores the given C<$value> in the family. It can currently store binary
537data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 518data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
538 519
520=item $db = cf::db_table "name"
521
522Create and/or open a new database table. The string must not be "db" and must be unique
523within each server.
524
539=cut 525=cut
526
527sub db_table($) {
528 my ($name) = @_;
529 my $db = BDB::db_create $DB_ENV;
530
531 eval {
532 $db->set_flags (BDB::CHKSUM);
533
534 utf8::encode $name;
535 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
536 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
537 cf::cleanup "db_open(db): $!" if $!;
538 };
539 cf::cleanup "db_open(db): $@" if $@;
540
541 $db
542}
540 543
541our $DB; 544our $DB;
542 545
543sub db_init { 546sub db_init {
544 unless ($DB) {
545 $DB = BDB::db_create $DB_ENV;
546
547 cf::sync_job { 547 cf::sync_job {
548 eval { 548 $DB ||= db_table "db";
549 $DB->set_flags (BDB::CHKSUM);
550
551 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
552 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
553 cf::cleanup "db_open(db): $!" if $!;
554 };
555 cf::cleanup "db_open(db): $@" if $@;
556 };
557 } 549 };
558} 550}
559 551
560sub db_get($$) { 552sub db_get($$) {
561 my $key = "$_[0]/$_[1]"; 553 my $key = "$_[0]/$_[1]";
562 554
… …
612 if (1) { 604 if (1) {
613 $md5 = 605 $md5 =
614 join "\x00", 606 join "\x00",
615 $processversion, 607 $processversion,
616 map { 608 map {
617 Coro::cede; 609 cf::cede_to_tick;
618 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 610 ($src->[$_], Digest::MD5::md5_hex $data[$_])
619 } 0.. $#$src; 611 } 0.. $#$src;
620 612
621 613
622 my $dbmd5 = db_get cache => "$id/md5"; 614 my $dbmd5 = db_get cache => "$id/md5";
… …
974 966
975=cut 967=cut
976 968
977############################################################################# 969#############################################################################
978# object support 970# object support
979#
980 971
972sub _object_equal($$);
973sub _object_equal($$) {
974 my ($a, $b) = @_;
975
976 return 0 unless (ref $a) eq (ref $b);
977
978 if ("HASH" eq ref $a) {
979 my @ka = keys %$a;
980 my @kb = keys %$b;
981
982 return 0 if @ka != @kb;
983
984 for (0 .. $#ka) {
985 return 0 unless $ka[$_] eq $kb[$_];
986 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
987 }
988
989 } elsif ("ARRAY" eq ref $a) {
990
991 return 0 if @$a != @$b;
992
993 for (0 .. $#$a) {
994 return 0 unless _object_equal $a->[$_], $b->[$_];
995 }
996
997 } elsif ($a ne $b) {
998 return 0;
999 }
1000
1001 1
1002}
1003
1004our $SLOW_MERGES;#d#
981sub _can_merge { 1005sub _can_merge {
982 my ($ob1, $ob2) = @_; 1006 my ($ob1, $ob2) = @_;
983 1007
984 local $Storable::canonical = 1; 1008 ++$SLOW_MERGES;#d#
985 my $fob1 = Storable::freeze $ob1;
986 my $fob2 = Storable::freeze $ob2;
987 1009
988 $fob1 eq $fob2 1010 # we do the slow way here
1011 return _object_equal $ob1, $ob2
989} 1012}
990 1013
991sub reattach { 1014sub reattach {
992 # basically do the same as instantiate, without calling instantiate 1015 # basically do the same as instantiate, without calling instantiate
993 my ($obj) = @_; 1016 my ($obj) = @_;
… …
1041sub object_freezer_save { 1064sub object_freezer_save {
1042 my ($filename, $rdata, $objs) = @_; 1065 my ($filename, $rdata, $objs) = @_;
1043 1066
1044 sync_job { 1067 sync_job {
1045 if (length $$rdata) { 1068 if (length $$rdata) {
1069 utf8::decode (my $decname = $filename);
1046 warn sprintf "saving %s (%d,%d)\n", 1070 warn sprintf "saving %s (%d,%d)\n",
1047 $filename, length $$rdata, scalar @$objs; 1071 $decname, length $$rdata, scalar @$objs;
1048 1072
1049 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1073 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1050 chmod SAVE_MODE, $fh; 1074 chmod SAVE_MODE, $fh;
1051 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1075 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1052 aio_fsync $fh if $cf::USE_FSYNC; 1076 aio_fsync $fh if $cf::USE_FSYNC;
1053 close $fh; 1077 close $fh;
1054 1078
1055 if (@$objs) { 1079 if (@$objs) {
1056 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1080 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1057 chmod SAVE_MODE, $fh; 1081 chmod SAVE_MODE, $fh;
1058 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1082 my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };
1059 aio_write $fh, 0, (length $data), $data, 0; 1083 aio_write $fh, 0, (length $data), $data, 0;
1060 aio_fsync $fh if $cf::USE_FSYNC; 1084 aio_fsync $fh if $cf::USE_FSYNC;
1061 close $fh; 1085 close $fh;
1062 aio_rename "$filename.pst~", "$filename.pst"; 1086 aio_rename "$filename.pst~", "$filename.pst";
1063 } 1087 }
… …
1071 } 1095 }
1072 } else { 1096 } else {
1073 aio_unlink $filename; 1097 aio_unlink $filename;
1074 aio_unlink "$filename.pst"; 1098 aio_unlink "$filename.pst";
1075 } 1099 }
1076 } 1100 };
1077} 1101}
1078 1102
1079sub object_freezer_as_string { 1103sub object_freezer_as_string {
1080 my ($rdata, $objs) = @_; 1104 my ($rdata, $objs) = @_;
1081 1105
… …
1093 or return; 1117 or return;
1094 1118
1095 unless (aio_stat "$filename.pst") { 1119 unless (aio_stat "$filename.pst") {
1096 (aio_load "$filename.pst", $av) >= 0 1120 (aio_load "$filename.pst", $av) >= 0
1097 or return; 1121 or return;
1098 $av = eval { (Storable::thaw $av)->{objs} };
1099 }
1100 1122
1123 my $st = eval { Coro::Storable::thaw $av }
1124 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1125 $av = $st->{objs};
1126 }
1127
1128 utf8::decode (my $decname = $filename);
1101 warn sprintf "loading %s (%d)\n", 1129 warn sprintf "loading %s (%d,%d)\n",
1102 $filename, length $data, scalar @{$av || []}; 1130 $decname, length $data, scalar @{$av || []};
1131
1103 return ($data, $av); 1132 ($data, $av)
1104} 1133}
1105 1134
1106=head2 COMMAND CALLBACKS 1135=head2 COMMAND CALLBACKS
1107 1136
1108=over 4 1137=over 4
… …
1186 my ($type, $reply, @payload) = 1215 my ($type, $reply, @payload) =
1187 "ARRAY" eq ref $msg 1216 "ARRAY" eq ref $msg
1188 ? @$msg 1217 ? @$msg
1189 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove 1218 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1190 1219
1220 my @reply;
1221
1191 if (my $cb = $EXTCMD{$type}) { 1222 if (my $cb = $EXTCMD{$type}) {
1192 my @reply = $cb->($pl, @payload); 1223 @reply = $cb->($pl, @payload);
1193
1194 $pl->ext_reply ($reply, @reply)
1195 if $reply;
1196 } 1224 }
1225
1226 $pl->ext_reply ($reply, @reply)
1227 if $reply;
1228
1197 } else { 1229 } else {
1198 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1230 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1199 } 1231 }
1200 1232
1201 cf::override; 1233 cf::override;
… …
1291 1323
1292=head3 cf::player 1324=head3 cf::player
1293 1325
1294=over 4 1326=over 4
1295 1327
1328=item cf::player::num_playing
1329
1330Returns the official number of playing players, as per the Crossfire metaserver rules.
1331
1332=cut
1333
1334sub num_playing {
1335 scalar grep
1336 $_->ob->map
1337 && !$_->hidden
1338 && !$_->ob->flag (cf::FLAG_WIZ),
1339 cf::player::list
1340}
1341
1296=item cf::player::find $login 1342=item cf::player::find $login
1297 1343
1298Returns the given player object, loading it if necessary (might block). 1344Returns the given player object, loading it if necessary (might block).
1299 1345
1300=cut 1346=cut
… …
1335 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1381 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1336 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1382 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1337 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1383 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1338 aio_unlink +(playerdir $login) . "/$login.pl"; 1384 aio_unlink +(playerdir $login) . "/$login.pl";
1339 1385
1340 my $pl = load_pl path $login 1386 my $f = new_from_file cf::object::thawer path $login
1341 or return; 1387 or return;
1388
1389 my $pl = cf::player::load_pl $f
1390 or return;
1391 local $cf::PLAYER_LOADING{$login} = $pl;
1392 $f->resolve_delayed_derefs;
1342 $cf::PLAYER{$login} = $pl 1393 $cf::PLAYER{$login} = $pl
1343 } 1394 }
1344 } 1395 }
1345} 1396}
1346 1397
… …
1356 1407
1357 aio_mkdir playerdir $pl, 0770; 1408 aio_mkdir playerdir $pl, 0770;
1358 $pl->{last_save} = $cf::RUNTIME; 1409 $pl->{last_save} = $cf::RUNTIME;
1359 1410
1360 $pl->save_pl ($path); 1411 $pl->save_pl ($path);
1361 Coro::cede; 1412 cf::cede_to_tick;
1362} 1413}
1363 1414
1364sub new($) { 1415sub new($) {
1365 my ($login) = @_; 1416 my ($login) = @_;
1366 1417
… …
1370 $self->{deny_save} = 1; 1421 $self->{deny_save} = 1;
1371 1422
1372 $cf::PLAYER{$login} = $self; 1423 $cf::PLAYER{$login} = $self;
1373 1424
1374 $self 1425 $self
1426}
1427
1428=item $player->send_msg ($channel, $msg, $color, [extra...])
1429
1430=cut
1431
1432sub send_msg {
1433 my $ns = shift->ns
1434 or return;
1435 $ns->send_msg (@_);
1375} 1436}
1376 1437
1377=item $pl->quit_character 1438=item $pl->quit_character
1378 1439
1379Nukes the player without looking back. If logged in, the connection will 1440Nukes the player without looking back. If logged in, the connection will
… …
1434 or return []; 1495 or return [];
1435 1496
1436 my @logins; 1497 my @logins;
1437 1498
1438 for my $login (@$dirs) { 1499 for my $login (@$dirs) {
1500 my $path = path $login;
1501
1502 # a .pst is a dead give-away for a valid player
1503 unless (-e "$path.pst") {
1439 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1504 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1440 aio_read $fh, 0, 512, my $buf, 0 or next; 1505 aio_read $fh, 0, 512, my $buf, 0 or next;
1441 $buf !~ /^password -------------$/m or next; # official not-valid tag 1506 $buf !~ /^password -------------$/m or next; # official not-valid tag
1507 }
1442 1508
1443 utf8::decode $login; 1509 utf8::decode $login;
1444 push @logins, $login; 1510 push @logins, $login;
1445 } 1511 }
1446 1512
… …
1484sub expand_cfpod { 1550sub expand_cfpod {
1485 ((my $self), (local $_)) = @_; 1551 ((my $self), (local $_)) = @_;
1486 1552
1487 # escape & and < 1553 # escape & and <
1488 s/&/&amp;/g; 1554 s/&/&amp;/g;
1489 s/(?<![BIUGH])</&lt;/g; 1555 s/(?<![BIUGHT])</&lt;/g;
1490 1556
1491 # this is buggy, it needs to properly take care of nested <'s 1557 # this is buggy, it needs to properly take care of nested <'s
1492 1558
1493 1 while 1559 1 while
1494 # replace B<>, I<>, U<> etc. 1560 # replace B<>, I<>, U<> etc.
1495 s/B<([^\>]*)>/<b>$1<\/b>/ 1561 s/B<([^\>]*)>/<b>$1<\/b>/
1496 || s/I<([^\>]*)>/<i>$1<\/i>/ 1562 || s/I<([^\>]*)>/<i>$1<\/i>/
1497 || s/U<([^\>]*)>/<u>$1<\/u>/ 1563 || s/U<([^\>]*)>/<u>$1<\/u>/
1564 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1498 # replace G<male|female> tags 1565 # replace G<male|female> tags
1499 || s{G<([^>|]*)\|([^>]*)>}{ 1566 || s{G<([^>|]*)\|([^>]*)>}{
1500 $self->gender ? $2 : $1 1567 $self->gender ? $2 : $1
1501 }ge 1568 }ge
1502 # replace H<hint text> 1569 # replace H<hint text>
… …
1532=cut 1599=cut
1533 1600
1534sub ext_reply($$@) { 1601sub ext_reply($$@) {
1535 my ($self, $id, @msg) = @_; 1602 my ($self, $id, @msg) = @_;
1536 1603
1537 if ($self->ns->extcmd == 2) { 1604 $self->ns->ext_reply ($id, @msg)
1538 $self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
1539 } elsif ($self->ns->extcmd == 1) {
1540 #TODO: version 1, remove
1541 unshift @msg, msgtype => "reply", msgid => $id;
1542 $self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
1543 }
1544} 1605}
1545 1606
1546=item $player->ext_msg ($type, @msg) 1607=item $player->ext_msg ($type, @msg)
1547 1608
1548Sends an ext event to the client. 1609Sends an ext event to the client.
… …
1776 1837
1777sub load_header_from($) { 1838sub load_header_from($) {
1778 my ($self, $path) = @_; 1839 my ($self, $path) = @_;
1779 1840
1780 utf8::encode $path; 1841 utf8::encode $path;
1781 #aio_open $path, O_RDONLY, 0 1842 my $f = new_from_file cf::object::thawer $path
1782 # or return;
1783
1784 $self->_load_header ($path)
1785 or return; 1843 or return;
1844
1845 $self->_load_header ($f)
1846 or return;
1847
1848 local $MAP_LOADING{$self->{path}} = $self;
1849 $f->resolve_delayed_derefs;
1786 1850
1787 $self->{load_path} = $path; 1851 $self->{load_path} = $path;
1788 1852
1789 1 1853 1
1790} 1854}
… …
1844sub find { 1908sub find {
1845 my ($path, $origin) = @_; 1909 my ($path, $origin) = @_;
1846 1910
1847 $path = normalise $path, $origin && $origin->path; 1911 $path = normalise $path, $origin && $origin->path;
1848 1912
1913 cf::lock_wait "map_data:$path";#d#remove
1849 cf::lock_wait "map_find:$path"; 1914 cf::lock_wait "map_find:$path";
1850 1915
1851 $cf::MAP{$path} || do { 1916 $cf::MAP{$path} || do {
1852 my $guard = cf::lock_acquire "map_find:$path"; 1917 my $guard1 = cf::lock_acquire "map_find:$path";
1918 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1919
1853 my $map = new_from_path cf::map $path 1920 my $map = new_from_path cf::map $path
1854 or return; 1921 or return;
1855 1922
1856 $map->{last_save} = $cf::RUNTIME; 1923 $map->{last_save} = $cf::RUNTIME;
1857 1924
… …
1859 or return; 1926 or return;
1860 1927
1861 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1928 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1862 # doing this can freeze the server in a sync job, obviously 1929 # doing this can freeze the server in a sync job, obviously
1863 #$cf::WAIT_FOR_TICK->wait; 1930 #$cf::WAIT_FOR_TICK->wait;
1931 undef $guard1;
1932 undef $guard2;
1864 $map->reset; 1933 $map->reset;
1865 undef $guard;
1866 return find $path; 1934 return find $path;
1867 } 1935 }
1868 1936
1869 $cf::MAP{$path} = $map 1937 $cf::MAP{$path} = $map
1870 } 1938 }
… …
1879 local $self->{deny_reset} = 1; # loading can take a long time 1947 local $self->{deny_reset} = 1; # loading can take a long time
1880 1948
1881 my $path = $self->{path}; 1949 my $path = $self->{path};
1882 1950
1883 { 1951 {
1884 my $guard = cf::lock_acquire "map_load:$path"; 1952 my $guard = cf::lock_acquire "map_data:$path";
1885 1953
1954 return unless $self->valid;
1886 return if $self->in_memory != cf::MAP_SWAPPED; 1955 return unless $self->in_memory == cf::MAP_SWAPPED;
1887 1956
1888 $self->in_memory (cf::MAP_LOADING); 1957 $self->in_memory (cf::MAP_LOADING);
1889 1958
1890 $self->alloc; 1959 $self->alloc;
1891 1960
1892 $self->pre_load; 1961 $self->pre_load;
1893 Coro::cede; 1962 cf::cede_to_tick;
1894 1963
1964 my $f = new_from_file cf::object::thawer $self->{load_path};
1965 $f->skip_block;
1895 $self->_load_objects ($self->{load_path}, 1) 1966 $self->_load_objects ($f)
1896 or return; 1967 or return;
1897 1968
1898 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1969 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1899 if delete $self->{load_original}; 1970 if delete $self->{load_original};
1900 1971
1901 if (my $uniq = $self->uniq_path) { 1972 if (my $uniq = $self->uniq_path) {
1902 utf8::encode $uniq; 1973 utf8::encode $uniq;
1903 if (aio_open $uniq, O_RDONLY, 0) { 1974 unless (aio_stat $uniq) {
1975 if (my $f = new_from_file cf::object::thawer $uniq) {
1904 $self->clear_unique_items; 1976 $self->clear_unique_items;
1905 $self->_load_objects ($uniq, 0); 1977 $self->_load_objects ($f);
1978 $f->resolve_delayed_derefs;
1979 }
1906 } 1980 }
1907 } 1981 }
1908 1982
1909 Coro::cede; 1983 $f->resolve_delayed_derefs;
1984
1985 cf::cede_to_tick;
1910 # now do the right thing for maps 1986 # now do the right thing for maps
1911 $self->link_multipart_objects; 1987 $self->link_multipart_objects;
1912 $self->difficulty ($self->estimate_difficulty) 1988 $self->difficulty ($self->estimate_difficulty)
1913 unless $self->difficulty; 1989 unless $self->difficulty;
1914 Coro::cede; 1990 cf::cede_to_tick;
1915 1991
1916 unless ($self->{deny_activate}) { 1992 unless ($self->{deny_activate}) {
1917 $self->decay_objects; 1993 $self->decay_objects;
1918 $self->fix_auto_apply; 1994 $self->fix_auto_apply;
1919 $self->update_buttons; 1995 $self->update_buttons;
1920 Coro::cede; 1996 cf::cede_to_tick;
1921 $self->set_darkness_map; 1997 $self->set_darkness_map;
1922 Coro::cede; 1998 cf::cede_to_tick;
1923 $self->activate; 1999 $self->activate;
1924 } 2000 }
2001
2002 $self->{last_save} = $cf::RUNTIME;
2003 $self->last_access ($cf::RUNTIME);
1925 2004
1926 $self->in_memory (cf::MAP_IN_MEMORY); 2005 $self->in_memory (cf::MAP_IN_MEMORY);
1927 } 2006 }
1928 2007
1929 $self->post_load; 2008 $self->post_load;
… …
1940 2019
1941 $self 2020 $self
1942} 2021}
1943 2022
1944# find and load all maps in the 3x3 area around a map 2023# find and load all maps in the 3x3 area around a map
1945sub load_diag { 2024sub load_neighbours {
1946 my ($map) = @_; 2025 my ($map) = @_;
1947 2026
1948 my @diag; # diagonal neighbours 2027 my @neigh; # diagonal neighbours
1949 2028
1950 for (0 .. 3) { 2029 for (0 .. 3) {
1951 my $neigh = $map->tile_path ($_) 2030 my $neigh = $map->tile_path ($_)
1952 or next; 2031 or next;
1953 $neigh = find $neigh, $map 2032 $neigh = find $neigh, $map
1954 or next; 2033 or next;
1955 $neigh->load; 2034 $neigh->load;
1956 2035
2036 push @neigh,
1957 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2037 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1958 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2038 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1959 } 2039 }
1960 2040
1961 for (@diag) { 2041 for (grep defined $_->[0], @neigh) {
2042 my ($path, $origin) = @$_;
1962 my $neigh = find @$_ 2043 my $neigh = find $path, $origin
1963 or next; 2044 or next;
1964 $neigh->load; 2045 $neigh->load;
1965 } 2046 }
1966} 2047}
1967 2048
… …
1972} 2053}
1973 2054
1974sub do_load_sync { 2055sub do_load_sync {
1975 my ($map) = @_; 2056 my ($map) = @_;
1976 2057
2058 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2059 if $Coro::current == $Coro::main;
2060
1977 cf::sync_job { $map->load }; 2061 cf::sync_job { $map->load };
1978} 2062}
1979 2063
1980our %MAP_PREFETCH; 2064our %MAP_PREFETCH;
1981our $MAP_PREFETCHER = undef; 2065our $MAP_PREFETCHER = undef;
1982 2066
1983sub find_async { 2067sub find_async {
1984 my ($path, $origin) = @_; 2068 my ($path, $origin, $load) = @_;
1985 2069
1986 $path = normalise $path, $origin && $origin->{path}; 2070 $path = normalise $path, $origin && $origin->{path};
1987 2071
1988 if (my $map = $cf::MAP{$path}) { 2072 if (my $map = $cf::MAP{$path}) {
1989 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2073 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1990 } 2074 }
1991 2075
1992 undef $MAP_PREFETCH{$path}; 2076 $MAP_PREFETCH{$path} |= $load;
2077
1993 $MAP_PREFETCHER ||= cf::async { 2078 $MAP_PREFETCHER ||= cf::async {
2079 $Coro::current->{desc} = "map prefetcher";
2080
1994 while (%MAP_PREFETCH) { 2081 while (%MAP_PREFETCH) {
1995 for my $path (keys %MAP_PREFETCH) { 2082 while (my ($k, $v) = each %MAP_PREFETCH) {
1996 if (my $map = find $path) { 2083 if (my $map = find $k) {
1997 $map->load; 2084 $map->load if $v;
1998 } 2085 }
1999 2086
2000 delete $MAP_PREFETCH{$path}; 2087 delete $MAP_PREFETCH{$k};
2001 } 2088 }
2002 } 2089 }
2003 undef $MAP_PREFETCHER; 2090 undef $MAP_PREFETCHER;
2004 }; 2091 };
2005 $MAP_PREFETCHER->prio (6); 2092 $MAP_PREFETCHER->prio (6);
… …
2008} 2095}
2009 2096
2010sub save { 2097sub save {
2011 my ($self) = @_; 2098 my ($self) = @_;
2012 2099
2013 my $lock = cf::lock_acquire "map_data:" . $self->path; 2100 my $lock = cf::lock_acquire "map_data:$self->{path}";
2014 2101
2015 $self->{last_save} = $cf::RUNTIME; 2102 $self->{last_save} = $cf::RUNTIME;
2016 2103
2017 return unless $self->dirty; 2104 return unless $self->dirty;
2018 2105
… …
2024 return if $self->{deny_save}; 2111 return if $self->{deny_save};
2025 2112
2026 local $self->{last_access} = $self->last_access;#d# 2113 local $self->{last_access} = $self->last_access;#d#
2027 2114
2028 cf::async { 2115 cf::async {
2116 $Coro::current->{desc} = "map player save";
2029 $_->contr->save for $self->players; 2117 $_->contr->save for $self->players;
2030 }; 2118 };
2031 2119
2032 if ($uniq) { 2120 if ($uniq) {
2033 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2121 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2041 my ($self) = @_; 2129 my ($self) = @_;
2042 2130
2043 # save first because save cedes 2131 # save first because save cedes
2044 $self->save; 2132 $self->save;
2045 2133
2046 my $lock = cf::lock_acquire "map_data:" . $self->path; 2134 my $lock = cf::lock_acquire "map_data:$self->{path}";
2047 2135
2048 return if $self->players; 2136 return if $self->players;
2049 return if $self->in_memory != cf::MAP_IN_MEMORY; 2137 return if $self->in_memory != cf::MAP_IN_MEMORY;
2050 return if $self->{deny_save}; 2138 return if $self->{deny_save};
2051 2139
2140 $self->in_memory (cf::MAP_SWAPPED);
2141
2142 $self->deactivate;
2143 $_->clear_links_to ($self) for values %cf::MAP;
2052 $self->clear; 2144 $self->clear;
2053 $self->in_memory (cf::MAP_SWAPPED);
2054} 2145}
2055 2146
2056sub reset_at { 2147sub reset_at {
2057 my ($self) = @_; 2148 my ($self) = @_;
2058 2149
… …
2090 if $uniq; 2181 if $uniq;
2091 } 2182 }
2092 2183
2093 delete $cf::MAP{$self->path}; 2184 delete $cf::MAP{$self->path};
2094 2185
2186 $self->deactivate;
2187 $_->clear_links_to ($self) for values %cf::MAP;
2095 $self->clear; 2188 $self->clear;
2096
2097 $_->clear_links_to ($self) for values %cf::MAP;
2098 2189
2099 $self->unlink_save; 2190 $self->unlink_save;
2100 $self->destroy; 2191 $self->destroy;
2101} 2192}
2102 2193
2103my $nuke_counter = "aaaa"; 2194my $nuke_counter = "aaaa";
2104 2195
2105sub nuke { 2196sub nuke {
2106 my ($self) = @_; 2197 my ($self) = @_;
2107 2198
2199 {
2200 my $lock = cf::lock_acquire "map_data:$self->{path}";
2201
2108 delete $cf::MAP{$self->path}; 2202 delete $cf::MAP{$self->path};
2109 2203
2110 $self->unlink_save; 2204 $self->unlink_save;
2111 2205
2112 bless $self, "cf::map"; 2206 bless $self, "cf::map";
2113 delete $self->{deny_reset}; 2207 delete $self->{deny_reset};
2114 $self->{deny_save} = 1; 2208 $self->{deny_save} = 1;
2115 $self->reset_timeout (1); 2209 $self->reset_timeout (1);
2116 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2210 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2117 2211
2118 $cf::MAP{$self->path} = $self; 2212 $cf::MAP{$self->path} = $self;
2213 }
2119 2214
2120 $self->reset; # polite request, might not happen 2215 $self->reset; # polite request, might not happen
2121} 2216}
2122 2217
2123=item $maps = cf::map::tmp_maps 2218=item $maps = cf::map::tmp_maps
… …
2199 2294
2200sub inv_recursive { 2295sub inv_recursive {
2201 inv_recursive_ inv $_[0] 2296 inv_recursive_ inv $_[0]
2202} 2297}
2203 2298
2299=item $ref = $ob->ref
2300
2301creates and returns a persistent reference to an objetc that can be stored as a string.
2302
2303=item $ob = cf::object::deref ($refstring)
2304
2305returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2306even if the object actually exists. May block.
2307
2308=cut
2309
2310sub deref {
2311 my ($ref) = @_;
2312
2313 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2314 my ($uuid, $name) = ($1, $2);
2315 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2316 or return;
2317 $pl->ob->uuid eq $uuid
2318 or return;
2319
2320 $pl->ob
2321 } else {
2322 warn "$ref: cannot resolve object reference\n";
2323 undef
2324 }
2325}
2326
2204package cf; 2327package cf;
2205 2328
2206=back 2329=back
2207 2330
2208=head3 cf::object::player 2331=head3 cf::object::player
… …
2240 $self->message ($msg, $flags); 2363 $self->message ($msg, $flags);
2241 } 2364 }
2242 } 2365 }
2243} 2366}
2244 2367
2368=item $object->send_msg ($channel, $msg, $color, [extra...])
2369
2370=cut
2371
2372sub cf::object::send_msg {
2373 my $pl = shift->contr
2374 or return;
2375 $pl->send_msg (@_);
2376}
2377
2245=item $player_object->may ("access") 2378=item $player_object->may ("access")
2246 2379
2247Returns wether the given player is authorized to access resource "access" 2380Returns wether the given player is authorized to access resource "access"
2248(e.g. "command_wizcast"). 2381(e.g. "command_wizcast").
2249 2382
… …
2326 # use -1 or undef as default coordinates, not 0, 0 2459 # use -1 or undef as default coordinates, not 0, 0
2327 ($x, $y) = ($map->enter_x, $map->enter_y) 2460 ($x, $y) = ($map->enter_x, $map->enter_y)
2328 if $x <=0 && $y <= 0; 2461 if $x <=0 && $y <= 0;
2329 2462
2330 $map->load; 2463 $map->load;
2331 $map->load_diag; 2464 $map->load_neighbours;
2332 2465
2333 return unless $self->contr->active; 2466 return unless $self->contr->active;
2334 $self->activate_recursive; 2467 $self->activate_recursive;
2335 2468
2336 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2469 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
… …
2356 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2489 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2357 2490
2358 $self->enter_link; 2491 $self->enter_link;
2359 2492
2360 (async { 2493 (async {
2494 $Coro::current->{desc} = "player::goto $path $x $y";
2495
2496 # *tag paths override both path and x|y
2497 if ($path =~ /^\*(.*)$/) {
2498 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2499 my $ob = $obs[rand @obs];
2500
2501 # see if we actually can go there
2502 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2503 $ob = $obs[rand @obs];
2504 } else {
2505 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2506 }
2507 # else put us there anyways for now #d#
2508
2509 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2510 } else {
2511 ($path, $x, $y) = (undef, undef, undef);
2512 }
2513 }
2514
2361 my $map = eval { 2515 my $map = eval {
2362 my $map = cf::map::find $path; 2516 my $map = defined $path ? cf::map::find $path : undef;
2363 2517
2364 if ($map) { 2518 if ($map) {
2365 $map = $map->customise_for ($self); 2519 $map = $map->customise_for ($self);
2366 $map = $check->($map) if $check && $map; 2520 $map = $check->($map) if $check && $map;
2367 } else { 2521 } else {
2368 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2522 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2369 } 2523 }
2370 2524
2371 $map 2525 $map
2372 }; 2526 };
2373 2527
… …
2463 # if exit is damned, update players death & WoR home-position 2617 # if exit is damned, update players death & WoR home-position
2464 $self->contr->savebed ($slaying, $hp, $sp) 2618 $self->contr->savebed ($slaying, $hp, $sp)
2465 if $exit->flag (FLAG_DAMNED); 2619 if $exit->flag (FLAG_DAMNED);
2466 2620
2467 (async { 2621 (async {
2622 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2623
2468 $self->deactivate_recursive; # just to be sure 2624 $self->deactivate_recursive; # just to be sure
2469 unless (eval { 2625 unless (eval {
2470 $self->goto ($slaying, $hp, $sp); 2626 $self->goto ($slaying, $hp, $sp);
2471 2627
2472 1; 2628 1;
… …
2507the message, with C<log> being the default. If C<$color> is negative, suppress 2663the message, with C<log> being the default. If C<$color> is negative, suppress
2508the message unless the client supports the msg packet. 2664the message unless the client supports the msg packet.
2509 2665
2510=cut 2666=cut
2511 2667
2668our %CHANNEL = (
2669 "c/identify" => {
2670 id => "infobox",
2671 title => "Identify",
2672 reply => undef,
2673 tooltip => "Items recently identified",
2674 },
2675 "c/examine" => {
2676 id => "infobox",
2677 title => "Examine",
2678 reply => undef,
2679 tooltip => "Signs and other items you examined",
2680 },
2681 "c/lookat" => {
2682 id => "infobox",
2683 title => "Look",
2684 reply => undef,
2685 tooltip => "What you saw there",
2686 },
2687);
2688
2512sub cf::client::send_msg { 2689sub cf::client::send_msg {
2513 my ($self, $channel, $msg, $color, @extra) = @_; 2690 my ($self, $channel, $msg, $color, @extra) = @_;
2514 2691
2515 $msg = $self->pl->expand_cfpod ($msg); 2692 $msg = $self->pl->expand_cfpod ($msg);
2516 2693
2517 $color &= ~cf::NDI_UNIQUE; # just in case... 2694 $color &= cf::NDI_CLIENT_MASK; # just in case...
2518 2695
2696 # check predefined channels, for the benefit of C
2697 if ($CHANNEL{$channel}) {
2698 $channel = $CHANNEL{$channel};
2699
2700 $self->ext_msg (channel_info => $channel)
2701 if $self->can_msg;
2702
2703 $channel = $channel->{id};
2704
2519 if (ref $channel) { 2705 } elsif (ref $channel) {
2520 # send meta info to client, if not yet sent 2706 # send meta info to client, if not yet sent
2521 unless (exists $self->{channel}{$channel->{id}}) { 2707 unless (exists $self->{channel}{$channel->{id}}) {
2522 $self->{channel}{$channel->{id}} = $channel; 2708 $self->{channel}{$channel->{id}} = $channel;
2523 $self->ext_msg (channel_info => %$channel); 2709 $self->ext_msg (channel_info => $channel)
2710 if $self->can_msg;
2524 } 2711 }
2525 2712
2526 $channel = $channel->{id}; 2713 $channel = $channel->{id};
2527 } 2714 }
2528 2715
2529 return unless @extra || length $msg; 2716 return unless @extra || length $msg;
2530 2717
2531 if ($self->can_msg) { 2718 if ($self->can_msg) {
2719 # default colour, mask it out
2720 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2721 if $color & cf::NDI_DEF;
2722
2532 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra])); 2723 $self->send_packet ("msg " . $self->{json_coder}->encode (
2724 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2533 } else { 2725 } else {
2534 # replace some tags by gcfclient-compatible ones
2535 for ($msg) {
2536 1 while
2537 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2538 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2539 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2540 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2541 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2542 }
2543
2544 if ($color >= 0) { 2726 if ($color >= 0) {
2727 # replace some tags by gcfclient-compatible ones
2728 for ($msg) {
2729 1 while
2730 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2731 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2732 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2733 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2734 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2735 }
2736
2737 $color &= cf::NDI_COLOR_MASK;
2738
2739 utf8::encode $msg;
2740
2545 if (0 && $msg =~ /\[/) { 2741 if (0 && $msg =~ /\[/) {
2742 # COMMAND/INFO
2546 $self->send_packet ("drawextinfo $color 4 0 $msg") 2743 $self->send_packet ("drawextinfo $color 10 8 $msg")
2547 } else { 2744 } else {
2548 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2745 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2549 $self->send_packet ("drawinfo $color $msg") 2746 $self->send_packet ("drawinfo $color $msg")
2550 } 2747 }
2551 } 2748 }
… …
2559=cut 2756=cut
2560 2757
2561sub cf::client::ext_msg($$@) { 2758sub cf::client::ext_msg($$@) {
2562 my ($self, $type, @msg) = @_; 2759 my ($self, $type, @msg) = @_;
2563 2760
2564 my $extcmd = $self->extcmd;
2565
2566 if ($extcmd == 2) { 2761 if ($self->extcmd == 2) {
2567 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 2762 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2568 } elsif ($extcmd == 1) { # TODO: remove 2763 } elsif ($self->extcmd == 1) { # TODO: remove
2569 push @msg, msgtype => "event_$type"; 2764 push @msg, msgtype => "event_$type";
2765 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2766 }
2767}
2768
2769=item $client->ext_reply ($msgid, @msg)
2770
2771Sends an ext reply to the client.
2772
2773=cut
2774
2775sub cf::client::ext_reply($$@) {
2776 my ($self, $id, @msg) = @_;
2777
2778 if ($self->extcmd == 2) {
2779 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2780 } elsif ($self->extcmd == 1) {
2781 #TODO: version 1, remove
2782 unshift @msg, msgtype => "reply", msgid => $id;
2570 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2783 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2571 } 2784 }
2572} 2785}
2573 2786
2574=item $success = $client->query ($flags, "text", \&cb) 2787=item $success = $client->query ($flags, "text", \&cb)
… …
2636 my ($type, $reply, @payload) = 2849 my ($type, $reply, @payload) =
2637 "ARRAY" eq ref $msg 2850 "ARRAY" eq ref $msg
2638 ? @$msg 2851 ? @$msg
2639 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove 2852 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2640 2853
2854 my @reply;
2855
2641 if (my $cb = $EXTICMD{$type}) { 2856 if (my $cb = $EXTICMD{$type}) {
2642 my @reply = $cb->($ns, @payload); 2857 @reply = $cb->($ns, @payload);
2643
2644 $ns->ext_reply ($reply, @reply)
2645 if $reply;
2646 } 2858 }
2859
2860 $ns->ext_reply ($reply, @reply)
2861 if $reply;
2862
2647 } else { 2863 } else {
2648 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2864 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2649 } 2865 }
2650 2866
2651 cf::override; 2867 cf::override;
… …
2698our $safe = new Safe "safe"; 2914our $safe = new Safe "safe";
2699our $safe_hole = new Safe::Hole; 2915our $safe_hole = new Safe::Hole;
2700 2916
2701$SIG{FPE} = 'IGNORE'; 2917$SIG{FPE} = 'IGNORE';
2702 2918
2703$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2919$safe->permit_only (Opcode::opset qw(
2920 :base_core :base_mem :base_orig :base_math
2921 grepstart grepwhile mapstart mapwhile
2922 sort time
2923));
2704 2924
2705# here we export the classes and methods available to script code 2925# here we export the classes and methods available to script code
2706 2926
2707=pod 2927=pod
2708 2928
2709The following functions and methods are available within a safe environment: 2929The following functions and methods are available within a safe environment:
2710 2930
2711 cf::object 2931 cf::object
2712 contr pay_amount pay_player map x y force_find force_add 2932 contr pay_amount pay_player map x y force_find force_add destroy
2713 insert remove 2933 insert remove name archname title slaying race decrease_ob_nr
2714 2934
2715 cf::object::player 2935 cf::object::player
2716 player 2936 player
2717 2937
2718 cf::player 2938 cf::player
… …
2723 2943
2724=cut 2944=cut
2725 2945
2726for ( 2946for (
2727 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 2947 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2948 insert remove inv name archname title slaying race
2728 insert remove)], 2949 decrease_ob_nr destroy)],
2729 ["cf::object::player" => qw(player)], 2950 ["cf::object::player" => qw(player)],
2730 ["cf::player" => qw(peaceful)], 2951 ["cf::player" => qw(peaceful)],
2731 ["cf::map" => qw(trigger)], 2952 ["cf::map" => qw(trigger)],
2732) { 2953) {
2733 no strict 'refs'; 2954 no strict 'refs';
… …
2809# the server's init and main functions 3030# the server's init and main functions
2810 3031
2811sub load_facedata($) { 3032sub load_facedata($) {
2812 my ($path) = @_; 3033 my ($path) = @_;
2813 3034
3035 # HACK to clear player env face cache, we need some signal framework
3036 # for this (global event?)
3037 %ext::player_env::MUSIC_FACE_CACHE = ();
3038
3039 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3040
2814 warn "loading facedata from $path\n"; 3041 warn "loading facedata from $path\n";
2815 3042
2816 my $facedata; 3043 my $facedata;
2817 0 < aio_load $path, $facedata 3044 0 < aio_load $path, $facedata
2818 or die "$path: $!"; 3045 or die "$path: $!";
2819 3046
2820 $facedata = Coro::Storable::thaw $facedata; 3047 $facedata = Coro::Storable::thaw $facedata;
2821 3048
2822 $facedata->{version} == 2 3049 $facedata->{version} == 2
2823 or cf::cleanup "$path: version mismatch, cannot proceed."; 3050 or cf::cleanup "$path: version mismatch, cannot proceed.";
3051
3052 # patch in the exptable
3053 $facedata->{resource}{"res/exp_table"} = {
3054 type => FT_RSRC,
3055 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3056 };
3057 cf::cede_to_tick;
2824 3058
2825 { 3059 {
2826 my $faces = $facedata->{faceinfo}; 3060 my $faces = $facedata->{faceinfo};
2827 3061
2828 while (my ($face, $info) = each %$faces) { 3062 while (my ($face, $info) = each %$faces) {
2829 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3063 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2830 cf::face::set_visibility $idx, $info->{visibility}; 3064 cf::face::set_visibility $idx, $info->{visibility};
2831 cf::face::set_magicmap $idx, $info->{magicmap}; 3065 cf::face::set_magicmap $idx, $info->{magicmap};
2832 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3066 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2833 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3067 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2834 3068
2835 cf::cede_to_tick; 3069 cf::cede_to_tick;
2836 } 3070 }
2837 3071
2838 while (my ($face, $info) = each %$faces) { 3072 while (my ($face, $info) = each %$faces) {
… …
2863 3097
2864 { 3098 {
2865 # TODO: for gcfclient pleasure, we should give resources 3099 # TODO: for gcfclient pleasure, we should give resources
2866 # that gcfclient doesn't grok a >10000 face index. 3100 # that gcfclient doesn't grok a >10000 face index.
2867 my $res = $facedata->{resource}; 3101 my $res = $facedata->{resource};
2868 my $enc = JSON::XS->new->utf8->canonical; 3102
3103 my $soundconf = delete $res->{"res/sound.conf"};
2869 3104
2870 while (my ($name, $info) = each %$res) { 3105 while (my ($name, $info) = each %$res) {
2871 my $meta = $enc->encode ({
2872 name => $name,
2873 copyright => $info->{copyright}, #TODO#
2874 });
2875
2876 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3106 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3107 my $data;
2877 3108
2878 if ($info->{type} & 1) { 3109 if ($info->{type} & 1) {
2879 # prepend meta info 3110 # prepend meta info
2880 3111
3112 my $meta = $enc->encode ({
3113 name => $name,
3114 %{ $info->{meta} || {} },
3115 });
3116
2881 my $data = pack "(w/a*)*", $meta, $info->{data}; 3117 $data = pack "(w/a*)*", $meta, $info->{data};
2882 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2883
2884 cf::face::set_data $idx, 0, $data, $chk;
2885 } else { 3118 } else {
2886 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum}; 3119 $data = $info->{data};
2887 } 3120 }
2888 3121
3122 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2889 cf::face::set_type $idx, $info->{type}; 3123 cf::face::set_type $idx, $info->{type};
2890 3124
2891 cf::cede_to_tick; 3125 cf::cede_to_tick;
3126 }
3127
3128 if ($soundconf) {
3129 $soundconf = $enc->decode (delete $soundconf->{data});
3130
3131 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3132 my $sound = $soundconf->{compat}[$_]
3133 or next;
3134
3135 my $face = cf::face::find "sound/$sound->[1]";
3136 cf::sound::set $sound->[0] => $face;
3137 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3138 }
3139
3140 while (my ($k, $v) = each %{$soundconf->{event}}) {
3141 my $face = cf::face::find "sound/$v";
3142 cf::sound::set $k => $face;
3143 }
2892 } 3144 }
2893 } 3145 }
2894 3146
2895 1 3147 1
2896} 3148}
… …
2902 $ns->fx_want ($k, $v); 3154 $ns->fx_want ($k, $v);
2903 } 3155 }
2904}; 3156};
2905 3157
2906sub reload_regions { 3158sub reload_regions {
3159 # HACK to clear player env face cache, we need some signal framework
3160 # for this (global event?)
3161 %ext::player_env::MUSIC_FACE_CACHE = ();
3162
2907 load_resource_file "$MAPDIR/regions" 3163 load_resource_file "$MAPDIR/regions"
2908 or die "unable to load regions file\n"; 3164 or die "unable to load regions file\n";
2909 3165
2910 for (cf::region::list) { 3166 for (cf::region::list) {
2911 $_->{match} = qr/$_->{match}/ 3167 $_->{match} = qr/$_->{match}/
… …
2947 3203
2948sub init { 3204sub init {
2949 reload_resources; 3205 reload_resources;
2950} 3206}
2951 3207
2952sub cfg_load { 3208sub reload_config {
2953 open my $fh, "<:utf8", "$CONFDIR/config" 3209 open my $fh, "<:utf8", "$CONFDIR/config"
2954 or return; 3210 or return;
2955 3211
2956 local $/; 3212 local $/;
2957 *CFG = YAML::Syck::Load <$fh>; 3213 *CFG = YAML::Syck::Load <$fh>;
… …
2973sub main { 3229sub main {
2974 # we must not ever block the main coroutine 3230 # we must not ever block the main coroutine
2975 local $Coro::idle = sub { 3231 local $Coro::idle = sub {
2976 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3232 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2977 (async { 3233 (async {
3234 $Coro::current->{desc} = "IDLE BUG HANDLER";
2978 Event::one_event; 3235 Event::one_event;
2979 })->prio (Coro::PRIO_MAX); 3236 })->prio (Coro::PRIO_MAX);
2980 }; 3237 };
2981 3238
2982 cfg_load; 3239 reload_config;
2983 db_init; 3240 db_init;
2984 load_extensions; 3241 load_extensions;
2985 3242
2986 $TICK_WATCHER->start; 3243 $TICK_WATCHER->start;
2987 Event::loop; 3244 Event::loop;
… …
3054 # and maps saved/destroyed asynchronously. 3311 # and maps saved/destroyed asynchronously.
3055 warn "begin emergency player save\n"; 3312 warn "begin emergency player save\n";
3056 for my $login (keys %cf::PLAYER) { 3313 for my $login (keys %cf::PLAYER) {
3057 my $pl = $cf::PLAYER{$login} or next; 3314 my $pl = $cf::PLAYER{$login} or next;
3058 $pl->valid or next; 3315 $pl->valid or next;
3316 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3059 $pl->save; 3317 $pl->save;
3060 } 3318 }
3061 warn "end emergency player save\n"; 3319 warn "end emergency player save\n";
3062 3320
3063 warn "begin emergency map save\n"; 3321 warn "begin emergency map save\n";
… …
3180 warn "reloading cf.pm"; 3438 warn "reloading cf.pm";
3181 require cf; 3439 require cf;
3182 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3440 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3183 3441
3184 warn "loading config and database again"; 3442 warn "loading config and database again";
3185 cf::cfg_load; 3443 cf::reload_config;
3186 3444
3187 warn "loading extensions"; 3445 warn "loading extensions";
3188 cf::load_extensions; 3446 cf::load_extensions;
3189 3447
3190 warn "reattaching attachments to objects/players"; 3448 warn "reattaching attachments to objects/players";
… …
3226register_command "reload" => sub { 3484register_command "reload" => sub {
3227 my ($who, $arg) = @_; 3485 my ($who, $arg) = @_;
3228 3486
3229 if ($who->flag (FLAG_WIZ)) { 3487 if ($who->flag (FLAG_WIZ)) {
3230 $who->message ("reloading server."); 3488 $who->message ("reloading server.");
3489 async {
3490 $Coro::current->{desc} = "perl_reload";
3231 async { reload_perl }; 3491 reload_perl;
3492 };
3232 } 3493 }
3233}; 3494};
3234 3495
3235unshift @INC, $LIBDIR; 3496unshift @INC, $LIBDIR;
3236 3497
… …
3255 my $signal = new Coro::Signal; 3516 my $signal = new Coro::Signal;
3256 push @WAIT_FOR_TICK_BEGIN, $signal; 3517 push @WAIT_FOR_TICK_BEGIN, $signal;
3257 $signal->wait; 3518 $signal->wait;
3258} 3519}
3259 3520
3260 my $min = 1e6;#d#
3261 my $avg = 10;
3262$TICK_WATCHER = Event->timer ( 3521$TICK_WATCHER = Event->timer (
3263 reentrant => 0, 3522 reentrant => 0,
3264 parked => 1, 3523 parked => 1,
3265 prio => 0, 3524 prio => 0,
3266 at => $NEXT_TICK || $TICK, 3525 at => $NEXT_TICK || $TICK,
… …
3274 3533
3275 $NOW = $tick_start = Event::time; 3534 $NOW = $tick_start = Event::time;
3276 3535
3277 cf::server_tick; # one server iteration 3536 cf::server_tick; # one server iteration
3278 3537
3279 0 && sync_job {#d#
3280 for(1..10) {
3281 my $t = Event::time;
3282 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3283 or die;
3284
3285 $map->width (50);
3286 $map->height (50);
3287 $map->alloc;
3288 $map->_load_objects ("/tmp/x.map", 1);
3289 my $t = Event::time - $t;
3290
3291 #next unless $t < 0.0013;#d#
3292 if ($t < $min) {
3293 $min = $t;
3294 }
3295 $avg = $avg * 0.99 + $t * 0.01;
3296 }
3297 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3298 exit 0;
3299 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3300 };
3301
3302 $RUNTIME += $TICK; 3538 $RUNTIME += $TICK;
3303 $NEXT_TICK += $TICK; 3539 $NEXT_TICK += $TICK;
3304 3540
3305 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3541 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3306 $NEXT_RUNTIME_WRITE = $NOW + 10; 3542 $NEXT_RUNTIME_WRITE = $NOW + 10;
3307 Coro::async_pool { 3543 Coro::async_pool {
3544 $Coro::current->{desc} = "runtime saver";
3308 write_runtime 3545 write_runtime
3309 or warn "ERROR: unable to write runtime file: $!"; 3546 or warn "ERROR: unable to write runtime file: $!";
3310 }; 3547 };
3311 } 3548 }
3312 3549
3313# my $AFTER = Event::time;
3314# warn $AFTER - $NOW;#d#
3315
3316 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3550 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3317 $sig->send; 3551 $sig->send;
3318 } 3552 }
3319 while (my $sig = shift @WAIT_FOR_TICK) { 3553 while (my $sig = shift @WAIT_FOR_TICK) {
3320 $sig->send; 3554 $sig->send;
… …
3330 3564
3331 $LOAD = ($NOW - $tick_start) / $TICK; 3565 $LOAD = ($NOW - $tick_start) / $TICK;
3332 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3566 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3333 3567
3334 _post_tick; 3568 _post_tick;
3335
3336
3337 }, 3569 },
3338); 3570);
3339 3571
3340{ 3572{
3573 BDB::min_parallel 8;
3341 BDB::max_poll_time $TICK * 0.1; 3574 BDB::max_poll_time $TICK * 0.1;
3342 $BDB_POLL_WATCHER = Event->io ( 3575 $BDB_POLL_WATCHER = Event->io (
3343 reentrant => 0, 3576 reentrant => 0,
3344 fd => BDB::poll_fileno, 3577 fd => BDB::poll_fileno,
3345 poll => 'r', 3578 poll => 'r',
3346 prio => 0, 3579 prio => 0,
3347 data => WF_AUTOCANCEL, 3580 data => WF_AUTOCANCEL,
3348 cb => \&BDB::poll_cb, 3581 cb => \&BDB::poll_cb,
3349 ); 3582 );
3350 BDB::min_parallel 8;
3351 3583
3352 BDB::set_sync_prepare { 3584 BDB::set_sync_prepare {
3353 my $status; 3585 my $status;
3354 my $current = $Coro::current; 3586 my $current = $Coro::current;
3355 ( 3587 (
… …
3364 ) 3596 )
3365 }; 3597 };
3366 3598
3367 unless ($DB_ENV) { 3599 unless ($DB_ENV) {
3368 $DB_ENV = BDB::db_env_create; 3600 $DB_ENV = BDB::db_env_create;
3601 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3602 | BDB::LOG_AUTOREMOVE, 1);
3603 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3604 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3369 3605
3370 cf::sync_job { 3606 cf::sync_job {
3371 eval { 3607 eval {
3372 BDB::db_env_open 3608 BDB::db_env_open
3373 $DB_ENV, 3609 $DB_ENV,
… …
3375 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3611 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3376 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3612 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3377 0666; 3613 0666;
3378 3614
3379 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3615 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3380
3381 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3382 $DB_ENV->set_lk_detect;
3383 }; 3616 };
3384 3617
3385 cf::cleanup "db_env_open(db): $@" if $@; 3618 cf::cleanup "db_env_open(db): $@" if $@;
3386 }; 3619 };
3387 } 3620 }
3621
3622 $BDB_DEADLOCK_WATCHER = Event->timer (
3623 after => 3,
3624 interval => 1,
3625 hard => 1,
3626 prio => 0,
3627 data => WF_AUTOCANCEL,
3628 cb => sub {
3629 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3630 },
3631 );
3632 $BDB_CHECKPOINT_WATCHER = Event->timer (
3633 after => 11,
3634 interval => 60,
3635 hard => 1,
3636 prio => 0,
3637 data => WF_AUTOCANCEL,
3638 cb => sub {
3639 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3640 },
3641 );
3642 $BDB_TRICKLE_WATCHER = Event->timer (
3643 after => 5,
3644 interval => 10,
3645 hard => 1,
3646 prio => 0,
3647 data => WF_AUTOCANCEL,
3648 cb => sub {
3649 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3650 },
3651 );
3388} 3652}
3389 3653
3390{ 3654{
3391 IO::AIO::min_parallel 8; 3655 IO::AIO::min_parallel 8;
3392 3656
… …
3395 $AIO_POLL_WATCHER = Event->io ( 3659 $AIO_POLL_WATCHER = Event->io (
3396 reentrant => 0, 3660 reentrant => 0,
3397 data => WF_AUTOCANCEL, 3661 data => WF_AUTOCANCEL,
3398 fd => IO::AIO::poll_fileno, 3662 fd => IO::AIO::poll_fileno,
3399 poll => 'r', 3663 poll => 'r',
3400 prio => 6, 3664 prio => 0,
3401 cb => \&IO::AIO::poll_cb, 3665 cb => \&IO::AIO::poll_cb,
3402 ); 3666 );
3403} 3667}
3404 3668
3405my $_log_backtrace; 3669my $_log_backtrace;
… …
3411 3675
3412 # limit the # of concurrent backtraces 3676 # limit the # of concurrent backtraces
3413 if ($_log_backtrace < 2) { 3677 if ($_log_backtrace < 2) {
3414 ++$_log_backtrace; 3678 ++$_log_backtrace;
3415 async { 3679 async {
3680 $Coro::current->{desc} = "abt $msg";
3681
3416 my @bt = fork_call { 3682 my @bt = fork_call {
3417 @addr = map { sprintf "%x", $_ } @addr; 3683 @addr = map { sprintf "%x", $_ } @addr;
3418 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3684 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3419 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3685 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3420 or die "addr2line: $!"; 3686 or die "addr2line: $!";

Diff Legend

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