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.275 by root, Thu Jun 7 19:12:22 2007 UTC vs.
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC

… …
206} 206}
207 207
208$Event::DIED = sub { 208$Event::DIED = sub {
209 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
210}; 210};
211
212#############################################################################
211 213
212=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
213 215
214=over 4 216=over 4
215 217
… …
318 320
319BEGIN { *async = \&Coro::async_pool } 321BEGIN { *async = \&Coro::async_pool }
320 322
321=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
322 324
323The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
324always able to handle events or runnable, as crossfire+ is only partly 326is always able to handle events or runnable, as Crossfire TRT is only
325reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable.
326 329
327If it must be done, put the blocking parts into C<sync_job>. This will run 330If it must be done, put the blocking parts into C<sync_job>. This will run
328the given BLOCK in another coroutine while waiting for the result. The 331the given BLOCK in another coroutine while waiting for the result. The
329server will be frozen during this time, so the block should either finish 332server will be frozen during this time, so the block should either finish
330fast or be very important. 333fast or be very important.
… …
390 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
391 394
392 $coro 395 $coro
393} 396}
394 397
395sub write_runtime { 398=item fork_call { }, $args
396 my $runtime = "$LOCALDIR/runtime";
397 399
398 # first touch the runtime file to show we are still running: 400Executes the given code block with the given arguments in a seperate
399 # the fsync below can take a very very long time. 401process, returning the results. Everything must be serialisable with
402Coro::Storable. May, of course, block. Note that the executed sub may
403never block itself or use any form of Event handling.
400 404
401 IO::AIO::aio_utime $runtime, undef, undef; 405=cut
402 406
403 my $guard = cf::lock_acquire "write_runtime"; 407sub fork_call(&@) {
408 my ($cb, @args) = @_;
404 409
405 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
406 or return; 411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
407 414
408 my $value = $cf::RUNTIME + 90 + 10; 415 if (my $pid = fork) {
409 # 10 is the runtime save interval, for a monotonic clock
410 # 60 allows for the watchdog to kill the server.
411
412 (aio_write $fh, 0, (length $value), $value, 0) <= 0
413 and return;
414
415 # always fsync - this file is important
416 aio_fsync $fh
417 and return;
418
419 # touch it again to show we are up-to-date
420 aio_utime $fh, undef, undef;
421
422 close $fh 416 close $fh2;
423 or return;
424 417
425 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
426 and return; 419 $res = Coro::Storable::thaw $res;
427 420
428 warn "runtime file written.\n"; 421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429 422
423 die $$res unless "ARRAY" eq ref $res;
424
425 return wantarray ? @$res : $res->[-1];
426 } else {
427 reset_signals;
428 local $SIG{__WARN__};
429 local $SIG{__DIE__};
430 eval {
431 close $fh1;
432
433 my @res = eval { $cb->(@args) };
434 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
435 };
436
437 warn $@ if $@;
438 _exit 0;
430 1 439 }
440}
441
442=item $value = cf::db_get $family => $key
443
444Returns a single value from the environment database.
445
446=item cf::db_put $family => $key => $value
447
448Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450
451=cut
452
453our $DB;
454
455sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job {
460 eval {
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 }
470}
471
472sub db_get($$) {
473 my $key = "$_[0]/$_[1]";
474
475 cf::sync_job {
476 BDB::db_get $DB, undef, $key, my $data;
477
478 $! ? ()
479 : $data
480 }
481}
482
483sub db_put($$$) {
484 BDB::dbreq_pri 4;
485 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
486}
487
488=item cf::cache $id => [$paths...], $processversion => $process
489
490Generic caching function that returns the value of the resource $id,
491caching and regenerating as required.
492
493This function can block.
494
495=cut
496
497sub cache {
498 my ($id, $src, $processversion, $process) = @_;
499
500 my $meta =
501 join "\x00",
502 $processversion,
503 map {
504 aio_stat $_
505 and Carp::croak "$_: $!";
506
507 ($_, (stat _)[7,9])
508 } @$src;
509
510 my $dbmeta = db_get cache => "$id/meta";
511 if ($dbmeta ne $meta) {
512 # changed, we may need to process
513
514 my @data;
515 my $md5;
516
517 for (0 .. $#$src) {
518 0 <= aio_load $src->[$_], $data[$_]
519 or Carp::croak "$src->[$_]: $!";
520 }
521
522 # if processing is expensive, check
523 # checksum first
524 if (1) {
525 $md5 =
526 join "\x00",
527 $processversion,
528 map {
529 Coro::cede;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src;
532
533
534 my $dbmd5 = db_get cache => "$id/md5";
535 if ($dbmd5 eq $md5) {
536 db_put cache => "$id/meta", $meta;
537
538 return db_get cache => "$id/data";
539 }
540 }
541
542 my $t1 = Time::HiRes::time;
543 my $data = $process->(\@data);
544 my $t2 = Time::HiRes::time;
545
546 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
547
548 db_put cache => "$id/data", $data;
549 db_put cache => "$id/md5" , $md5;
550 db_put cache => "$id/meta", $meta;
551
552 return $data;
553 }
554
555 db_get cache => "$id/data"
431} 556}
432 557
433=item cf::datalog type => key => value, ... 558=item cf::datalog type => key => value, ...
434 559
435Log a datalog packet of the given type with the given key-value pairs. 560Log a datalog packet of the given type with the given key-value pairs.
… …
453attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
454to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
455 580
456In the following description, CLASS can be any of C<global>, C<object> 581In the following description, CLASS can be any of C<global>, C<object>
457C<player>, C<client> or C<map> (i.e. the attachable objects in 582C<player>, C<client> or C<map> (i.e. the attachable objects in
458crossfire+). 583Crossfire TRT).
459 584
460=over 4 585=over 4
461 586
462=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
463 588
… …
665 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
666 } 791 }
667 792
668 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
669 } else { 794 } else {
670 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
671 } 796 }
672 797
673 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
674} 799}
675 800
… …
877 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
878 $filename, length $data, scalar @{$av || []}; 1003 $filename, length $data, scalar @{$av || []};
879 return ($data, $av); 1004 return ($data, $av);
880} 1005}
881 1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
1012
882############################################################################# 1013#############################################################################
883# command handling &c 1014# command handling &c
884 1015
885=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
886 1017
… …
898 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
899} 1030}
900 1031
901=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
902 1033
903Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
904 1035
905If the callback returns something, it is sent back as if reply was being 1036If the callback returns something, it is sent back as if reply was being
906called. 1037called.
907 1038
908=cut 1039=cut
… …
943 1074
944 cf::override; 1075 cf::override;
945 }, 1076 },
946); 1077);
947 1078
948sub load_extension {
949 my ($path) = @_;
950
951 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
952 my $base = $1;
953 my $pkg = $1;
954 $pkg =~ s/[^[:word:]]/_/g;
955 $pkg = "ext::$pkg";
956
957 warn "... loading '$path' into '$pkg'\n";
958
959 open my $fh, "<:utf8", $path
960 or die "$path: $!";
961
962 my $source =
963 "package $pkg; use strict; use utf8;\n"
964 . "#line 1 \"$path\"\n{\n"
965 . (do { local $/; <$fh> })
966 . "\n};\n1";
967
968 unless (eval $source) {
969 my $msg = $@ ? "$path: $@\n"
970 : "extension disabled.\n";
971 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
972 warn $@;
973 warn "mandatory extension failed to load, exiting.\n";
974 exit 1;
975 }
976 die $@;
977 }
978
979 push @EXTS, $pkg;
980}
981
982sub load_extensions { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
983 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
984 next unless -r $ext; 1084 next unless -r $path;
985 eval { 1085
986 load_extension $ext; 1086 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1087 my $base = $1;
1088 my $pkg = $1;
1089 $pkg =~ s/[^[:word:]]/_/g;
1090 $pkg = "ext::$pkg";
1091
1092 open my $fh, "<:utf8", $path
1093 or die "$path: $!";
1094
1095 my $source = do { local $/; <$fh> };
1096
1097 my %ext = (
1098 path => $path,
1099 base => $base,
1100 pkg => $pkg,
1101 );
1102
1103 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1104 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1105
1106 $ext{source} =
1107 "package $pkg; use strict; use utf8;\n"
1108 . "#line 1 \"$path\"\n{\n"
1109 . $source
1110 . "\n};\n1";
1111
1112 $todo{$base} = \%ext;
1113 }
1114
1115 my %done;
1116 while (%todo) {
1117 my $progress;
1118
1119 while (my ($k, $v) = each %todo) {
1120 for (split /,\s*/, $v->{meta}{depends}) {
1121 goto skip
1122 unless exists $done{$_};
1123 }
1124
1125 warn "... loading '$k' into '$v->{pkg}'\n";
1126
1127 unless (eval $v->{source}) {
1128 my $msg = $@ ? "$v->{path}: $@\n"
1129 : "$v->{base}: extension inactive.\n";
1130
1131 if (exists $v->{meta}{mandatory}) {
1132 warn $msg;
1133 warn "mandatory extension failed to load, exiting.\n";
1134 exit 1;
1135 }
1136
1137 warn $msg;
1138 }
1139
1140 $done{$k} = delete $todo{$k};
1141 push @EXTS, $v->{pkg};
1142 $progress = 1;
987 1 1143 }
988 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
989 } 1149 };
990} 1150}
991 1151
992############################################################################# 1152#############################################################################
1153
1154=back
993 1155
994=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
995 1157
996Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
997 1159
… …
1221 1383
1222package cf::region; 1384package cf::region;
1223 1385
1224=item cf::region::find_by_path $path 1386=item cf::region::find_by_path $path
1225 1387
1226Tries to decuce the probable region for a map knowing only its path. 1388Tries to decuce the likely region for a map knowing only its path.
1227 1389
1228=cut 1390=cut
1229 1391
1230sub find_by_path($) { 1392sub find_by_path($) {
1231 my ($path) = @_; 1393 my ($path) = @_;
… …
1776 $cf::MAP{$self->path} = $self; 1938 $cf::MAP{$self->path} = $self;
1777 1939
1778 $self->reset; # polite request, might not happen 1940 $self->reset; # polite request, might not happen
1779} 1941}
1780 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
1781=item cf::map::unique_maps 1979=item cf::map::unique_maps
1782 1980
1783Returns an arrayref of paths of all shared maps that have 1981Returns an arrayref of paths of all shared maps that have
1784instantiated unique items. May block. 1982instantiated unique items. May block.
1785 1983
1786=cut 1984=cut
1787 1985
1788sub unique_maps() { 1986sub unique_maps() {
1789 my $files = aio_readdir $UNIQUEDIR 1987 [
1790 or return; 1988 map {
1791
1792 my @paths;
1793
1794 for (@$files) {
1795 utf8::decode $_; 1989 utf8::decode $_;
1796 next if /\.pst$/; 1990 /\.map$/
1797 next unless /^$PATH_SEP/o; 1991 ? normalise $_
1798 1992 : ()
1799 push @paths, cf::map::normalise $_; 1993 } @{ aio_readdir $UNIQUEDIR or [] }
1800 } 1994 ]
1801
1802 \@paths
1803} 1995}
1804 1996
1805package cf; 1997package cf;
1806 1998
1807=back 1999=back
… …
1853 2045
1854 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2046 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1855 2047
1856 if ($self->{record_replies}) { 2048 if ($self->{record_replies}) {
1857 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2049 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2050
1858 } 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 {
1859 $msg = $npc->name . " says: $msg" if $npc; 2061 $msg = $npc->name . " says: $msg" if $npc;
1860 $self->message ($msg, $flags); 2062 $self->message ($msg, $flags);
2063 }
1861 } 2064 }
1862} 2065}
1863 2066
1864=item $player_object->may ("access") 2067=item $player_object->may ("access")
1865 2068
… …
2317} 2520}
2318 2521
2319=back 2522=back
2320 2523
2321=cut 2524=cut
2322
2323#############################################################################
2324
2325=head2 EXTENSION DATABASE SUPPORT
2326
2327Crossfire maintains a very simple database for extension use. It can
2328currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2329convert to/from binary).
2330
2331The parameter C<$family> should best start with the name of the extension
2332using it, it should be unique.
2333
2334=over 4
2335
2336=item $value = cf::db_get $family => $key
2337
2338Returns a single value from the database.
2339
2340=item cf::db_put $family => $key => $value
2341
2342Stores the given C<$value> in the family.
2343
2344=cut
2345
2346our $DB;
2347
2348sub db_init {
2349 unless ($DB) {
2350 $DB = BDB::db_create $DB_ENV;
2351
2352 cf::sync_job {
2353 eval {
2354 $DB->set_flags (BDB::CHKSUM);
2355
2356 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2357 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2358 cf::cleanup "db_open(db): $!" if $!;
2359 };
2360 cf::cleanup "db_open(db): $@" if $@;
2361 };
2362 }
2363}
2364
2365sub db_get($$) {
2366 my $key = "$_[0]/$_[1]";
2367
2368 cf::sync_job {
2369 BDB::db_get $DB, undef, $key, my $data;
2370
2371 $! ? ()
2372 : $data
2373 }
2374}
2375
2376sub db_put($$$) {
2377 BDB::dbreq_pri 4;
2378 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2379}
2380
2381=item cf::cache $id => [$paths...], $processversion => $process
2382
2383Generic caching function that returns the value of the resource $id,
2384caching and regenerating as required.
2385
2386This function can block.
2387
2388=cut
2389
2390sub cache {
2391 my ($id, $src, $processversion, $process) = @_;
2392
2393 my $meta =
2394 join "\x00",
2395 $processversion,
2396 map {
2397 aio_stat $_
2398 and Carp::croak "$_: $!";
2399
2400 ($_, (stat _)[7,9])
2401 } @$src;
2402
2403 my $dbmeta = db_get cache => "$id/meta";
2404 if ($dbmeta ne $meta) {
2405 # changed, we may need to process
2406
2407 my @data;
2408 my $md5;
2409
2410 for (0 .. $#$src) {
2411 0 <= aio_load $src->[$_], $data[$_]
2412 or Carp::croak "$src->[$_]: $!";
2413 }
2414
2415 # if processing is expensive, check
2416 # checksum first
2417 if (1) {
2418 $md5 =
2419 join "\x00",
2420 $processversion,
2421 map {
2422 Coro::cede;
2423 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2424 } 0.. $#$src;
2425
2426
2427 my $dbmd5 = db_get cache => "$id/md5";
2428 if ($dbmd5 eq $md5) {
2429 db_put cache => "$id/meta", $meta;
2430
2431 return db_get cache => "$id/data";
2432 }
2433 }
2434
2435 my $t1 = Time::HiRes::time;
2436 my $data = $process->(\@data);
2437 my $t2 = Time::HiRes::time;
2438
2439 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2440
2441 db_put cache => "$id/data", $data;
2442 db_put cache => "$id/md5" , $md5;
2443 db_put cache => "$id/meta", $meta;
2444
2445 return $data;
2446 }
2447
2448 db_get cache => "$id/data"
2449}
2450
2451=item fork_call { }, $args
2452
2453Executes the given code block with the given arguments in a seperate
2454process, returning the results. Everything must be serialisable with
2455Coro::Storable. May, of course, block. Note that the executed sub may
2456never block itself or use any form of Event handling.
2457
2458=cut
2459
2460sub fork_call(&@) {
2461 my ($cb, @args) = @_;
2462
2463# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2464# or die "socketpair: $!";
2465 pipe my $fh1, my $fh2
2466 or die "pipe: $!";
2467
2468 if (my $pid = fork) {
2469 close $fh2;
2470
2471 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2472 $res = Coro::Storable::thaw $res;
2473
2474 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2475
2476 die $$res unless "ARRAY" eq ref $res;
2477
2478 return wantarray ? @$res : $res->[-1];
2479 } else {
2480 reset_signals;
2481 local $SIG{__WARN__};
2482 local $SIG{__DIE__};
2483 eval {
2484 close $fh1;
2485
2486 my @res = eval { $cb->(@args) };
2487 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2488 };
2489
2490 warn $@ if $@;
2491 _exit 0;
2492 }
2493}
2494 2525
2495############################################################################# 2526#############################################################################
2496# the server's init and main functions 2527# the server's init and main functions
2497 2528
2498sub load_facedata($) { 2529sub load_facedata($) {
… …
2635 cb => sub { 2666 cb => sub {
2636 cf::cleanup "SIG$signal"; 2667 cf::cleanup "SIG$signal";
2637 }, 2668 },
2638 ); 2669 );
2639 } 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
2640} 2709}
2641 2710
2642sub emergency_save() { 2711sub emergency_save() {
2643 my $freeze_guard = cf::freeze_mainloop; 2712 my $freeze_guard = cf::freeze_mainloop;
2644 2713

Diff Legend

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