… | |
… | |
3 | use utf8; |
3 | use utf8; |
4 | use strict; |
4 | use strict; |
5 | |
5 | |
6 | use Symbol; |
6 | use Symbol; |
7 | use List::Util; |
7 | use List::Util; |
|
|
8 | use Socket; |
8 | use Storable; |
9 | use Storable; |
9 | use Event; |
10 | use Event; |
10 | use Opcode; |
11 | use Opcode; |
11 | use Safe; |
12 | use Safe; |
12 | use Safe::Hole; |
13 | use Safe::Hole; |
13 | |
14 | |
14 | use Coro 3.61 (); |
15 | use Coro 3.61 (); |
15 | use Coro::State; |
16 | use Coro::State; |
|
|
17 | use Coro::Handle; |
16 | use Coro::Event; |
18 | use Coro::Event; |
17 | use Coro::Timer; |
19 | use Coro::Timer; |
18 | use Coro::Signal; |
20 | use Coro::Signal; |
19 | use Coro::Semaphore; |
21 | use Coro::Semaphore; |
20 | use Coro::AIO; |
22 | use Coro::AIO; |
… | |
… | |
146 | =cut |
148 | =cut |
147 | |
149 | |
148 | BEGIN { |
150 | BEGIN { |
149 | *CORE::GLOBAL::warn = sub { |
151 | *CORE::GLOBAL::warn = sub { |
150 | my $msg = join "", @_; |
152 | my $msg = join "", @_; |
151 | utf8::encode $msg; |
|
|
152 | |
153 | |
153 | $msg .= "\n" |
154 | $msg .= "\n" |
154 | unless $msg =~ /\n$/; |
155 | unless $msg =~ /\n$/; |
155 | |
156 | |
|
|
157 | $msg =~ s/([\x00-\x09\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; |
|
|
158 | |
|
|
159 | utf8::encode $msg; |
156 | LOG llevError, $msg; |
160 | LOG llevError, $msg; |
157 | }; |
161 | }; |
158 | } |
162 | } |
159 | |
163 | |
160 | @safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; |
164 | @safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; |
… | |
… | |
2262 | ############################################################################# |
2266 | ############################################################################# |
2263 | |
2267 | |
2264 | =head2 EXTENSION DATABASE SUPPORT |
2268 | =head2 EXTENSION DATABASE SUPPORT |
2265 | |
2269 | |
2266 | Crossfire maintains a very simple database for extension use. It can |
2270 | Crossfire maintains a very simple database for extension use. It can |
2267 | currently store anything that can be serialised using Storable, which |
2271 | currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to |
2268 | excludes objects. |
2272 | convert to/from binary). |
2269 | |
2273 | |
2270 | The parameter C<$family> should best start with the name of the extension |
2274 | The parameter C<$family> should best start with the name of the extension |
2271 | using it, it should be unique. |
2275 | using it, it should be unique. |
2272 | |
2276 | |
2273 | =over 4 |
2277 | =over 4 |
… | |
… | |
2296 | BDB::CREATE | BDB::AUTO_COMMIT, 0666; |
2300 | BDB::CREATE | BDB::AUTO_COMMIT, 0666; |
2297 | cf::cleanup "db_open(db): $!" if $!; |
2301 | cf::cleanup "db_open(db): $!" if $!; |
2298 | }; |
2302 | }; |
2299 | cf::cleanup "db_open(db): $@" if $@; |
2303 | cf::cleanup "db_open(db): $@" if $@; |
2300 | }; |
2304 | }; |
2301 | |
|
|
2302 | my $path = cf::localdir . "/database.pst"; |
|
|
2303 | if (stat $path) { |
|
|
2304 | cf::sync_job { |
|
|
2305 | my $pst = Storable::retrieve $path; |
|
|
2306 | |
|
|
2307 | cf::db_put (board => data => $pst->{board}); |
|
|
2308 | cf::db_put (guildrules => data => $pst->{guildrules}); |
|
|
2309 | cf::db_put (rent => balance => $pst->{rent}{balance}); |
|
|
2310 | BDB::db_env_txn_checkpoint $DB_ENV; |
|
|
2311 | |
|
|
2312 | unlink $path; |
|
|
2313 | }; |
|
|
2314 | } |
|
|
2315 | } |
2305 | } |
2316 | } |
2306 | } |
2317 | |
2307 | |
2318 | sub db_get($$) { |
2308 | sub db_get($$) { |
2319 | my $key = "$_[0]/$_[1]"; |
2309 | my $key = "$_[0]/$_[1]"; |
2320 | |
2310 | |
2321 | cf::sync_job { |
2311 | cf::sync_job { |
2322 | BDB::db_get $DB, undef, $key, my $data; |
2312 | BDB::db_get $DB, undef, $key, my $data; |
2323 | |
2313 | |
2324 | $! ? () |
2314 | $! ? () |
2325 | : Compress::LZF::sthaw $data |
2315 | : $data |
2326 | } |
2316 | } |
2327 | } |
2317 | } |
2328 | |
2318 | |
2329 | sub db_put($$$) { |
2319 | sub db_put($$$) { |
2330 | BDB::dbreq_pri 4; |
2320 | BDB::dbreq_pri 4; |
2331 | BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { }; |
2321 | BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; |
2332 | } |
2322 | } |
|
|
2323 | |
|
|
2324 | =item cf::cache $id => [$paths...], $processversion => $process |
|
|
2325 | |
|
|
2326 | Generic caching function that returns the value of the resource $id, |
|
|
2327 | caching and regenerating as required. |
|
|
2328 | |
|
|
2329 | This function can block. |
|
|
2330 | |
|
|
2331 | =cut |
|
|
2332 | |
|
|
2333 | sub cache { |
|
|
2334 | my ($id, $src, $processversion, $process) = @_; |
|
|
2335 | |
|
|
2336 | my $meta = |
|
|
2337 | join "\x00", |
|
|
2338 | $processversion, |
|
|
2339 | map { |
|
|
2340 | aio_stat $_ |
|
|
2341 | and Carp::croak "$_: $!"; |
|
|
2342 | |
|
|
2343 | ($_, (stat _)[7,9]) |
|
|
2344 | } @$src; |
|
|
2345 | |
|
|
2346 | my $dbmeta = db_get cache => "$id/meta"; |
|
|
2347 | if ($dbmeta ne $meta) { |
|
|
2348 | # changed, we may need to process |
|
|
2349 | |
|
|
2350 | my @data; |
|
|
2351 | my $md5; |
|
|
2352 | |
|
|
2353 | for (0 .. $#$src) { |
|
|
2354 | 0 <= aio_load $src->[$_], $data[$_] |
|
|
2355 | or Carp::croak "$src->[$_]: $!"; |
|
|
2356 | } |
|
|
2357 | |
|
|
2358 | # if processing is expensive, check |
|
|
2359 | # checksum first |
|
|
2360 | if (1) { |
|
|
2361 | $md5 = |
|
|
2362 | join "\x00", |
|
|
2363 | $processversion, |
|
|
2364 | map { |
|
|
2365 | Coro::cede; |
|
|
2366 | ($src->[$_], Digest::MD5::md5_hex $data[$_]) |
|
|
2367 | } 0.. $#$src; |
|
|
2368 | |
|
|
2369 | |
|
|
2370 | my $dbmd5 = db_get cache => "$id/md5"; |
|
|
2371 | if ($dbmd5 eq $md5) { |
|
|
2372 | db_put cache => "$id/meta", $meta; |
|
|
2373 | |
|
|
2374 | return db_get cache => "$id/data"; |
|
|
2375 | } |
|
|
2376 | } |
|
|
2377 | |
|
|
2378 | my $data = $process->(\@data); |
|
|
2379 | |
|
|
2380 | db_put cache => "$id/data", $data; |
|
|
2381 | db_put cache => "$id/md5" , $md5; |
|
|
2382 | db_put cache => "$id/meta", $meta; |
|
|
2383 | |
|
|
2384 | return $data; |
|
|
2385 | } |
|
|
2386 | |
|
|
2387 | db_get cache => "$id/data" |
|
|
2388 | } |
|
|
2389 | |
|
|
2390 | =item fork_call { }, $args |
|
|
2391 | |
|
|
2392 | Executes the given code block with the given arguments in a seperate |
|
|
2393 | process, returning the results. Everything must be serialisable with |
|
|
2394 | Coro::Storable. May, of course, block. Note that the executed sub may |
|
|
2395 | never block itself or use any form of Event handling. |
|
|
2396 | |
|
|
2397 | =cut |
|
|
2398 | |
|
|
2399 | sub fork_call(&@) { |
|
|
2400 | my ($cb, @args) = @_; |
|
|
2401 | |
|
|
2402 | # socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC |
|
|
2403 | # or die "socketpair: $!"; |
|
|
2404 | pipe my $fh1, my $fh2 |
|
|
2405 | or die "pipe: $!"; |
|
|
2406 | |
|
|
2407 | if (my $pid = fork) { |
|
|
2408 | close $fh2; |
|
|
2409 | |
|
|
2410 | my $res = (Coro::Handle::unblock $fh1)->readline (undef); |
|
|
2411 | $res = Coro::Storable::thaw $res; |
|
|
2412 | |
|
|
2413 | waitpid $pid, 0; # should not block anymore, we expect the child to simply behave |
|
|
2414 | |
|
|
2415 | die $$res unless "ARRAY" eq ref $res; |
|
|
2416 | |
|
|
2417 | return wantarray ? @$res : $res->[-1]; |
|
|
2418 | } else { |
|
|
2419 | eval { |
|
|
2420 | local $SIG{__DIE__}; |
|
|
2421 | local $SIG{__WARN__}; |
|
|
2422 | close $fh1; |
|
|
2423 | |
|
|
2424 | my @res = eval { $cb->(@args) }; |
|
|
2425 | syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res); |
|
|
2426 | }; |
|
|
2427 | |
|
|
2428 | _exit 0; |
|
|
2429 | } |
|
|
2430 | } |
|
|
2431 | |
|
|
2432 | |
2333 | |
2433 | |
2334 | ############################################################################# |
2434 | ############################################################################# |
2335 | # the server's init and main functions |
2435 | # the server's init and main functions |
2336 | |
2436 | |
2337 | sub load_facedata { |
2437 | sub load_facedata($) { |
2338 | my $path = sprintf "%s/facedata", cf::datadir; |
2438 | my ($path) = @_; |
2339 | |
2439 | |
2340 | warn "loading facedata from $path\n"; |
2440 | warn "loading facedata from $path\n"; |
2341 | |
2441 | |
2342 | my $facedata; |
2442 | my $facedata; |
2343 | 0 < aio_load $path, $facedata |
2443 | 0 < aio_load $path, $facedata |
… | |
… | |
2384 | } |
2484 | } |
2385 | |
2485 | |
2386 | 1 |
2486 | 1 |
2387 | } |
2487 | } |
2388 | |
2488 | |
|
|
2489 | sub reload_facedata { |
|
|
2490 | load_facedata sprintf "%s/facedata", cf::datadir |
|
|
2491 | or die "unable to load facedata\n"; |
|
|
2492 | } |
|
|
2493 | |
|
|
2494 | sub reload_regions { |
|
|
2495 | load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir |
|
|
2496 | or die "unable to load regions file\n"; |
|
|
2497 | } |
|
|
2498 | |
2389 | sub load_archetypes { |
2499 | sub reload_archetypes { |
2390 | load_archetype_file sprintf "%s/archetypes", cf::datadir; # remove when stable |
|
|
2391 | load_archetype_file sprintf "%s/archetypes", cf::datadir |
2500 | load_resource_file sprintf "%s/archetypes", cf::datadir |
|
|
2501 | or die "unable to load archetypes\n"; |
2392 | } |
2502 | } |
2393 | |
2503 | |
2394 | sub load_treasures { |
2504 | sub reload_treasures { |
2395 | load_treasure_file sprintf "%s/treasures", cf::datadir |
2505 | load_resource_file sprintf "%s/treasures", cf::datadir |
|
|
2506 | or die "unable to load treasurelists\n"; |
2396 | } |
2507 | } |
2397 | |
2508 | |
2398 | sub reload_resources { |
2509 | sub reload_resources { |
2399 | warn "reloading resource files...\n"; |
2510 | warn "reloading resource files...\n"; |
2400 | |
2511 | |
2401 | load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir |
2512 | reload_regions; |
2402 | or die "unable to load regions file\n"; |
|
|
2403 | load_facedata |
2513 | reload_facedata; |
2404 | or die "unable to load facedata\n"; |
|
|
2405 | load_archetypes |
2514 | reload_archetypes; |
2406 | or die "unable to load archetypes\n"; |
|
|
2407 | load_treasures |
2515 | reload_treasures; |
2408 | or die "unable to load treasurelists\n"; |
|
|
2409 | |
2516 | |
2410 | warn "finished reloading resource files\n"; |
2517 | warn "finished reloading resource files\n"; |
2411 | } |
2518 | } |
2412 | |
2519 | |
2413 | sub init { |
2520 | sub init { |
… | |
… | |
2508 | |
2615 | |
2509 | warn Carp::longmess "post_cleanup backtrace" |
2616 | warn Carp::longmess "post_cleanup backtrace" |
2510 | if $make_core; |
2617 | if $make_core; |
2511 | } |
2618 | } |
2512 | |
2619 | |
2513 | sub reload() { |
2620 | sub do_reload_perl() { |
2514 | # can/must only be called in main |
2621 | # can/must only be called in main |
2515 | if ($Coro::current != $Coro::main) { |
2622 | if ($Coro::current != $Coro::main) { |
2516 | warn "can only reload from main coroutine"; |
2623 | warn "can only reload from main coroutine"; |
2517 | return; |
2624 | return; |
2518 | } |
2625 | } |
… | |
… | |
2617 | warn "reattaching attachments to maps"; |
2724 | warn "reattaching attachments to maps"; |
2618 | reattach $_ for values %MAP; |
2725 | reattach $_ for values %MAP; |
2619 | warn "reattaching attachments to players"; |
2726 | warn "reattaching attachments to players"; |
2620 | reattach $_ for values %PLAYER; |
2727 | reattach $_ for values %PLAYER; |
2621 | |
2728 | |
2622 | warn "loading reloadable resources"; |
|
|
2623 | reload_resources; |
|
|
2624 | |
|
|
2625 | warn "leaving sync_job"; |
2729 | warn "leaving sync_job"; |
2626 | |
2730 | |
2627 | 1 |
2731 | 1 |
2628 | } or do { |
2732 | } or do { |
2629 | warn $@; |
2733 | warn $@; |
… | |
… | |
2634 | warn "reloaded"; |
2738 | warn "reloaded"; |
2635 | }; |
2739 | }; |
2636 | |
2740 | |
2637 | our $RELOAD_WATCHER; # used only during reload |
2741 | our $RELOAD_WATCHER; # used only during reload |
2638 | |
2742 | |
|
|
2743 | sub reload_perl() { |
|
|
2744 | # doing reload synchronously and two reloads happen back-to-back, |
|
|
2745 | # coro crashes during coro_state_free->destroy here. |
|
|
2746 | |
|
|
2747 | $RELOAD_WATCHER ||= Event->timer ( |
|
|
2748 | reentrant => 0, |
|
|
2749 | after => 0, |
|
|
2750 | data => WF_AUTOCANCEL, |
|
|
2751 | cb => sub { |
|
|
2752 | do_reload_perl; |
|
|
2753 | undef $RELOAD_WATCHER; |
|
|
2754 | }, |
|
|
2755 | ); |
|
|
2756 | } |
|
|
2757 | |
2639 | register_command "reload" => sub { |
2758 | register_command "reload" => sub { |
2640 | my ($who, $arg) = @_; |
2759 | my ($who, $arg) = @_; |
2641 | |
2760 | |
2642 | if ($who->flag (FLAG_WIZ)) { |
2761 | if ($who->flag (FLAG_WIZ)) { |
2643 | $who->message ("reloading server."); |
2762 | $who->message ("reloading server."); |
2644 | |
2763 | async { reload_perl }; |
2645 | # doing reload synchronously and two reloads happen back-to-back, |
|
|
2646 | # coro crashes during coro_state_free->destroy here. |
|
|
2647 | |
|
|
2648 | $RELOAD_WATCHER ||= Event->timer ( |
|
|
2649 | reentrant => 0, |
|
|
2650 | after => 0, |
|
|
2651 | data => WF_AUTOCANCEL, |
|
|
2652 | cb => sub { |
|
|
2653 | reload; |
|
|
2654 | undef $RELOAD_WATCHER; |
|
|
2655 | }, |
|
|
2656 | ); |
|
|
2657 | } |
2764 | } |
2658 | }; |
2765 | }; |
2659 | |
2766 | |
2660 | unshift @INC, $LIBDIR; |
2767 | unshift @INC, $LIBDIR; |
2661 | |
2768 | |
… | |
… | |
2793 | prio => 6, |
2900 | prio => 6, |
2794 | cb => \&IO::AIO::poll_cb, |
2901 | cb => \&IO::AIO::poll_cb, |
2795 | ); |
2902 | ); |
2796 | } |
2903 | } |
2797 | |
2904 | |
|
|
2905 | # load additional modules |
|
|
2906 | use cf::pod; |
|
|
2907 | |
2798 | END { cf::emergency_save } |
2908 | END { cf::emergency_save } |
2799 | |
2909 | |
2800 | 1 |
2910 | 1 |
2801 | |
2911 | |