| … | |
… | |
| 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 | local $SIG{__WARN__}; |
|
|
2420 | eval { |
|
|
2421 | local $SIG{__DIE__}; |
|
|
2422 | close $fh1; |
|
|
2423 | |
|
|
2424 | my @res = eval { $cb->(@args) }; |
|
|
2425 | syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res); |
|
|
2426 | }; |
|
|
2427 | |
|
|
2428 | warn $@ if $@; |
|
|
2429 | _exit 0; |
|
|
2430 | } |
|
|
2431 | } |
|
|
2432 | |
|
|
2433 | |
| 2333 | |
2434 | |
| 2334 | ############################################################################# |
2435 | ############################################################################# |
| 2335 | # the server's init and main functions |
2436 | # the server's init and main functions |
| 2336 | |
2437 | |
| 2337 | sub load_facedata($) { |
2438 | sub load_facedata($) { |
| … | |
… | |
| 2600 | Symbol::delete_package "safe::$_" |
2701 | Symbol::delete_package "safe::$_" |
| 2601 | for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); |
2702 | for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); |
| 2602 | |
2703 | |
| 2603 | warn "unloading cf.pm \"a bit\""; |
2704 | warn "unloading cf.pm \"a bit\""; |
| 2604 | delete $INC{"cf.pm"}; |
2705 | delete $INC{"cf.pm"}; |
|
|
2706 | delete $INC{"cf/pod.pm"}; |
| 2605 | |
2707 | |
| 2606 | # don't, removes xs symbols, too, |
2708 | # don't, removes xs symbols, too, |
| 2607 | # and global variables created in xs |
2709 | # and global variables created in xs |
| 2608 | #Symbol::delete_package __PACKAGE__; |
2710 | #Symbol::delete_package __PACKAGE__; |
| 2609 | |
2711 | |
| … | |
… | |
| 2800 | prio => 6, |
2902 | prio => 6, |
| 2801 | cb => \&IO::AIO::poll_cb, |
2903 | cb => \&IO::AIO::poll_cb, |
| 2802 | ); |
2904 | ); |
| 2803 | } |
2905 | } |
| 2804 | |
2906 | |
|
|
2907 | # load additional modules |
|
|
2908 | use cf::pod; |
|
|
2909 | |
| 2805 | END { cf::emergency_save } |
2910 | END { cf::emergency_save } |
| 2806 | |
2911 | |
| 2807 | 1 |
2912 | 1 |
| 2808 | |
2913 | |
