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.269 by root, Tue May 22 21:35:26 2007 UTC vs.
Revision 1.281 by root, Sat Jun 16 23:22:59 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
… …
1904 $self->deactivate_recursive; 2105 $self->deactivate_recursive;
1905 2106
1906 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2107 return if UNIVERSAL::isa $self->map, "ext::map_link";
1907 2108
1908 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2109 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1909 if $self->map; 2110 if $self->map && $self->map->{path} ne "{link}";
1910 2111
1911 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2112 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1912} 2113}
1913 2114
1914sub cf::object::player::leave_link { 2115sub cf::object::player::leave_link {
1915 my ($self, $map, $x, $y) = @_; 2116 my ($self, $map, $x, $y) = @_;
2117
2118 return unless $self->contr->active;
1916 2119
1917 my $link_pos = delete $self->{_link_pos}; 2120 my $link_pos = delete $self->{_link_pos};
1918 2121
1919 unless ($map) { 2122 unless ($map) {
1920 # restore original map position 2123 # restore original map position
… …
1943 2146
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2147 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1945 $self->enter_map ($map, $x, $y); 2148 $self->enter_map ($map, $x, $y);
1946} 2149}
1947 2150
1948cf::player->attach (
1949 on_logout => sub {
1950 my ($pl) = @_;
1951
1952 # abort map switching before logout
1953 if ($pl->ob->{_link_pos}) {
1954 cf::sync_job {
1955 $pl->ob->leave_link
1956 };
1957 }
1958 },
1959 on_login => sub {
1960 my ($pl) = @_;
1961
1962 # try to abort aborted map switching on player login :)
1963 # should happen only on crashes
1964 if ($pl->ob->{_link_pos}) {
1965 $pl->ob->enter_link;
1966 (async {
1967 $pl->ob->reply (undef,
1968 "There was an internal problem at your last logout, "
1969 . "the server will try to bring you to your intended destination in a second.",
1970 cf::NDI_RED);
1971 # we need this sleep as the login has a concurrent enter_exit running
1972 # and this sleep increases chances of the player not ending up in scorn
1973 Coro::Timer::sleep 1;
1974 $pl->ob->leave_link;
1975 })->prio (2);
1976 }
1977 },
1978);
1979
1980=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2151=item $player_object->goto ($path, $x, $y[, $check->($map)])
1981 2152
1982Moves the player to the given map-path and coordinates by first freezing 2153Moves the player to the given map-path and coordinates by first freezing
1983her, loading and preparing them map, calling the provided $check callback 2154her, loading and preparing them map, calling the provided $check callback
1984that has to return the map if sucecssful, and then unfreezes the player on 2155that has to return the map if sucecssful, and then unfreezes the player on
1985the new (success) or old (failed) map position. 2156the new (success) or old (failed) map position.
1986 2157
1987=cut 2158=cut
1988 2159
2160our $GOTOGEN;
2161
1989sub cf::object::player::goto { 2162sub cf::object::player::goto {
1990 my ($self, $path, $x, $y, $check) = @_; 2163 my ($self, $path, $x, $y, $check) = @_;
2164
2165 # do generation counting so two concurrent goto's will be executed in-order
2166 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1991 2167
1992 $self->enter_link; 2168 $self->enter_link;
1993 2169
1994 (async { 2170 (async {
1995 my $map = eval { 2171 my $map = eval {
… …
2008 if ($@) { 2184 if ($@) {
2009 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED); 2185 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2010 LOG llevError | logBacktrace, Carp::longmess $@; 2186 LOG llevError | logBacktrace, Carp::longmess $@;
2011 } 2187 }
2012 2188
2189 if ($gen == $self->{_goto_generation}) {
2190 delete $self->{_goto_generation};
2013 $self->leave_link ($map, $x, $y); 2191 $self->leave_link ($map, $x, $y);
2192 }
2014 })->prio (1); 2193 })->prio (1);
2015} 2194}
2016 2195
2017=item $player_object->enter_exit ($exit_object) 2196=item $player_object->enter_exit ($exit_object)
2018 2197
… …
2332=back 2511=back
2333 2512
2334=cut 2513=cut
2335 2514
2336############################################################################# 2515#############################################################################
2337
2338=head2 EXTENSION DATABASE SUPPORT
2339
2340Crossfire maintains a very simple database for extension use. It can
2341currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2342convert to/from binary).
2343
2344The parameter C<$family> should best start with the name of the extension
2345using it, it should be unique.
2346
2347=over 4
2348
2349=item $value = cf::db_get $family => $key
2350
2351Returns a single value from the database.
2352
2353=item cf::db_put $family => $key => $value
2354
2355Stores the given C<$value> in the family.
2356
2357=cut
2358
2359our $DB;
2360
2361sub db_init {
2362 unless ($DB) {
2363 $DB = BDB::db_create $DB_ENV;
2364
2365 cf::sync_job {
2366 eval {
2367 $DB->set_flags (BDB::CHKSUM);
2368
2369 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2370 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2371 cf::cleanup "db_open(db): $!" if $!;
2372 };
2373 cf::cleanup "db_open(db): $@" if $@;
2374 };
2375 }
2376}
2377
2378sub db_get($$) {
2379 my $key = "$_[0]/$_[1]";
2380
2381 cf::sync_job {
2382 BDB::db_get $DB, undef, $key, my $data;
2383
2384 $! ? ()
2385 : $data
2386 }
2387}
2388
2389sub db_put($$$) {
2390 BDB::dbreq_pri 4;
2391 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2392}
2393
2394=item cf::cache $id => [$paths...], $processversion => $process
2395
2396Generic caching function that returns the value of the resource $id,
2397caching and regenerating as required.
2398
2399This function can block.
2400
2401=cut
2402
2403sub cache {
2404 my ($id, $src, $processversion, $process) = @_;
2405
2406 my $meta =
2407 join "\x00",
2408 $processversion,
2409 map {
2410 aio_stat $_
2411 and Carp::croak "$_: $!";
2412
2413 ($_, (stat _)[7,9])
2414 } @$src;
2415
2416 my $dbmeta = db_get cache => "$id/meta";
2417 if ($dbmeta ne $meta) {
2418 # changed, we may need to process
2419
2420 my @data;
2421 my $md5;
2422
2423 for (0 .. $#$src) {
2424 0 <= aio_load $src->[$_], $data[$_]
2425 or Carp::croak "$src->[$_]: $!";
2426 }
2427
2428 # if processing is expensive, check
2429 # checksum first
2430 if (1) {
2431 $md5 =
2432 join "\x00",
2433 $processversion,
2434 map {
2435 Coro::cede;
2436 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2437 } 0.. $#$src;
2438
2439
2440 my $dbmd5 = db_get cache => "$id/md5";
2441 if ($dbmd5 eq $md5) {
2442 db_put cache => "$id/meta", $meta;
2443
2444 return db_get cache => "$id/data";
2445 }
2446 }
2447
2448 my $t1 = Time::HiRes::time;
2449 my $data = $process->(\@data);
2450 my $t2 = Time::HiRes::time;
2451
2452 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2453
2454 db_put cache => "$id/data", $data;
2455 db_put cache => "$id/md5" , $md5;
2456 db_put cache => "$id/meta", $meta;
2457
2458 return $data;
2459 }
2460
2461 db_get cache => "$id/data"
2462}
2463
2464=item fork_call { }, $args
2465
2466Executes the given code block with the given arguments in a seperate
2467process, returning the results. Everything must be serialisable with
2468Coro::Storable. May, of course, block. Note that the executed sub may
2469never block itself or use any form of Event handling.
2470
2471=cut
2472
2473sub fork_call(&@) {
2474 my ($cb, @args) = @_;
2475
2476# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2477# or die "socketpair: $!";
2478 pipe my $fh1, my $fh2
2479 or die "pipe: $!";
2480
2481 if (my $pid = fork) {
2482 close $fh2;
2483
2484 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2485 $res = Coro::Storable::thaw $res;
2486
2487 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2488
2489 die $$res unless "ARRAY" eq ref $res;
2490
2491 return wantarray ? @$res : $res->[-1];
2492 } else {
2493 reset_signals;
2494 local $SIG{__WARN__};
2495 local $SIG{__DIE__};
2496 eval {
2497 close $fh1;
2498
2499 my @res = eval { $cb->(@args) };
2500 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2501 };
2502
2503 warn $@ if $@;
2504 _exit 0;
2505 }
2506}
2507
2508
2509
2510#############################################################################
2511# the server's init and main functions 2516# the server's init and main functions
2512 2517
2513sub load_facedata($) { 2518sub load_facedata($) {
2514 my ($path) = @_; 2519 my ($path) = @_;
2515 2520
… …
2585sub reload_resources { 2590sub reload_resources {
2586 warn "reloading resource files...\n"; 2591 warn "reloading resource files...\n";
2587 2592
2588 reload_regions; 2593 reload_regions;
2589 reload_facedata; 2594 reload_facedata;
2595 #reload_archetypes;#d#
2590 reload_archetypes; 2596 reload_archetypes;
2591 reload_treasures; 2597 reload_treasures;
2592 2598
2593 warn "finished reloading resource files\n"; 2599 warn "finished reloading resource files\n";
2594} 2600}
… …
2649 cb => sub { 2655 cb => sub {
2650 cf::cleanup "SIG$signal"; 2656 cf::cleanup "SIG$signal";
2651 }, 2657 },
2652 ); 2658 );
2653 } 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
2654} 2698}
2655 2699
2656sub emergency_save() { 2700sub emergency_save() {
2657 my $freeze_guard = cf::freeze_mainloop; 2701 my $freeze_guard = cf::freeze_mainloop;
2658 2702

Diff Legend

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