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

Diff Legend

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