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.279 by root, Mon Jun 11 22:16:53 2007 UTC vs.
Revision 1.288 by root, Mon Jun 25 07:40:53 2007 UTC

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

Diff Legend

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