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.278 by root, Mon Jun 11 21:38:14 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
… …
665 _attach $registry, $klass, @attach; 798 _attach $registry, $klass, @attach;
666 } 799 }
667 800
668 $obj->{$name} = \%arg; 801 $obj->{$name} = \%arg;
669 } else { 802 } else {
670 warn "object uses attachment '$name' that is not available, postponing.\n"; 803 warn "object uses attachment '$name' which is not available, postponing.\n";
671 } 804 }
672 805
673 $obj->{_attachment}{$name} = undef; 806 $obj->{_attachment}{$name} = undef;
674} 807}
675 808
… …
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) = @_;
… …
967 path => $path, 1127 path => $path,
968 base => $base, 1128 base => $base,
969 pkg => $pkg, 1129 pkg => $pkg,
970 ); 1130 );
971 1131
972 $ext{meta} = { map { split /=/, $_, 2 } split /\s+/, $1 } 1132 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
973 if $source =~ /^#!.*?perl.*?#\s*(.*)$/; 1133 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
974 1134
975 $ext{source} = 1135 $ext{source} =
976 "package $pkg; use strict; use utf8;\n" 1136 "package $pkg; use strict; use utf8;\n"
977 . "#line 1 \"$path\"\n{\n" 1137 . "#line 1 \"$path\"\n{\n"
978 . $source 1138 . $source
… …
984 my %done; 1144 my %done;
985 while (%todo) { 1145 while (%todo) {
986 my $progress; 1146 my $progress;
987 1147
988 while (my ($k, $v) = each %todo) { 1148 while (my ($k, $v) = each %todo) {
989 for (split /,\s*/, $ext{meta}{depends}) { 1149 for (split /,\s*/, $v->{meta}{depends}) {
990 goto skip 1150 goto skip
991 unless exists $done{$_}; 1151 unless exists $done{$_};
992 } 1152 }
993 1153
994 warn "... loading '$k' into '$v->{pkg}'\n"; 1154 warn "... loading '$k' into '$v->{pkg}'\n";
995 1155
996 unless (eval $v->{source}) { 1156 unless (eval $v->{source}) {
997 my $msg = $@ ? "$v->{path}: $@\n" 1157 my $msg = $@ ? "$v->{path}: $@\n"
998 : "extension disabled.\n"; 1158 : "$v->{base}: extension inactive.\n";
999 1159
1000 if (exists $v->{meta}{mandatory}) { 1160 if (exists $v->{meta}{mandatory}) {
1001 warn $msg; 1161 warn $msg;
1002 warn "mandatory extension failed to load, exiting.\n"; 1162 warn "mandatory extension failed to load, exiting.\n";
1003 exit 1; 1163 exit 1;
1004 } 1164 }
1005 1165
1006 die $msg; 1166 warn $msg;
1007 } 1167 }
1008 1168
1009 $done{$k} = delete $todo{$k}; 1169 $done{$k} = delete $todo{$k};
1010 push @EXTS, $v->{pkg}; 1170 push @EXTS, $v->{pkg};
1171 $progress = 1;
1011 } 1172 }
1012 1173
1013 skip: 1174 skip:
1014 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1175 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1015 unless $progress; 1176 unless $progress;
1016 } 1177 }
1017 }; 1178 };
1018} 1179}
1019 1180
1020############################################################################# 1181#############################################################################
1182
1183=back
1021 1184
1022=head2 CORE EXTENSIONS 1185=head2 CORE EXTENSIONS
1023 1186
1024Functions and methods that extend core crossfire objects. 1187Functions and methods that extend core crossfire objects.
1025 1188
… …
1213 } 1376 }
1214 1377
1215 \@paths 1378 \@paths
1216} 1379}
1217 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
1218=item $player->ext_reply ($msgid, %msg) 1414=item $player->ext_reply ($msgid, %msg)
1219 1415
1220Sends an ext reply to the player. 1416Sends an ext reply to the player.
1221 1417
1222=cut 1418=cut
1223 1419
1224sub ext_reply($$%) { 1420sub ext_reply($$%) {
1225 my ($self, $id, %msg) = @_; 1421 my ($self, $id, %msg) = @_;
1226 1422
1227 $msg{msgid} = $id; 1423 $msg{msgid} = $id;
1228
1229 $self->send ("ext " . cf::to_json \%msg); 1424 $self->send ("ext " . cf::to_json \%msg);
1230} 1425}
1231 1426
1232=item $player->ext_event ($type, %msg) 1427=item $player->ext_event ($type, %msg)
1233 1428
… …
1249 1444
1250package cf::region; 1445package cf::region;
1251 1446
1252=item cf::region::find_by_path $path 1447=item cf::region::find_by_path $path
1253 1448
1254Tries 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.
1255 1450
1256=cut 1451=cut
1257 1452
1258sub find_by_path($) { 1453sub find_by_path($) {
1259 my ($path) = @_; 1454 my ($path) = @_;
… …
1911 2106
1912 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2107 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1913 2108
1914 if ($self->{record_replies}) { 2109 if ($self->{record_replies}) {
1915 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2110 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2111
1916 } 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 {
1917 $msg = $npc->name . " says: $msg" if $npc; 2125 $msg = $npc->name . " says: $msg" if $npc;
1918 $self->message ($msg, $flags); 2126 $self->message ($msg, $flags);
2127 }
1919 } 2128 }
1920} 2129}
1921 2130
1922=item $player_object->may ("access") 2131=item $player_object->may ("access")
1923 2132
… …
2168 2377
2169 utf8::encode $text; 2378 utf8::encode $text;
2170 $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);
2171} 2380}
2172 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
2173=item $client->ext_event ($type, %msg) 2420=item $client->ext_event ($type, %msg)
2174 2421
2175Sends an exti event to the client. 2422Sends an ext event to the client.
2176 2423
2177=cut 2424=cut
2178 2425
2179sub cf::client::ext_event($$%) { 2426sub cf::client::ext_event($$%) {
2180 my ($self, $type, %msg) = @_; 2427 my ($self, $type, %msg) = @_;
… …
2187 2434
2188Queues a query to the client, calling the given callback with 2435Queues a query to the client, calling the given callback with
2189the 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>,
2190C<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>.
2191 2438
2192Queries 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
2193reliable at some point in the future. 2440become reliable at some point in the future.
2194 2441
2195=cut 2442=cut
2196 2443
2197sub cf::client::query { 2444sub cf::client::query {
2198 my ($self, $flags, $text, $cb) = @_; 2445 my ($self, $flags, $text, $cb) = @_;
… …
2206 utf8::encode $text; 2453 utf8::encode $text;
2207 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2454 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2208 2455
2209 $self->send_packet ($self->{query_queue}[0][0]) 2456 $self->send_packet ($self->{query_queue}[0][0])
2210 if @{ $self->{query_queue} } == 1; 2457 if @{ $self->{query_queue} } == 1;
2458
2459 1
2211} 2460}
2212 2461
2213cf::client->attach ( 2462cf::client->attach (
2214 on_reply => sub { 2463 on_reply => sub {
2215 my ($ns, $msg) = @_; 2464 my ($ns, $msg) = @_;
… …
2229 $ns->send_packet ($ns->{query_queue}[0][0]); 2478 $ns->send_packet ($ns->{query_queue}[0][0]);
2230 } else { 2479 } else {
2231 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2480 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2232 } 2481 }
2233 } 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;
2234 }, 2501 },
2235); 2502);
2236 2503
2237=item $client->async (\&cb) 2504=item $client->async (\&cb)
2238 2505
… …
2375} 2642}
2376 2643
2377=back 2644=back
2378 2645
2379=cut 2646=cut
2380
2381#############################################################################
2382
2383=head2 EXTENSION DATABASE SUPPORT
2384
2385Crossfire maintains a very simple database for extension use. It can
2386currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2387convert to/from binary).
2388
2389The parameter C<$family> should best start with the name of the extension
2390using it, it should be unique.
2391
2392=over 4
2393
2394=item $value = cf::db_get $family => $key
2395
2396Returns a single value from the database.
2397
2398=item cf::db_put $family => $key => $value
2399
2400Stores the given C<$value> in the family.
2401
2402=cut
2403
2404our $DB;
2405
2406sub db_init {
2407 unless ($DB) {
2408 $DB = BDB::db_create $DB_ENV;
2409
2410 cf::sync_job {
2411 eval {
2412 $DB->set_flags (BDB::CHKSUM);
2413
2414 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2415 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2416 cf::cleanup "db_open(db): $!" if $!;
2417 };
2418 cf::cleanup "db_open(db): $@" if $@;
2419 };
2420 }
2421}
2422
2423sub db_get($$) {
2424 my $key = "$_[0]/$_[1]";
2425
2426 cf::sync_job {
2427 BDB::db_get $DB, undef, $key, my $data;
2428
2429 $! ? ()
2430 : $data
2431 }
2432}
2433
2434sub db_put($$$) {
2435 BDB::dbreq_pri 4;
2436 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2437}
2438
2439=item cf::cache $id => [$paths...], $processversion => $process
2440
2441Generic caching function that returns the value of the resource $id,
2442caching and regenerating as required.
2443
2444This function can block.
2445
2446=cut
2447
2448sub cache {
2449 my ($id, $src, $processversion, $process) = @_;
2450
2451 my $meta =
2452 join "\x00",
2453 $processversion,
2454 map {
2455 aio_stat $_
2456 and Carp::croak "$_: $!";
2457
2458 ($_, (stat _)[7,9])
2459 } @$src;
2460
2461 my $dbmeta = db_get cache => "$id/meta";
2462 if ($dbmeta ne $meta) {
2463 # changed, we may need to process
2464
2465 my @data;
2466 my $md5;
2467
2468 for (0 .. $#$src) {
2469 0 <= aio_load $src->[$_], $data[$_]
2470 or Carp::croak "$src->[$_]: $!";
2471 }
2472
2473 # if processing is expensive, check
2474 # checksum first
2475 if (1) {
2476 $md5 =
2477 join "\x00",
2478 $processversion,
2479 map {
2480 Coro::cede;
2481 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2482 } 0.. $#$src;
2483
2484
2485 my $dbmd5 = db_get cache => "$id/md5";
2486 if ($dbmd5 eq $md5) {
2487 db_put cache => "$id/meta", $meta;
2488
2489 return db_get cache => "$id/data";
2490 }
2491 }
2492
2493 my $t1 = Time::HiRes::time;
2494 my $data = $process->(\@data);
2495 my $t2 = Time::HiRes::time;
2496
2497 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2498
2499 db_put cache => "$id/data", $data;
2500 db_put cache => "$id/md5" , $md5;
2501 db_put cache => "$id/meta", $meta;
2502
2503 return $data;
2504 }
2505
2506 db_get cache => "$id/data"
2507}
2508
2509=item fork_call { }, $args
2510
2511Executes the given code block with the given arguments in a seperate
2512process, returning the results. Everything must be serialisable with
2513Coro::Storable. May, of course, block. Note that the executed sub may
2514never block itself or use any form of Event handling.
2515
2516=cut
2517
2518sub fork_call(&@) {
2519 my ($cb, @args) = @_;
2520
2521# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2522# or die "socketpair: $!";
2523 pipe my $fh1, my $fh2
2524 or die "pipe: $!";
2525
2526 if (my $pid = fork) {
2527 close $fh2;
2528
2529 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2530 $res = Coro::Storable::thaw $res;
2531
2532 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2533
2534 die $$res unless "ARRAY" eq ref $res;
2535
2536 return wantarray ? @$res : $res->[-1];
2537 } else {
2538 reset_signals;
2539 local $SIG{__WARN__};
2540 local $SIG{__DIE__};
2541 eval {
2542 close $fh1;
2543
2544 my @res = eval { $cb->(@args) };
2545 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2546 };
2547
2548 warn $@ if $@;
2549 _exit 0;
2550 }
2551}
2552 2647
2553############################################################################# 2648#############################################################################
2554# the server's init and main functions 2649# the server's init and main functions
2555 2650
2556sub load_facedata($) { 2651sub load_facedata($) {
… …
2695 }, 2790 },
2696 ); 2791 );
2697 } 2792 }
2698} 2793}
2699 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
2700sub emergency_save() { 2833sub emergency_save() {
2701 my $freeze_guard = cf::freeze_mainloop; 2834 my $freeze_guard = cf::freeze_mainloop;
2702 2835
2703 warn "enter emergency perl save\n"; 2836 warn "enter emergency perl save\n";
2704 2837
… …
2779 %EXT_CORO = (); 2912 %EXT_CORO = ();
2780 2913
2781 warn "removing commands"; 2914 warn "removing commands";
2782 %COMMAND = (); 2915 %COMMAND = ();
2783 2916
2784 warn "removing ext commands"; 2917 warn "removing ext/exti commands";
2785 %EXTCMD = (); 2918 %EXTCMD = ();
2919 %EXTICMD = ();
2786 2920
2787 warn "unloading/nuking all extensions"; 2921 warn "unloading/nuking all extensions";
2788 for my $pkg (@EXTS) { 2922 for my $pkg (@EXTS) {
2789 warn "... unloading $pkg"; 2923 warn "... unloading $pkg";
2790 2924

Diff Legend

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