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.280 by root, Sat Jun 16 14:35:41 2007 UTC vs.
Revision 1.287 by root, Mon Jun 25 05:43:45 2007 UTC

… …
49our %COMMAND = (); 49our %COMMAND = ();
50our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
51 51
52our @EXTS = (); # list of extension package names 52our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 53our %EXTCMD = ();
54our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 55our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 56our %EXT_MAP = (); # pluggable maps
56 57
57our $RELOAD; # number of reloads so far 58our $RELOAD; # number of reloads so far
58our @EVENT; 59our @EVENT;
… …
206} 207}
207 208
208$Event::DIED = sub { 209$Event::DIED = sub {
209 warn "error in event callback: @_"; 210 warn "error in event callback: @_";
210}; 211};
212
213#############################################################################
211 214
212=head2 UTILITY FUNCTIONS 215=head2 UTILITY FUNCTIONS
213 216
214=over 4 217=over 4
215 218
… …
234 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 237 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
235 $d 238 $d
236 } || "[unable to dump $_[0]: '$@']"; 239 } || "[unable to dump $_[0]: '$@']";
237} 240}
238 241
239use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working 242use JSON::XS ();
240 243
241=item $ref = cf::from_json $json 244=item $ref = cf::from_json $json
242 245
243Converts a JSON string into the corresponding perl data structure. 246Converts a JSON string into the corresponding perl data structure.
244 247
245=item $json = cf::to_json $ref 248=item $json = cf::to_json $ref
246 249
247Converts a perl data structure into its JSON representation. 250Converts a perl data structure into its JSON representation.
251
252=cut
253
254our $json_coder = JSON::XS->new->convert_blessed->utf8;
255
256sub to_json ($) { $json_coder->encode ($_[0]) }
257sub from_json ($) { $json_coder->decode ($_[0]) }
248 258
249=item cf::lock_wait $string 259=item cf::lock_wait $string
250 260
251Wait until the given lock is available. See cf::lock_acquire. 261Wait until the given lock is available. See cf::lock_acquire.
252 262
… …
318 328
319BEGIN { *async = \&Coro::async_pool } 329BEGIN { *async = \&Coro::async_pool }
320 330
321=item cf::sync_job { BLOCK } 331=item cf::sync_job { BLOCK }
322 332
323The design of crossfire+ requires that the main coro ($Coro::main) is 333The design of Crossfire TRT requires that the main coroutine ($Coro::main)
324always able to handle events or runnable, as crossfire+ is only partly 334is 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. 335partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
336acceptable.
326 337
327If it must be done, put the blocking parts into C<sync_job>. This will run 338If 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 339the given BLOCK in another coroutine while waiting for the result. The
329server will be frozen during this time, so the block should either finish 340server will be frozen during this time, so the block should either finish
330fast or be very important. 341fast or be very important.
… …
390 $EXT_CORO{$coro+0} = $coro; 401 $EXT_CORO{$coro+0} = $coro;
391 402
392 $coro 403 $coro
393} 404}
394 405
395sub write_runtime { 406=item fork_call { }, $args
396 my $runtime = "$LOCALDIR/runtime";
397 407
398 # first touch the runtime file to show we are still running: 408Executes the given code block with the given arguments in a seperate
399 # the fsync below can take a very very long time. 409process, returning the results. Everything must be serialisable with
410Coro::Storable. May, of course, block. Note that the executed sub may
411never block itself or use any form of Event handling.
400 412
401 IO::AIO::aio_utime $runtime, undef, undef; 413=cut
402 414
403 my $guard = cf::lock_acquire "write_runtime"; 415sub fork_call(&@) {
416 my ($cb, @args) = @_;
404 417
405 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 418# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
406 or return; 419# or die "socketpair: $!";
420 pipe my $fh1, my $fh2
421 or die "pipe: $!";
407 422
408 my $value = $cf::RUNTIME + 90 + 10; 423 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 424 close $fh2;
423 or return;
424 425
425 aio_rename "$runtime~", $runtime 426 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
426 and return; 427 $res = Coro::Storable::thaw $res;
427 428
428 warn "runtime file written.\n"; 429 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429 430
431 die $$res unless "ARRAY" eq ref $res;
432
433 return wantarray ? @$res : $res->[-1];
434 } else {
435 reset_signals;
436 local $SIG{__WARN__};
437 local $SIG{__DIE__};
438 eval {
439 close $fh1;
440
441 my @res = eval { $cb->(@args) };
442 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
443 };
444
445 warn $@ if $@;
446 _exit 0;
430 1 447 }
448}
449
450=item $value = cf::db_get $family => $key
451
452Returns a single value from the environment database.
453
454=item cf::db_put $family => $key => $value
455
456Stores the given C<$value> in the family. It can currently store binary
457data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
458
459=cut
460
461our $DB;
462
463sub db_init {
464 unless ($DB) {
465 $DB = BDB::db_create $DB_ENV;
466
467 cf::sync_job {
468 eval {
469 $DB->set_flags (BDB::CHKSUM);
470
471 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
472 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
473 cf::cleanup "db_open(db): $!" if $!;
474 };
475 cf::cleanup "db_open(db): $@" if $@;
476 };
477 }
478}
479
480sub db_get($$) {
481 my $key = "$_[0]/$_[1]";
482
483 cf::sync_job {
484 BDB::db_get $DB, undef, $key, my $data;
485
486 $! ? ()
487 : $data
488 }
489}
490
491sub db_put($$$) {
492 BDB::dbreq_pri 4;
493 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
494}
495
496=item cf::cache $id => [$paths...], $processversion => $process
497
498Generic caching function that returns the value of the resource $id,
499caching and regenerating as required.
500
501This function can block.
502
503=cut
504
505sub cache {
506 my ($id, $src, $processversion, $process) = @_;
507
508 my $meta =
509 join "\x00",
510 $processversion,
511 map {
512 aio_stat $_
513 and Carp::croak "$_: $!";
514
515 ($_, (stat _)[7,9])
516 } @$src;
517
518 my $dbmeta = db_get cache => "$id/meta";
519 if ($dbmeta ne $meta) {
520 # changed, we may need to process
521
522 my @data;
523 my $md5;
524
525 for (0 .. $#$src) {
526 0 <= aio_load $src->[$_], $data[$_]
527 or Carp::croak "$src->[$_]: $!";
528 }
529
530 # if processing is expensive, check
531 # checksum first
532 if (1) {
533 $md5 =
534 join "\x00",
535 $processversion,
536 map {
537 Coro::cede;
538 ($src->[$_], Digest::MD5::md5_hex $data[$_])
539 } 0.. $#$src;
540
541
542 my $dbmd5 = db_get cache => "$id/md5";
543 if ($dbmd5 eq $md5) {
544 db_put cache => "$id/meta", $meta;
545
546 return db_get cache => "$id/data";
547 }
548 }
549
550 my $t1 = Time::HiRes::time;
551 my $data = $process->(\@data);
552 my $t2 = Time::HiRes::time;
553
554 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
555
556 db_put cache => "$id/data", $data;
557 db_put cache => "$id/md5" , $md5;
558 db_put cache => "$id/meta", $meta;
559
560 return $data;
561 }
562
563 db_get cache => "$id/data"
431} 564}
432 565
433=item cf::datalog type => key => value, ... 566=item cf::datalog type => key => value, ...
434 567
435Log a datalog packet of the given type with the given key-value pairs. 568Log 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") 586attach callbacks/event handlers (a collection of which is called an "attachment")
454to it. All such attachable objects support the following methods. 587to it. All such attachable objects support the following methods.
455 588
456In the following description, CLASS can be any of C<global>, C<object> 589In 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 590C<player>, C<client> or C<map> (i.e. the attachable objects in
458crossfire+). 591Crossfire TRT).
459 592
460=over 4 593=over 4
461 594
462=item $attachable->attach ($attachment, key => $value...) 595=item $attachable->attach ($attachment, key => $value...)
463 596
… …
877 warn sprintf "loading %s (%d)\n", 1010 warn sprintf "loading %s (%d)\n",
878 $filename, length $data, scalar @{$av || []}; 1011 $filename, length $data, scalar @{$av || []};
879 return ($data, $av); 1012 return ($data, $av);
880} 1013}
881 1014
1015=head2 COMMAND CALLBACKS
1016
1017=over 4
1018
1019=cut
1020
882############################################################################# 1021#############################################################################
883# command handling &c 1022# command handling &c
884 1023
885=item cf::register_command $name => \&callback($ob,$args); 1024=item cf::register_command $name => \&callback($ob,$args);
886 1025
… …
898 push @{ $COMMAND{$name} }, [$caller, $cb]; 1037 push @{ $COMMAND{$name} }, [$caller, $cb];
899} 1038}
900 1039
901=item cf::register_extcmd $name => \&callback($pl,$packet); 1040=item cf::register_extcmd $name => \&callback($pl,$packet);
902 1041
903Register a callbackf ro execution when the client sends an extcmd packet. 1042Register a callback for execution when the client sends an (synchronous)
1043extcmd packet. Ext commands will be processed in the order they are
1044received by the server, like other user commands. The first argument is
1045the logged-in player. Ext commands can only be processed after a player
1046has logged in successfully.
904 1047
905If the callback returns something, it is sent back as if reply was being 1048If the callback returns something, it is sent back as if reply was being
906called. 1049called.
907 1050
1051=item cf::register_exticmd $name => \&callback($ns,$packet);
1052
1053Register a callback for execution when the client sends an (asynchronous)
1054exticmd packet. Exti commands are processed by the server as soon as they
1055are received, i.e. out of order w.r.t. other commands. The first argument
1056is a client socket. Exti commands can be received anytime, even before
1057log-in.
1058
1059If the callback returns something, it is sent back as if reply was being
1060called.
1061
908=cut 1062=cut
909 1063
910sub register_extcmd { 1064sub register_extcmd {
911 my ($name, $cb) = @_; 1065 my ($name, $cb) = @_;
912 1066
913 $EXTCMD{$name} = $cb; 1067 $EXTCMD{$name} = $cb;
1068}
1069
1070sub register_exticmd {
1071 my ($name, $cb) = @_;
1072
1073 $EXTICMD{$name} = $cb;
914} 1074}
915 1075
916cf::player->attach ( 1076cf::player->attach (
917 on_command => sub { 1077 on_command => sub {
918 my ($pl, $name, $params) = @_; 1078 my ($pl, $name, $params) = @_;
… …
1018 }; 1178 };
1019} 1179}
1020 1180
1021############################################################################# 1181#############################################################################
1022 1182
1183=back
1184
1023=head2 CORE EXTENSIONS 1185=head2 CORE EXTENSIONS
1024 1186
1025Functions and methods that extend core crossfire objects. 1187Functions and methods that extend core crossfire objects.
1026 1188
1027=cut 1189=cut
… …
1214 } 1376 }
1215 1377
1216 \@paths 1378 \@paths
1217} 1379}
1218 1380
1381=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1382
1383Expand crossfire pod fragments into protocol xml.
1384
1385=cut
1386
1387sub expand_cfpod {
1388 ((my $self), (local $_)) = @_;
1389
1390 # escape & and <
1391 s/&/&amp;/g;
1392 s/(?<![BIUGH])</&lt;/g;
1393
1394 # this is buggy, it needs to properly take care of nested <'s
1395
1396 1 while
1397 # replace B<>, I<>, U<> etc.
1398 s/B<([^\>]*)>/<b>$1<\/b>/
1399 || s/I<([^\>]*)>/<i>$1<\/i>/
1400 || s/U<([^\>]*)>/<u>$1<\/u>/
1401 # replace G<male|female> tags
1402 || s{G<([^>|]*)\|([^>]*)>}{
1403 $self->gender ? $2 : $1
1404 }ge
1405 # replace H<hint text>
1406 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1407
1408 # create single paragraphs (very hackish)
1409 s/(?<=\S)\n(?=\w)/ /g;
1410
1411 $_
1412}
1413
1219=item $player->ext_reply ($msgid, %msg) 1414=item $player->ext_reply ($msgid, %msg)
1220 1415
1221Sends an ext reply to the player. 1416Sends an ext reply to the player.
1222 1417
1223=cut 1418=cut
1224 1419
1225sub ext_reply($$%) { 1420sub ext_reply($$%) {
1226 my ($self, $id, %msg) = @_; 1421 my ($self, $id, %msg) = @_;
1227 1422
1228 $msg{msgid} = $id; 1423 $msg{msgid} = $id;
1229
1230 $self->send ("ext " . cf::to_json \%msg); 1424 $self->send ("ext " . cf::to_json \%msg);
1231} 1425}
1232 1426
1233=item $player->ext_event ($type, %msg) 1427=item $player->ext_event ($type, %msg)
1234 1428
… …
1250 1444
1251package cf::region; 1445package cf::region;
1252 1446
1253=item cf::region::find_by_path $path 1447=item cf::region::find_by_path $path
1254 1448
1255Tries to decuce the probable region for a map knowing only its path. 1449Tries to decuce the likely region for a map knowing only its path.
1256 1450
1257=cut 1451=cut
1258 1452
1259sub find_by_path($) { 1453sub find_by_path($) {
1260 my ($path) = @_; 1454 my ($path) = @_;
… …
1912 2106
1913 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2107 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1914 2108
1915 if ($self->{record_replies}) { 2109 if ($self->{record_replies}) {
1916 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2110 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2111
1917 } else { 2112 } else {
2113 my $pl = $self->contr;
2114
2115 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2116 my $diag = $pl->{npc_dialog};
2117 $diag->{pl}->ext_reply (
2118 $diag->{id},
2119 msgtype => "reply",
2120 msg => $diag->{pl}->expand_cfpod ($msg),
2121 add_topics => []
2122 );
2123
2124 } else {
1918 $msg = $npc->name . " says: $msg" if $npc; 2125 $msg = $npc->name . " says: $msg" if $npc;
1919 $self->message ($msg, $flags); 2126 $self->message ($msg, $flags);
2127 }
1920 } 2128 }
1921} 2129}
1922 2130
1923=item $player_object->may ("access") 2131=item $player_object->may ("access")
1924 2132
… …
2169 2377
2170 utf8::encode $text; 2378 utf8::encode $text;
2171 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2379 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2172} 2380}
2173 2381
2382=item $client->send_msg ($color, $type, $msg, [extra...])
2383
2384Send a drawinfo or msg packet to the client, formatting the msg for the
2385client if neccessary. C<$type> should be a string identifying the type of
2386the message, with C<log> being the default. If C<$color> is negative, suppress
2387the message unless the client supports the msg packet.
2388
2389=cut
2390
2391sub cf::client::send_msg {
2392 my ($self, $color, $type, $msg, @extra) = @_;
2393
2394 $msg = $self->pl->expand_cfpod ($msg);
2395
2396 if ($self->can_msg) {
2397 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2398 } else {
2399 # replace some tags by gcfclient-compatible ones
2400 for ($msg) {
2401 1 while
2402 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2403 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2404 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2405 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2406 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2407 }
2408
2409 if ($color >= 0) {
2410 if (0 && $msg =~ /\[/) {
2411 $self->send_packet ("drawextinfo $color 4 0 $msg")
2412 } else {
2413 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2414 $self->send_packet ("drawinfo $color $msg")
2415 }
2416 }
2417 }
2418}
2419
2174=item $client->ext_event ($type, %msg) 2420=item $client->ext_event ($type, %msg)
2175 2421
2176Sends an exti event to the client. 2422Sends an ext event to the client.
2177 2423
2178=cut 2424=cut
2179 2425
2180sub cf::client::ext_event($$%) { 2426sub cf::client::ext_event($$%) {
2181 my ($self, $type, %msg) = @_; 2427 my ($self, $type, %msg) = @_;
… …
2188 2434
2189Queues a query to the client, calling the given callback with 2435Queues a query to the client, calling the given callback with
2190the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2436the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2191C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2437C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2192 2438
2193Queries can fail, so check the return code. Or don't, as queries will become 2439Queries can fail, so check the return code. Or don't, as queries will
2194reliable at some point in the future. 2440become reliable at some point in the future.
2195 2441
2196=cut 2442=cut
2197 2443
2198sub cf::client::query { 2444sub cf::client::query {
2199 my ($self, $flags, $text, $cb) = @_; 2445 my ($self, $flags, $text, $cb) = @_;
… …
2207 utf8::encode $text; 2453 utf8::encode $text;
2208 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2454 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2209 2455
2210 $self->send_packet ($self->{query_queue}[0][0]) 2456 $self->send_packet ($self->{query_queue}[0][0])
2211 if @{ $self->{query_queue} } == 1; 2457 if @{ $self->{query_queue} } == 1;
2458
2459 1
2212} 2460}
2213 2461
2214cf::client->attach ( 2462cf::client->attach (
2215 on_reply => sub { 2463 on_reply => sub {
2216 my ($ns, $msg) = @_; 2464 my ($ns, $msg) = @_;
… …
2230 $ns->send_packet ($ns->{query_queue}[0][0]); 2478 $ns->send_packet ($ns->{query_queue}[0][0]);
2231 } else { 2479 } else {
2232 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2480 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2233 } 2481 }
2234 } 2482 }
2483 },
2484 on_exticmd => sub {
2485 my ($ns, $buf) = @_;
2486
2487 my $msg = eval { from_json $buf };
2488
2489 if (ref $msg) {
2490 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2491 if (my %reply = $cb->($ns, $msg)) {
2492 $reply{msgid} = $msg->{msgid};
2493 $ns->send ("ext " . cf::to_json \%reply);
2494 }
2495 }
2496 } else {
2497 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2498 }
2499
2500 cf::override;
2235 }, 2501 },
2236); 2502);
2237 2503
2238=item $client->async (\&cb) 2504=item $client->async (\&cb)
2239 2505
… …
2376} 2642}
2377 2643
2378=back 2644=back
2379 2645
2380=cut 2646=cut
2381
2382#############################################################################
2383
2384=head2 EXTENSION DATABASE SUPPORT
2385
2386Crossfire maintains a very simple database for extension use. It can
2387currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2388convert to/from binary).
2389
2390The parameter C<$family> should best start with the name of the extension
2391using it, it should be unique.
2392
2393=over 4
2394
2395=item $value = cf::db_get $family => $key
2396
2397Returns a single value from the database.
2398
2399=item cf::db_put $family => $key => $value
2400
2401Stores the given C<$value> in the family.
2402
2403=cut
2404
2405our $DB;
2406
2407sub db_init {
2408 unless ($DB) {
2409 $DB = BDB::db_create $DB_ENV;
2410
2411 cf::sync_job {
2412 eval {
2413 $DB->set_flags (BDB::CHKSUM);
2414
2415 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2416 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2417 cf::cleanup "db_open(db): $!" if $!;
2418 };
2419 cf::cleanup "db_open(db): $@" if $@;
2420 };
2421 }
2422}
2423
2424sub db_get($$) {
2425 my $key = "$_[0]/$_[1]";
2426
2427 cf::sync_job {
2428 BDB::db_get $DB, undef, $key, my $data;
2429
2430 $! ? ()
2431 : $data
2432 }
2433}
2434
2435sub db_put($$$) {
2436 BDB::dbreq_pri 4;
2437 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2438}
2439
2440=item cf::cache $id => [$paths...], $processversion => $process
2441
2442Generic caching function that returns the value of the resource $id,
2443caching and regenerating as required.
2444
2445This function can block.
2446
2447=cut
2448
2449sub cache {
2450 my ($id, $src, $processversion, $process) = @_;
2451
2452 my $meta =
2453 join "\x00",
2454 $processversion,
2455 map {
2456 aio_stat $_
2457 and Carp::croak "$_: $!";
2458
2459 ($_, (stat _)[7,9])
2460 } @$src;
2461
2462 my $dbmeta = db_get cache => "$id/meta";
2463 if ($dbmeta ne $meta) {
2464 # changed, we may need to process
2465
2466 my @data;
2467 my $md5;
2468
2469 for (0 .. $#$src) {
2470 0 <= aio_load $src->[$_], $data[$_]
2471 or Carp::croak "$src->[$_]: $!";
2472 }
2473
2474 # if processing is expensive, check
2475 # checksum first
2476 if (1) {
2477 $md5 =
2478 join "\x00",
2479 $processversion,
2480 map {
2481 Coro::cede;
2482 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2483 } 0.. $#$src;
2484
2485
2486 my $dbmd5 = db_get cache => "$id/md5";
2487 if ($dbmd5 eq $md5) {
2488 db_put cache => "$id/meta", $meta;
2489
2490 return db_get cache => "$id/data";
2491 }
2492 }
2493
2494 my $t1 = Time::HiRes::time;
2495 my $data = $process->(\@data);
2496 my $t2 = Time::HiRes::time;
2497
2498 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2499
2500 db_put cache => "$id/data", $data;
2501 db_put cache => "$id/md5" , $md5;
2502 db_put cache => "$id/meta", $meta;
2503
2504 return $data;
2505 }
2506
2507 db_get cache => "$id/data"
2508}
2509
2510=item fork_call { }, $args
2511
2512Executes the given code block with the given arguments in a seperate
2513process, returning the results. Everything must be serialisable with
2514Coro::Storable. May, of course, block. Note that the executed sub may
2515never block itself or use any form of Event handling.
2516
2517=cut
2518
2519sub fork_call(&@) {
2520 my ($cb, @args) = @_;
2521
2522# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2523# or die "socketpair: $!";
2524 pipe my $fh1, my $fh2
2525 or die "pipe: $!";
2526
2527 if (my $pid = fork) {
2528 close $fh2;
2529
2530 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2531 $res = Coro::Storable::thaw $res;
2532
2533 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2534
2535 die $$res unless "ARRAY" eq ref $res;
2536
2537 return wantarray ? @$res : $res->[-1];
2538 } else {
2539 reset_signals;
2540 local $SIG{__WARN__};
2541 local $SIG{__DIE__};
2542 eval {
2543 close $fh1;
2544
2545 my @res = eval { $cb->(@args) };
2546 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2547 };
2548
2549 warn $@ if $@;
2550 _exit 0;
2551 }
2552}
2553 2647
2554############################################################################# 2648#############################################################################
2555# the server's init and main functions 2649# the server's init and main functions
2556 2650
2557sub load_facedata($) { 2651sub load_facedata($) {
… …
2696 }, 2790 },
2697 ); 2791 );
2698 } 2792 }
2699} 2793}
2700 2794
2795sub write_runtime {
2796 my $runtime = "$LOCALDIR/runtime";
2797
2798 # first touch the runtime file to show we are still running:
2799 # the fsync below can take a very very long time.
2800
2801 IO::AIO::aio_utime $runtime, undef, undef;
2802
2803 my $guard = cf::lock_acquire "write_runtime";
2804
2805 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2806 or return;
2807
2808 my $value = $cf::RUNTIME + 90 + 10;
2809 # 10 is the runtime save interval, for a monotonic clock
2810 # 60 allows for the watchdog to kill the server.
2811
2812 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2813 and return;
2814
2815 # always fsync - this file is important
2816 aio_fsync $fh
2817 and return;
2818
2819 # touch it again to show we are up-to-date
2820 aio_utime $fh, undef, undef;
2821
2822 close $fh
2823 or return;
2824
2825 aio_rename "$runtime~", $runtime
2826 and return;
2827
2828 warn "runtime file written.\n";
2829
2830 1
2831}
2832
2701sub emergency_save() { 2833sub emergency_save() {
2702 my $freeze_guard = cf::freeze_mainloop; 2834 my $freeze_guard = cf::freeze_mainloop;
2703 2835
2704 warn "enter emergency perl save\n"; 2836 warn "enter emergency perl save\n";
2705 2837
… …
2780 %EXT_CORO = (); 2912 %EXT_CORO = ();
2781 2913
2782 warn "removing commands"; 2914 warn "removing commands";
2783 %COMMAND = (); 2915 %COMMAND = ();
2784 2916
2785 warn "removing ext commands"; 2917 warn "removing ext/exti commands";
2786 %EXTCMD = (); 2918 %EXTCMD = ();
2919 %EXTICMD = ();
2787 2920
2788 warn "unloading/nuking all extensions"; 2921 warn "unloading/nuking all extensions";
2789 for my $pkg (@EXTS) { 2922 for my $pkg (@EXTS) {
2790 warn "... unloading $pkg"; 2923 warn "... unloading $pkg";
2791 2924

Diff Legend

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