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.277 by root, Sun Jun 10 04:24:50 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) = @_;
… …
943 1103
944 cf::override; 1104 cf::override;
945 }, 1105 },
946); 1106);
947 1107
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 { 1108sub load_extensions {
1109 cf::sync_job {
1110 my %todo;
1111
983 for my $ext (<$LIBDIR/*.ext>) { 1112 for my $path (<$LIBDIR/*.ext>) {
984 next unless -r $ext; 1113 next unless -r $path;
985 eval { 1114
986 load_extension $ext; 1115 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1116 my $base = $1;
1117 my $pkg = $1;
1118 $pkg =~ s/[^[:word:]]/_/g;
1119 $pkg = "ext::$pkg";
1120
1121 open my $fh, "<:utf8", $path
1122 or die "$path: $!";
1123
1124 my $source = do { local $/; <$fh> };
1125
1126 my %ext = (
1127 path => $path,
1128 base => $base,
1129 pkg => $pkg,
1130 );
1131
1132 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1133 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1134
1135 $ext{source} =
1136 "package $pkg; use strict; use utf8;\n"
1137 . "#line 1 \"$path\"\n{\n"
1138 . $source
1139 . "\n};\n1";
1140
1141 $todo{$base} = \%ext;
1142 }
1143
1144 my %done;
1145 while (%todo) {
1146 my $progress;
1147
1148 while (my ($k, $v) = each %todo) {
1149 for (split /,\s*/, $v->{meta}{depends}) {
1150 goto skip
1151 unless exists $done{$_};
1152 }
1153
1154 warn "... loading '$k' into '$v->{pkg}'\n";
1155
1156 unless (eval $v->{source}) {
1157 my $msg = $@ ? "$v->{path}: $@\n"
1158 : "$v->{base}: extension inactive.\n";
1159
1160 if (exists $v->{meta}{mandatory}) {
1161 warn $msg;
1162 warn "mandatory extension failed to load, exiting.\n";
1163 exit 1;
1164 }
1165
1166 warn $msg;
1167 }
1168
1169 $done{$k} = delete $todo{$k};
1170 push @EXTS, $v->{pkg};
1171 $progress = 1;
987 1 1172 }
988 } or warn "$ext not loaded: $@"; 1173
1174 skip:
1175 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1176 unless $progress;
1177 }
989 } 1178 };
990} 1179}
991 1180
992############################################################################# 1181#############################################################################
1182
1183=back
993 1184
994=head2 CORE EXTENSIONS 1185=head2 CORE EXTENSIONS
995 1186
996Functions and methods that extend core crossfire objects. 1187Functions and methods that extend core crossfire objects.
997 1188
… …
1185 } 1376 }
1186 1377
1187 \@paths 1378 \@paths
1188} 1379}
1189 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
1190=item $player->ext_reply ($msgid, %msg) 1414=item $player->ext_reply ($msgid, %msg)
1191 1415
1192Sends an ext reply to the player. 1416Sends an ext reply to the player.
1193 1417
1194=cut 1418=cut
1195 1419
1196sub ext_reply($$%) { 1420sub ext_reply($$%) {
1197 my ($self, $id, %msg) = @_; 1421 my ($self, $id, %msg) = @_;
1198 1422
1199 $msg{msgid} = $id; 1423 $msg{msgid} = $id;
1200
1201 $self->send ("ext " . cf::to_json \%msg); 1424 $self->send ("ext " . cf::to_json \%msg);
1202} 1425}
1203 1426
1204=item $player->ext_event ($type, %msg) 1427=item $player->ext_event ($type, %msg)
1205 1428
… …
1221 1444
1222package cf::region; 1445package cf::region;
1223 1446
1224=item cf::region::find_by_path $path 1447=item cf::region::find_by_path $path
1225 1448
1226Tries 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.
1227 1450
1228=cut 1451=cut
1229 1452
1230sub find_by_path($) { 1453sub find_by_path($) {
1231 my ($path) = @_; 1454 my ($path) = @_;
… …
1883 2106
1884 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2107 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1885 2108
1886 if ($self->{record_replies}) { 2109 if ($self->{record_replies}) {
1887 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2110 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2111
1888 } 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 {
1889 $msg = $npc->name . " says: $msg" if $npc; 2125 $msg = $npc->name . " says: $msg" if $npc;
1890 $self->message ($msg, $flags); 2126 $self->message ($msg, $flags);
2127 }
1891 } 2128 }
1892} 2129}
1893 2130
1894=item $player_object->may ("access") 2131=item $player_object->may ("access")
1895 2132
… …
2140 2377
2141 utf8::encode $text; 2378 utf8::encode $text;
2142 $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);
2143} 2380}
2144 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
2145=item $client->ext_event ($type, %msg) 2420=item $client->ext_event ($type, %msg)
2146 2421
2147Sends an exti event to the client. 2422Sends an ext event to the client.
2148 2423
2149=cut 2424=cut
2150 2425
2151sub cf::client::ext_event($$%) { 2426sub cf::client::ext_event($$%) {
2152 my ($self, $type, %msg) = @_; 2427 my ($self, $type, %msg) = @_;
… …
2159 2434
2160Queues a query to the client, calling the given callback with 2435Queues a query to the client, calling the given callback with
2161the 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>,
2162C<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>.
2163 2438
2164Queries 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
2165reliable at some point in the future. 2440become reliable at some point in the future.
2166 2441
2167=cut 2442=cut
2168 2443
2169sub cf::client::query { 2444sub cf::client::query {
2170 my ($self, $flags, $text, $cb) = @_; 2445 my ($self, $flags, $text, $cb) = @_;
… …
2178 utf8::encode $text; 2453 utf8::encode $text;
2179 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2454 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2180 2455
2181 $self->send_packet ($self->{query_queue}[0][0]) 2456 $self->send_packet ($self->{query_queue}[0][0])
2182 if @{ $self->{query_queue} } == 1; 2457 if @{ $self->{query_queue} } == 1;
2458
2459 1
2183} 2460}
2184 2461
2185cf::client->attach ( 2462cf::client->attach (
2186 on_reply => sub { 2463 on_reply => sub {
2187 my ($ns, $msg) = @_; 2464 my ($ns, $msg) = @_;
… …
2201 $ns->send_packet ($ns->{query_queue}[0][0]); 2478 $ns->send_packet ($ns->{query_queue}[0][0]);
2202 } else { 2479 } else {
2203 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2480 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2204 } 2481 }
2205 } 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;
2206 }, 2501 },
2207); 2502);
2208 2503
2209=item $client->async (\&cb) 2504=item $client->async (\&cb)
2210 2505
… …
2347} 2642}
2348 2643
2349=back 2644=back
2350 2645
2351=cut 2646=cut
2352
2353#############################################################################
2354
2355=head2 EXTENSION DATABASE SUPPORT
2356
2357Crossfire maintains a very simple database for extension use. It can
2358currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2359convert to/from binary).
2360
2361The parameter C<$family> should best start with the name of the extension
2362using it, it should be unique.
2363
2364=over 4
2365
2366=item $value = cf::db_get $family => $key
2367
2368Returns a single value from the database.
2369
2370=item cf::db_put $family => $key => $value
2371
2372Stores the given C<$value> in the family.
2373
2374=cut
2375
2376our $DB;
2377
2378sub db_init {
2379 unless ($DB) {
2380 $DB = BDB::db_create $DB_ENV;
2381
2382 cf::sync_job {
2383 eval {
2384 $DB->set_flags (BDB::CHKSUM);
2385
2386 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2387 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2388 cf::cleanup "db_open(db): $!" if $!;
2389 };
2390 cf::cleanup "db_open(db): $@" if $@;
2391 };
2392 }
2393}
2394
2395sub db_get($$) {
2396 my $key = "$_[0]/$_[1]";
2397
2398 cf::sync_job {
2399 BDB::db_get $DB, undef, $key, my $data;
2400
2401 $! ? ()
2402 : $data
2403 }
2404}
2405
2406sub db_put($$$) {
2407 BDB::dbreq_pri 4;
2408 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2409}
2410
2411=item cf::cache $id => [$paths...], $processversion => $process
2412
2413Generic caching function that returns the value of the resource $id,
2414caching and regenerating as required.
2415
2416This function can block.
2417
2418=cut
2419
2420sub cache {
2421 my ($id, $src, $processversion, $process) = @_;
2422
2423 my $meta =
2424 join "\x00",
2425 $processversion,
2426 map {
2427 aio_stat $_
2428 and Carp::croak "$_: $!";
2429
2430 ($_, (stat _)[7,9])
2431 } @$src;
2432
2433 my $dbmeta = db_get cache => "$id/meta";
2434 if ($dbmeta ne $meta) {
2435 # changed, we may need to process
2436
2437 my @data;
2438 my $md5;
2439
2440 for (0 .. $#$src) {
2441 0 <= aio_load $src->[$_], $data[$_]
2442 or Carp::croak "$src->[$_]: $!";
2443 }
2444
2445 # if processing is expensive, check
2446 # checksum first
2447 if (1) {
2448 $md5 =
2449 join "\x00",
2450 $processversion,
2451 map {
2452 Coro::cede;
2453 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2454 } 0.. $#$src;
2455
2456
2457 my $dbmd5 = db_get cache => "$id/md5";
2458 if ($dbmd5 eq $md5) {
2459 db_put cache => "$id/meta", $meta;
2460
2461 return db_get cache => "$id/data";
2462 }
2463 }
2464
2465 my $t1 = Time::HiRes::time;
2466 my $data = $process->(\@data);
2467 my $t2 = Time::HiRes::time;
2468
2469 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2470
2471 db_put cache => "$id/data", $data;
2472 db_put cache => "$id/md5" , $md5;
2473 db_put cache => "$id/meta", $meta;
2474
2475 return $data;
2476 }
2477
2478 db_get cache => "$id/data"
2479}
2480
2481=item fork_call { }, $args
2482
2483Executes the given code block with the given arguments in a seperate
2484process, returning the results. Everything must be serialisable with
2485Coro::Storable. May, of course, block. Note that the executed sub may
2486never block itself or use any form of Event handling.
2487
2488=cut
2489
2490sub fork_call(&@) {
2491 my ($cb, @args) = @_;
2492
2493# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2494# or die "socketpair: $!";
2495 pipe my $fh1, my $fh2
2496 or die "pipe: $!";
2497
2498 if (my $pid = fork) {
2499 close $fh2;
2500
2501 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2502 $res = Coro::Storable::thaw $res;
2503
2504 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2505
2506 die $$res unless "ARRAY" eq ref $res;
2507
2508 return wantarray ? @$res : $res->[-1];
2509 } else {
2510 reset_signals;
2511 local $SIG{__WARN__};
2512 local $SIG{__DIE__};
2513 eval {
2514 close $fh1;
2515
2516 my @res = eval { $cb->(@args) };
2517 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2518 };
2519
2520 warn $@ if $@;
2521 _exit 0;
2522 }
2523}
2524 2647
2525############################################################################# 2648#############################################################################
2526# the server's init and main functions 2649# the server's init and main functions
2527 2650
2528sub load_facedata($) { 2651sub load_facedata($) {
… …
2667 }, 2790 },
2668 ); 2791 );
2669 } 2792 }
2670} 2793}
2671 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
2672sub emergency_save() { 2833sub emergency_save() {
2673 my $freeze_guard = cf::freeze_mainloop; 2834 my $freeze_guard = cf::freeze_mainloop;
2674 2835
2675 warn "enter emergency perl save\n"; 2836 warn "enter emergency perl save\n";
2676 2837
… …
2751 %EXT_CORO = (); 2912 %EXT_CORO = ();
2752 2913
2753 warn "removing commands"; 2914 warn "removing commands";
2754 %COMMAND = (); 2915 %COMMAND = ();
2755 2916
2756 warn "removing ext commands"; 2917 warn "removing ext/exti commands";
2757 %EXTCMD = (); 2918 %EXTCMD = ();
2919 %EXTICMD = ();
2758 2920
2759 warn "unloading/nuking all extensions"; 2921 warn "unloading/nuking all extensions";
2760 for my $pkg (@EXTS) { 2922 for my $pkg (@EXTS) {
2761 warn "... unloading $pkg"; 2923 warn "... unloading $pkg";
2762 2924

Diff Legend

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