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.298 by root, Sun Jul 8 14:50:07 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->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 warn "pst<$res>" unless $res =~ /^pst/;
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 Carp::confess $$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 local $Coro::idle;
439 $Coro::current->prio (Coro::PRIO_MAX);
440 eval {
441 close $fh1;
442
443 my @res = eval { $cb->(@args) };
444
445 open my $fh, ">", \my $buf
446 or die "fork_call: cannot open fh-to-buf in child : $!";
447 Storable::store_fd +($@ ? \"$@" : \@res), $fh;
448 close $fh;
449
450 warn "writing ", length $buf;
451 my $x;
452 (length $buf) == ($x = syswrite $fh2, $buf)
453 or warn "error writing ".(length $buf)." != $x\n";
454 close $fh2;
455 };
456
457 warn $@ if $@;
458 _exit 0;
430 1 459 }
460}
461
462=item $value = cf::db_get $family => $key
463
464Returns a single value from the environment database.
465
466=item cf::db_put $family => $key => $value
467
468Stores the given C<$value> in the family. It can currently store binary
469data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
470
471=cut
472
473our $DB;
474
475sub db_init {
476 unless ($DB) {
477 $DB = BDB::db_create $DB_ENV;
478
479 cf::sync_job {
480 eval {
481 $DB->set_flags (BDB::CHKSUM);
482
483 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
484 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
485 cf::cleanup "db_open(db): $!" if $!;
486 };
487 cf::cleanup "db_open(db): $@" if $@;
488 };
489 }
490}
491
492sub db_get($$) {
493 my $key = "$_[0]/$_[1]";
494
495 cf::sync_job {
496 BDB::db_get $DB, undef, $key, my $data;
497
498 $! ? ()
499 : $data
500 }
501}
502
503sub db_put($$$) {
504 BDB::dbreq_pri 4;
505 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
506}
507
508=item cf::cache $id => [$paths...], $processversion => $process
509
510Generic caching function that returns the value of the resource $id,
511caching and regenerating as required.
512
513This function can block.
514
515=cut
516
517sub cache {
518 my ($id, $src, $processversion, $process) = @_;
519
520 my $meta =
521 join "\x00",
522 $processversion,
523 map {
524 aio_stat $_
525 and Carp::croak "$_: $!";
526
527 ($_, (stat _)[7,9])
528 } @$src;
529
530 my $dbmeta = db_get cache => "$id/meta";
531 if ($dbmeta ne $meta) {
532 # changed, we may need to process
533
534 my @data;
535 my $md5;
536
537 for (0 .. $#$src) {
538 0 <= aio_load $src->[$_], $data[$_]
539 or Carp::croak "$src->[$_]: $!";
540 }
541
542 # if processing is expensive, check
543 # checksum first
544 if (1) {
545 $md5 =
546 join "\x00",
547 $processversion,
548 map {
549 Coro::cede;
550 ($src->[$_], Digest::MD5::md5_hex $data[$_])
551 } 0.. $#$src;
552
553
554 my $dbmd5 = db_get cache => "$id/md5";
555 if ($dbmd5 eq $md5) {
556 db_put cache => "$id/meta", $meta;
557
558 return db_get cache => "$id/data";
559 }
560 }
561
562 my $t1 = Time::HiRes::time;
563 my $data = $process->(\@data);
564 my $t2 = Time::HiRes::time;
565
566 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
567
568 db_put cache => "$id/data", $data;
569 db_put cache => "$id/md5" , $md5;
570 db_put cache => "$id/meta", $meta;
571
572 return $data;
573 }
574
575 db_get cache => "$id/data"
431} 576}
432 577
433=item cf::datalog type => key => value, ... 578=item cf::datalog type => key => value, ...
434 579
435Log a datalog packet of the given type with the given key-value pairs. 580Log 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") 598attach callbacks/event handlers (a collection of which is called an "attachment")
454to it. All such attachable objects support the following methods. 599to it. All such attachable objects support the following methods.
455 600
456In the following description, CLASS can be any of C<global>, C<object> 601In 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 602C<player>, C<client> or C<map> (i.e. the attachable objects in
458crossfire+). 603Crossfire TRT).
459 604
460=over 4 605=over 4
461 606
462=item $attachable->attach ($attachment, key => $value...) 607=item $attachable->attach ($attachment, key => $value...)
463 608
665 _attach $registry, $klass, @attach; 810 _attach $registry, $klass, @attach;
666 } 811 }
667 812
668 $obj->{$name} = \%arg; 813 $obj->{$name} = \%arg;
669 } else { 814 } else {
670 warn "object uses attachment '$name' that is not available, postponing.\n"; 815 warn "object uses attachment '$name' which is not available, postponing.\n";
671 } 816 }
672 817
673 $obj->{_attachment}{$name} = undef; 818 $obj->{_attachment}{$name} = undef;
674} 819}
675 820
877 warn sprintf "loading %s (%d)\n", 1022 warn sprintf "loading %s (%d)\n",
878 $filename, length $data, scalar @{$av || []}; 1023 $filename, length $data, scalar @{$av || []};
879 return ($data, $av); 1024 return ($data, $av);
880} 1025}
881 1026
1027=head2 COMMAND CALLBACKS
1028
1029=over 4
1030
1031=cut
1032
882############################################################################# 1033#############################################################################
883# command handling &c 1034# command handling &c
884 1035
885=item cf::register_command $name => \&callback($ob,$args); 1036=item cf::register_command $name => \&callback($ob,$args);
886 1037
898 push @{ $COMMAND{$name} }, [$caller, $cb]; 1049 push @{ $COMMAND{$name} }, [$caller, $cb];
899} 1050}
900 1051
901=item cf::register_extcmd $name => \&callback($pl,$packet); 1052=item cf::register_extcmd $name => \&callback($pl,$packet);
902 1053
903Register a callbackf ro execution when the client sends an extcmd packet. 1054Register a callback for execution when the client sends an (synchronous)
1055extcmd packet. Ext commands will be processed in the order they are
1056received by the server, like other user commands. The first argument is
1057the logged-in player. Ext commands can only be processed after a player
1058has logged in successfully.
904 1059
905If the callback returns something, it is sent back as if reply was being 1060If the callback returns something, it is sent back as if reply was being
906called. 1061called.
907 1062
1063=item cf::register_exticmd $name => \&callback($ns,$packet);
1064
1065Register a callback for execution when the client sends an (asynchronous)
1066exticmd packet. Exti commands are processed by the server as soon as they
1067are received, i.e. out of order w.r.t. other commands. The first argument
1068is a client socket. Exti commands can be received anytime, even before
1069log-in.
1070
1071If the callback returns something, it is sent back as if reply was being
1072called.
1073
908=cut 1074=cut
909 1075
910sub register_extcmd { 1076sub register_extcmd {
911 my ($name, $cb) = @_; 1077 my ($name, $cb) = @_;
912 1078
913 $EXTCMD{$name} = $cb; 1079 $EXTCMD{$name} = $cb;
1080}
1081
1082sub register_exticmd {
1083 my ($name, $cb) = @_;
1084
1085 $EXTICMD{$name} = $cb;
914} 1086}
915 1087
916cf::player->attach ( 1088cf::player->attach (
917 on_command => sub { 1089 on_command => sub {
918 my ($pl, $name, $params) = @_; 1090 my ($pl, $name, $params) = @_;
927 cf::override; 1099 cf::override;
928 }, 1100 },
929 on_extcmd => sub { 1101 on_extcmd => sub {
930 my ($pl, $buf) = @_; 1102 my ($pl, $buf) = @_;
931 1103
932 my $msg = eval { from_json $buf }; 1104 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
933 1105
934 if (ref $msg) { 1106 if (ref $msg) {
935 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1107 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
936 if (my %reply = $cb->($pl, $msg)) { 1108 if (my %reply = $cb->($pl, $msg)) {
937 $pl->ext_reply ($msg->{msgid}, %reply); 1109 $pl->ext_reply ($msg->{msgid}, %reply);
967 path => $path, 1139 path => $path,
968 base => $base, 1140 base => $base,
969 pkg => $pkg, 1141 pkg => $pkg,
970 ); 1142 );
971 1143
972 $ext{meta} = { map { split /=/, $_, 2 } split /\s+/, $1 } 1144 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
973 if $source =~ /^#!.*?perl.*?#\s*(.*)$/; 1145 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
974 1146
975 $ext{source} = 1147 $ext{source} =
976 "package $pkg; use strict; use utf8;\n" 1148 "package $pkg; use strict; use utf8;\n"
977 . "#line 1 \"$path\"\n{\n" 1149 . "#line 1 \"$path\"\n{\n"
978 . $source 1150 . $source
984 my %done; 1156 my %done;
985 while (%todo) { 1157 while (%todo) {
986 my $progress; 1158 my $progress;
987 1159
988 while (my ($k, $v) = each %todo) { 1160 while (my ($k, $v) = each %todo) {
989 for (split /,\s*/, $ext{meta}{depends}) { 1161 for (split /,\s*/, $v->{meta}{depends}) {
990 goto skip 1162 goto skip
991 unless exists $done{$_}; 1163 unless exists $done{$_};
992 } 1164 }
993 1165
994 warn "... loading '$k' into '$v->{pkg}'\n"; 1166 warn "... loading '$k' into '$v->{pkg}'\n";
995 1167
996 unless (eval $v->{source}) { 1168 unless (eval $v->{source}) {
997 my $msg = $@ ? "$v->{path}: $@\n" 1169 my $msg = $@ ? "$v->{path}: $@\n"
998 : "extension disabled.\n"; 1170 : "$v->{base}: extension inactive.\n";
999 1171
1000 if (exists $v->{meta}{mandatory}) { 1172 if (exists $v->{meta}{mandatory}) {
1001 warn $msg; 1173 warn $msg;
1002 warn "mandatory extension failed to load, exiting.\n"; 1174 warn "mandatory extension failed to load, exiting.\n";
1003 exit 1; 1175 exit 1;
1004 } 1176 }
1005 1177
1006 die $msg; 1178 warn $msg;
1007 } 1179 }
1008 1180
1009 $done{$k} = delete $todo{$k}; 1181 $done{$k} = delete $todo{$k};
1010 push @EXTS, $v->{pkg}; 1182 push @EXTS, $v->{pkg};
1183 $progress = 1;
1011 } 1184 }
1012 1185
1013 skip: 1186 skip:
1014 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1187 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1015 unless $progress; 1188 unless $progress;
1016 } 1189 }
1017 }; 1190 };
1018} 1191}
1019 1192
1020############################################################################# 1193#############################################################################
1194
1195=back
1021 1196
1022=head2 CORE EXTENSIONS 1197=head2 CORE EXTENSIONS
1023 1198
1024Functions and methods that extend core crossfire objects. 1199Functions and methods that extend core crossfire objects.
1025 1200
1213 } 1388 }
1214 1389
1215 \@paths 1390 \@paths
1216} 1391}
1217 1392
1393=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1394
1395Expand crossfire pod fragments into protocol xml.
1396
1397=cut
1398
1399sub expand_cfpod {
1400 ((my $self), (local $_)) = @_;
1401
1402 # escape & and <
1403 s/&/&amp;/g;
1404 s/(?<![BIUGH])</&lt;/g;
1405
1406 # this is buggy, it needs to properly take care of nested <'s
1407
1408 1 while
1409 # replace B<>, I<>, U<> etc.
1410 s/B<([^\>]*)>/<b>$1<\/b>/
1411 || s/I<([^\>]*)>/<i>$1<\/i>/
1412 || s/U<([^\>]*)>/<u>$1<\/u>/
1413 # replace G<male|female> tags
1414 || s{G<([^>|]*)\|([^>]*)>}{
1415 $self->gender ? $2 : $1
1416 }ge
1417 # replace H<hint text>
1418 || s{H<([^\>]*)>}
1419 {
1420 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1421 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1422 "")
1423 [$self->{hintmode}]
1424 }ge;
1425
1426 # create single paragraphs (very hackish)
1427 s/(?<=\S)\n(?=\w)/ /g;
1428
1429 # compress some whitespace
1430 s/\s+\n/\n/g; # ws line-ends
1431 s/\n\n+/\n/g; # double lines
1432 s/^\n+//; # beginning lines
1433 s/\n+$//; # ending lines
1434
1435 $_
1436}
1437
1438sub hintmode {
1439 $_[0]{hintmode} = $_[1] if @_ > 1;
1440 $_[0]{hintmode}
1441}
1442
1218=item $player->ext_reply ($msgid, %msg) 1443=item $player->ext_reply ($msgid, %msg)
1219 1444
1220Sends an ext reply to the player. 1445Sends an ext reply to the player.
1221 1446
1222=cut 1447=cut
1223 1448
1224sub ext_reply($$%) { 1449sub ext_reply($$%) {
1225 my ($self, $id, %msg) = @_; 1450 my ($self, $id, %msg) = @_;
1226 1451
1227 $msg{msgid} = $id; 1452 $msg{msgid} = $id;
1228 1453 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1229 $self->send ("ext " . cf::to_json \%msg);
1230} 1454}
1231 1455
1232=item $player->ext_event ($type, %msg) 1456=item $player->ext_event ($type, %msg)
1233 1457
1234Sends an ext event to the client. 1458Sends an ext event to the client.
1249 1473
1250package cf::region; 1474package cf::region;
1251 1475
1252=item cf::region::find_by_path $path 1476=item cf::region::find_by_path $path
1253 1477
1254Tries to decuce the probable region for a map knowing only its path. 1478Tries to decuce the likely region for a map knowing only its path.
1255 1479
1256=cut 1480=cut
1257 1481
1258sub find_by_path($) { 1482sub find_by_path($) {
1259 my ($path) = @_; 1483 my ($path) = @_;
1911 2135
1912 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2136 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1913 2137
1914 if ($self->{record_replies}) { 2138 if ($self->{record_replies}) {
1915 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2139 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2140
1916 } else { 2141 } else {
2142 my $pl = $self->contr;
2143
2144 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2145 my $diag = $pl->{npc_dialog};
2146 $diag->{pl}->ext_reply (
2147 $diag->{id},
2148 msgtype => "reply",
2149 msg => $diag->{pl}->expand_cfpod ($msg),
2150 add_topics => []
2151 );
2152
2153 } else {
1917 $msg = $npc->name . " says: $msg" if $npc; 2154 $msg = $npc->name . " says: $msg" if $npc;
1918 $self->message ($msg, $flags); 2155 $self->message ($msg, $flags);
2156 }
1919 } 2157 }
1920} 2158}
1921 2159
1922=item $player_object->may ("access") 2160=item $player_object->may ("access")
1923 2161
2132 my $hp = $exit->stats->hp; 2370 my $hp = $exit->stats->hp;
2133 my $sp = $exit->stats->sp; 2371 my $sp = $exit->stats->sp;
2134 2372
2135 $self->enter_link; 2373 $self->enter_link;
2136 2374
2375 # if exit is damned, update players death & WoR home-position
2376 $self->contr->savebed ($slaying, $hp, $sp)
2377 if $exit->flag (FLAG_DAMNED);
2378
2137 (async { 2379 (async {
2138 $self->deactivate_recursive; # just to be sure 2380 $self->deactivate_recursive; # just to be sure
2139 unless (eval { 2381 unless (eval {
2140 $self->goto ($slaying, $hp, $sp); 2382 $self->goto ($slaying, $hp, $sp);
2141 2383
2168 2410
2169 utf8::encode $text; 2411 utf8::encode $text;
2170 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2412 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2171} 2413}
2172 2414
2415=item $client->send_msg ($color, $type, $msg, [extra...])
2416
2417Send a drawinfo or msg packet to the client, formatting the msg for the
2418client if neccessary. C<$type> should be a string identifying the type of
2419the message, with C<log> being the default. If C<$color> is negative, suppress
2420the message unless the client supports the msg packet.
2421
2422=cut
2423
2424sub cf::client::send_msg {
2425 my ($self, $color, $type, $msg, @extra) = @_;
2426
2427 $msg = $self->pl->expand_cfpod ($msg);
2428
2429 return unless @extra || length $msg;
2430
2431 if ($self->can_msg) {
2432 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2433 } else {
2434 # replace some tags by gcfclient-compatible ones
2435 for ($msg) {
2436 1 while
2437 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2438 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2439 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2440 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2441 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2442 }
2443
2444 if ($color >= 0) {
2445 if (0 && $msg =~ /\[/) {
2446 $self->send_packet ("drawextinfo $color 4 0 $msg")
2447 } else {
2448 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2449 $self->send_packet ("drawinfo $color $msg")
2450 }
2451 }
2452 }
2453}
2454
2173=item $client->ext_event ($type, %msg) 2455=item $client->ext_event ($type, %msg)
2174 2456
2175Sends an exti event to the client. 2457Sends an ext event to the client.
2176 2458
2177=cut 2459=cut
2178 2460
2179sub cf::client::ext_event($$%) { 2461sub cf::client::ext_event($$%) {
2180 my ($self, $type, %msg) = @_; 2462 my ($self, $type, %msg) = @_;
2181 2463
2182 $msg{msgtype} = "event_$type"; 2464 $msg{msgtype} = "event_$type";
2183 $self->send_packet ("ext " . cf::to_json \%msg); 2465 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2184} 2466}
2185 2467
2186=item $success = $client->query ($flags, "text", \&cb) 2468=item $success = $client->query ($flags, "text", \&cb)
2187 2469
2188Queues a query to the client, calling the given callback with 2470Queues a query to the client, calling the given callback with
2189the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2471the 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>. 2472C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2191 2473
2192Queries can fail, so check the return code. Or don't, as queries will become 2474Queries can fail, so check the return code. Or don't, as queries will
2193reliable at some point in the future. 2475become reliable at some point in the future.
2194 2476
2195=cut 2477=cut
2196 2478
2197sub cf::client::query { 2479sub cf::client::query {
2198 my ($self, $flags, $text, $cb) = @_; 2480 my ($self, $flags, $text, $cb) = @_;
2206 utf8::encode $text; 2488 utf8::encode $text;
2207 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2489 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2208 2490
2209 $self->send_packet ($self->{query_queue}[0][0]) 2491 $self->send_packet ($self->{query_queue}[0][0])
2210 if @{ $self->{query_queue} } == 1; 2492 if @{ $self->{query_queue} } == 1;
2493
2494 1
2211} 2495}
2212 2496
2213cf::client->attach ( 2497cf::client->attach (
2498 on_connect => sub {
2499 my ($ns) = @_;
2500
2501 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2502 },
2214 on_reply => sub { 2503 on_reply => sub {
2215 my ($ns, $msg) = @_; 2504 my ($ns, $msg) = @_;
2216 2505
2217 # this weird shuffling is so that direct followup queries 2506 # this weird shuffling is so that direct followup queries
2218 # get handled first 2507 # get handled first
2230 } else { 2519 } else {
2231 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2520 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2232 } 2521 }
2233 } 2522 }
2234 }, 2523 },
2524 on_exticmd => sub {
2525 my ($ns, $buf) = @_;
2526
2527 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2528
2529 if (ref $msg) {
2530 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2531 if (my %reply = $cb->($ns, $msg)) {
2532 $reply{msgid} = $msg->{msgid};
2533 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2534 }
2535 }
2536 } else {
2537 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2538 }
2539
2540 cf::override;
2541 },
2235); 2542);
2236 2543
2237=item $client->async (\&cb) 2544=item $client->async (\&cb)
2238 2545
2239Create a new coroutine, running the specified callback. The coroutine will 2546Create a new coroutine, running the specified callback. The coroutine will
2288 2595
2289=pod 2596=pod
2290 2597
2291The following functions and methods are available within a safe environment: 2598The following functions and methods are available within a safe environment:
2292 2599
2293 cf::object contr pay_amount pay_player map 2600 cf::object
2601 contr pay_amount pay_player map x y force_find force_add
2602 insert remove
2603
2294 cf::object::player player 2604 cf::object::player
2295 cf::player peaceful 2605 player
2296 cf::map trigger 2606
2607 cf::player
2608 peaceful
2609
2610 cf::map
2611 trigger
2297 2612
2298=cut 2613=cut
2299 2614
2300for ( 2615for (
2301 ["cf::object" => qw(contr pay_amount pay_player map)], 2616 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2617 insert remove)],
2302 ["cf::object::player" => qw(player)], 2618 ["cf::object::player" => qw(player)],
2303 ["cf::player" => qw(peaceful)], 2619 ["cf::player" => qw(peaceful)],
2304 ["cf::map" => qw(trigger)], 2620 ["cf::map" => qw(trigger)],
2305) { 2621) {
2306 no strict 'refs'; 2622 no strict 'refs';
2375} 2691}
2376 2692
2377=back 2693=back
2378 2694
2379=cut 2695=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 2696
2553############################################################################# 2697#############################################################################
2554# the server's init and main functions 2698# the server's init and main functions
2555 2699
2556sub load_facedata($) { 2700sub load_facedata($) {
2614 load_facedata "$DATADIR/facedata" 2758 load_facedata "$DATADIR/facedata"
2615 or die "unable to load facedata\n"; 2759 or die "unable to load facedata\n";
2616} 2760}
2617 2761
2618sub reload_archetypes { 2762sub reload_archetypes {
2763 load_resource_file "$DATADIR/archetypes"
2764 or die "unable to load archetypes\n";
2765 #d# NEED to laod twice to resolve forward references
2766 # this really needs to be done in an extra post-pass
2767 # (which needs to be synchronous, so solve it differently)
2619 load_resource_file "$DATADIR/archetypes" 2768 load_resource_file "$DATADIR/archetypes"
2620 or die "unable to load archetypes\n"; 2769 or die "unable to load archetypes\n";
2621} 2770}
2622 2771
2623sub reload_treasures { 2772sub reload_treasures {
2695 }, 2844 },
2696 ); 2845 );
2697 } 2846 }
2698} 2847}
2699 2848
2849sub write_runtime {
2850 my $runtime = "$LOCALDIR/runtime";
2851
2852 # first touch the runtime file to show we are still running:
2853 # the fsync below can take a very very long time.
2854
2855 IO::AIO::aio_utime $runtime, undef, undef;
2856
2857 my $guard = cf::lock_acquire "write_runtime";
2858
2859 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2860 or return;
2861
2862 my $value = $cf::RUNTIME + 90 + 10;
2863 # 10 is the runtime save interval, for a monotonic clock
2864 # 60 allows for the watchdog to kill the server.
2865
2866 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2867 and return;
2868
2869 # always fsync - this file is important
2870 aio_fsync $fh
2871 and return;
2872
2873 # touch it again to show we are up-to-date
2874 aio_utime $fh, undef, undef;
2875
2876 close $fh
2877 or return;
2878
2879 aio_rename "$runtime~", $runtime
2880 and return;
2881
2882 warn "runtime file written.\n";
2883
2884 1
2885}
2886
2700sub emergency_save() { 2887sub emergency_save() {
2701 my $freeze_guard = cf::freeze_mainloop; 2888 my $freeze_guard = cf::freeze_mainloop;
2702 2889
2703 warn "enter emergency perl save\n"; 2890 warn "enter emergency perl save\n";
2704 2891
2779 %EXT_CORO = (); 2966 %EXT_CORO = ();
2780 2967
2781 warn "removing commands"; 2968 warn "removing commands";
2782 %COMMAND = (); 2969 %COMMAND = ();
2783 2970
2784 warn "removing ext commands"; 2971 warn "removing ext/exti commands";
2785 %EXTCMD = (); 2972 %EXTCMD = ();
2973 %EXTICMD = ();
2786 2974
2787 warn "unloading/nuking all extensions"; 2975 warn "unloading/nuking all extensions";
2788 for my $pkg (@EXTS) { 2976 for my $pkg (@EXTS) {
2789 warn "... unloading $pkg"; 2977 warn "... unloading $pkg";
2790 2978

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines