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.275 by root, Thu Jun 7 19:12:22 2007 UTC vs.
Revision 1.284 by root, Sun Jun 24 04:15:42 2007 UTC

… …
206} 206}
207 207
208$Event::DIED = sub { 208$Event::DIED = sub {
209 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
210}; 210};
211
212#############################################################################
211 213
212=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
213 215
214=over 4 216=over 4
215 217
… …
318 320
319BEGIN { *async = \&Coro::async_pool } 321BEGIN { *async = \&Coro::async_pool }
320 322
321=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
322 324
323The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
324always able to handle events or runnable, as crossfire+ is only partly 326is always able to handle events or runnable, as Crossfire TRT is only
325reentrant. 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.
326 329
327If 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
328the given BLOCK in another coroutine while waiting for the result. The 331the given BLOCK in another coroutine while waiting for the result. The
329server 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
330fast or be very important. 333fast or be very important.
… …
390 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
391 394
392 $coro 395 $coro
393} 396}
394 397
395sub write_runtime { 398=item fork_call { }, $args
396 my $runtime = "$LOCALDIR/runtime";
397 399
398 # first touch the runtime file to show we are still running: 400Executes the given code block with the given arguments in a seperate
399 # the fsync below can take a very very long time. 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.
400 404
401 IO::AIO::aio_utime $runtime, undef, undef; 405=cut
402 406
403 my $guard = cf::lock_acquire "write_runtime"; 407sub fork_call(&@) {
408 my ($cb, @args) = @_;
404 409
405 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
406 or return; 411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
407 414
408 my $value = $cf::RUNTIME + 90 + 10; 415 if (my $pid = fork) {
409 # 10 is the runtime save interval, for a monotonic clock
410 # 60 allows for the watchdog to kill the server.
411
412 (aio_write $fh, 0, (length $value), $value, 0) <= 0
413 and return;
414
415 # always fsync - this file is important
416 aio_fsync $fh
417 and return;
418
419 # touch it again to show we are up-to-date
420 aio_utime $fh, undef, undef;
421
422 close $fh 416 close $fh2;
423 or return;
424 417
425 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
426 and return; 419 $res = Coro::Storable::thaw $res;
427 420
428 warn "runtime file written.\n"; 421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429 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;
430 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"
431} 556}
432 557
433=item cf::datalog type => key => value, ... 558=item cf::datalog type => key => value, ...
434 559
435Log 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.
… …
453attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
454to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
455 580
456In 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>
457C<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
458crossfire+). 583Crossfire TRT).
459 584
460=over 4 585=over 4
461 586
462=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
463 588
… …
665 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
666 } 791 }
667 792
668 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
669 } else { 794 } else {
670 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
671 } 796 }
672 797
673 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
674} 799}
675 800
… …
877 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
878 $filename, length $data, scalar @{$av || []}; 1003 $filename, length $data, scalar @{$av || []};
879 return ($data, $av); 1004 return ($data, $av);
880} 1005}
881 1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
1012
882############################################################################# 1013#############################################################################
883# command handling &c 1014# command handling &c
884 1015
885=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
886 1017
… …
898 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
899} 1030}
900 1031
901=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
902 1033
903Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
904 1035
905If 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
906called. 1037called.
907 1038
908=cut 1039=cut
… …
943 1074
944 cf::override; 1075 cf::override;
945 }, 1076 },
946); 1077);
947 1078
948sub load_extension {
949 my ($path) = @_;
950
951 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
952 my $base = $1;
953 my $pkg = $1;
954 $pkg =~ s/[^[:word:]]/_/g;
955 $pkg = "ext::$pkg";
956
957 warn "... loading '$path' into '$pkg'\n";
958
959 open my $fh, "<:utf8", $path
960 or die "$path: $!";
961
962 my $source =
963 "package $pkg; use strict; use utf8;\n"
964 . "#line 1 \"$path\"\n{\n"
965 . (do { local $/; <$fh> })
966 . "\n};\n1";
967
968 unless (eval $source) {
969 my $msg = $@ ? "$path: $@\n"
970 : "extension disabled.\n";
971 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
972 warn $@;
973 warn "mandatory extension failed to load, exiting.\n";
974 exit 1;
975 }
976 die $@;
977 }
978
979 push @EXTS, $pkg;
980}
981
982sub load_extensions { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
983 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
984 next unless -r $ext; 1084 next unless -r $path;
985 eval { 1085
986 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;
987 1 1143 }
988 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
989 } 1149 };
990} 1150}
991 1151
992############################################################################# 1152#############################################################################
1153
1154=back
993 1155
994=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
995 1157
996Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
997 1159
… …
1185 } 1347 }
1186 1348
1187 \@paths 1349 \@paths
1188} 1350}
1189 1351
1352=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1353
1354Expand crossfire pod fragments into protocol xml.
1355
1356=cut
1357
1358sub expand_cfpod {
1359 ((my $self), (local $_)) = @_;
1360
1361 # escape & and <
1362 s/&/&amp;/g;
1363 s/(?<![BIUGH])</&lt;/g;
1364
1365 # this is buggy, it needs to properly take care of nested <'s
1366
1367 1 while
1368 # replace B<>, I<>, U<> etc.
1369 s/B<([^\>]*)>/<b>$1<\/b>/
1370 || s/I<([^\>]*)>/<i>$1<\/i>/
1371 || s/U<([^\>]*)>/<u>$1<\/u>/
1372 # replace G<male|female> tags
1373 || s{G<([^>|]*)\|([^>]*)>}{
1374 $self->gender ? $2 : $1
1375 }ge
1376 # replace H<hint text>
1377 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1378
1379 # create single paragraphs (very hackish)
1380 s/(?<=\S)\n(?=\w)/ /g;
1381
1382 $_
1383}
1384
1190=item $player->ext_reply ($msgid, %msg) 1385=item $player->ext_reply ($msgid, %msg)
1191 1386
1192Sends an ext reply to the player. 1387Sends an ext reply to the player.
1193 1388
1194=cut 1389=cut
… …
1221 1416
1222package cf::region; 1417package cf::region;
1223 1418
1224=item cf::region::find_by_path $path 1419=item cf::region::find_by_path $path
1225 1420
1226Tries to decuce the probable region for a map knowing only its path. 1421Tries to decuce the likely region for a map knowing only its path.
1227 1422
1228=cut 1423=cut
1229 1424
1230sub find_by_path($) { 1425sub find_by_path($) {
1231 my ($path) = @_; 1426 my ($path) = @_;
… …
1776 $cf::MAP{$self->path} = $self; 1971 $cf::MAP{$self->path} = $self;
1777 1972
1778 $self->reset; # polite request, might not happen 1973 $self->reset; # polite request, might not happen
1779} 1974}
1780 1975
1976=item $maps = cf::map::tmp_maps
1977
1978Returns an arrayref with all map paths of currently instantiated and saved
1979maps. May block.
1980
1981=cut
1982
1983sub tmp_maps() {
1984 [
1985 map {
1986 utf8::decode $_;
1987 /\.map$/
1988 ? normalise $_
1989 : ()
1990 } @{ aio_readdir $TMPDIR or [] }
1991 ]
1992}
1993
1994=item $maps = cf::map::random_maps
1995
1996Returns an arrayref with all map paths of currently instantiated and saved
1997random maps. May block.
1998
1999=cut
2000
2001sub random_maps() {
2002 [
2003 map {
2004 utf8::decode $_;
2005 /\.map$/
2006 ? normalise "?random/$_"
2007 : ()
2008 } @{ aio_readdir $RANDOMDIR or [] }
2009 ]
2010}
2011
1781=item cf::map::unique_maps 2012=item cf::map::unique_maps
1782 2013
1783Returns an arrayref of paths of all shared maps that have 2014Returns an arrayref of paths of all shared maps that have
1784instantiated unique items. May block. 2015instantiated unique items. May block.
1785 2016
1786=cut 2017=cut
1787 2018
1788sub unique_maps() { 2019sub unique_maps() {
1789 my $files = aio_readdir $UNIQUEDIR 2020 [
1790 or return; 2021 map {
1791
1792 my @paths;
1793
1794 for (@$files) {
1795 utf8::decode $_; 2022 utf8::decode $_;
1796 next if /\.pst$/; 2023 /\.map$/
1797 next unless /^$PATH_SEP/o; 2024 ? normalise $_
1798 2025 : ()
1799 push @paths, cf::map::normalise $_; 2026 } @{ aio_readdir $UNIQUEDIR or [] }
1800 } 2027 ]
1801
1802 \@paths
1803} 2028}
1804 2029
1805package cf; 2030package cf;
1806 2031
1807=back 2032=back
… …
1853 2078
1854 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2079 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1855 2080
1856 if ($self->{record_replies}) { 2081 if ($self->{record_replies}) {
1857 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2082 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2083
1858 } else { 2084 } else {
2085 my $pl = $self->contr;
2086
2087 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2088 my $diag = $pl->{npc_dialog};
2089 $diag->{pl}->ext_reply (
2090 $diag->{id},
2091 msgtype => "reply",
2092 msg => $diag->{pl}->expand_cfpod ($msg),
2093 add_topics => []
2094 );
2095
2096 } else {
1859 $msg = $npc->name . " says: $msg" if $npc; 2097 $msg = $npc->name . " says: $msg" if $npc;
1860 $self->message ($msg, $flags); 2098 $self->message ($msg, $flags);
2099 }
1861 } 2100 }
1862} 2101}
1863 2102
1864=item $player_object->may ("access") 2103=item $player_object->may ("access")
1865 2104
… …
2108sub cf::client::send_drawinfo { 2347sub cf::client::send_drawinfo {
2109 my ($self, $text, $flags) = @_; 2348 my ($self, $text, $flags) = @_;
2110 2349
2111 utf8::encode $text; 2350 utf8::encode $text;
2112 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2351 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2352}
2353
2354=item $client->send_msg ($color, $type, $msg, [extra...])
2355
2356Send a drawinfo or msg packet to the client, formatting the msg for the
2357client if neccessary. C<$type> should be a string identifying the type of
2358the message, with C<log> being the default. If C<$color> is negative, suppress
2359the message unless the client supports the msg packet.
2360
2361=cut
2362
2363sub cf::client::send_msg {
2364 my ($self, $color, $type, $msg, @extra) = @_;
2365
2366 $msg = $self->pl->expand_cfpod ($msg);
2367
2368 if ($self->can_msg) {
2369 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2370 } else {
2371 # replace some tags by gcfclient-compatible ones
2372 for ($msg) {
2373 1 while
2374 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2375 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2376 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2377 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2378 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${1}[\/color]/;
2379 }
2380
2381 if ($color >= 0) {
2382 if (0 && $msg =~ /\[/) {
2383 $self->send_packet ("drawextinfo $color 4 0 $msg")
2384 } else {
2385 s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2386 $self->send_packet ("drawinfo $color $msg")
2387 }
2388 }
2389 }
2113} 2390}
2114 2391
2115=item $client->ext_event ($type, %msg) 2392=item $client->ext_event ($type, %msg)
2116 2393
2117Sends an exti event to the client. 2394Sends an exti event to the client.
… …
2317} 2594}
2318 2595
2319=back 2596=back
2320 2597
2321=cut 2598=cut
2322
2323#############################################################################
2324
2325=head2 EXTENSION DATABASE SUPPORT
2326
2327Crossfire maintains a very simple database for extension use. It can
2328currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2329convert to/from binary).
2330
2331The parameter C<$family> should best start with the name of the extension
2332using it, it should be unique.
2333
2334=over 4
2335
2336=item $value = cf::db_get $family => $key
2337
2338Returns a single value from the database.
2339
2340=item cf::db_put $family => $key => $value
2341
2342Stores the given C<$value> in the family.
2343
2344=cut
2345
2346our $DB;
2347
2348sub db_init {
2349 unless ($DB) {
2350 $DB = BDB::db_create $DB_ENV;
2351
2352 cf::sync_job {
2353 eval {
2354 $DB->set_flags (BDB::CHKSUM);
2355
2356 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2357 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2358 cf::cleanup "db_open(db): $!" if $!;
2359 };
2360 cf::cleanup "db_open(db): $@" if $@;
2361 };
2362 }
2363}
2364
2365sub db_get($$) {
2366 my $key = "$_[0]/$_[1]";
2367
2368 cf::sync_job {
2369 BDB::db_get $DB, undef, $key, my $data;
2370
2371 $! ? ()
2372 : $data
2373 }
2374}
2375
2376sub db_put($$$) {
2377 BDB::dbreq_pri 4;
2378 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2379}
2380
2381=item cf::cache $id => [$paths...], $processversion => $process
2382
2383Generic caching function that returns the value of the resource $id,
2384caching and regenerating as required.
2385
2386This function can block.
2387
2388=cut
2389
2390sub cache {
2391 my ($id, $src, $processversion, $process) = @_;
2392
2393 my $meta =
2394 join "\x00",
2395 $processversion,
2396 map {
2397 aio_stat $_
2398 and Carp::croak "$_: $!";
2399
2400 ($_, (stat _)[7,9])
2401 } @$src;
2402
2403 my $dbmeta = db_get cache => "$id/meta";
2404 if ($dbmeta ne $meta) {
2405 # changed, we may need to process
2406
2407 my @data;
2408 my $md5;
2409
2410 for (0 .. $#$src) {
2411 0 <= aio_load $src->[$_], $data[$_]
2412 or Carp::croak "$src->[$_]: $!";
2413 }
2414
2415 # if processing is expensive, check
2416 # checksum first
2417 if (1) {
2418 $md5 =
2419 join "\x00",
2420 $processversion,
2421 map {
2422 Coro::cede;
2423 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2424 } 0.. $#$src;
2425
2426
2427 my $dbmd5 = db_get cache => "$id/md5";
2428 if ($dbmd5 eq $md5) {
2429 db_put cache => "$id/meta", $meta;
2430
2431 return db_get cache => "$id/data";
2432 }
2433 }
2434
2435 my $t1 = Time::HiRes::time;
2436 my $data = $process->(\@data);
2437 my $t2 = Time::HiRes::time;
2438
2439 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2440
2441 db_put cache => "$id/data", $data;
2442 db_put cache => "$id/md5" , $md5;
2443 db_put cache => "$id/meta", $meta;
2444
2445 return $data;
2446 }
2447
2448 db_get cache => "$id/data"
2449}
2450
2451=item fork_call { }, $args
2452
2453Executes the given code block with the given arguments in a seperate
2454process, returning the results. Everything must be serialisable with
2455Coro::Storable. May, of course, block. Note that the executed sub may
2456never block itself or use any form of Event handling.
2457
2458=cut
2459
2460sub fork_call(&@) {
2461 my ($cb, @args) = @_;
2462
2463# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2464# or die "socketpair: $!";
2465 pipe my $fh1, my $fh2
2466 or die "pipe: $!";
2467
2468 if (my $pid = fork) {
2469 close $fh2;
2470
2471 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2472 $res = Coro::Storable::thaw $res;
2473
2474 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2475
2476 die $$res unless "ARRAY" eq ref $res;
2477
2478 return wantarray ? @$res : $res->[-1];
2479 } else {
2480 reset_signals;
2481 local $SIG{__WARN__};
2482 local $SIG{__DIE__};
2483 eval {
2484 close $fh1;
2485
2486 my @res = eval { $cb->(@args) };
2487 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2488 };
2489
2490 warn $@ if $@;
2491 _exit 0;
2492 }
2493}
2494 2599
2495############################################################################# 2600#############################################################################
2496# the server's init and main functions 2601# the server's init and main functions
2497 2602
2498sub load_facedata($) { 2603sub load_facedata($) {
… …
2635 cb => sub { 2740 cb => sub {
2636 cf::cleanup "SIG$signal"; 2741 cf::cleanup "SIG$signal";
2637 }, 2742 },
2638 ); 2743 );
2639 } 2744 }
2745}
2746
2747sub write_runtime {
2748 my $runtime = "$LOCALDIR/runtime";
2749
2750 # first touch the runtime file to show we are still running:
2751 # the fsync below can take a very very long time.
2752
2753 IO::AIO::aio_utime $runtime, undef, undef;
2754
2755 my $guard = cf::lock_acquire "write_runtime";
2756
2757 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2758 or return;
2759
2760 my $value = $cf::RUNTIME + 90 + 10;
2761 # 10 is the runtime save interval, for a monotonic clock
2762 # 60 allows for the watchdog to kill the server.
2763
2764 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2765 and return;
2766
2767 # always fsync - this file is important
2768 aio_fsync $fh
2769 and return;
2770
2771 # touch it again to show we are up-to-date
2772 aio_utime $fh, undef, undef;
2773
2774 close $fh
2775 or return;
2776
2777 aio_rename "$runtime~", $runtime
2778 and return;
2779
2780 warn "runtime file written.\n";
2781
2782 1
2640} 2783}
2641 2784
2642sub emergency_save() { 2785sub emergency_save() {
2643 my $freeze_guard = cf::freeze_mainloop; 2786 my $freeze_guard = cf::freeze_mainloop;
2644 2787

Diff Legend

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