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.273 by root, Mon Jun 4 12:19:08 2007 UTC vs.
Revision 1.282 by elmex, Tue Jun 19 18:15:34 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";#d# 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
… …
873 or return; 998 or return;
874 $av = eval { (Storable::thaw $av)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
875 } 1000 }
876 1001
877 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
878 $filename, length $data, scalar @{$av || []};#d# 1003 $filename, length $data, scalar @{$av || []};
879 return ($data, $av); 1004 return ($data, $av);
880} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
881 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);
… …
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
… …
943 1074
944 cf::override; 1075 cf::override;
945 }, 1076 },
946); 1077);
947 1078
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 { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
983 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
984 next unless -r $ext; 1084 next unless -r $path;
985 eval { 1085
986 load_extension $ext; 1086 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1087 my $base = $1;
1088 my $pkg = $1;
1089 $pkg =~ s/[^[:word:]]/_/g;
1090 $pkg = "ext::$pkg";
1091
1092 open my $fh, "<:utf8", $path
1093 or die "$path: $!";
1094
1095 my $source = do { local $/; <$fh> };
1096
1097 my %ext = (
1098 path => $path,
1099 base => $base,
1100 pkg => $pkg,
1101 );
1102
1103 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1104 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1105
1106 $ext{source} =
1107 "package $pkg; use strict; use utf8;\n"
1108 . "#line 1 \"$path\"\n{\n"
1109 . $source
1110 . "\n};\n1";
1111
1112 $todo{$base} = \%ext;
1113 }
1114
1115 my %done;
1116 while (%todo) {
1117 my $progress;
1118
1119 while (my ($k, $v) = each %todo) {
1120 for (split /,\s*/, $v->{meta}{depends}) {
1121 goto skip
1122 unless exists $done{$_};
1123 }
1124
1125 warn "... loading '$k' into '$v->{pkg}'\n";
1126
1127 unless (eval $v->{source}) {
1128 my $msg = $@ ? "$v->{path}: $@\n"
1129 : "$v->{base}: extension inactive.\n";
1130
1131 if (exists $v->{meta}{mandatory}) {
1132 warn $msg;
1133 warn "mandatory extension failed to load, exiting.\n";
1134 exit 1;
1135 }
1136
1137 warn $msg;
1138 }
1139
1140 $done{$k} = delete $todo{$k};
1141 push @EXTS, $v->{pkg};
1142 $progress = 1;
987 1 1143 }
988 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
989 } 1149 };
990} 1150}
991 1151
992############################################################################# 1152#############################################################################
1153
1154=back
993 1155
994=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
995 1157
996Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
997 1159
… …
1221 1383
1222package cf::region; 1384package cf::region;
1223 1385
1224=item cf::region::find_by_path $path 1386=item cf::region::find_by_path $path
1225 1387
1226Tries 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.
1227 1389
1228=cut 1390=cut
1229 1391
1230sub find_by_path($) { 1392sub find_by_path($) {
1231 my ($path) = @_; 1393 my ($path) = @_;
… …
1305 my ($self, $merge) = @_; 1467 my ($self, $merge) = @_;
1306 1468
1307 # we have to keep some variables in memory intact 1469 # we have to keep some variables in memory intact
1308 local $self->{path}; 1470 local $self->{path};
1309 local $self->{load_path}; 1471 local $self->{load_path};
1310 local $self->{deny_save};
1311 local $self->{deny_reset};
1312 1472
1313 $self->SUPER::thawer_merge ($merge); 1473 $self->SUPER::thawer_merge ($merge);
1314} 1474}
1315 1475
1316sub normalise { 1476sub normalise {
… …
1416 1576
1417 $_->change_map_light ($change) 1577 $_->change_map_light ($change)
1418 for grep $_->outdoor, values %cf::MAP; 1578 for grep $_->outdoor, values %cf::MAP;
1419} 1579}
1420 1580
1581sub decay_objects {
1582 my ($self) = @_;
1583
1584 return if $self->{deny_reset};
1585
1586 $self->do_decay_objects;
1587}
1588
1421sub unlink_save { 1589sub unlink_save {
1422 my ($self) = @_; 1590 my ($self) = @_;
1423 1591
1424 utf8::encode (my $save = $self->save_path); 1592 utf8::encode (my $save = $self->save_path);
1425 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1593 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1481 $self->load_header_orig 1649 $self->load_header_orig
1482 or return; 1650 or return;
1483 $self->prepare_orig; 1651 $self->prepare_orig;
1484 } 1652 }
1485 1653
1654 $self->{deny_reset} = 1
1655 if $self->no_reset;
1656
1486 $self->default_region (cf::region::find_by_path $self->{path}) 1657 $self->default_region (cf::region::find_by_path $self->{path})
1487 unless $self->default_region; 1658 unless $self->default_region;
1488 1659
1489 1 1660 1
1490} 1661}
… …
1505 $map->{last_save} = $cf::RUNTIME; 1676 $map->{last_save} = $cf::RUNTIME;
1506 1677
1507 $map->load_header 1678 $map->load_header
1508 or return; 1679 or return;
1509 1680
1510 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1681 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1511 # doing this can freeze the server in a sync job, obviously 1682 # doing this can freeze the server in a sync job, obviously
1512 #$cf::WAIT_FOR_TICK->wait; 1683 #$cf::WAIT_FOR_TICK->wait;
1513 $map->reset; 1684 $map->reset;
1514 undef $guard; 1685 undef $guard;
1515 return find $path; 1686 return find $path;
… …
1582 my ($self, $ob) = @_; 1753 my ($self, $ob) = @_;
1583 1754
1584 return find "~" . $ob->name . "/" . $self->{path} 1755 return find "~" . $ob->name . "/" . $self->{path}
1585 if $self->per_player; 1756 if $self->per_player;
1586 1757
1758# return find "?party/" . $ob->name . "/" . $self->{path}
1759# if $self->per_party;
1760
1587 $self 1761 $self
1588} 1762}
1589 1763
1590# find and load all maps in the 3x3 area around a map 1764# find and load all maps in the 3x3 area around a map
1591sub load_diag { 1765sub load_diag {
… …
1701 1875
1702sub reset_at { 1876sub reset_at {
1703 my ($self) = @_; 1877 my ($self) = @_;
1704 1878
1705 # TODO: safety, remove and allow resettable per-player maps 1879 # TODO: safety, remove and allow resettable per-player maps
1706 return 1e99 if $self->isa ("ext::map_per_player");#d#
1707 return 1e99 if $self->{deny_reset}; 1880 return 1e99 if $self->{deny_reset};
1708 1881
1709 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1882 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1710 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1883 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1711 1884
… …
1722 my ($self) = @_; 1895 my ($self) = @_;
1723 1896
1724 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1897 my $lock = cf::lock_acquire "map_data:$self->{path}";
1725 1898
1726 return if $self->players; 1899 return if $self->players;
1727 return if $self->isa ("ext::map_per_player");#d#
1728 1900
1729 warn "resetting map ", $self->path;#d# 1901 warn "resetting map ", $self->path;
1730 1902
1731 $self->in_memory (cf::MAP_SWAPPED); 1903 $self->in_memory (cf::MAP_SWAPPED);
1732 1904
1733 # need to save uniques path 1905 # need to save uniques path
1734 unless ($self->{deny_save}) { 1906 unless ($self->{deny_save}) {
… …
1766 $cf::MAP{$self->path} = $self; 1938 $cf::MAP{$self->path} = $self;
1767 1939
1768 $self->reset; # polite request, might not happen 1940 $self->reset; # polite request, might not happen
1769} 1941}
1770 1942
1943=item $maps = cf::map::tmp_maps
1944
1945Returns an arrayref with all map paths of currently instantiated and saved
1946maps. May block.
1947
1948=cut
1949
1950sub tmp_maps() {
1951 [
1952 map {
1953 utf8::decode $_;
1954 /\.map$/
1955 ? normalise $_
1956 : ()
1957 } @{ aio_readdir $TMPDIR or [] }
1958 ]
1959}
1960
1961=item $maps = cf::map::random_maps
1962
1963Returns an arrayref with all map paths of currently instantiated and saved
1964random maps. May block.
1965
1966=cut
1967
1968sub random_maps() {
1969 [
1970 map {
1971 utf8::decode $_;
1972 /\.map$/
1973 ? normalise "?random/$_"
1974 : ()
1975 } @{ aio_readdir $RANDOMDIR or [] }
1976 ]
1977}
1978
1771=item cf::map::unique_maps 1979=item cf::map::unique_maps
1772 1980
1773Returns an arrayref of paths of all shared maps that have 1981Returns an arrayref of paths of all shared maps that have
1774instantiated unique items. May block. 1982instantiated unique items. May block.
1775 1983
1776=cut 1984=cut
1777 1985
1778sub unique_maps() { 1986sub unique_maps() {
1779 my $files = aio_readdir $UNIQUEDIR 1987 [
1780 or return; 1988 map {
1781
1782 my @paths;
1783
1784 for (@$files) {
1785 utf8::decode $_; 1989 utf8::decode $_;
1786 next if /\.pst$/; 1990 /\.map$/
1787 next unless /^$PATH_SEP/o; 1991 ? normalise $_
1788 1992 : ()
1789 push @paths, cf::map::normalise $_; 1993 } @{ aio_readdir $UNIQUEDIR or [] }
1790 } 1994 ]
1791
1792 \@paths
1793} 1995}
1794 1996
1795package cf; 1997package cf;
1796 1998
1797=back 1999=back
… …
1843 2045
1844 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2046 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1845 2047
1846 if ($self->{record_replies}) { 2048 if ($self->{record_replies}) {
1847 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2049 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2050
1848 } else { 2051 } else {
2052 my $pl = $self->contr;
2053
2054 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2055 my $diag = $pl->{npc_dialog};
2056 $diag->{pl}->ext_reply (
2057 $diag->{id}, msgtype => "reply", msg => $msg, add_topics => []
2058 );
2059
2060 } else {
1849 $msg = $npc->name . " says: $msg" if $npc; 2061 $msg = $npc->name . " says: $msg" if $npc;
1850 $self->message ($msg, $flags); 2062 $self->message ($msg, $flags);
2063 }
1851 } 2064 }
1852} 2065}
1853 2066
1854=item $player_object->may ("access") 2067=item $player_object->may ("access")
1855 2068
… …
2309=back 2522=back
2310 2523
2311=cut 2524=cut
2312 2525
2313############################################################################# 2526#############################################################################
2314
2315=head2 EXTENSION DATABASE SUPPORT
2316
2317Crossfire maintains a very simple database for extension use. It can
2318currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2319convert to/from binary).
2320
2321The parameter C<$family> should best start with the name of the extension
2322using it, it should be unique.
2323
2324=over 4
2325
2326=item $value = cf::db_get $family => $key
2327
2328Returns a single value from the database.
2329
2330=item cf::db_put $family => $key => $value
2331
2332Stores the given C<$value> in the family.
2333
2334=cut
2335
2336our $DB;
2337
2338sub db_init {
2339 unless ($DB) {
2340 $DB = BDB::db_create $DB_ENV;
2341
2342 cf::sync_job {
2343 eval {
2344 $DB->set_flags (BDB::CHKSUM);
2345
2346 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2347 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2348 cf::cleanup "db_open(db): $!" if $!;
2349 };
2350 cf::cleanup "db_open(db): $@" if $@;
2351 };
2352 }
2353}
2354
2355sub db_get($$) {
2356 my $key = "$_[0]/$_[1]";
2357
2358 cf::sync_job {
2359 BDB::db_get $DB, undef, $key, my $data;
2360
2361 $! ? ()
2362 : $data
2363 }
2364}
2365
2366sub db_put($$$) {
2367 BDB::dbreq_pri 4;
2368 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2369}
2370
2371=item cf::cache $id => [$paths...], $processversion => $process
2372
2373Generic caching function that returns the value of the resource $id,
2374caching and regenerating as required.
2375
2376This function can block.
2377
2378=cut
2379
2380sub cache {
2381 my ($id, $src, $processversion, $process) = @_;
2382
2383 my $meta =
2384 join "\x00",
2385 $processversion,
2386 map {
2387 aio_stat $_
2388 and Carp::croak "$_: $!";
2389
2390 ($_, (stat _)[7,9])
2391 } @$src;
2392
2393 my $dbmeta = db_get cache => "$id/meta";
2394 if ($dbmeta ne $meta) {
2395 # changed, we may need to process
2396
2397 my @data;
2398 my $md5;
2399
2400 for (0 .. $#$src) {
2401 0 <= aio_load $src->[$_], $data[$_]
2402 or Carp::croak "$src->[$_]: $!";
2403 }
2404
2405 # if processing is expensive, check
2406 # checksum first
2407 if (1) {
2408 $md5 =
2409 join "\x00",
2410 $processversion,
2411 map {
2412 Coro::cede;
2413 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2414 } 0.. $#$src;
2415
2416
2417 my $dbmd5 = db_get cache => "$id/md5";
2418 if ($dbmd5 eq $md5) {
2419 db_put cache => "$id/meta", $meta;
2420
2421 return db_get cache => "$id/data";
2422 }
2423 }
2424
2425 my $t1 = Time::HiRes::time;
2426 my $data = $process->(\@data);
2427 my $t2 = Time::HiRes::time;
2428
2429 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2430
2431 db_put cache => "$id/data", $data;
2432 db_put cache => "$id/md5" , $md5;
2433 db_put cache => "$id/meta", $meta;
2434
2435 return $data;
2436 }
2437
2438 db_get cache => "$id/data"
2439}
2440
2441=item fork_call { }, $args
2442
2443Executes the given code block with the given arguments in a seperate
2444process, returning the results. Everything must be serialisable with
2445Coro::Storable. May, of course, block. Note that the executed sub may
2446never block itself or use any form of Event handling.
2447
2448=cut
2449
2450sub fork_call(&@) {
2451 my ($cb, @args) = @_;
2452
2453# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2454# or die "socketpair: $!";
2455 pipe my $fh1, my $fh2
2456 or die "pipe: $!";
2457
2458 if (my $pid = fork) {
2459 close $fh2;
2460
2461 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2462 $res = Coro::Storable::thaw $res;
2463
2464 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2465
2466 die $$res unless "ARRAY" eq ref $res;
2467
2468 return wantarray ? @$res : $res->[-1];
2469 } else {
2470 reset_signals;
2471 local $SIG{__WARN__};
2472 local $SIG{__DIE__};
2473 eval {
2474 close $fh1;
2475
2476 my @res = eval { $cb->(@args) };
2477 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2478 };
2479
2480 warn $@ if $@;
2481 _exit 0;
2482 }
2483}
2484
2485#############################################################################
2486# the server's init and main functions 2527# the server's init and main functions
2487 2528
2488sub load_facedata($) { 2529sub load_facedata($) {
2489 my ($path) = @_; 2530 my ($path) = @_;
2490 2531
… …
2560sub reload_resources { 2601sub reload_resources {
2561 warn "reloading resource files...\n"; 2602 warn "reloading resource files...\n";
2562 2603
2563 reload_regions; 2604 reload_regions;
2564 reload_facedata; 2605 reload_facedata;
2606 #reload_archetypes;#d#
2565 reload_archetypes; 2607 reload_archetypes;
2566 reload_treasures; 2608 reload_treasures;
2567 2609
2568 warn "finished reloading resource files\n"; 2610 warn "finished reloading resource files\n";
2569} 2611}
… …
2624 cb => sub { 2666 cb => sub {
2625 cf::cleanup "SIG$signal"; 2667 cf::cleanup "SIG$signal";
2626 }, 2668 },
2627 ); 2669 );
2628 } 2670 }
2671}
2672
2673sub write_runtime {
2674 my $runtime = "$LOCALDIR/runtime";
2675
2676 # first touch the runtime file to show we are still running:
2677 # the fsync below can take a very very long time.
2678
2679 IO::AIO::aio_utime $runtime, undef, undef;
2680
2681 my $guard = cf::lock_acquire "write_runtime";
2682
2683 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2684 or return;
2685
2686 my $value = $cf::RUNTIME + 90 + 10;
2687 # 10 is the runtime save interval, for a monotonic clock
2688 # 60 allows for the watchdog to kill the server.
2689
2690 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2691 and return;
2692
2693 # always fsync - this file is important
2694 aio_fsync $fh
2695 and return;
2696
2697 # touch it again to show we are up-to-date
2698 aio_utime $fh, undef, undef;
2699
2700 close $fh
2701 or return;
2702
2703 aio_rename "$runtime~", $runtime
2704 and return;
2705
2706 warn "runtime file written.\n";
2707
2708 1
2629} 2709}
2630 2710
2631sub emergency_save() { 2711sub emergency_save() {
2632 my $freeze_guard = cf::freeze_mainloop; 2712 my $freeze_guard = cf::freeze_mainloop;
2633 2713

Diff Legend

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