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.283 by root, Sun Jun 24 04:09:29 2007 UTC

… …
206} 206}
207 207
208$Event::DIED = sub { 208$Event::DIED = sub {
209 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
210}; 210};
211
212#############################################################################
211 213
212=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
213 215
214=over 4 216=over 4
215 217
… …
318 320
319BEGIN { *async = \&Coro::async_pool } 321BEGIN { *async = \&Coro::async_pool }
320 322
321=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
322 324
323The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
324always able to handle events or runnable, as crossfire+ is only partly 326is 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. 327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable.
326 329
327If it must be done, put the blocking parts into C<sync_job>. This will run 330If 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 331the given BLOCK in another coroutine while waiting for the result. The
329server will be frozen during this time, so the block should either finish 332server will be frozen during this time, so the block should either finish
330fast or be very important. 333fast or be very important.
… …
390 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
391 394
392 $coro 395 $coro
393} 396}
394 397
395sub write_runtime { 398=item fork_call { }, $args
396 my $runtime = "$LOCALDIR/runtime";
397 399
398 # first touch the runtime file to show we are still running: 400Executes the given code block with the given arguments in a seperate
399 # the fsync below can take a very very long time. 401process, returning the results. Everything must be serialisable with
402Coro::Storable. May, of course, block. Note that the executed sub may
403never block itself or use any form of Event handling.
400 404
401 IO::AIO::aio_utime $runtime, undef, undef; 405=cut
402 406
403 my $guard = cf::lock_acquire "write_runtime"; 407sub fork_call(&@) {
408 my ($cb, @args) = @_;
404 409
405 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
406 or return; 411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
407 414
408 my $value = $cf::RUNTIME + 90 + 10; 415 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 416 close $fh2;
423 or return;
424 417
425 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
426 and return; 419 $res = Coro::Storable::thaw $res;
427 420
428 warn "runtime file written.\n"; 421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429 422
423 die $$res unless "ARRAY" eq ref $res;
424
425 return wantarray ? @$res : $res->[-1];
426 } else {
427 reset_signals;
428 local $SIG{__WARN__};
429 local $SIG{__DIE__};
430 eval {
431 close $fh1;
432
433 my @res = eval { $cb->(@args) };
434 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
435 };
436
437 warn $@ if $@;
438 _exit 0;
430 1 439 }
440}
441
442=item $value = cf::db_get $family => $key
443
444Returns a single value from the environment database.
445
446=item cf::db_put $family => $key => $value
447
448Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450
451=cut
452
453our $DB;
454
455sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job {
460 eval {
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 }
470}
471
472sub db_get($$) {
473 my $key = "$_[0]/$_[1]";
474
475 cf::sync_job {
476 BDB::db_get $DB, undef, $key, my $data;
477
478 $! ? ()
479 : $data
480 }
481}
482
483sub db_put($$$) {
484 BDB::dbreq_pri 4;
485 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
486}
487
488=item cf::cache $id => [$paths...], $processversion => $process
489
490Generic caching function that returns the value of the resource $id,
491caching and regenerating as required.
492
493This function can block.
494
495=cut
496
497sub cache {
498 my ($id, $src, $processversion, $process) = @_;
499
500 my $meta =
501 join "\x00",
502 $processversion,
503 map {
504 aio_stat $_
505 and Carp::croak "$_: $!";
506
507 ($_, (stat _)[7,9])
508 } @$src;
509
510 my $dbmeta = db_get cache => "$id/meta";
511 if ($dbmeta ne $meta) {
512 # changed, we may need to process
513
514 my @data;
515 my $md5;
516
517 for (0 .. $#$src) {
518 0 <= aio_load $src->[$_], $data[$_]
519 or Carp::croak "$src->[$_]: $!";
520 }
521
522 # if processing is expensive, check
523 # checksum first
524 if (1) {
525 $md5 =
526 join "\x00",
527 $processversion,
528 map {
529 Coro::cede;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src;
532
533
534 my $dbmd5 = db_get cache => "$id/md5";
535 if ($dbmd5 eq $md5) {
536 db_put cache => "$id/meta", $meta;
537
538 return db_get cache => "$id/data";
539 }
540 }
541
542 my $t1 = Time::HiRes::time;
543 my $data = $process->(\@data);
544 my $t2 = Time::HiRes::time;
545
546 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
547
548 db_put cache => "$id/data", $data;
549 db_put cache => "$id/md5" , $md5;
550 db_put cache => "$id/meta", $meta;
551
552 return $data;
553 }
554
555 db_get cache => "$id/data"
431} 556}
432 557
433=item cf::datalog type => key => value, ... 558=item cf::datalog type => key => value, ...
434 559
435Log a datalog packet of the given type with the given key-value pairs. 560Log 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") 578attach callbacks/event handlers (a collection of which is called an "attachment")
454to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
455 580
456In the following description, CLASS can be any of C<global>, C<object> 581In 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 582C<player>, C<client> or C<map> (i.e. the attachable objects in
458crossfire+). 583Crossfire TRT).
459 584
460=over 4 585=over 4
461 586
462=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
463 588
… …
665 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
666 } 791 }
667 792
668 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
669 } else { 794 } else {
670 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
671 } 796 }
672 797
673 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
674} 799}
675 800
… …
877 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
878 $filename, length $data, scalar @{$av || []}; 1003 $filename, length $data, scalar @{$av || []};
879 return ($data, $av); 1004 return ($data, $av);
880} 1005}
881 1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
1012
882############################################################################# 1013#############################################################################
883# command handling &c 1014# command handling &c
884 1015
885=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
886 1017
… …
898 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
899} 1030}
900 1031
901=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
902 1033
903Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
904 1035
905If the callback returns something, it is sent back as if reply was being 1036If the callback returns something, it is sent back as if reply was being
906called. 1037called.
907 1038
908=cut 1039=cut
… …
1018 }; 1149 };
1019} 1150}
1020 1151
1021############################################################################# 1152#############################################################################
1022 1153
1154=back
1155
1023=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
1024 1157
1025Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
1026 1159
1027=cut 1160=cut
… …
1214 } 1347 }
1215 1348
1216 \@paths 1349 \@paths
1217} 1350}
1218 1351
1352=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1353
1354Expand crossfire pod fragments into protocol xml.
1355
1356=cut
1357
1358sub expand_cfpod {
1359 ((my $self), (local $_)) = @_;
1360
1361 # escape & and <
1362 s/&/&amp;/g;
1363 s/(?<![BIUGH])</&lt;/g;
1364
1365 # this is buggy, it needs to properly take care of nested <'s
1366
1367 1 while
1368 # replace B<>, I<>, U<> etc.
1369 s/B<([^\>]*)>/<b>$1<\/b>/
1370 || s/I<([^\>]*)>/<i>$1<\/i>/
1371 || s/U<([^\>]*)>/<u>$1<\/u>/
1372 # replace G<male|female> tags
1373 || s{G<([^>|]*)\|([^>]*)>}{
1374 $self->gender ? $2 : $1
1375 }ge
1376 # replace H<hint text>
1377 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1378
1379 # create single paragraphs (very hackish)
1380 s/(?<=\S)\n(?=\w)/ /g;
1381
1382 $_
1383}
1384
1219=item $player->ext_reply ($msgid, %msg) 1385=item $player->ext_reply ($msgid, %msg)
1220 1386
1221Sends an ext reply to the player. 1387Sends an ext reply to the player.
1222 1388
1223=cut 1389=cut
… …
1250 1416
1251package cf::region; 1417package cf::region;
1252 1418
1253=item cf::region::find_by_path $path 1419=item cf::region::find_by_path $path
1254 1420
1255Tries to decuce the probable region for a map knowing only its path. 1421Tries to decuce the likely region for a map knowing only its path.
1256 1422
1257=cut 1423=cut
1258 1424
1259sub find_by_path($) { 1425sub find_by_path($) {
1260 my ($path) = @_; 1426 my ($path) = @_;
… …
1912 2078
1913 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2079 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1914 2080
1915 if ($self->{record_replies}) { 2081 if ($self->{record_replies}) {
1916 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2082 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2083
1917 } else { 2084 } else {
2085 my $pl = $self->contr;
2086
2087 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2088 my $diag = $pl->{npc_dialog};
2089 $diag->{pl}->ext_reply (
2090 $diag->{id},
2091 msgtype => "reply",
2092 msg => $diag->{pl}->expand_cfpod ($msg),
2093 add_topics => []
2094 );
2095
2096 } else {
1918 $msg = $npc->name . " says: $msg" if $npc; 2097 $msg = $npc->name . " says: $msg" if $npc;
1919 $self->message ($msg, $flags); 2098 $self->message ($msg, $flags);
2099 }
1920 } 2100 }
1921} 2101}
1922 2102
1923=item $player_object->may ("access") 2103=item $player_object->may ("access")
1924 2104
… …
2167sub cf::client::send_drawinfo { 2347sub cf::client::send_drawinfo {
2168 my ($self, $text, $flags) = @_; 2348 my ($self, $text, $flags) = @_;
2169 2349
2170 utf8::encode $text; 2350 utf8::encode $text;
2171 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2351 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2352}
2353
2354=item $client->send_msg ($color, $type, $msg, [extra...])
2355
2356Send a drawinfo or msg packet to the client, formatting the msg for the
2357client if neccessary. C<$type> should be a string identifying the type of
2358the message, with C<log> being the default. If C<$color> is negative, suppress
2359the message unless the client supports the msg packet.
2360
2361=cut
2362
2363sub cf::client::send_msg {
2364 my ($self, $color, $type, $msg, @extra) = @_;
2365
2366 $msg = $self->pl->expand_cfpod ($msg);
2367
2368 if ($self->can_msg) {
2369 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2370 } else {
2371 # replace some tags by gcfclient-compatible ones
2372 for ($msg) {
2373 1 while
2374 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2375 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2376 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2377 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2378 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${1}[\/color]/;
2379 }
2380
2381 if ($color >= 0) {
2382 if ($msg =~ /\[/) {
2383 $self->send_packet ("drawextinfo $color 4 0 $msg")
2384 } else {
2385 $self->send_packet ("drawinfo $color $msg")
2386 }
2387 }
2388 }
2172} 2389}
2173 2390
2174=item $client->ext_event ($type, %msg) 2391=item $client->ext_event ($type, %msg)
2175 2392
2176Sends an exti event to the client. 2393Sends an exti event to the client.
… …
2376} 2593}
2377 2594
2378=back 2595=back
2379 2596
2380=cut 2597=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 2598
2554############################################################################# 2599#############################################################################
2555# the server's init and main functions 2600# the server's init and main functions
2556 2601
2557sub load_facedata($) { 2602sub load_facedata($) {
… …
2694 cb => sub { 2739 cb => sub {
2695 cf::cleanup "SIG$signal"; 2740 cf::cleanup "SIG$signal";
2696 }, 2741 },
2697 ); 2742 );
2698 } 2743 }
2744}
2745
2746sub write_runtime {
2747 my $runtime = "$LOCALDIR/runtime";
2748
2749 # first touch the runtime file to show we are still running:
2750 # the fsync below can take a very very long time.
2751
2752 IO::AIO::aio_utime $runtime, undef, undef;
2753
2754 my $guard = cf::lock_acquire "write_runtime";
2755
2756 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2757 or return;
2758
2759 my $value = $cf::RUNTIME + 90 + 10;
2760 # 10 is the runtime save interval, for a monotonic clock
2761 # 60 allows for the watchdog to kill the server.
2762
2763 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2764 and return;
2765
2766 # always fsync - this file is important
2767 aio_fsync $fh
2768 and return;
2769
2770 # touch it again to show we are up-to-date
2771 aio_utime $fh, undef, undef;
2772
2773 close $fh
2774 or return;
2775
2776 aio_rename "$runtime~", $runtime
2777 and return;
2778
2779 warn "runtime file written.\n";
2780
2781 1
2699} 2782}
2700 2783
2701sub emergency_save() { 2784sub emergency_save() {
2702 my $freeze_guard = cf::freeze_mainloop; 2785 my $freeze_guard = cf::freeze_mainloop;
2703 2786

Diff Legend

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