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.268 by root, Tue May 22 10:50:00 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
… …
1904 $self->deactivate_recursive; 2116 $self->deactivate_recursive;
1905 2117
1906 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2118 return if UNIVERSAL::isa $self->map, "ext::map_link";
1907 2119
1908 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2120 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1909 if $self->map; 2121 if $self->map && $self->map->{path} ne "{link}";
1910 2122
1911 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2123 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1912} 2124}
1913 2125
1914sub cf::object::player::leave_link { 2126sub cf::object::player::leave_link {
1915 my ($self, $map, $x, $y) = @_; 2127 my ($self, $map, $x, $y) = @_;
2128
2129 return unless $self->contr->active;
1916 2130
1917 my $link_pos = delete $self->{_link_pos}; 2131 my $link_pos = delete $self->{_link_pos};
1918 2132
1919 unless ($map) { 2133 unless ($map) {
1920 # restore original map position 2134 # restore original map position
… …
1943 2157
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2158 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1945 $self->enter_map ($map, $x, $y); 2159 $self->enter_map ($map, $x, $y);
1946} 2160}
1947 2161
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)]) 2162=item $player_object->goto ($path, $x, $y[, $check->($map)])
1981 2163
1982Moves the player to the given map-path and coordinates by first freezing 2164Moves the player to the given map-path and coordinates by first freezing
1983her, loading and preparing them map, calling the provided $check callback 2165her, loading and preparing them map, calling the provided $check callback
1984that has to return the map if sucecssful, and then unfreezes the player on 2166that has to return the map if sucecssful, and then unfreezes the player on
1985the new (success) or old (failed) map position. 2167the new (success) or old (failed) map position.
1986 2168
1987=cut 2169=cut
1988 2170
2171our $GOTOGEN;
2172
1989sub cf::object::player::goto { 2173sub cf::object::player::goto {
1990 my ($self, $path, $x, $y, $check) = @_; 2174 my ($self, $path, $x, $y, $check) = @_;
1991 2175
1992 #d# #TODO# 2176 # do generation counting so two concurrent goto's will be executed in-order
1993 if ($check && !ref $check) { 2177 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1994 warn Carp::longmess "goto called with non-ref check argument";#d#
1995 undef $check;
1996 }
1997 2178
1998 $self->enter_link; 2179 $self->enter_link;
1999 2180
2000 (async { 2181 (async {
2001 my $map = eval { 2182 my $map = eval {
… …
2014 if ($@) { 2195 if ($@) {
2015 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED); 2196 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2016 LOG llevError | logBacktrace, Carp::longmess $@; 2197 LOG llevError | logBacktrace, Carp::longmess $@;
2017 } 2198 }
2018 2199
2200 if ($gen == $self->{_goto_generation}) {
2201 delete $self->{_goto_generation};
2019 $self->leave_link ($map, $x, $y); 2202 $self->leave_link ($map, $x, $y);
2203 }
2020 })->prio (1); 2204 })->prio (1);
2021} 2205}
2022 2206
2023=item $player_object->enter_exit ($exit_object) 2207=item $player_object->enter_exit ($exit_object)
2024 2208
… …
2338=back 2522=back
2339 2523
2340=cut 2524=cut
2341 2525
2342############################################################################# 2526#############################################################################
2343
2344=head2 EXTENSION DATABASE SUPPORT
2345
2346Crossfire maintains a very simple database for extension use. It can
2347currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2348convert to/from binary).
2349
2350The parameter C<$family> should best start with the name of the extension
2351using it, it should be unique.
2352
2353=over 4
2354
2355=item $value = cf::db_get $family => $key
2356
2357Returns a single value from the database.
2358
2359=item cf::db_put $family => $key => $value
2360
2361Stores the given C<$value> in the family.
2362
2363=cut
2364
2365our $DB;
2366
2367sub db_init {
2368 unless ($DB) {
2369 $DB = BDB::db_create $DB_ENV;
2370
2371 cf::sync_job {
2372 eval {
2373 $DB->set_flags (BDB::CHKSUM);
2374
2375 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2376 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2377 cf::cleanup "db_open(db): $!" if $!;
2378 };
2379 cf::cleanup "db_open(db): $@" if $@;
2380 };
2381 }
2382}
2383
2384sub db_get($$) {
2385 my $key = "$_[0]/$_[1]";
2386
2387 cf::sync_job {
2388 BDB::db_get $DB, undef, $key, my $data;
2389
2390 $! ? ()
2391 : $data
2392 }
2393}
2394
2395sub db_put($$$) {
2396 BDB::dbreq_pri 4;
2397 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2398}
2399
2400=item cf::cache $id => [$paths...], $processversion => $process
2401
2402Generic caching function that returns the value of the resource $id,
2403caching and regenerating as required.
2404
2405This function can block.
2406
2407=cut
2408
2409sub cache {
2410 my ($id, $src, $processversion, $process) = @_;
2411
2412 my $meta =
2413 join "\x00",
2414 $processversion,
2415 map {
2416 aio_stat $_
2417 and Carp::croak "$_: $!";
2418
2419 ($_, (stat _)[7,9])
2420 } @$src;
2421
2422 my $dbmeta = db_get cache => "$id/meta";
2423 if ($dbmeta ne $meta) {
2424 # changed, we may need to process
2425
2426 my @data;
2427 my $md5;
2428
2429 for (0 .. $#$src) {
2430 0 <= aio_load $src->[$_], $data[$_]
2431 or Carp::croak "$src->[$_]: $!";
2432 }
2433
2434 # if processing is expensive, check
2435 # checksum first
2436 if (1) {
2437 $md5 =
2438 join "\x00",
2439 $processversion,
2440 map {
2441 Coro::cede;
2442 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2443 } 0.. $#$src;
2444
2445
2446 my $dbmd5 = db_get cache => "$id/md5";
2447 if ($dbmd5 eq $md5) {
2448 db_put cache => "$id/meta", $meta;
2449
2450 return db_get cache => "$id/data";
2451 }
2452 }
2453
2454 my $t1 = Time::HiRes::time;
2455 my $data = $process->(\@data);
2456 my $t2 = Time::HiRes::time;
2457
2458 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2459
2460 db_put cache => "$id/data", $data;
2461 db_put cache => "$id/md5" , $md5;
2462 db_put cache => "$id/meta", $meta;
2463
2464 return $data;
2465 }
2466
2467 db_get cache => "$id/data"
2468}
2469
2470=item fork_call { }, $args
2471
2472Executes the given code block with the given arguments in a seperate
2473process, returning the results. Everything must be serialisable with
2474Coro::Storable. May, of course, block. Note that the executed sub may
2475never block itself or use any form of Event handling.
2476
2477=cut
2478
2479sub fork_call(&@) {
2480 my ($cb, @args) = @_;
2481
2482# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2483# or die "socketpair: $!";
2484 pipe my $fh1, my $fh2
2485 or die "pipe: $!";
2486
2487 if (my $pid = fork) {
2488 close $fh2;
2489
2490 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2491 $res = Coro::Storable::thaw $res;
2492
2493 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2494
2495 die $$res unless "ARRAY" eq ref $res;
2496
2497 return wantarray ? @$res : $res->[-1];
2498 } else {
2499 reset_signals;
2500 local $SIG{__WARN__};
2501 local $SIG{__DIE__};
2502 eval {
2503 close $fh1;
2504
2505 my @res = eval { $cb->(@args) };
2506 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2507 };
2508
2509 warn $@ if $@;
2510 _exit 0;
2511 }
2512}
2513
2514
2515
2516#############################################################################
2517# the server's init and main functions 2527# the server's init and main functions
2518 2528
2519sub load_facedata($) { 2529sub load_facedata($) {
2520 my ($path) = @_; 2530 my ($path) = @_;
2521 2531
… …
2591sub reload_resources { 2601sub reload_resources {
2592 warn "reloading resource files...\n"; 2602 warn "reloading resource files...\n";
2593 2603
2594 reload_regions; 2604 reload_regions;
2595 reload_facedata; 2605 reload_facedata;
2606 #reload_archetypes;#d#
2596 reload_archetypes; 2607 reload_archetypes;
2597 reload_treasures; 2608 reload_treasures;
2598 2609
2599 warn "finished reloading resource files\n"; 2610 warn "finished reloading resource files\n";
2600} 2611}
… …
2655 cb => sub { 2666 cb => sub {
2656 cf::cleanup "SIG$signal"; 2667 cf::cleanup "SIG$signal";
2657 }, 2668 },
2658 ); 2669 );
2659 } 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
2660} 2709}
2661 2710
2662sub emergency_save() { 2711sub emergency_save() {
2663 my $freeze_guard = cf::freeze_mainloop; 2712 my $freeze_guard = cf::freeze_mainloop;
2664 2713

Diff Legend

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