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.276 by root, Sun Jun 10 04:05:47 2007 UTC vs.
Revision 1.286 by root, Sun Jun 24 04:27:20 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) = @_;
1779} 1974}
1780 1975
1781=item $maps = cf::map::tmp_maps 1976=item $maps = cf::map::tmp_maps
1782 1977
1783Returns an arrayref with all map paths of currently instantiated and saved 1978Returns an arrayref with all map paths of currently instantiated and saved
1784maps. 1979maps. May block.
1785 1980
1786=cut 1981=cut
1787 1982
1788sub tmp_maps() { 1983sub tmp_maps() {
1789 [ 1984 [
1790 map { 1985 map {
1791 utf8::decode $_; 1986 utf8::decode $_;
1792 !/\.(?:pst|meta)$/ && /^$PATH_SEP/o 1987 /\.map$/
1793 ? normalise $_ 1988 ? normalise $_
1794 : () 1989 : ()
1795 } @{ aio_readdir $TMPDIR or [] } 1990 } @{ aio_readdir $TMPDIR or [] }
1796 ] 1991 ]
1797} 1992}
1798 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
1799=item cf::map::unique_maps 2012=item cf::map::unique_maps
1800 2013
1801Returns an arrayref of paths of all shared maps that have 2014Returns an arrayref of paths of all shared maps that have
1802instantiated unique items. May block. 2015instantiated unique items. May block.
1803 2016
1805 2018
1806sub unique_maps() { 2019sub unique_maps() {
1807 [ 2020 [
1808 map { 2021 map {
1809 utf8::decode $_; 2022 utf8::decode $_;
1810 !/\.(?:pst|meta)$/ && /^$PATH_SEP/o 2023 /\.map$/
1811 ? normalise $_ 2024 ? normalise $_
1812 : () 2025 : ()
1813 } @{ aio_readdir $UNIQUEDIR or [] } 2026 } @{ aio_readdir $UNIQUEDIR or [] }
1814 ] 2027 ]
1815} 2028}
1865 2078
1866 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2079 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1867 2080
1868 if ($self->{record_replies}) { 2081 if ($self->{record_replies}) {
1869 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2082 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2083
1870 } 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 {
1871 $msg = $npc->name . " says: $msg" if $npc; 2097 $msg = $npc->name . " says: $msg" if $npc;
1872 $self->message ($msg, $flags); 2098 $self->message ($msg, $flags);
2099 }
1873 } 2100 }
1874} 2101}
1875 2102
1876=item $player_object->may ("access") 2103=item $player_object->may ("access")
1877 2104
2120sub cf::client::send_drawinfo { 2347sub cf::client::send_drawinfo {
2121 my ($self, $text, $flags) = @_; 2348 my ($self, $text, $flags) = @_;
2122 2349
2123 utf8::encode $text; 2350 utf8::encode $text;
2124 $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]${2}[\/color]/;
2379 }
2380
2381 if ($color >= 0) {
2382 if (0 && $msg =~ /\[/) {
2383 $self->send_packet ("drawextinfo $color 4 0 $msg")
2384 } else {
2385 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2386 $self->send_packet ("drawinfo $color $msg")
2387 }
2388 }
2389 }
2125} 2390}
2126 2391
2127=item $client->ext_event ($type, %msg) 2392=item $client->ext_event ($type, %msg)
2128 2393
2129Sends an exti event to the client. 2394Sends an exti event to the client.
2329} 2594}
2330 2595
2331=back 2596=back
2332 2597
2333=cut 2598=cut
2334
2335#############################################################################
2336
2337=head2 EXTENSION DATABASE SUPPORT
2338
2339Crossfire maintains a very simple database for extension use. It can
2340currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2341convert to/from binary).
2342
2343The parameter C<$family> should best start with the name of the extension
2344using it, it should be unique.
2345
2346=over 4
2347
2348=item $value = cf::db_get $family => $key
2349
2350Returns a single value from the database.
2351
2352=item cf::db_put $family => $key => $value
2353
2354Stores the given C<$value> in the family.
2355
2356=cut
2357
2358our $DB;
2359
2360sub db_init {
2361 unless ($DB) {
2362 $DB = BDB::db_create $DB_ENV;
2363
2364 cf::sync_job {
2365 eval {
2366 $DB->set_flags (BDB::CHKSUM);
2367
2368 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2369 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2370 cf::cleanup "db_open(db): $!" if $!;
2371 };
2372 cf::cleanup "db_open(db): $@" if $@;
2373 };
2374 }
2375}
2376
2377sub db_get($$) {
2378 my $key = "$_[0]/$_[1]";
2379
2380 cf::sync_job {
2381 BDB::db_get $DB, undef, $key, my $data;
2382
2383 $! ? ()
2384 : $data
2385 }
2386}
2387
2388sub db_put($$$) {
2389 BDB::dbreq_pri 4;
2390 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2391}
2392
2393=item cf::cache $id => [$paths...], $processversion => $process
2394
2395Generic caching function that returns the value of the resource $id,
2396caching and regenerating as required.
2397
2398This function can block.
2399
2400=cut
2401
2402sub cache {
2403 my ($id, $src, $processversion, $process) = @_;
2404
2405 my $meta =
2406 join "\x00",
2407 $processversion,
2408 map {
2409 aio_stat $_
2410 and Carp::croak "$_: $!";
2411
2412 ($_, (stat _)[7,9])
2413 } @$src;
2414
2415 my $dbmeta = db_get cache => "$id/meta";
2416 if ($dbmeta ne $meta) {
2417 # changed, we may need to process
2418
2419 my @data;
2420 my $md5;
2421
2422 for (0 .. $#$src) {
2423 0 <= aio_load $src->[$_], $data[$_]
2424 or Carp::croak "$src->[$_]: $!";
2425 }
2426
2427 # if processing is expensive, check
2428 # checksum first
2429 if (1) {
2430 $md5 =
2431 join "\x00",
2432 $processversion,
2433 map {
2434 Coro::cede;
2435 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2436 } 0.. $#$src;
2437
2438
2439 my $dbmd5 = db_get cache => "$id/md5";
2440 if ($dbmd5 eq $md5) {
2441 db_put cache => "$id/meta", $meta;
2442
2443 return db_get cache => "$id/data";
2444 }
2445 }
2446
2447 my $t1 = Time::HiRes::time;
2448 my $data = $process->(\@data);
2449 my $t2 = Time::HiRes::time;
2450
2451 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2452
2453 db_put cache => "$id/data", $data;
2454 db_put cache => "$id/md5" , $md5;
2455 db_put cache => "$id/meta", $meta;
2456
2457 return $data;
2458 }
2459
2460 db_get cache => "$id/data"
2461}
2462
2463=item fork_call { }, $args
2464
2465Executes the given code block with the given arguments in a seperate
2466process, returning the results. Everything must be serialisable with
2467Coro::Storable. May, of course, block. Note that the executed sub may
2468never block itself or use any form of Event handling.
2469
2470=cut
2471
2472sub fork_call(&@) {
2473 my ($cb, @args) = @_;
2474
2475# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2476# or die "socketpair: $!";
2477 pipe my $fh1, my $fh2
2478 or die "pipe: $!";
2479
2480 if (my $pid = fork) {
2481 close $fh2;
2482
2483 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2484 $res = Coro::Storable::thaw $res;
2485
2486 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2487
2488 die $$res unless "ARRAY" eq ref $res;
2489
2490 return wantarray ? @$res : $res->[-1];
2491 } else {
2492 reset_signals;
2493 local $SIG{__WARN__};
2494 local $SIG{__DIE__};
2495 eval {
2496 close $fh1;
2497
2498 my @res = eval { $cb->(@args) };
2499 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2500 };
2501
2502 warn $@ if $@;
2503 _exit 0;
2504 }
2505}
2506 2599
2507############################################################################# 2600#############################################################################
2508# the server's init and main functions 2601# the server's init and main functions
2509 2602
2510sub load_facedata($) { 2603sub load_facedata($) {
2647 cb => sub { 2740 cb => sub {
2648 cf::cleanup "SIG$signal"; 2741 cf::cleanup "SIG$signal";
2649 }, 2742 },
2650 ); 2743 );
2651 } 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
2652} 2783}
2653 2784
2654sub emergency_save() { 2785sub emergency_save() {
2655 my $freeze_guard = cf::freeze_mainloop; 2786 my $freeze_guard = cf::freeze_mainloop;
2656 2787

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines