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.249 by root, Wed Apr 18 12:43:54 2007 UTC vs.
Revision 1.250 by root, Wed Apr 18 14:24:10 2007 UTC

… …
3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
9use Event; 10use Event;
10use Opcode; 11use Opcode;
11use Safe; 12use Safe;
12use Safe::Hole; 13use Safe::Hole;
13 14
14use Coro 3.61 (); 15use Coro 3.61 ();
15use Coro::State; 16use Coro::State;
17use Coro::Handle;
16use Coro::Event; 18use Coro::Event;
17use Coro::Timer; 19use Coro::Timer;
18use Coro::Signal; 20use Coro::Signal;
19use Coro::Semaphore; 21use Coro::Semaphore;
20use Coro::AIO; 22use Coro::AIO;
… …
146=cut 148=cut
147 149
148BEGIN { 150BEGIN {
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
2266Crossfire maintains a very simple database for extension use. It can 2270Crossfire maintains a very simple database for extension use. It can
2267currently store anything that can be serialised using Storable, which 2271currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2268excludes objects. 2272convert to/from binary).
2269 2273
2270The parameter C<$family> should best start with the name of the extension 2274The parameter C<$family> should best start with the name of the extension
2271using it, it should be unique. 2275using 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
2318sub db_get($$) { 2308sub 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
2329sub db_put($$$) { 2319sub 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}
2333 2323
2334=item cf::cache $id => ... 2324=item cf::cache $id => [$paths...], $processversion => $process
2335 2325
2336Generic caching function that returns the value of the resource $id, 2326Generic caching function that returns the value of the resource $id,
2337caching and regenerating as required. 2327caching and regenerating as required.
2338 2328
2339This function can block. 2329This function can block.
2340 2330
2341 source => filename returning the data (must be a scalar)
2342 expensive => true == try to cache harder
2343 filter => sub that processes the data into a scalar
2344
2345=cut 2331=cut
2346 2332
2347sub cache { 2333sub cache {
2348 my ($id, %arg) = @_; 2334 my ($id, $src, $processversion, $process) = @_;
2349 2335
2350 aio_stat $arg{source} 2336 my $meta =
2351 and Carp::croak "$arg{source}: $!"; 2337 join "\x00",
2338 $processversion,
2339 map {
2340 aio_stat $_
2341 and Carp::croak "$_: $!";
2352 2342
2353 my $meta = join ":", (stat _)[7,9]; 2343 ($_, (stat _)[7,9])
2354 my $md5; 2344 } @$src;
2355 2345
2356 if ($arg{expensive}) {
2357 0 <= aio_load $arg{source}, my $buf
2358 or Carp::croak "$arg{source}: $!";
2359
2360 $md5 = Digest::MD5::md5_hex $buf;
2361 }
2362
2363 my $dbmeta = db_get "$id/meta"; 2346 my $dbmeta = db_get cache => "$id/meta";
2364 if ($dbmeta ne $meta) { 2347 if ($dbmeta ne $meta) {
2365 # changed, we need to process 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
2392Executes the given code block with the given arguments in a seperate
2393process, returning the results. Everything must be serialisable with
2394Coro::Storable. May, of course, block. Note that the executed sub may
2395never block itself or use any form of Event handling.
2396
2397=cut
2398
2399sub 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];
2366 } else { 2418 } else {
2367 # just fetch 2419 eval {
2368 } 2420 local $SIG{__DIE__};
2421 local $SIG{__WARN__};
2422 close $fh1;
2369 2423
2424 my @res = eval { $cb->(@args) };
2425 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2426 };
2370 2427
2428 _exit 0;
2429 }
2371} 2430}
2431
2432
2372 2433
2373############################################################################# 2434#############################################################################
2374# the server's init and main functions 2435# the server's init and main functions
2375 2436
2376sub load_facedata($) { 2437sub load_facedata($) {

Diff Legend

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