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.280 by root, Sat Jun 16 14:35:41 2007 UTC vs.
Revision 1.281 by root, Sat Jun 16 23:22:59 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
… …
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
… …
1250 1383
1251package cf::region; 1384package cf::region;
1252 1385
1253=item cf::region::find_by_path $path 1386=item cf::region::find_by_path $path
1254 1387
1255Tries to decuce the probable region for a map knowing only its path. 1388Tries to decuce the likely region for a map knowing only its path.
1256 1389
1257=cut 1390=cut
1258 1391
1259sub find_by_path($) { 1392sub find_by_path($) {
1260 my ($path) = @_; 1393 my ($path) = @_;
… …
2378=back 2511=back
2379 2512
2380=cut 2513=cut
2381 2514
2382############################################################################# 2515#############################################################################
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
2554#############################################################################
2555# the server's init and main functions 2516# the server's init and main functions
2556 2517
2557sub load_facedata($) { 2518sub load_facedata($) {
2558 my ($path) = @_; 2519 my ($path) = @_;
2559 2520
… …
2694 cb => sub { 2655 cb => sub {
2695 cf::cleanup "SIG$signal"; 2656 cf::cleanup "SIG$signal";
2696 }, 2657 },
2697 ); 2658 );
2698 } 2659 }
2660}
2661
2662sub write_runtime {
2663 my $runtime = "$LOCALDIR/runtime";
2664
2665 # first touch the runtime file to show we are still running:
2666 # the fsync below can take a very very long time.
2667
2668 IO::AIO::aio_utime $runtime, undef, undef;
2669
2670 my $guard = cf::lock_acquire "write_runtime";
2671
2672 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2673 or return;
2674
2675 my $value = $cf::RUNTIME + 90 + 10;
2676 # 10 is the runtime save interval, for a monotonic clock
2677 # 60 allows for the watchdog to kill the server.
2678
2679 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2680 and return;
2681
2682 # always fsync - this file is important
2683 aio_fsync $fh
2684 and return;
2685
2686 # touch it again to show we are up-to-date
2687 aio_utime $fh, undef, undef;
2688
2689 close $fh
2690 or return;
2691
2692 aio_rename "$runtime~", $runtime
2693 and return;
2694
2695 warn "runtime file written.\n";
2696
2697 1
2699} 2698}
2700 2699
2701sub emergency_save() { 2700sub emergency_save() {
2702 my $freeze_guard = cf::freeze_mainloop; 2701 my $freeze_guard = cf::freeze_mainloop;
2703 2702

Diff Legend

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