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.356 by root, Tue Sep 4 05:43:21 2007 UTC vs.
Revision 1.396 by root, Wed Nov 14 08:09:46 2007 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable; 9use EV;
10use Event;
11use Opcode; 10use Opcode;
12use Safe; 11use Safe;
13use Safe::Hole; 12use Safe::Hole;
13use Storable ();
14 14
15use Coro 3.64 (); 15use Coro 4.1 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::EV;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
… …
27use BDB (); 27use BDB ();
28use Data::Dumper; 28use Data::Dumper;
29use Digest::MD5; 29use Digest::MD5;
30use Fcntl; 30use Fcntl;
31use YAML::Syck (); 31use YAML::Syck ();
32use IO::AIO 2.32 (); 32use IO::AIO 2.51 ();
33use Time::HiRes; 33use Time::HiRes;
34use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 (); 35use Digest::MD5 ();
36 36
37# configure various modules to our taste 37# configure various modules to our taste
38# 38#
39$Storable::canonical = 1; # reduce rsync transfers 39$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::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 41Compress::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 42
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1; 44$YAML::Syck::ImplicitUnicode = 1;
47 45
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
… …
80our $NEXT_TICK; 78our $NEXT_TICK;
81our $NOW; 79our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 80our $USE_FSYNC = 1; # use fsync to write maps - default off
83 81
84our $BDB_POLL_WATCHER; 82our $BDB_POLL_WATCHER;
83our $BDB_DEADLOCK_WATCHER;
84our $BDB_CHECKPOINT_WATCHER;
85our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 86our $DB_ENV;
86 87
87our %CFG; 88our %CFG;
88 89
89our $UPTIME; $UPTIME ||= time; 90our $UPTIME; $UPTIME ||= time;
… …
159 160
160The raw value load value from the last tick. 161The raw value load value from the last tick.
161 162
162=item %cf::CFG 163=item %cf::CFG
163 164
164Configuration for the server, loaded from C</etc/crossfire/config>, or 165Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 166from wherever your confdir points to.
166 167
167=item cf::wait_for_tick, cf::wait_for_tick_begin 168=item cf::wait_for_tick, cf::wait_for_tick_begin
168 169
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 170These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
187 $msg .= "\n" 188 $msg .= "\n"
188 unless $msg =~ /\n$/; 189 unless $msg =~ /\n$/;
189 190
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 191 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 192
192 utf8::encode $msg;
193 LOG llevError, $msg; 193 LOG llevError, $msg;
194 }; 194 };
195} 195}
196 196
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
213)) { 213)) {
214 no strict 'refs'; 214 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 216}
217 217
218$Event::DIED = sub { 218$EV::DIED = sub {
219 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
220}; 220};
221 221
222############################################################################# 222#############################################################################
223 223
… …
285Return true if the lock is currently active, i.e. somebody has locked it. 285Return true if the lock is currently active, i.e. somebody has locked it.
286 286
287=cut 287=cut
288 288
289our %LOCK; 289our %LOCK;
290our %LOCKER;#d#
290 291
291sub lock_wait($) { 292sub lock_wait($) {
292 my ($key) = @_; 293 my ($key) = @_;
294
295 if ($LOCKER{$key} == $Coro::current) {#d#
296 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
297 return;#d#
298 }#d#
293 299
294 # wait for lock, if any 300 # wait for lock, if any
295 while ($LOCK{$key}) { 301 while ($LOCK{$key}) {
296 push @{ $LOCK{$key} }, $Coro::current; 302 push @{ $LOCK{$key} }, $Coro::current;
297 Coro::schedule; 303 Coro::schedule;
… …
303 309
304 # wait, to be sure we are not locked 310 # wait, to be sure we are not locked
305 lock_wait $key; 311 lock_wait $key;
306 312
307 $LOCK{$key} = []; 313 $LOCK{$key} = [];
314 $LOCKER{$key} = $Coro::current;#d#
308 315
309 Coro::guard { 316 Coro::guard {
317 delete $LOCKER{$key};#d#
310 # wake up all waiters, to be on the safe side 318 # wake up all waiters, to be on the safe side
311 $_->ready for @{ delete $LOCK{$key} }; 319 $_->ready for @{ delete $LOCK{$key} };
312 } 320 }
313} 321}
314 322
… …
326 }; 334 };
327 $TICK_WATCHER->stop; 335 $TICK_WATCHER->stop;
328 $guard 336 $guard
329} 337}
330 338
339=item cf::periodic $interval, $cb
340
341Like EV::periodic, but randomly selects a starting point so that the actions
342get spread over timer.
343
344=cut
345
346sub periodic($$) {
347 my ($interval, $cb) = @_;
348
349 my $start = rand List::Util::min 180, $interval;
350
351 EV::periodic $start, $interval, 0, $cb
352}
353
331=item cf::get_slot $time[, $priority[, $name]] 354=item cf::get_slot $time[, $priority[, $name]]
332 355
333Allocate $time seconds of blocking CPU time at priority C<$priority>: 356Allocate $time seconds of blocking CPU time at priority C<$priority>:
334This call blocks and returns only when you have at least C<$time> seconds 357This call blocks and returns only when you have at least C<$time> seconds
335of cpu time till the next tick. The slot is only valid till the next cede. 358of cpu time till the next tick. The slot is only valid till the next cede.
… …
344our @SLOT_QUEUE; 367our @SLOT_QUEUE;
345our $SLOT_QUEUE; 368our $SLOT_QUEUE;
346 369
347$SLOT_QUEUE->cancel if $SLOT_QUEUE; 370$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async { 371$SLOT_QUEUE = Coro::async {
372 $Coro::current->desc ("timeslot manager");
373
349 my $signal = new Coro::Signal; 374 my $signal = new Coro::Signal;
350 375
351 while () { 376 while () {
352 next_job: 377 next_job:
353 my $avail = cf::till_tick; 378 my $avail = cf::till_tick;
… …
361 } 386 }
362 } 387 }
363 } 388 }
364 389
365 if (@SLOT_QUEUE) { 390 if (@SLOT_QUEUE) {
366 # we do not use wait_For_tick() as it returns immediately when tick is inactive 391 # we do not use wait_for_tick() as it returns immediately when tick is inactive
367 push @cf::WAIT_FOR_TICK, $signal; 392 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait; 393 $signal->wait;
369 } else { 394 } else {
370 Coro::schedule; 395 Coro::schedule;
371 } 396 }
… …
394 419
395BEGIN { *async = \&Coro::async_pool } 420BEGIN { *async = \&Coro::async_pool }
396 421
397=item cf::sync_job { BLOCK } 422=item cf::sync_job { BLOCK }
398 423
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 424The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 425is 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 426partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 427acceptable.
403 428
404If it must be done, put the blocking parts into C<sync_job>. This will run 429If 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 430the given BLOCK in another coroutine while waiting for the result. The
… …
410 435
411sub sync_job(&) { 436sub sync_job(&) {
412 my ($job) = @_; 437 my ($job) = @_;
413 438
414 if ($Coro::current == $Coro::main) { 439 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 440 my $time = EV::time;
416 441
417 # this is the main coro, too bad, we have to block 442 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 443 # till the operation succeeds, freezing the server :/
419 444
445 LOG llevError, Carp::longmess "sync job";#d#
446
420 # TODO: use suspend/resume instead 447 # TODO: use suspend/resume instead
421 # (but this is cancel-safe) 448 # (but this is cancel-safe)
422 my $freeze_guard = freeze_mainloop; 449 my $freeze_guard = freeze_mainloop;
423 450
424 my $busy = 1; 451 my $busy = 1;
425 my @res; 452 my @res;
426 453
427 (async { 454 (async {
455 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 456 @res = eval { $job->() };
429 warn $@ if $@; 457 warn $@ if $@;
430 undef $busy; 458 undef $busy;
431 })->prio (Coro::PRIO_MAX); 459 })->prio (Coro::PRIO_MAX);
432 460
433 while ($busy) { 461 while ($busy) {
434 Coro::cede or Event::one_event; 462 if (Coro::nready) {
463 Coro::cede_notself;
464 } else {
465 EV::loop EV::LOOP_ONESHOT;
435 } 466 }
467 }
436 468
437 $time = Event::time - $time; 469 $time = EV::time - $time;
438 470
439 LOG llevError | logBacktrace, Carp::longmess "long sync job" 471 LOG llevError | logBacktrace, Carp::longmess "long sync job"
440 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 472 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
441 473
442 $tick_start += $time; # do not account sync jobs to server load 474 $tick_start += $time; # do not account sync jobs to server load
… …
472=item fork_call { }, $args 504=item fork_call { }, $args
473 505
474Executes the given code block with the given arguments in a seperate 506Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 507process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 508Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 509never block itself or use any form of event handling.
478 510
479=cut 511=cut
480 512
481sub fork_call(&@) { 513sub fork_call(&@) {
482 my ($cb, @args) = @_; 514 my ($cb, @args) = @_;
… …
500=item cf::db_put $family => $key => $value 532=item cf::db_put $family => $key => $value
501 533
502Stores the given C<$value> in the family. It can currently store binary 534Stores 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). 535data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504 536
537=item $db = cf::db_table "name"
538
539Create and/or open a new database table. The string must not be "db" and must be unique
540within each server.
541
505=cut 542=cut
543
544sub db_table($) {
545 my ($name) = @_;
546 my $db = BDB::db_create $DB_ENV;
547
548 eval {
549 $db->set_flags (BDB::CHKSUM);
550
551 utf8::encode $name;
552 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
553 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
554 cf::cleanup "db_open(db): $!" if $!;
555 };
556 cf::cleanup "db_open(db): $@" if $@;
557
558 $db
559}
506 560
507our $DB; 561our $DB;
508 562
509sub db_init { 563sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 564 cf::sync_job {
514 eval { 565 $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 } 566 };
524} 567}
525 568
526sub db_get($$) { 569sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 570 my $key = "$_[0]/$_[1]";
528 571
… …
632attach callbacks/event handlers (a collection of which is called an "attachment") 675attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 676to it. All such attachable objects support the following methods.
634 677
635In the following description, CLASS can be any of C<global>, C<object> 678In 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 679C<player>, C<client> or C<map> (i.e. the attachable objects in
637Crossfire TRT). 680Deliantra).
638 681
639=over 4 682=over 4
640 683
641=item $attachable->attach ($attachment, key => $value...) 684=item $attachable->attach ($attachment, key => $value...)
642 685
… …
940 983
941=cut 984=cut
942 985
943############################################################################# 986#############################################################################
944# object support 987# object support
945#
946 988
989sub _object_equal($$);
990sub _object_equal($$) {
991 my ($a, $b) = @_;
992
993 return 0 unless (ref $a) eq (ref $b);
994
995 if ("HASH" eq ref $a) {
996 my @ka = keys %$a;
997 my @kb = keys %$b;
998
999 return 0 if @ka != @kb;
1000
1001 for (0 .. $#ka) {
1002 return 0 unless $ka[$_] eq $kb[$_];
1003 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1004 }
1005
1006 } elsif ("ARRAY" eq ref $a) {
1007
1008 return 0 if @$a != @$b;
1009
1010 for (0 .. $#$a) {
1011 return 0 unless _object_equal $a->[$_], $b->[$_];
1012 }
1013
1014 } elsif ($a ne $b) {
1015 return 0;
1016 }
1017
1018 1
1019}
1020
1021our $SLOW_MERGES;#d#
947sub _can_merge { 1022sub _can_merge {
948 my ($ob1, $ob2) = @_; 1023 my ($ob1, $ob2) = @_;
949 1024
950 local $Storable::canonical = 1; 1025 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1026
954 $fob1 eq $fob2 1027 # we do the slow way here
1028 return _object_equal $ob1, $ob2
955} 1029}
956 1030
957sub reattach { 1031sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1032 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1033 my ($obj) = @_;
… …
1005); 1079);
1006 1080
1007sub object_freezer_save { 1081sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1082 my ($filename, $rdata, $objs) = @_;
1009 1083
1010 my $guard = cf::lock_acquire "io";
1011
1012 sync_job { 1084 sync_job {
1013 if (length $$rdata) { 1085 if (length $$rdata) {
1086 utf8::decode (my $decname = $filename);
1014 warn sprintf "saving %s (%d,%d)\n", 1087 warn sprintf "saving %s (%d,%d)\n",
1015 $filename, length $$rdata, scalar @$objs; 1088 $decname, length $$rdata, scalar @$objs;
1016 1089
1017 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1090 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1018 chmod SAVE_MODE, $fh; 1091 chmod SAVE_MODE, $fh;
1019 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1092 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1020 aio_fsync $fh if $cf::USE_FSYNC; 1093 aio_fsync $fh if $cf::USE_FSYNC;
1021 close $fh; 1094 close $fh;
1022 1095
1023 if (@$objs) { 1096 if (@$objs) {
1024 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1097 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1025 chmod SAVE_MODE, $fh; 1098 chmod SAVE_MODE, $fh;
1026 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1099 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1027 aio_write $fh, 0, (length $data), $data, 0; 1100 aio_write $fh, 0, (length $data), $data, 0;
1028 aio_fsync $fh if $cf::USE_FSYNC; 1101 aio_fsync $fh if $cf::USE_FSYNC;
1029 close $fh; 1102 close $fh;
1030 aio_rename "$filename.pst~", "$filename.pst"; 1103 aio_rename "$filename.pst~", "$filename.pst";
1031 } 1104 }
… …
1040 } else { 1113 } else {
1041 aio_unlink $filename; 1114 aio_unlink $filename;
1042 aio_unlink "$filename.pst"; 1115 aio_unlink "$filename.pst";
1043 } 1116 }
1044 }; 1117 };
1045
1046 undef $guard;
1047} 1118}
1048 1119
1049sub object_freezer_as_string { 1120sub object_freezer_as_string {
1050 my ($rdata, $objs) = @_; 1121 my ($rdata, $objs) = @_;
1051 1122
… …
1056 1127
1057sub object_thawer_load { 1128sub object_thawer_load {
1058 my ($filename) = @_; 1129 my ($filename) = @_;
1059 1130
1060 my ($data, $av); 1131 my ($data, $av);
1061
1062 my $guard = cf::lock_acquire "io";
1063 1132
1064 (aio_load $filename, $data) >= 0 1133 (aio_load $filename, $data) >= 0
1065 or return; 1134 or return;
1066 1135
1067 unless (aio_stat "$filename.pst") { 1136 unless (aio_stat "$filename.pst") {
1068 (aio_load "$filename.pst", $av) >= 0 1137 (aio_load "$filename.pst", $av) >= 0
1069 or return; 1138 or return;
1070 1139
1071 undef $guard;
1072 $av = eval { (Storable::thaw $av)->{objs} }; 1140 my $st = eval { Coro::Storable::thaw $av };
1141 $av = $st->{objs};
1073 } 1142 }
1074 1143
1144 utf8::decode (my $decname = $filename);
1075 warn sprintf "loading %s (%d)\n", 1145 warn sprintf "loading %s (%d,%d)\n",
1076 $filename, length $data, scalar @{$av || []}; 1146 $decname, length $data, scalar @{$av || []};
1077 1147
1078 ($data, $av) 1148 ($data, $av)
1079} 1149}
1080 1150
1081=head2 COMMAND CALLBACKS 1151=head2 COMMAND CALLBACKS
… …
1269 1339
1270=head3 cf::player 1340=head3 cf::player
1271 1341
1272=over 4 1342=over 4
1273 1343
1344=item cf::player::num_playing
1345
1346Returns the official number of playing players, as per the Crossfire metaserver rules.
1347
1348=cut
1349
1350sub num_playing {
1351 scalar grep
1352 $_->ob->map
1353 && !$_->hidden
1354 && !$_->ob->flag (cf::FLAG_WIZ),
1355 cf::player::list
1356}
1357
1274=item cf::player::find $login 1358=item cf::player::find $login
1275 1359
1276Returns the given player object, loading it if necessary (might block). 1360Returns the given player object, loading it if necessary (might block).
1277 1361
1278=cut 1362=cut
… …
1316 aio_unlink +(playerdir $login) . "/$login.pl"; 1400 aio_unlink +(playerdir $login) . "/$login.pl";
1317 1401
1318 my $f = new_from_file cf::object::thawer path $login 1402 my $f = new_from_file cf::object::thawer path $login
1319 or return; 1403 or return;
1320 1404
1321 $f->next;
1322 my $pl = cf::player::load_pl $f 1405 my $pl = cf::player::load_pl $f
1323 or return; 1406 or return;
1324 local $cf::PLAYER_LOADING{$login} = $pl; 1407 local $cf::PLAYER_LOADING{$login} = $pl;
1325 $f->resolve_delayed_derefs; 1408 $f->resolve_delayed_derefs;
1326 $cf::PLAYER{$login} = $pl 1409 $cf::PLAYER{$login} = $pl
… …
1478 1561
1479Expand crossfire pod fragments into protocol xml. 1562Expand crossfire pod fragments into protocol xml.
1480 1563
1481=cut 1564=cut
1482 1565
1566use re 'eval';
1567
1568my $group;
1569my $interior; $interior = qr{
1570 # match a pod interior sequence sans C<< >>
1571 (?:
1572 \ (.*?)\ (?{ $group = $^N })
1573 | < (??{$interior}) >
1574 )
1575}x;
1576
1483sub expand_cfpod { 1577sub expand_cfpod {
1484 ((my $self), (local $_)) = @_; 1578 my ($self, $pod) = @_;
1485 1579
1486 # escape & and < 1580 my $xml;
1487 s/&/&amp;/g;
1488 s/(?<![BIUGHT])</&lt;/g;
1489 1581
1490 # this is buggy, it needs to properly take care of nested <'s 1582 while () {
1583 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1584 $group = $1;
1491 1585
1492 1 while 1586 $group =~ s/&/&amp;/g;
1493 # replace B<>, I<>, U<> etc. 1587 $group =~ s/</&lt;/g;
1494 s/B<([^\>]*)>/<b>$1<\/b>/ 1588
1495 || s/I<([^\>]*)>/<i>$1<\/i>/ 1589 $xml .= $group;
1496 || s/U<([^\>]*)>/<u>$1<\/u>/ 1590 } elsif ($pod =~ m%\G
1497 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1591 ([BCGHITU])
1498 # replace G<male|female> tags 1592 <
1499 || s{G<([^>|]*)\|([^>]*)>}{ 1593 (?:
1500 $self->gender ? $2 : $1 1594 ([^<>]*) (?{ $group = $^N })
1501 }ge 1595 | < $interior >
1502 # replace H<hint text> 1596 )
1503 || s{H<([^\>]*)>} 1597 >
1598 %gcsx
1504 { 1599 ) {
1600 my ($code, $data) = ($1, $group);
1601
1602 if ($code eq "B") {
1603 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1604 } elsif ($code eq "I") {
1605 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1606 } elsif ($code eq "U") {
1607 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1608 } elsif ($code eq "C") {
1609 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1610 } elsif ($code eq "T") {
1611 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1612 } elsif ($code eq "G") {
1613 my ($male, $female) = split /\|/, $data;
1614 $data = $self->gender ? $female : $male;
1615 $xml .= expand_cfpod ($self, $data);
1616 } elsif ($code eq "H") {
1505 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1617 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1506 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1618 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1507 "") 1619 "")
1508 [$self->{hintmode}] 1620 [$self->{hintmode}];
1621 } else {
1622 $xml .= "error processing '$code($data)' directive";
1509 }ge; 1623 }
1624 } else {
1625 if ($pod =~ /\G(.+)/) {
1626 warn "parse error while expanding $pod (at $1)";
1627 }
1628 last;
1629 }
1630 }
1510 1631
1632 for ($xml) {
1511 # create single paragraphs (very hackish) 1633 # create single paragraphs (very hackish)
1512 s/(?<=\S)\n(?=\w)/ /g; 1634 s/(?<=\S)\n(?=\w)/ /g;
1513 1635
1514 # compress some whitespace 1636 # compress some whitespace
1515 s/\s+\n/\n/g; # ws line-ends 1637 s/\s+\n/\n/g; # ws line-ends
1516 s/\n\n+/\n/g; # double lines 1638 s/\n\n+/\n/g; # double lines
1517 s/^\n+//; # beginning lines 1639 s/^\n+//; # beginning lines
1518 s/\n+$//; # ending lines 1640 s/\n+$//; # ending lines
1641 }
1519 1642
1520 $_ 1643 $xml
1521} 1644}
1645
1646no re 'eval';
1522 1647
1523sub hintmode { 1648sub hintmode {
1524 $_[0]{hintmode} = $_[1] if @_ > 1; 1649 $_[0]{hintmode} = $_[1] if @_ > 1;
1525 $_[0]{hintmode} 1650 $_[0]{hintmode}
1526} 1651}
… …
1841sub find { 1966sub find {
1842 my ($path, $origin) = @_; 1967 my ($path, $origin) = @_;
1843 1968
1844 $path = normalise $path, $origin && $origin->path; 1969 $path = normalise $path, $origin && $origin->path;
1845 1970
1971 cf::lock_wait "map_data:$path";#d#remove
1846 cf::lock_wait "map_find:$path"; 1972 cf::lock_wait "map_find:$path";
1847 1973
1848 $cf::MAP{$path} || do { 1974 $cf::MAP{$path} || do {
1849 my $guard = cf::lock_acquire "map_find:$path"; 1975 my $guard1 = cf::lock_acquire "map_find:$path";
1976 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1977
1850 my $map = new_from_path cf::map $path 1978 my $map = new_from_path cf::map $path
1851 or return; 1979 or return;
1852 1980
1853 $map->{last_save} = $cf::RUNTIME; 1981 $map->{last_save} = $cf::RUNTIME;
1854 1982
… …
1856 or return; 1984 or return;
1857 1985
1858 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1986 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1859 # doing this can freeze the server in a sync job, obviously 1987 # doing this can freeze the server in a sync job, obviously
1860 #$cf::WAIT_FOR_TICK->wait; 1988 #$cf::WAIT_FOR_TICK->wait;
1989 undef $guard1;
1990 undef $guard2;
1861 $map->reset; 1991 $map->reset;
1862 undef $guard;
1863 return find $path; 1992 return find $path;
1864 } 1993 }
1865 1994
1866 $cf::MAP{$path} = $map 1995 $cf::MAP{$path} = $map
1867 } 1996 }
… …
1876 local $self->{deny_reset} = 1; # loading can take a long time 2005 local $self->{deny_reset} = 1; # loading can take a long time
1877 2006
1878 my $path = $self->{path}; 2007 my $path = $self->{path};
1879 2008
1880 { 2009 {
1881 my $guard1 = cf::lock_acquire "map_data:$path"; 2010 my $guard = cf::lock_acquire "map_data:$path";
1882 my $guard2 = cf::lock_acquire "map_load:$path";
1883 2011
2012 return unless $self->valid;
1884 return if $self->in_memory != cf::MAP_SWAPPED; 2013 return unless $self->in_memory == cf::MAP_SWAPPED;
1885 2014
1886 $self->in_memory (cf::MAP_LOADING); 2015 $self->in_memory (cf::MAP_LOADING);
1887 2016
1888 $self->alloc; 2017 $self->alloc;
1889 2018
… …
2003 } 2132 }
2004 2133
2005 $MAP_PREFETCH{$path} |= $load; 2134 $MAP_PREFETCH{$path} |= $load;
2006 2135
2007 $MAP_PREFETCHER ||= cf::async { 2136 $MAP_PREFETCHER ||= cf::async {
2137 $Coro::current->{desc} = "map prefetcher";
2138
2008 while (%MAP_PREFETCH) { 2139 while (%MAP_PREFETCH) {
2009 while (my ($k, $v) = each %MAP_PREFETCH) { 2140 while (my ($k, $v) = each %MAP_PREFETCH) {
2010 if (my $map = find $k) { 2141 if (my $map = find $k) {
2011 $map->load if $v; 2142 $map->load if $v;
2012 } 2143 }
… …
2038 return if $self->{deny_save}; 2169 return if $self->{deny_save};
2039 2170
2040 local $self->{last_access} = $self->last_access;#d# 2171 local $self->{last_access} = $self->last_access;#d#
2041 2172
2042 cf::async { 2173 cf::async {
2174 $Coro::current->{desc} = "map player save";
2043 $_->contr->save for $self->players; 2175 $_->contr->save for $self->players;
2044 }; 2176 };
2045 2177
2046 if ($uniq) { 2178 if ($uniq) {
2047 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2179 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2061 2193
2062 return if $self->players; 2194 return if $self->players;
2063 return if $self->in_memory != cf::MAP_IN_MEMORY; 2195 return if $self->in_memory != cf::MAP_IN_MEMORY;
2064 return if $self->{deny_save}; 2196 return if $self->{deny_save};
2065 2197
2198 $self->in_memory (cf::MAP_SWAPPED);
2199
2200 $self->deactivate;
2201 $_->clear_links_to ($self) for values %cf::MAP;
2066 $self->clear; 2202 $self->clear;
2067 $self->in_memory (cf::MAP_SWAPPED);
2068} 2203}
2069 2204
2070sub reset_at { 2205sub reset_at {
2071 my ($self) = @_; 2206 my ($self) = @_;
2072 2207
… …
2104 if $uniq; 2239 if $uniq;
2105 } 2240 }
2106 2241
2107 delete $cf::MAP{$self->path}; 2242 delete $cf::MAP{$self->path};
2108 2243
2244 $self->deactivate;
2245 $_->clear_links_to ($self) for values %cf::MAP;
2109 $self->clear; 2246 $self->clear;
2110
2111 $_->clear_links_to ($self) for values %cf::MAP;
2112 2247
2113 $self->unlink_save; 2248 $self->unlink_save;
2114 $self->destroy; 2249 $self->destroy;
2115} 2250}
2116 2251
… …
2231=cut 2366=cut
2232 2367
2233sub deref { 2368sub deref {
2234 my ($ref) = @_; 2369 my ($ref) = @_;
2235 2370
2236 # temporary compatibility#TODO#remove
2237 $ref =~ s{^<}{player/<};
2238
2239 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2371 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2240 my ($uuid, $name) = ($1, $2); 2372 my ($uuid, $name) = ($1, $2);
2241 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2373 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2242 or return; 2374 or return;
2243 $pl->ob->uuid eq $uuid 2375 $pl->ob->uuid eq $uuid
2244 or return; 2376 or return;
… …
2415 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2547 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2416 2548
2417 $self->enter_link; 2549 $self->enter_link;
2418 2550
2419 (async { 2551 (async {
2552 $Coro::current->{desc} = "player::goto $path $x $y";
2553
2554 # *tag paths override both path and x|y
2555 if ($path =~ /^\*(.*)$/) {
2556 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2557 my $ob = $obs[rand @obs];
2558
2559 # see if we actually can go there
2560 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2561 $ob = $obs[rand @obs];
2562 } else {
2563 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2564 }
2565 # else put us there anyways for now #d#
2566
2567 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2568 } else {
2569 ($path, $x, $y) = (undef, undef, undef);
2570 }
2571 }
2572
2420 my $map = eval { 2573 my $map = eval {
2421 my $map = cf::map::find $path; 2574 my $map = defined $path ? cf::map::find $path : undef;
2422 2575
2423 if ($map) { 2576 if ($map) {
2424 $map = $map->customise_for ($self); 2577 $map = $map->customise_for ($self);
2425 $map = $check->($map) if $check && $map; 2578 $map = $check->($map) if $check && $map;
2426 } else { 2579 } else {
2427 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2580 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2428 } 2581 }
2429 2582
2430 $map 2583 $map
2431 }; 2584 };
2432 2585
… …
2522 # if exit is damned, update players death & WoR home-position 2675 # if exit is damned, update players death & WoR home-position
2523 $self->contr->savebed ($slaying, $hp, $sp) 2676 $self->contr->savebed ($slaying, $hp, $sp)
2524 if $exit->flag (FLAG_DAMNED); 2677 if $exit->flag (FLAG_DAMNED);
2525 2678
2526 (async { 2679 (async {
2680 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2681
2527 $self->deactivate_recursive; # just to be sure 2682 $self->deactivate_recursive; # just to be sure
2528 unless (eval { 2683 unless (eval {
2529 $self->goto ($slaying, $hp, $sp); 2684 $self->goto ($slaying, $hp, $sp);
2530 2685
2531 1; 2686 1;
… …
2566the message, with C<log> being the default. If C<$color> is negative, suppress 2721the message, with C<log> being the default. If C<$color> is negative, suppress
2567the message unless the client supports the msg packet. 2722the message unless the client supports the msg packet.
2568 2723
2569=cut 2724=cut
2570 2725
2726# non-persistent channels (usually the info channel)
2571our %CHANNEL = ( 2727our %CHANNEL = (
2572 "c/identify" => { 2728 "c/identify" => {
2573 id => "identify", 2729 id => "infobox",
2574 title => "Identify", 2730 title => "Identify",
2575 reply => undef, 2731 reply => undef,
2576 tooltip => "Items recently identified", 2732 tooltip => "Items recently identified",
2577 }, 2733 },
2578 "c/examine" => { 2734 "c/examine" => {
2579 id => "examine", 2735 id => "infobox",
2580 title => "Examine", 2736 title => "Examine",
2581 reply => undef, 2737 reply => undef,
2582 tooltip => "Signs and other items you examined", 2738 tooltip => "Signs and other items you examined",
2583 }, 2739 },
2740 "c/book" => {
2741 id => "infobox",
2742 title => "Book",
2743 reply => undef,
2744 tooltip => "The contents of a note or book",
2745 },
2746 "c/lookat" => {
2747 id => "infobox",
2748 title => "Look",
2749 reply => undef,
2750 tooltip => "What you saw there",
2751 },
2752 "c/who" => {
2753 id => "infobox",
2754 title => "Players",
2755 reply => undef,
2756 tooltip => "Shows players who are currently online",
2757 },
2758 "c/body" => {
2759 id => "infobox",
2760 title => "Body Parts",
2761 reply => undef,
2762 tooltip => "Shows which body parts you posess and are available",
2763 },
2764 "c/uptime" => {
2765 id => "infobox",
2766 title => "Uptime",
2767 reply => undef,
2768 tooltip => "How long the server has been running since last restart",
2769 },
2770 "c/mapinfo" => {
2771 id => "infobox",
2772 title => "Map Info",
2773 reply => undef,
2774 tooltip => "Information related to the maps",
2775 },
2584); 2776);
2585 2777
2586sub cf::client::send_msg { 2778sub cf::client::send_msg {
2587 my ($self, $channel, $msg, $color, @extra) = @_; 2779 my ($self, $channel, $msg, $color, @extra) = @_;
2588 2780
2589 $msg = $self->pl->expand_cfpod ($msg); 2781 $msg = $self->pl->expand_cfpod ($msg);
2590 2782
2591 $color &= cf::NDI_CLIENT_MASK; # just in case... 2783 $color &= cf::NDI_CLIENT_MASK; # just in case...
2592 2784
2593 # check predefined channels, for the benefit of C 2785 # check predefined channels, for the benefit of C
2594 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2786 if ($CHANNEL{$channel}) {
2787 $channel = $CHANNEL{$channel};
2595 2788
2789 $self->ext_msg (channel_info => $channel)
2790 if $self->can_msg;
2791
2792 $channel = $channel->{id};
2793
2596 if (ref $channel) { 2794 } elsif (ref $channel) {
2597 # send meta info to client, if not yet sent 2795 # send meta info to client, if not yet sent
2598 unless (exists $self->{channel}{$channel->{id}}) { 2796 unless (exists $self->{channel}{$channel->{id}}) {
2599 $self->{channel}{$channel->{id}} = $channel; 2797 $self->{channel}{$channel->{id}} = $channel;
2600 $self->ext_msg (channel_info => $channel) 2798 $self->ext_msg (channel_info => $channel)
2601 if $self->can_msg; 2799 if $self->can_msg;
… …
2818=pod 3016=pod
2819 3017
2820The following functions and methods are available within a safe environment: 3018The following functions and methods are available within a safe environment:
2821 3019
2822 cf::object 3020 cf::object
2823 contr pay_amount pay_player map x y force_find force_add 3021 contr pay_amount pay_player map x y force_find force_add destroy
2824 insert remove name archname title slaying race decrease_ob_nr 3022 insert remove name archname title slaying race decrease_ob_nr
2825 3023
2826 cf::object::player 3024 cf::object::player
2827 player 3025 player
2828 3026
… …
2835=cut 3033=cut
2836 3034
2837for ( 3035for (
2838 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3036 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2839 insert remove inv name archname title slaying race 3037 insert remove inv name archname title slaying race
2840 decrease_ob_nr)], 3038 decrease_ob_nr destroy)],
2841 ["cf::object::player" => qw(player)], 3039 ["cf::object::player" => qw(player)],
2842 ["cf::player" => qw(peaceful)], 3040 ["cf::player" => qw(peaceful)],
2843 ["cf::map" => qw(trigger)], 3041 ["cf::map" => qw(trigger)],
2844) { 3042) {
2845 no strict 'refs'; 3043 no strict 'refs';
… …
3120sub main { 3318sub main {
3121 # we must not ever block the main coroutine 3319 # we must not ever block the main coroutine
3122 local $Coro::idle = sub { 3320 local $Coro::idle = sub {
3123 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3321 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3124 (async { 3322 (async {
3125 Event::one_event; 3323 $Coro::current->{desc} = "IDLE BUG HANDLER";
3324 EV::loop EV::LOOP_ONESHOT;
3126 })->prio (Coro::PRIO_MAX); 3325 })->prio (Coro::PRIO_MAX);
3127 }; 3326 };
3128 3327
3129 reload_config; 3328 reload_config;
3130 db_init; 3329 db_init;
3131 load_extensions; 3330 load_extensions;
3132 3331
3133 $TICK_WATCHER->start; 3332 $TICK_WATCHER->start;
3134 Event::loop; 3333 EV::loop;
3135} 3334}
3136 3335
3137############################################################################# 3336#############################################################################
3138# initialisation and cleanup 3337# initialisation and cleanup
3139 3338
3140# install some emergency cleanup handlers 3339# install some emergency cleanup handlers
3141BEGIN { 3340BEGIN {
3341 our %SIGWATCHER = ();
3142 for my $signal (qw(INT HUP TERM)) { 3342 for my $signal (qw(INT HUP TERM)) {
3143 Event->signal ( 3343 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3144 reentrant => 0,
3145 data => WF_AUTOCANCEL,
3146 signal => $signal,
3147 prio => 0,
3148 cb => sub {
3149 cf::cleanup "SIG$signal"; 3344 cf::cleanup "SIG$signal";
3150 },
3151 ); 3345 };
3152 } 3346 }
3153} 3347}
3154 3348
3155sub write_runtime { 3349sub write_runtime {
3156 my $runtime = "$LOCALDIR/runtime"; 3350 my $runtime = "$LOCALDIR/runtime";
… …
3201 # and maps saved/destroyed asynchronously. 3395 # and maps saved/destroyed asynchronously.
3202 warn "begin emergency player save\n"; 3396 warn "begin emergency player save\n";
3203 for my $login (keys %cf::PLAYER) { 3397 for my $login (keys %cf::PLAYER) {
3204 my $pl = $cf::PLAYER{$login} or next; 3398 my $pl = $cf::PLAYER{$login} or next;
3205 $pl->valid or next; 3399 $pl->valid or next;
3400 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3206 $pl->save; 3401 $pl->save;
3207 } 3402 }
3208 warn "end emergency player save\n"; 3403 warn "end emergency player save\n";
3209 3404
3210 warn "begin emergency map save\n"; 3405 warn "begin emergency map save\n";
… …
3249 warn "syncing database to disk"; 3444 warn "syncing database to disk";
3250 BDB::db_env_txn_checkpoint $DB_ENV; 3445 BDB::db_env_txn_checkpoint $DB_ENV;
3251 3446
3252 # if anything goes wrong in here, we should simply crash as we already saved 3447 # if anything goes wrong in here, we should simply crash as we already saved
3253 3448
3254 warn "cancelling all WF_AUTOCANCEL watchers";
3255 for (Event::all_watchers) {
3256 $_->cancel if $_->data & WF_AUTOCANCEL;
3257 }
3258
3259 warn "flushing outstanding aio requests"; 3449 warn "flushing outstanding aio requests";
3260 for (;;) { 3450 for (;;) {
3261 BDB::flush; 3451 BDB::flush;
3262 IO::AIO::flush; 3452 IO::AIO::flush;
3263 Coro::cede; 3453 Coro::cede_notself;
3264 last unless IO::AIO::nreqs || BDB::nreqs; 3454 last unless IO::AIO::nreqs || BDB::nreqs;
3265 warn "iterate..."; 3455 warn "iterate...";
3266 } 3456 }
3267 3457
3268 ++$RELOAD; 3458 ++$RELOAD;
… …
3357 3547
3358sub reload_perl() { 3548sub reload_perl() {
3359 # doing reload synchronously and two reloads happen back-to-back, 3549 # doing reload synchronously and two reloads happen back-to-back,
3360 # coro crashes during coro_state_free->destroy here. 3550 # coro crashes during coro_state_free->destroy here.
3361 3551
3362 $RELOAD_WATCHER ||= Event->timer ( 3552 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3363 reentrant => 0,
3364 after => 0,
3365 data => WF_AUTOCANCEL,
3366 cb => sub {
3367 do_reload_perl;
3368 undef $RELOAD_WATCHER; 3553 undef $RELOAD_WATCHER;
3369 }, 3554 do_reload_perl;
3370 ); 3555 };
3371} 3556}
3372 3557
3373register_command "reload" => sub { 3558register_command "reload" => sub {
3374 my ($who, $arg) = @_; 3559 my ($who, $arg) = @_;
3375 3560
3376 if ($who->flag (FLAG_WIZ)) { 3561 if ($who->flag (FLAG_WIZ)) {
3377 $who->message ("reloading server."); 3562 $who->message ("reloading server.");
3563 async {
3564 $Coro::current->{desc} = "perl_reload";
3378 async { reload_perl }; 3565 reload_perl;
3566 };
3379 } 3567 }
3380}; 3568};
3381 3569
3382unshift @INC, $LIBDIR; 3570unshift @INC, $LIBDIR;
3383 3571
… …
3402 my $signal = new Coro::Signal; 3590 my $signal = new Coro::Signal;
3403 push @WAIT_FOR_TICK_BEGIN, $signal; 3591 push @WAIT_FOR_TICK_BEGIN, $signal;
3404 $signal->wait; 3592 $signal->wait;
3405} 3593}
3406 3594
3407 my $min = 1e6;#d# 3595$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3408 my $avg = 10;
3409$TICK_WATCHER = Event->timer (
3410 reentrant => 0,
3411 parked => 1,
3412 prio => 0,
3413 at => $NEXT_TICK || $TICK,
3414 data => WF_AUTOCANCEL,
3415 cb => sub {
3416 if ($Coro::current != $Coro::main) { 3596 if ($Coro::current != $Coro::main) {
3417 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3597 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3418 unless ++$bug_warning > 10; 3598 unless ++$bug_warning > 10;
3419 return; 3599 return;
3420 } 3600 }
3421 3601
3422 $NOW = $tick_start = Event::time; 3602 $NOW = $tick_start = EV::now;
3423 3603
3424 cf::server_tick; # one server iteration 3604 cf::server_tick; # one server iteration
3425 3605
3426 0 && sync_job {#d# 3606 $RUNTIME += $TICK;
3427 for(1..10) { 3607 $NEXT_TICK += $TICK;
3428 my $t = Event::time;
3429 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3430 or die;
3431 3608
3432 $map->width (50); 3609 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3433 $map->height (50); 3610 $NEXT_RUNTIME_WRITE = $NOW + 10;
3434 $map->alloc; 3611 Coro::async_pool {
3435 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work 3612 $Coro::current->{desc} = "runtime saver";
3436 my $t = Event::time - $t; 3613 write_runtime
3437 3614 or warn "ERROR: unable to write runtime file: $!";
3438 #next unless $t < 0.0013;#d#
3439 if ($t < $min) {
3440 $min = $t;
3441 }
3442 $avg = $avg * 0.99 + $t * 0.01;
3443 }
3444 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3445 exit 0;
3446 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3447 }; 3615 };
3616 }
3448 3617
3449 $RUNTIME += $TICK;
3450 $NEXT_TICK += $TICK;
3451
3452 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3453 $NEXT_RUNTIME_WRITE = $NOW + 10;
3454 Coro::async_pool {
3455 write_runtime
3456 or warn "ERROR: unable to write runtime file: $!";
3457 };
3458 }
3459
3460# my $AFTER = Event::time;
3461# warn $AFTER - $NOW;#d#
3462
3463 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3618 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3464 $sig->send; 3619 $sig->send;
3465 } 3620 }
3466 while (my $sig = shift @WAIT_FOR_TICK) { 3621 while (my $sig = shift @WAIT_FOR_TICK) {
3467 $sig->send; 3622 $sig->send;
3468 } 3623 }
3469 3624
3470 $NOW = Event::time;
3471
3472 # if we are delayed by four ticks or more, skip them all
3473 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3474
3475 $TICK_WATCHER->at ($NEXT_TICK);
3476 $TICK_WATCHER->start;
3477
3478 $LOAD = ($NOW - $tick_start) / $TICK; 3625 $LOAD = ($NOW - $tick_start) / $TICK;
3479 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3626 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3480 3627
3481 _post_tick; 3628 _post_tick;
3482 3629};
3483 3630$TICK_WATCHER->priority (EV::MAXPRI);
3484 },
3485);
3486 3631
3487{ 3632{
3633 BDB::min_parallel 8;
3488 BDB::max_poll_time $TICK * 0.1; 3634 BDB::max_poll_time $TICK * 0.1;
3489 $BDB_POLL_WATCHER = Event->io ( 3635 $BDB_POLL_WATCHER = EV::io BDB::poll_fileno, EV::READ, \&BDB::poll_cb;
3490 reentrant => 0,
3491 fd => BDB::poll_fileno,
3492 poll => 'r',
3493 prio => 0,
3494 data => WF_AUTOCANCEL,
3495 cb => \&BDB::poll_cb,
3496 );
3497 BDB::min_parallel 8;
3498 3636
3499 BDB::set_sync_prepare { 3637 BDB::set_sync_prepare {
3500 my $status; 3638 my $status;
3501 my $current = $Coro::current; 3639 my $current = $Coro::current;
3502 ( 3640 (
… …
3511 ) 3649 )
3512 }; 3650 };
3513 3651
3514 unless ($DB_ENV) { 3652 unless ($DB_ENV) {
3515 $DB_ENV = BDB::db_env_create; 3653 $DB_ENV = BDB::db_env_create;
3654 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3655 | BDB::LOG_AUTOREMOVE, 1);
3656 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3657 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3516 3658
3517 cf::sync_job { 3659 cf::sync_job {
3518 eval { 3660 eval {
3519 BDB::db_env_open 3661 BDB::db_env_open
3520 $DB_ENV, 3662 $DB_ENV,
… …
3522 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3664 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3523 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3665 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3524 0666; 3666 0666;
3525 3667
3526 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3668 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3527
3528 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3529 $DB_ENV->set_lk_detect;
3530 }; 3669 };
3531 3670
3532 cf::cleanup "db_env_open(db): $@" if $@; 3671 cf::cleanup "db_env_open(db): $@" if $@;
3533 }; 3672 };
3534 } 3673 }
3674
3675 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3676 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3677 };
3678 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3679 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3680 };
3681 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3682 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3683 };
3535} 3684}
3536 3685
3537{ 3686{
3538 IO::AIO::min_parallel 8; 3687 IO::AIO::min_parallel 8;
3539 3688
3540 undef $Coro::AIO::WATCHER; 3689 undef $Coro::AIO::WATCHER;
3541 IO::AIO::max_poll_time $TICK * 0.1; 3690 IO::AIO::max_poll_time $TICK * 0.1;
3542 $AIO_POLL_WATCHER = Event->io ( 3691 $AIO_POLL_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
3543 reentrant => 0,
3544 data => WF_AUTOCANCEL,
3545 fd => IO::AIO::poll_fileno,
3546 poll => 'r',
3547 prio => 6,
3548 cb => \&IO::AIO::poll_cb,
3549 );
3550} 3692}
3551 3693
3552my $_log_backtrace; 3694my $_log_backtrace;
3553 3695
3554sub _log_backtrace { 3696sub _log_backtrace {
… …
3558 3700
3559 # limit the # of concurrent backtraces 3701 # limit the # of concurrent backtraces
3560 if ($_log_backtrace < 2) { 3702 if ($_log_backtrace < 2) {
3561 ++$_log_backtrace; 3703 ++$_log_backtrace;
3562 async { 3704 async {
3705 $Coro::current->{desc} = "abt $msg";
3706
3563 my @bt = fork_call { 3707 my @bt = fork_call {
3564 @addr = map { sprintf "%x", $_ } @addr; 3708 @addr = map { sprintf "%x", $_ } @addr;
3565 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3709 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3566 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3710 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3567 or die "addr2line: $!"; 3711 or die "addr2line: $!";

Diff Legend

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