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.270 by root, Sat May 26 15:44:06 2007 UTC vs.
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC

… …
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
192@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
192@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 193@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
193 194
194# we bless all objects into (empty) derived classes to force a method lookup 195# we bless all objects into (empty) derived classes to force a method lookup
195# within the Safe compartment. 196# within the Safe compartment.
196for my $pkg (qw( 197for my $pkg (qw(
197 cf::global cf::attachable 198 cf::global cf::attachable
… …
205} 206}
206 207
207$Event::DIED = sub { 208$Event::DIED = sub {
208 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
209}; 210};
211
212#############################################################################
210 213
211=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
212 215
213=over 4 216=over 4
214 217
… …
317 320
318BEGIN { *async = \&Coro::async_pool } 321BEGIN { *async = \&Coro::async_pool }
319 322
320=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
321 324
322The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
323always able to handle events or runnable, as crossfire+ is only partly 326is always able to handle events or runnable, as Crossfire TRT is only
324reentrant. 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.
325 329
326If 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
327the given BLOCK in another coroutine while waiting for the result. The 331the given BLOCK in another coroutine while waiting for the result. The
328server 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
329fast or be very important. 333fast or be very important.
… …
389 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
390 394
391 $coro 395 $coro
392} 396}
393 397
394sub write_runtime { 398=item fork_call { }, $args
395 my $runtime = "$LOCALDIR/runtime";
396 399
397 # first touch the runtime file to show we are still running: 400Executes the given code block with the given arguments in a seperate
398 # 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.
399 404
400 if (my $fh = aio_open $runtime, O_WRONLY, 0) { 405=cut
401 utime undef, undef, $fh;
402 }
403 406
404 my $guard = cf::lock_acquire "write_runtime"; 407sub fork_call(&@) {
408 my ($cb, @args) = @_;
405 409
406 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
407 or return; 411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
408 414
409 my $value = $cf::RUNTIME + 90 + 10; 415 if (my $pid = fork) {
410 # 10 is the runtime save interval, for a monotonic clock
411 # 60 allows for the watchdog to kill the server.
412
413 (aio_write $fh, 0, (length $value), $value, 0) <= 0
414 and return;
415
416 # always fsync - this file is important
417 aio_fsync $fh
418 and return;
419
420 # touch it again to show we are up-to-date
421 utime undef, undef, $fh;
422
423 close $fh 416 close $fh2;
424 or return;
425 417
426 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
427 and return; 419 $res = Coro::Storable::thaw $res;
428 420
429 warn "runtime file written.\n";#d# 421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
430 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;
431 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"
432} 556}
433 557
434=item cf::datalog type => key => value, ... 558=item cf::datalog type => key => value, ...
435 559
436Log 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.
… …
454attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
455to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
456 580
457In 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>
458C<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
459crossfire+). 583Crossfire TRT).
460 584
461=over 4 585=over 4
462 586
463=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
464 588
… …
666 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
667 } 791 }
668 792
669 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
670 } else { 794 } else {
671 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
672 } 796 }
673 797
674 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
675} 799}
676 800
… …
874 or return; 998 or return;
875 $av = eval { (Storable::thaw $av)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
876 } 1000 }
877 1001
878 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
879 $filename, length $data, scalar @{$av || []};#d# 1003 $filename, length $data, scalar @{$av || []};
880 return ($data, $av); 1004 return ($data, $av);
881} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
882 1012
883############################################################################# 1013#############################################################################
884# command handling &c 1014# command handling &c
885 1015
886=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
… …
899 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
900} 1030}
901 1031
902=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
903 1033
904Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
905 1035
906If 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
907called. 1037called.
908 1038
909=cut 1039=cut
… …
944 1074
945 cf::override; 1075 cf::override;
946 }, 1076 },
947); 1077);
948 1078
949sub load_extension {
950 my ($path) = @_;
951
952 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
953 my $base = $1;
954 my $pkg = $1;
955 $pkg =~ s/[^[:word:]]/_/g;
956 $pkg = "ext::$pkg";
957
958 warn "... loading '$path' into '$pkg'\n";
959
960 open my $fh, "<:utf8", $path
961 or die "$path: $!";
962
963 my $source =
964 "package $pkg; use strict; use utf8;\n"
965 . "#line 1 \"$path\"\n{\n"
966 . (do { local $/; <$fh> })
967 . "\n};\n1";
968
969 unless (eval $source) {
970 my $msg = $@ ? "$path: $@\n"
971 : "extension disabled.\n";
972 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
973 warn $@;
974 warn "mandatory extension failed to load, exiting.\n";
975 exit 1;
976 }
977 die $@;
978 }
979
980 push @EXTS, $pkg;
981}
982
983sub load_extensions { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
984 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
985 next unless -r $ext; 1084 next unless -r $path;
986 eval { 1085
987 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;
988 1 1143 }
989 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
990 } 1149 };
991} 1150}
992 1151
993############################################################################# 1152#############################################################################
1153
1154=back
994 1155
995=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
996 1157
997Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
998 1159
… …
1222 1383
1223package cf::region; 1384package cf::region;
1224 1385
1225=item cf::region::find_by_path $path 1386=item cf::region::find_by_path $path
1226 1387
1227Tries 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.
1228 1389
1229=cut 1390=cut
1230 1391
1231sub find_by_path($) { 1392sub find_by_path($) {
1232 my ($path) = @_; 1393 my ($path) = @_;
… …
1306 my ($self, $merge) = @_; 1467 my ($self, $merge) = @_;
1307 1468
1308 # we have to keep some variables in memory intact 1469 # we have to keep some variables in memory intact
1309 local $self->{path}; 1470 local $self->{path};
1310 local $self->{load_path}; 1471 local $self->{load_path};
1311 local $self->{deny_save};
1312 local $self->{deny_reset};
1313 1472
1314 $self->SUPER::thawer_merge ($merge); 1473 $self->SUPER::thawer_merge ($merge);
1315} 1474}
1316 1475
1317sub normalise { 1476sub normalise {
… …
1417 1576
1418 $_->change_map_light ($change) 1577 $_->change_map_light ($change)
1419 for grep $_->outdoor, values %cf::MAP; 1578 for grep $_->outdoor, values %cf::MAP;
1420} 1579}
1421 1580
1581sub decay_objects {
1582 my ($self) = @_;
1583
1584 return if $self->{deny_reset};
1585
1586 $self->do_decay_objects;
1587}
1588
1422sub unlink_save { 1589sub unlink_save {
1423 my ($self) = @_; 1590 my ($self) = @_;
1424 1591
1425 utf8::encode (my $save = $self->save_path); 1592 utf8::encode (my $save = $self->save_path);
1426 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1593 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1482 $self->load_header_orig 1649 $self->load_header_orig
1483 or return; 1650 or return;
1484 $self->prepare_orig; 1651 $self->prepare_orig;
1485 } 1652 }
1486 1653
1654 $self->{deny_reset} = 1
1655 if $self->no_reset;
1656
1487 $self->default_region (cf::region::find_by_path $self->{path}) 1657 $self->default_region (cf::region::find_by_path $self->{path})
1488 unless $self->default_region; 1658 unless $self->default_region;
1489 1659
1490 1 1660 1
1491} 1661}
… …
1506 $map->{last_save} = $cf::RUNTIME; 1676 $map->{last_save} = $cf::RUNTIME;
1507 1677
1508 $map->load_header 1678 $map->load_header
1509 or return; 1679 or return;
1510 1680
1511 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1681 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1512 # doing this can freeze the server in a sync job, obviously 1682 # doing this can freeze the server in a sync job, obviously
1513 #$cf::WAIT_FOR_TICK->wait; 1683 #$cf::WAIT_FOR_TICK->wait;
1514 $map->reset; 1684 $map->reset;
1515 undef $guard; 1685 undef $guard;
1516 return find $path; 1686 return find $path;
… …
1583 my ($self, $ob) = @_; 1753 my ($self, $ob) = @_;
1584 1754
1585 return find "~" . $ob->name . "/" . $self->{path} 1755 return find "~" . $ob->name . "/" . $self->{path}
1586 if $self->per_player; 1756 if $self->per_player;
1587 1757
1758# return find "?party/" . $ob->name . "/" . $self->{path}
1759# if $self->per_party;
1760
1588 $self 1761 $self
1589} 1762}
1590 1763
1591# 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
1592sub load_diag { 1765sub load_diag {
… …
1702 1875
1703sub reset_at { 1876sub reset_at {
1704 my ($self) = @_; 1877 my ($self) = @_;
1705 1878
1706 # TODO: safety, remove and allow resettable per-player maps 1879 # TODO: safety, remove and allow resettable per-player maps
1707 return 1e99 if $self->isa ("ext::map_per_player");#d#
1708 return 1e99 if $self->{deny_reset}; 1880 return 1e99 if $self->{deny_reset};
1709 1881
1710 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1882 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1711 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;
1712 1884
… …
1723 my ($self) = @_; 1895 my ($self) = @_;
1724 1896
1725 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1897 my $lock = cf::lock_acquire "map_data:$self->{path}";
1726 1898
1727 return if $self->players; 1899 return if $self->players;
1728 return if $self->isa ("ext::map_per_player");#d#
1729 1900
1730 warn "resetting map ", $self->path;#d# 1901 warn "resetting map ", $self->path;
1731 1902
1732 $self->in_memory (cf::MAP_SWAPPED); 1903 $self->in_memory (cf::MAP_SWAPPED);
1733 1904
1734 # need to save uniques path 1905 # need to save uniques path
1735 unless ($self->{deny_save}) { 1906 unless ($self->{deny_save}) {
… …
1767 $cf::MAP{$self->path} = $self; 1938 $cf::MAP{$self->path} = $self;
1768 1939
1769 $self->reset; # polite request, might not happen 1940 $self->reset; # polite request, might not happen
1770} 1941}
1771 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
1772=item cf::map::unique_maps 1979=item cf::map::unique_maps
1773 1980
1774Returns an arrayref of paths of all shared maps that have 1981Returns an arrayref of paths of all shared maps that have
1775instantiated unique items. May block. 1982instantiated unique items. May block.
1776 1983
1777=cut 1984=cut
1778 1985
1779sub unique_maps() { 1986sub unique_maps() {
1780 my $files = aio_readdir $UNIQUEDIR 1987 [
1781 or return; 1988 map {
1782
1783 my @paths;
1784
1785 for (@$files) {
1786 utf8::decode $_; 1989 utf8::decode $_;
1787 next if /\.pst$/; 1990 /\.map$/
1788 next unless /^$PATH_SEP/o; 1991 ? normalise $_
1789 1992 : ()
1790 push @paths, cf::map::normalise $_; 1993 } @{ aio_readdir $UNIQUEDIR or [] }
1791 } 1994 ]
1792
1793 \@paths
1794} 1995}
1795 1996
1796package cf; 1997package cf;
1797 1998
1798=back 1999=back
… …
1844 2045
1845 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2046 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1846 2047
1847 if ($self->{record_replies}) { 2048 if ($self->{record_replies}) {
1848 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2049 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2050
1849 } 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 {
1850 $msg = $npc->name . " says: $msg" if $npc; 2061 $msg = $npc->name . " says: $msg" if $npc;
1851 $self->message ($msg, $flags); 2062 $self->message ($msg, $flags);
2063 }
1852 } 2064 }
1853} 2065}
1854 2066
1855=item $player_object->may ("access") 2067=item $player_object->may ("access")
1856 2068
… …
2310=back 2522=back
2311 2523
2312=cut 2524=cut
2313 2525
2314############################################################################# 2526#############################################################################
2315
2316=head2 EXTENSION DATABASE SUPPORT
2317
2318Crossfire maintains a very simple database for extension use. It can
2319currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2320convert to/from binary).
2321
2322The parameter C<$family> should best start with the name of the extension
2323using it, it should be unique.
2324
2325=over 4
2326
2327=item $value = cf::db_get $family => $key
2328
2329Returns a single value from the database.
2330
2331=item cf::db_put $family => $key => $value
2332
2333Stores the given C<$value> in the family.
2334
2335=cut
2336
2337our $DB;
2338
2339sub db_init {
2340 unless ($DB) {
2341 $DB = BDB::db_create $DB_ENV;
2342
2343 cf::sync_job {
2344 eval {
2345 $DB->set_flags (BDB::CHKSUM);
2346
2347 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2348 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2349 cf::cleanup "db_open(db): $!" if $!;
2350 };
2351 cf::cleanup "db_open(db): $@" if $@;
2352 };
2353 }
2354}
2355
2356sub db_get($$) {
2357 my $key = "$_[0]/$_[1]";
2358
2359 cf::sync_job {
2360 BDB::db_get $DB, undef, $key, my $data;
2361
2362 $! ? ()
2363 : $data
2364 }
2365}
2366
2367sub db_put($$$) {
2368 BDB::dbreq_pri 4;
2369 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2370}
2371
2372=item cf::cache $id => [$paths...], $processversion => $process
2373
2374Generic caching function that returns the value of the resource $id,
2375caching and regenerating as required.
2376
2377This function can block.
2378
2379=cut
2380
2381sub cache {
2382 my ($id, $src, $processversion, $process) = @_;
2383
2384 my $meta =
2385 join "\x00",
2386 $processversion,
2387 map {
2388 aio_stat $_
2389 and Carp::croak "$_: $!";
2390
2391 ($_, (stat _)[7,9])
2392 } @$src;
2393
2394 my $dbmeta = db_get cache => "$id/meta";
2395 if ($dbmeta ne $meta) {
2396 # changed, we may need to process
2397
2398 my @data;
2399 my $md5;
2400
2401 for (0 .. $#$src) {
2402 0 <= aio_load $src->[$_], $data[$_]
2403 or Carp::croak "$src->[$_]: $!";
2404 }
2405
2406 # if processing is expensive, check
2407 # checksum first
2408 if (1) {
2409 $md5 =
2410 join "\x00",
2411 $processversion,
2412 map {
2413 Coro::cede;
2414 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2415 } 0.. $#$src;
2416
2417
2418 my $dbmd5 = db_get cache => "$id/md5";
2419 if ($dbmd5 eq $md5) {
2420 db_put cache => "$id/meta", $meta;
2421
2422 return db_get cache => "$id/data";
2423 }
2424 }
2425
2426 my $t1 = Time::HiRes::time;
2427 my $data = $process->(\@data);
2428 my $t2 = Time::HiRes::time;
2429
2430 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2431
2432 db_put cache => "$id/data", $data;
2433 db_put cache => "$id/md5" , $md5;
2434 db_put cache => "$id/meta", $meta;
2435
2436 return $data;
2437 }
2438
2439 db_get cache => "$id/data"
2440}
2441
2442=item fork_call { }, $args
2443
2444Executes the given code block with the given arguments in a seperate
2445process, returning the results. Everything must be serialisable with
2446Coro::Storable. May, of course, block. Note that the executed sub may
2447never block itself or use any form of Event handling.
2448
2449=cut
2450
2451sub fork_call(&@) {
2452 my ($cb, @args) = @_;
2453
2454# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2455# or die "socketpair: $!";
2456 pipe my $fh1, my $fh2
2457 or die "pipe: $!";
2458
2459 if (my $pid = fork) {
2460 close $fh2;
2461
2462 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2463 $res = Coro::Storable::thaw $res;
2464
2465 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2466
2467 die $$res unless "ARRAY" eq ref $res;
2468
2469 return wantarray ? @$res : $res->[-1];
2470 } else {
2471 reset_signals;
2472 local $SIG{__WARN__};
2473 local $SIG{__DIE__};
2474 eval {
2475 close $fh1;
2476
2477 my @res = eval { $cb->(@args) };
2478 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2479 };
2480
2481 warn $@ if $@;
2482 _exit 0;
2483 }
2484}
2485
2486
2487
2488#############################################################################
2489# the server's init and main functions 2527# the server's init and main functions
2490 2528
2491sub load_facedata($) { 2529sub load_facedata($) {
2492 my ($path) = @_; 2530 my ($path) = @_;
2493 2531
… …
2563sub reload_resources { 2601sub reload_resources {
2564 warn "reloading resource files...\n"; 2602 warn "reloading resource files...\n";
2565 2603
2566 reload_regions; 2604 reload_regions;
2567 reload_facedata; 2605 reload_facedata;
2606 #reload_archetypes;#d#
2568 reload_archetypes; 2607 reload_archetypes;
2569 reload_treasures; 2608 reload_treasures;
2570 2609
2571 warn "finished reloading resource files\n"; 2610 warn "finished reloading resource files\n";
2572} 2611}
… …
2627 cb => sub { 2666 cb => sub {
2628 cf::cleanup "SIG$signal"; 2667 cf::cleanup "SIG$signal";
2629 }, 2668 },
2630 ); 2669 );
2631 } 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
2632} 2709}
2633 2710
2634sub emergency_save() { 2711sub emergency_save() {
2635 my $freeze_guard = cf::freeze_mainloop; 2712 my $freeze_guard = cf::freeze_mainloop;
2636 2713

Diff Legend

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