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.253 by root, Wed Apr 18 17:32:07 2007 UTC vs.
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC

… …
90our $LINK_MAP; # the special {link} map, which is always available 90our $LINK_MAP; # the special {link} map, which is always available
91 91
92# used to convert map paths into valid unix filenames by replacing / by ∕ 92# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 94
95our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing
97our $tick_start; # for load detecting purposes
98
95binmode STDOUT; 99binmode STDOUT;
96binmode STDERR; 100binmode STDERR;
97 101
98# read virtual server time, if available 102# read virtual server time, if available
99unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
… …
139 143
140=item $cf::TICK 144=item $cf::TICK
141 145
142The interval between server ticks, in seconds. 146The interval between server ticks, in seconds.
143 147
148=item $cf::LOADAVG
149
150The current CPU load on the server (alpha-smoothed), as a value between 0
151(none) and 1 (overloaded), indicating how much time is spent on processing
152objects per tick. Healthy values are < 0.5.
153
154=item $cf::LOAD
155
156The raw value load value from the last tick.
157
144=item %cf::CFG 158=item %cf::CFG
145 159
146Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
147from wherever your confdir points to. 161from wherever your confdir points to.
148 162
… …
161 my $msg = join "", @_; 175 my $msg = join "", @_;
162 176
163 $msg .= "\n" 177 $msg .= "\n"
164 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
165 179
166 $msg =~ s/([\x00-\x09\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
167 181
168 utf8::encode $msg; 182 utf8::encode $msg;
169 LOG llevError, $msg; 183 LOG llevError, $msg;
170 }; 184 };
171} 185}
… …
173@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
174@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
175@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
176@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
177@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
192@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
178@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 193@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
179 194
180# we bless all objects into (empty) derived classes to force a method lookup 195# we bless all objects into (empty) derived classes to force a method lookup
181# within the Safe compartment. 196# within the Safe compartment.
182for my $pkg (qw( 197for my $pkg (qw(
183 cf::global cf::attachable 198 cf::global cf::attachable
… …
191} 206}
192 207
193$Event::DIED = sub { 208$Event::DIED = sub {
194 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
195}; 210};
211
212#############################################################################
196 213
197=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
198 215
199=over 4 216=over 4
200 217
… …
303 320
304BEGIN { *async = \&Coro::async_pool } 321BEGIN { *async = \&Coro::async_pool }
305 322
306=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
307 324
308The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
309always able to handle events or runnable, as crossfire+ is only partly 326is always able to handle events or runnable, as Crossfire TRT is only
310reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable.
311 329
312If it must be done, put the blocking parts into C<sync_job>. This will run 330If it must be done, put the blocking parts into C<sync_job>. This will run
313the given BLOCK in another coroutine while waiting for the result. The 331the given BLOCK in another coroutine while waiting for the result. The
314server will be frozen during this time, so the block should either finish 332server will be frozen during this time, so the block should either finish
315fast or be very important. 333fast or be very important.
… …
318 336
319sub sync_job(&) { 337sub sync_job(&) {
320 my ($job) = @_; 338 my ($job) = @_;
321 339
322 if ($Coro::current == $Coro::main) { 340 if ($Coro::current == $Coro::main) {
341 my $time = Event::time;
342
323 # this is the main coro, too bad, we have to block 343 # this is the main coro, too bad, we have to block
324 # till the operation succeeds, freezing the server :/ 344 # till the operation succeeds, freezing the server :/
325 345
326 # TODO: use suspend/resume instead 346 # TODO: use suspend/resume instead
327 # (but this is cancel-safe) 347 # (but this is cancel-safe)
… …
338 358
339 while ($busy) { 359 while ($busy) {
340 Coro::cede or Event::one_event; 360 Coro::cede or Event::one_event;
341 } 361 }
342 362
363 $time = Event::time - $time;
364
365 LOG llevError | logBacktrace, Carp::longmess "long sync job"
366 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
367
368 $tick_start += $time; # do not account sync jobs to server load
369
343 wantarray ? @res : $res[0] 370 wantarray ? @res : $res[0]
344 } else { 371 } else {
345 # we are in another coroutine, how wonderful, everything just works 372 # we are in another coroutine, how wonderful, everything just works
346 373
347 $job->() 374 $job->()
… …
366 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
367 394
368 $coro 395 $coro
369} 396}
370 397
371sub write_runtime { 398=item fork_call { }, $args
372 my $guard = cf::lock_acquire "write_runtime";
373 399
374 my $runtime = "$LOCALDIR/runtime"; 400Executes the given code block with the given arguments in a seperate
401process, returning the results. Everything must be serialisable with
402Coro::Storable. May, of course, block. Note that the executed sub may
403never block itself or use any form of Event handling.
375 404
376 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 405=cut
377 or return;
378 406
379 my $value = $cf::RUNTIME + 90 + 10; 407sub fork_call(&@) {
380 # 10 is the runtime save interval, for a monotonic clock 408 my ($cb, @args) = @_;
381 # 60 allows for the watchdog to kill the server.
382 409
383 (aio_write $fh, 0, (length $value), $value, 0) <= 0 410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
384 and return; 411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
385 414
386 # always fsync - this file is important 415 if (my $pid = fork) {
387 aio_fsync $fh
388 and return;
389
390 close $fh 416 close $fh2;
391 or return;
392 417
393 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
394 and return; 419 $res = Coro::Storable::thaw $res;
395 420
421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422
423 die $$res unless "ARRAY" eq ref $res;
424
425 return wantarray ? @$res : $res->[-1];
426 } else {
427 reset_signals;
428 local $SIG{__WARN__};
429 local $SIG{__DIE__};
430 eval {
431 close $fh1;
432
433 my @res = eval { $cb->(@args) };
434 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
435 };
436
437 warn $@ if $@;
438 _exit 0;
396 1 439 }
440}
441
442=item $value = cf::db_get $family => $key
443
444Returns a single value from the environment database.
445
446=item cf::db_put $family => $key => $value
447
448Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450
451=cut
452
453our $DB;
454
455sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job {
460 eval {
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 }
470}
471
472sub db_get($$) {
473 my $key = "$_[0]/$_[1]";
474
475 cf::sync_job {
476 BDB::db_get $DB, undef, $key, my $data;
477
478 $! ? ()
479 : $data
480 }
481}
482
483sub db_put($$$) {
484 BDB::dbreq_pri 4;
485 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
486}
487
488=item cf::cache $id => [$paths...], $processversion => $process
489
490Generic caching function that returns the value of the resource $id,
491caching and regenerating as required.
492
493This function can block.
494
495=cut
496
497sub cache {
498 my ($id, $src, $processversion, $process) = @_;
499
500 my $meta =
501 join "\x00",
502 $processversion,
503 map {
504 aio_stat $_
505 and Carp::croak "$_: $!";
506
507 ($_, (stat _)[7,9])
508 } @$src;
509
510 my $dbmeta = db_get cache => "$id/meta";
511 if ($dbmeta ne $meta) {
512 # changed, we may need to process
513
514 my @data;
515 my $md5;
516
517 for (0 .. $#$src) {
518 0 <= aio_load $src->[$_], $data[$_]
519 or Carp::croak "$src->[$_]: $!";
520 }
521
522 # if processing is expensive, check
523 # checksum first
524 if (1) {
525 $md5 =
526 join "\x00",
527 $processversion,
528 map {
529 Coro::cede;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src;
532
533
534 my $dbmd5 = db_get cache => "$id/md5";
535 if ($dbmd5 eq $md5) {
536 db_put cache => "$id/meta", $meta;
537
538 return db_get cache => "$id/data";
539 }
540 }
541
542 my $t1 = Time::HiRes::time;
543 my $data = $process->(\@data);
544 my $t2 = Time::HiRes::time;
545
546 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
547
548 db_put cache => "$id/data", $data;
549 db_put cache => "$id/md5" , $md5;
550 db_put cache => "$id/meta", $meta;
551
552 return $data;
553 }
554
555 db_get cache => "$id/data"
397} 556}
398 557
399=item cf::datalog type => key => value, ... 558=item cf::datalog type => key => value, ...
400 559
401Log a datalog packet of the given type with the given key-value pairs. 560Log a datalog packet of the given type with the given key-value pairs.
… …
419attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
420to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
421 580
422In the following description, CLASS can be any of C<global>, C<object> 581In the following description, CLASS can be any of C<global>, C<object>
423C<player>, C<client> or C<map> (i.e. the attachable objects in 582C<player>, C<client> or C<map> (i.e. the attachable objects in
424crossfire+). 583Crossfire TRT).
425 584
426=over 4 585=over 4
427 586
428=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
429 588
… …
592 $registry = $CB_TYPE[$object_type] ||= []; 751 $registry = $CB_TYPE[$object_type] ||= [];
593 752
594 } elsif ($type eq "subtype") { 753 } elsif ($type eq "subtype") {
595 defined $object_type or Carp::croak "subtype specified without type"; 754 defined $object_type or Carp::croak "subtype specified without type";
596 my $object_subtype = shift @arg; 755 my $object_subtype = shift @arg;
597 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 756 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
598 757
599 } elsif ($type eq "package") { 758 } elsif ($type eq "package") {
600 my $pkg = shift @arg; 759 my $pkg = shift @arg;
601 760
602 while (my ($name, $id) = each %cb_id) { 761 while (my ($name, $id) = each %cb_id) {
… …
631 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
632 } 791 }
633 792
634 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
635 } else { 794 } else {
636 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
637 } 796 }
638 797
639 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
640} 799}
641 800
… …
643 if (ref $_[0]) { 802 if (ref $_[0]) {
644 _object_attach @_; 803 _object_attach @_;
645 } else { 804 } else {
646 _attach shift->_attach_registry, @_; 805 _attach shift->_attach_registry, @_;
647 } 806 }
807 _recalc_want;
648}; 808};
649 809
650# all those should be optimised 810# all those should be optimised
651sub cf::attachable::detach { 811sub cf::attachable::detach {
652 my ($obj, $name) = @_; 812 my ($obj, $name) = @_;
… …
655 delete $obj->{_attachment}{$name}; 815 delete $obj->{_attachment}{$name};
656 reattach ($obj); 816 reattach ($obj);
657 } else { 817 } else {
658 Carp::croak "cannot, currently, detach class attachments"; 818 Carp::croak "cannot, currently, detach class attachments";
659 } 819 }
820 _recalc_want;
660}; 821};
661 822
662sub cf::attachable::attached { 823sub cf::attachable::attached {
663 my ($obj, $name) = @_; 824 my ($obj, $name) = @_;
664 825
… …
837 or return; 998 or return;
838 $av = eval { (Storable::thaw $av)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
839 } 1000 }
840 1001
841 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
842 $filename, length $data, scalar @{$av || []};#d# 1003 $filename, length $data, scalar @{$av || []};
843 return ($data, $av); 1004 return ($data, $av);
844} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
845 1012
846############################################################################# 1013#############################################################################
847# command handling &c 1014# command handling &c
848 1015
849=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
… …
862 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
863} 1030}
864 1031
865=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
866 1033
867Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
868 1035
869If the callback returns something, it is sent back as if reply was being 1036If the callback returns something, it is sent back as if reply was being
870called. 1037called.
871 1038
872=cut 1039=cut
… …
907 1074
908 cf::override; 1075 cf::override;
909 }, 1076 },
910); 1077);
911 1078
912sub load_extension {
913 my ($path) = @_;
914
915 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
916 my $base = $1;
917 my $pkg = $1;
918 $pkg =~ s/[^[:word:]]/_/g;
919 $pkg = "ext::$pkg";
920
921 warn "... loading '$path' into '$pkg'\n";
922
923 open my $fh, "<:utf8", $path
924 or die "$path: $!";
925
926 my $source =
927 "package $pkg; use strict; use utf8;\n"
928 . "#line 1 \"$path\"\n{\n"
929 . (do { local $/; <$fh> })
930 . "\n};\n1";
931
932 unless (eval $source) {
933 my $msg = $@ ? "$path: $@\n"
934 : "extension disabled.\n";
935 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
936 warn $@;
937 warn "mandatory extension failed to load, exiting.\n";
938 exit 1;
939 }
940 die $@;
941 }
942
943 push @EXTS, $pkg;
944}
945
946sub load_extensions { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
947 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
948 next unless -r $ext; 1084 next unless -r $path;
949 eval { 1085
950 load_extension $ext; 1086 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1087 my $base = $1;
1088 my $pkg = $1;
1089 $pkg =~ s/[^[:word:]]/_/g;
1090 $pkg = "ext::$pkg";
1091
1092 open my $fh, "<:utf8", $path
1093 or die "$path: $!";
1094
1095 my $source = do { local $/; <$fh> };
1096
1097 my %ext = (
1098 path => $path,
1099 base => $base,
1100 pkg => $pkg,
1101 );
1102
1103 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1104 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1105
1106 $ext{source} =
1107 "package $pkg; use strict; use utf8;\n"
1108 . "#line 1 \"$path\"\n{\n"
1109 . $source
1110 . "\n};\n1";
1111
1112 $todo{$base} = \%ext;
1113 }
1114
1115 my %done;
1116 while (%todo) {
1117 my $progress;
1118
1119 while (my ($k, $v) = each %todo) {
1120 for (split /,\s*/, $v->{meta}{depends}) {
1121 goto skip
1122 unless exists $done{$_};
1123 }
1124
1125 warn "... loading '$k' into '$v->{pkg}'\n";
1126
1127 unless (eval $v->{source}) {
1128 my $msg = $@ ? "$v->{path}: $@\n"
1129 : "$v->{base}: extension inactive.\n";
1130
1131 if (exists $v->{meta}{mandatory}) {
1132 warn $msg;
1133 warn "mandatory extension failed to load, exiting.\n";
1134 exit 1;
1135 }
1136
1137 warn $msg;
1138 }
1139
1140 $done{$k} = delete $todo{$k};
1141 push @EXTS, $v->{pkg};
1142 $progress = 1;
951 1 1143 }
952 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
953 } 1149 };
954} 1150}
955 1151
956############################################################################# 1152#############################################################################
1153
1154=back
957 1155
958=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
959 1157
960Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
961 1159
… …
1185 1383
1186package cf::region; 1384package cf::region;
1187 1385
1188=item cf::region::find_by_path $path 1386=item cf::region::find_by_path $path
1189 1387
1190Tries to decuce the probable region for a map knowing only its path. 1388Tries to decuce the likely region for a map knowing only its path.
1191 1389
1192=cut 1390=cut
1193 1391
1194sub find_by_path($) { 1392sub find_by_path($) {
1195 my ($path) = @_; 1393 my ($path) = @_;
… …
1269 my ($self, $merge) = @_; 1467 my ($self, $merge) = @_;
1270 1468
1271 # we have to keep some variables in memory intact 1469 # we have to keep some variables in memory intact
1272 local $self->{path}; 1470 local $self->{path};
1273 local $self->{load_path}; 1471 local $self->{load_path};
1274 local $self->{deny_save};
1275 local $self->{deny_reset};
1276 1472
1277 $self->SUPER::thawer_merge ($merge); 1473 $self->SUPER::thawer_merge ($merge);
1278} 1474}
1279 1475
1280sub normalise { 1476sub normalise {
… …
1352 1548
1353# the original (read-only) location 1549# the original (read-only) location
1354sub load_path { 1550sub load_path {
1355 my ($self) = @_; 1551 my ($self) = @_;
1356 1552
1357 "$MAPDIR($self->{path}" 1553 "$MAPDIR/$self->{path}.map"
1358} 1554}
1359 1555
1360# the temporary/swap location 1556# the temporary/swap location
1361sub save_path { 1557sub save_path {
1362 my ($self) = @_; 1558 my ($self) = @_;
1363 1559
1364 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1560 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1365 "$TMPDIR/$path" 1561 "$TMPDIR/$path.map"
1366} 1562}
1367 1563
1368# the unique path, undef == no special unique path 1564# the unique path, undef == no special unique path
1369sub uniq_path { 1565sub uniq_path {
1370 my ($self) = @_; 1566 my ($self) = @_;
… …
1378sub change_all_map_light { 1574sub change_all_map_light {
1379 my ($change) = @_; 1575 my ($change) = @_;
1380 1576
1381 $_->change_map_light ($change) 1577 $_->change_map_light ($change)
1382 for grep $_->outdoor, values %cf::MAP; 1578 for grep $_->outdoor, values %cf::MAP;
1579}
1580
1581sub decay_objects {
1582 my ($self) = @_;
1583
1584 return if $self->{deny_reset};
1585
1586 $self->do_decay_objects;
1383} 1587}
1384 1588
1385sub unlink_save { 1589sub unlink_save {
1386 my ($self) = @_; 1590 my ($self) = @_;
1387 1591
… …
1445 $self->load_header_orig 1649 $self->load_header_orig
1446 or return; 1650 or return;
1447 $self->prepare_orig; 1651 $self->prepare_orig;
1448 } 1652 }
1449 1653
1654 $self->{deny_reset} = 1
1655 if $self->no_reset;
1656
1450 $self->default_region (cf::region::find_by_path $self->{path}) 1657 $self->default_region (cf::region::find_by_path $self->{path})
1451 unless $self->default_region; 1658 unless $self->default_region;
1452 1659
1453 1 1660 1
1454} 1661}
… …
1469 $map->{last_save} = $cf::RUNTIME; 1676 $map->{last_save} = $cf::RUNTIME;
1470 1677
1471 $map->load_header 1678 $map->load_header
1472 or return; 1679 or return;
1473 1680
1474 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1681 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1475 # doing this can freeze the server in a sync job, obviously 1682 # doing this can freeze the server in a sync job, obviously
1476 #$cf::WAIT_FOR_TICK->wait; 1683 #$cf::WAIT_FOR_TICK->wait;
1477 $map->reset; 1684 $map->reset;
1478 undef $guard; 1685 undef $guard;
1479 return find $path; 1686 return find $path;
… …
1490 my ($self) = @_; 1697 my ($self) = @_;
1491 1698
1492 local $self->{deny_reset} = 1; # loading can take a long time 1699 local $self->{deny_reset} = 1; # loading can take a long time
1493 1700
1494 my $path = $self->{path}; 1701 my $path = $self->{path};
1702
1703 {
1495 my $guard = cf::lock_acquire "map_load:$path"; 1704 my $guard = cf::lock_acquire "map_load:$path";
1496 1705
1497 return if $self->in_memory != cf::MAP_SWAPPED; 1706 return if $self->in_memory != cf::MAP_SWAPPED;
1498 1707
1499 $self->in_memory (cf::MAP_LOADING); 1708 $self->in_memory (cf::MAP_LOADING);
1500 1709
1501 $self->alloc; 1710 $self->alloc;
1502 1711
1503 $self->pre_load; 1712 $self->pre_load;
1504 Coro::cede;
1505
1506 $self->_load_objects ($self->{load_path}, 1)
1507 or return;
1508
1509 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1510 if delete $self->{load_original};
1511
1512 if (my $uniq = $self->uniq_path) {
1513 utf8::encode $uniq;
1514 if (aio_open $uniq, O_RDONLY, 0) {
1515 $self->clear_unique_items;
1516 $self->_load_objects ($uniq, 0);
1517 }
1518 }
1519
1520 Coro::cede;
1521 # now do the right thing for maps
1522 $self->link_multipart_objects;
1523 Coro::cede;
1524
1525 unless ($self->{deny_activate}) {
1526 $self->decay_objects;
1527 $self->fix_auto_apply;
1528 $self->update_buttons;
1529 Coro::cede; 1713 Coro::cede;
1530 $self->set_darkness_map; 1714
1715 $self->_load_objects ($self->{load_path}, 1)
1716 or return;
1717
1718 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1719 if delete $self->{load_original};
1720
1721 if (my $uniq = $self->uniq_path) {
1722 utf8::encode $uniq;
1723 if (aio_open $uniq, O_RDONLY, 0) {
1724 $self->clear_unique_items;
1725 $self->_load_objects ($uniq, 0);
1726 }
1727 }
1728
1729 Coro::cede;
1730 # now do the right thing for maps
1731 $self->link_multipart_objects;
1531 $self->difficulty ($self->estimate_difficulty) 1732 $self->difficulty ($self->estimate_difficulty)
1532 unless $self->difficulty; 1733 unless $self->difficulty;
1533 Coro::cede; 1734 Coro::cede;
1735
1736 unless ($self->{deny_activate}) {
1737 $self->decay_objects;
1738 $self->fix_auto_apply;
1739 $self->update_buttons;
1740 Coro::cede;
1741 $self->set_darkness_map;
1742 Coro::cede;
1534 $self->activate; 1743 $self->activate;
1535 Coro::cede; 1744 }
1745
1746 $self->in_memory (cf::MAP_IN_MEMORY);
1536 } 1747 }
1537 1748
1538 $self->post_load; 1749 $self->post_load;
1539 Coro::cede;
1540
1541 $self->in_memory (cf::MAP_IN_MEMORY);
1542} 1750}
1543 1751
1544sub customise_for { 1752sub customise_for {
1545 my ($self, $ob) = @_; 1753 my ($self, $ob) = @_;
1546 1754
1547 return find "~" . $ob->name . "/" . $self->{path} 1755 return find "~" . $ob->name . "/" . $self->{path}
1548 if $self->per_player; 1756 if $self->per_player;
1757
1758# return find "?party/" . $ob->name . "/" . $self->{path}
1759# if $self->per_party;
1549 1760
1550 $self 1761 $self
1551} 1762}
1552 1763
1553# find and load all maps in the 3x3 area around a map 1764# find and load all maps in the 3x3 area around a map
… …
1664 1875
1665sub reset_at { 1876sub reset_at {
1666 my ($self) = @_; 1877 my ($self) = @_;
1667 1878
1668 # TODO: safety, remove and allow resettable per-player maps 1879 # TODO: safety, remove and allow resettable per-player maps
1669 return 1e99 if $self->isa ("ext::map_per_player");#d#
1670 return 1e99 if $self->{deny_reset}; 1880 return 1e99 if $self->{deny_reset};
1671 1881
1672 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1882 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1673 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1883 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1674 1884
… …
1685 my ($self) = @_; 1895 my ($self) = @_;
1686 1896
1687 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1897 my $lock = cf::lock_acquire "map_data:$self->{path}";
1688 1898
1689 return if $self->players; 1899 return if $self->players;
1690 return if $self->isa ("ext::map_per_player");#d#
1691 1900
1692 warn "resetting map ", $self->path;#d# 1901 warn "resetting map ", $self->path;
1693 1902
1694 $self->in_memory (cf::MAP_SWAPPED); 1903 $self->in_memory (cf::MAP_SWAPPED);
1695 1904
1696 # need to save uniques path 1905 # need to save uniques path
1697 unless ($self->{deny_save}) { 1906 unless ($self->{deny_save}) {
… …
1729 $cf::MAP{$self->path} = $self; 1938 $cf::MAP{$self->path} = $self;
1730 1939
1731 $self->reset; # polite request, might not happen 1940 $self->reset; # polite request, might not happen
1732} 1941}
1733 1942
1943=item $maps = cf::map::tmp_maps
1944
1945Returns an arrayref with all map paths of currently instantiated and saved
1946maps. May block.
1947
1948=cut
1949
1950sub tmp_maps() {
1951 [
1952 map {
1953 utf8::decode $_;
1954 /\.map$/
1955 ? normalise $_
1956 : ()
1957 } @{ aio_readdir $TMPDIR or [] }
1958 ]
1959}
1960
1961=item $maps = cf::map::random_maps
1962
1963Returns an arrayref with all map paths of currently instantiated and saved
1964random maps. May block.
1965
1966=cut
1967
1968sub random_maps() {
1969 [
1970 map {
1971 utf8::decode $_;
1972 /\.map$/
1973 ? normalise "?random/$_"
1974 : ()
1975 } @{ aio_readdir $RANDOMDIR or [] }
1976 ]
1977}
1978
1734=item cf::map::unique_maps 1979=item cf::map::unique_maps
1735 1980
1736Returns an arrayref of paths of all shared maps that have 1981Returns an arrayref of paths of all shared maps that have
1737instantiated unique items. May block. 1982instantiated unique items. May block.
1738 1983
1739=cut 1984=cut
1740 1985
1741sub unique_maps() { 1986sub unique_maps() {
1742 my $files = aio_readdir $UNIQUEDIR 1987 [
1743 or return; 1988 map {
1744
1745 my @paths;
1746
1747 for (@$files) {
1748 utf8::decode $_; 1989 utf8::decode $_;
1749 next if /\.pst$/; 1990 /\.map$/
1750 next unless /^$PATH_SEP/o; 1991 ? normalise $_
1751 1992 : ()
1752 push @paths, cf::map::normalise $_; 1993 } @{ aio_readdir $UNIQUEDIR or [] }
1753 } 1994 ]
1754
1755 \@paths
1756} 1995}
1757 1996
1758package cf; 1997package cf;
1759 1998
1760=back 1999=back
… …
1806 2045
1807 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2046 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1808 2047
1809 if ($self->{record_replies}) { 2048 if ($self->{record_replies}) {
1810 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2049 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2050
1811 } else { 2051 } else {
2052 my $pl = $self->contr;
2053
2054 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2055 my $diag = $pl->{npc_dialog};
2056 $diag->{pl}->ext_reply (
2057 $diag->{id}, msgtype => "reply", msg => $msg, add_topics => []
2058 );
2059
2060 } else {
1812 $msg = $npc->name . " says: $msg" if $npc; 2061 $msg = $npc->name . " says: $msg" if $npc;
1813 $self->message ($msg, $flags); 2062 $self->message ($msg, $flags);
2063 }
1814 } 2064 }
1815} 2065}
1816 2066
1817=item $player_object->may ("access") 2067=item $player_object->may ("access")
1818 2068
… …
1866 $self->deactivate_recursive; 2116 $self->deactivate_recursive;
1867 2117
1868 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2118 return if UNIVERSAL::isa $self->map, "ext::map_link";
1869 2119
1870 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2120 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1871 if $self->map; 2121 if $self->map && $self->map->{path} ne "{link}";
1872 2122
1873 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2123 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1874} 2124}
1875 2125
1876sub cf::object::player::leave_link { 2126sub cf::object::player::leave_link {
1877 my ($self, $map, $x, $y) = @_; 2127 my ($self, $map, $x, $y) = @_;
2128
2129 return unless $self->contr->active;
1878 2130
1879 my $link_pos = delete $self->{_link_pos}; 2131 my $link_pos = delete $self->{_link_pos};
1880 2132
1881 unless ($map) { 2133 unless ($map) {
1882 # restore original map position 2134 # restore original map position
… …
1905 2157
1906 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2158 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1907 $self->enter_map ($map, $x, $y); 2159 $self->enter_map ($map, $x, $y);
1908} 2160}
1909 2161
1910cf::player->attach (
1911 on_logout => sub {
1912 my ($pl) = @_;
1913
1914 # abort map switching before logout
1915 if ($pl->ob->{_link_pos}) {
1916 cf::sync_job {
1917 $pl->ob->leave_link
1918 };
1919 }
1920 },
1921 on_login => sub {
1922 my ($pl) = @_;
1923
1924 # try to abort aborted map switching on player login :)
1925 # should happen only on crashes
1926 if ($pl->ob->{_link_pos}) {
1927 $pl->ob->enter_link;
1928 (async {
1929 $pl->ob->reply (undef,
1930 "There was an internal problem at your last logout, "
1931 . "the server will try to bring you to your intended destination in a second.",
1932 cf::NDI_RED);
1933 # we need this sleep as the login has a concurrent enter_exit running
1934 # and this sleep increases chances of the player not ending up in scorn
1935 Coro::Timer::sleep 1;
1936 $pl->ob->leave_link;
1937 })->prio (2);
1938 }
1939 },
1940);
1941
1942=item $player_object->goto ($path, $x, $y) 2162=item $player_object->goto ($path, $x, $y[, $check->($map)])
1943 2163
2164Moves the player to the given map-path and coordinates by first freezing
2165her, loading and preparing them map, calling the provided $check callback
2166that has to return the map if sucecssful, and then unfreezes the player on
2167the new (success) or old (failed) map position.
2168
1944=cut 2169=cut
2170
2171our $GOTOGEN;
1945 2172
1946sub cf::object::player::goto { 2173sub cf::object::player::goto {
1947 my ($self, $path, $x, $y) = @_; 2174 my ($self, $path, $x, $y, $check) = @_;
2175
2176 # do generation counting so two concurrent goto's will be executed in-order
2177 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1948 2178
1949 $self->enter_link; 2179 $self->enter_link;
1950 2180
1951 (async { 2181 (async {
1952 my $map = eval { 2182 my $map = eval {
1953 my $map = cf::map::find $path; 2183 my $map = cf::map::find $path;
2184
2185 if ($map) {
1954 $map = $map->customise_for ($self) if $map; 2186 $map = $map->customise_for ($self);
2187 $map = $check->($map) if $check && $map;
2188 } else {
2189 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2190 }
2191
1955 $map 2192 $map
2193 };
2194
2195 if ($@) {
2196 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2197 LOG llevError | logBacktrace, Carp::longmess $@;
1956 } or 2198 }
1957 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1958 2199
2200 if ($gen == $self->{_goto_generation}) {
2201 delete $self->{_goto_generation};
1959 $self->leave_link ($map, $x, $y); 2202 $self->leave_link ($map, $x, $y);
2203 }
1960 })->prio (1); 2204 })->prio (1);
1961} 2205}
1962 2206
1963=item $player_object->enter_exit ($exit_object) 2207=item $player_object->enter_exit ($exit_object)
1964 2208
… …
2278=back 2522=back
2279 2523
2280=cut 2524=cut
2281 2525
2282############################################################################# 2526#############################################################################
2283
2284=head2 EXTENSION DATABASE SUPPORT
2285
2286Crossfire maintains a very simple database for extension use. It can
2287currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2288convert to/from binary).
2289
2290The parameter C<$family> should best start with the name of the extension
2291using it, it should be unique.
2292
2293=over 4
2294
2295=item $value = cf::db_get $family => $key
2296
2297Returns a single value from the database.
2298
2299=item cf::db_put $family => $key => $value
2300
2301Stores the given C<$value> in the family.
2302
2303=cut
2304
2305our $DB;
2306
2307sub db_init {
2308 unless ($DB) {
2309 $DB = BDB::db_create $DB_ENV;
2310
2311 cf::sync_job {
2312 eval {
2313 $DB->set_flags (BDB::CHKSUM);
2314
2315 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2316 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2317 cf::cleanup "db_open(db): $!" if $!;
2318 };
2319 cf::cleanup "db_open(db): $@" if $@;
2320 };
2321 }
2322}
2323
2324sub db_get($$) {
2325 my $key = "$_[0]/$_[1]";
2326
2327 cf::sync_job {
2328 BDB::db_get $DB, undef, $key, my $data;
2329
2330 $! ? ()
2331 : $data
2332 }
2333}
2334
2335sub db_put($$$) {
2336 BDB::dbreq_pri 4;
2337 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2338}
2339
2340=item cf::cache $id => [$paths...], $processversion => $process
2341
2342Generic caching function that returns the value of the resource $id,
2343caching and regenerating as required.
2344
2345This function can block.
2346
2347=cut
2348
2349sub cache {
2350 my ($id, $src, $processversion, $process) = @_;
2351
2352 my $meta =
2353 join "\x00",
2354 $processversion,
2355 map {
2356 aio_stat $_
2357 and Carp::croak "$_: $!";
2358
2359 ($_, (stat _)[7,9])
2360 } @$src;
2361
2362 my $dbmeta = db_get cache => "$id/meta";
2363 if ($dbmeta ne $meta) {
2364 # changed, we may need to process
2365
2366 my @data;
2367 my $md5;
2368
2369 for (0 .. $#$src) {
2370 0 <= aio_load $src->[$_], $data[$_]
2371 or Carp::croak "$src->[$_]: $!";
2372 }
2373
2374 # if processing is expensive, check
2375 # checksum first
2376 if (1) {
2377 $md5 =
2378 join "\x00",
2379 $processversion,
2380 map {
2381 Coro::cede;
2382 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2383 } 0.. $#$src;
2384
2385
2386 my $dbmd5 = db_get cache => "$id/md5";
2387 if ($dbmd5 eq $md5) {
2388 db_put cache => "$id/meta", $meta;
2389
2390 return db_get cache => "$id/data";
2391 }
2392 }
2393
2394 my $t1 = Time::HiRes::time;
2395 my $data = $process->(\@data);
2396 my $t2 = Time::HiRes::time;
2397
2398 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2399
2400 db_put cache => "$id/data", $data;
2401 db_put cache => "$id/md5" , $md5;
2402 db_put cache => "$id/meta", $meta;
2403
2404 return $data;
2405 }
2406
2407 db_get cache => "$id/data"
2408}
2409
2410=item fork_call { }, $args
2411
2412Executes the given code block with the given arguments in a seperate
2413process, returning the results. Everything must be serialisable with
2414Coro::Storable. May, of course, block. Note that the executed sub may
2415never block itself or use any form of Event handling.
2416
2417=cut
2418
2419sub fork_call(&@) {
2420 my ($cb, @args) = @_;
2421
2422# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2423# or die "socketpair: $!";
2424 pipe my $fh1, my $fh2
2425 or die "pipe: $!";
2426
2427 if (my $pid = fork) {
2428 close $fh2;
2429
2430 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2431 $res = Coro::Storable::thaw $res;
2432
2433 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2434
2435 die $$res unless "ARRAY" eq ref $res;
2436
2437 return wantarray ? @$res : $res->[-1];
2438 } else {
2439 local $SIG{__WARN__};
2440 eval {
2441 local $SIG{__DIE__};
2442 close $fh1;
2443
2444 my @res = eval { $cb->(@args) };
2445 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2446 };
2447
2448 warn $@ if $@;
2449 _exit 0;
2450 }
2451}
2452
2453
2454
2455#############################################################################
2456# the server's init and main functions 2527# the server's init and main functions
2457 2528
2458sub load_facedata($) { 2529sub load_facedata($) {
2459 my ($path) = @_; 2530 my ($path) = @_;
2460 2531
… …
2530sub reload_resources { 2601sub reload_resources {
2531 warn "reloading resource files...\n"; 2602 warn "reloading resource files...\n";
2532 2603
2533 reload_regions; 2604 reload_regions;
2534 reload_facedata; 2605 reload_facedata;
2606 #reload_archetypes;#d#
2535 reload_archetypes; 2607 reload_archetypes;
2536 reload_treasures; 2608 reload_treasures;
2537 2609
2538 warn "finished reloading resource files\n"; 2610 warn "finished reloading resource files\n";
2539} 2611}
… …
2596 }, 2668 },
2597 ); 2669 );
2598 } 2670 }
2599} 2671}
2600 2672
2673sub write_runtime {
2674 my $runtime = "$LOCALDIR/runtime";
2675
2676 # first touch the runtime file to show we are still running:
2677 # the fsync below can take a very very long time.
2678
2679 IO::AIO::aio_utime $runtime, undef, undef;
2680
2681 my $guard = cf::lock_acquire "write_runtime";
2682
2683 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2684 or return;
2685
2686 my $value = $cf::RUNTIME + 90 + 10;
2687 # 10 is the runtime save interval, for a monotonic clock
2688 # 60 allows for the watchdog to kill the server.
2689
2690 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2691 and return;
2692
2693 # always fsync - this file is important
2694 aio_fsync $fh
2695 and return;
2696
2697 # touch it again to show we are up-to-date
2698 aio_utime $fh, undef, undef;
2699
2700 close $fh
2701 or return;
2702
2703 aio_rename "$runtime~", $runtime
2704 and return;
2705
2706 warn "runtime file written.\n";
2707
2708 1
2709}
2710
2601sub emergency_save() { 2711sub emergency_save() {
2602 my $freeze_guard = cf::freeze_mainloop; 2712 my $freeze_guard = cf::freeze_mainloop;
2603 2713
2604 warn "enter emergency perl save\n"; 2714 warn "enter emergency perl save\n";
2605 2715
… …
2809 my $signal = new Coro::Signal; 2919 my $signal = new Coro::Signal;
2810 push @WAIT_FOR_TICK_BEGIN, $signal; 2920 push @WAIT_FOR_TICK_BEGIN, $signal;
2811 $signal->wait; 2921 $signal->wait;
2812} 2922}
2813 2923
2924 my $min = 1e6;#d#
2925 my $avg = 10;
2814$TICK_WATCHER = Event->timer ( 2926$TICK_WATCHER = Event->timer (
2815 reentrant => 0, 2927 reentrant => 0,
2816 parked => 1, 2928 parked => 1,
2817 prio => 0, 2929 prio => 0,
2818 at => $NEXT_TICK || $TICK, 2930 at => $NEXT_TICK || $TICK,
… …
2822 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 2934 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2823 unless ++$bug_warning > 10; 2935 unless ++$bug_warning > 10;
2824 return; 2936 return;
2825 } 2937 }
2826 2938
2827 $NOW = Event::time; 2939 $NOW = $tick_start = Event::time;
2828 2940
2829 cf::server_tick; # one server iteration 2941 cf::server_tick; # one server iteration
2942
2943 0 && sync_job {#d#
2944 for(1..10) {
2945 my $t = Event::time;
2946 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2947 or die;
2948
2949 $map->width (50);
2950 $map->height (50);
2951 $map->alloc;
2952 $map->_load_objects ("/tmp/x.map", 1);
2953 my $t = Event::time - $t;
2954
2955 #next unless $t < 0.0013;#d#
2956 if ($t < $min) {
2957 $min = $t;
2958 }
2959 $avg = $avg * 0.99 + $t * 0.01;
2960 }
2961 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2962 exit 0;
2963 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2964 };
2830 2965
2831 $RUNTIME += $TICK; 2966 $RUNTIME += $TICK;
2832 $NEXT_TICK += $TICK; 2967 $NEXT_TICK += $TICK;
2833 2968
2834 if ($NOW >= $NEXT_RUNTIME_WRITE) { 2969 if ($NOW >= $NEXT_RUNTIME_WRITE) {
… …
2840 } 2975 }
2841 2976
2842# my $AFTER = Event::time; 2977# my $AFTER = Event::time;
2843# warn $AFTER - $NOW;#d# 2978# warn $AFTER - $NOW;#d#
2844 2979
2980 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2981 $sig->send;
2982 }
2983 while (my $sig = shift @WAIT_FOR_TICK) {
2984 $sig->send;
2985 }
2986
2987 $NOW = Event::time;
2988
2845 # if we are delayed by four ticks or more, skip them all 2989 # if we are delayed by four ticks or more, skip them all
2846 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2990 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2847 2991
2848 $TICK_WATCHER->at ($NEXT_TICK); 2992 $TICK_WATCHER->at ($NEXT_TICK);
2849 $TICK_WATCHER->start; 2993 $TICK_WATCHER->start;
2850 2994
2851 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 2995 $LOAD = ($NOW - $tick_start) / $TICK;
2852 $sig->send; 2996 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2853 }
2854 while (my $sig = shift @WAIT_FOR_TICK) {
2855 $sig->send;
2856 }
2857 2997
2858 _post_tick; 2998 _post_tick;
2999
3000
2859 }, 3001 },
2860); 3002);
2861 3003
2862{ 3004{
2863 BDB::max_poll_time $TICK * 0.1; 3005 BDB::max_poll_time $TICK * 0.1;
… …
2922 prio => 6, 3064 prio => 6,
2923 cb => \&IO::AIO::poll_cb, 3065 cb => \&IO::AIO::poll_cb,
2924 ); 3066 );
2925} 3067}
2926 3068
3069my $_log_backtrace;
3070
3071sub _log_backtrace {
3072 my ($msg, @addr) = @_;
3073
3074 $msg =~ s/\n//;
3075
3076 # limit the # of concurrent backtraces
3077 if ($_log_backtrace < 2) {
3078 ++$_log_backtrace;
3079 async {
3080 my @bt = fork_call {
3081 @addr = map { sprintf "%x", $_ } @addr;
3082 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3083 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3084 or die "addr2line: $!";
3085
3086 my @funcs;
3087 my @res = <$fh>;
3088 chomp for @res;
3089 while (@res) {
3090 my ($func, $line) = splice @res, 0, 2, ();
3091 push @funcs, "[$func] $line";
3092 }
3093
3094 @funcs
3095 };
3096
3097 LOG llevInfo, "[ABT] $msg\n";
3098 LOG llevInfo, "[ABT] $_\n" for @bt;
3099 --$_log_backtrace;
3100 };
3101 } else {
3102 LOG llevInfo, "[ABT] $msg\n";
3103 LOG llevInfo, "[ABT] [suppressed]\n";
3104 }
3105}
3106
2927# load additional modules 3107# load additional modules
2928use cf::pod; 3108use cf::pod;
2929 3109
2930END { cf::emergency_save } 3110END { cf::emergency_save }
2931 3111

Diff Legend

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