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.573 by root, Sun May 8 12:40:42 2011 UTC vs.
Revision 1.582 by root, Fri Feb 3 03:01:45 2012 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008,2009,2010,2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify it under 6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the 7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your 8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version. 9# option) any later version.
… …
108our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
109our $BDBDIR = "$LOCALDIR/db"; 109our $BDBDIR = "$LOCALDIR/db";
110our $PIDFILE = "$LOCALDIR/pid"; 110our $PIDFILE = "$LOCALDIR/pid";
111our $RUNTIMEFILE = "$LOCALDIR/runtime"; 111our $RUNTIMEFILE = "$LOCALDIR/runtime";
112 112
113our %RESOURCE; # unused 113#our %RESOURCE; # unused
114 114
115our $OUTPUT_RATE_MIN = 3000; 115our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000; 116our $OUTPUT_RATE_MAX = 1000000;
117 117
118our $MAX_LINKS = 32; # how many chained exits to follow 118our $MAX_LINKS = 32; # how many chained exits to follow
… …
129our $DB_ENV; 129our $DB_ENV;
130 130
131our @EXTRA_MODULES = qw(pod match mapscript incloader); 131our @EXTRA_MODULES = qw(pod match mapscript incloader);
132 132
133our %CFG; 133our %CFG;
134our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
134 135
135our $UPTIME; $UPTIME ||= time; 136our $UPTIME; $UPTIME ||= time;
136our $RUNTIME = 0; 137our $RUNTIME = 0;
137our $SERVER_TICK = 0; 138our $SERVER_TICK = 0;
138our $NOW; 139our $NOW;
… …
372 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 373 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
373 $d 374 $d
374 } || "[unable to dump $_[0]: '$@']"; 375 } || "[unable to dump $_[0]: '$@']";
375} 376}
376 377
377=item $scalar = load_file $path 378=item $scalar = cf::load_file $path
378 379
379Loads the given file from path and returns its contents. Croaks on error 380Loads the given file from path and returns its contents. Croaks on error
380and can block. 381and can block.
381 382
382=cut 383=cut
… …
384sub load_file($) { 385sub load_file($) {
385 0 <= aio_load $_[0], my $data 386 0 <= aio_load $_[0], my $data
386 or Carp::croak "$_[0]: $!"; 387 or Carp::croak "$_[0]: $!";
387 388
388 $data 389 $data
390}
391
392=item $success = cf::replace_file $path, $data, $sync
393
394Atomically replaces the file at the given $path with new $data, and
395optionally $sync the data to disk before replacing the file.
396
397=cut
398
399sub replace_file($$;$) {
400 my ($path, $data, $sync) = @_;
401
402 my $lock = cf::lock_acquire ("replace_file:$path");
403
404 my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
405 or return;
406
407 $data = $data->() if ref $data;
408
409 length $data == aio_write $fh, 0, (length $data), $data, 0
410 or return;
411
412 !$sync
413 or !aio_fsync $fh
414 or return;
415
416 aio_close $fh
417 and return;
418
419 aio_rename "$path~", $path
420 and return;
421
422 if ($sync) {
423 $path =~ s%/[^/]*$%%;
424 aio_pathsync $path;
425 }
426
427 1
389} 428}
390 429
391=item $ref = cf::decode_json $json 430=item $ref = cf::decode_json $json
392 431
393Converts a JSON string into the corresponding perl data structure. 432Converts a JSON string into the corresponding perl data structure.
… …
1461 my ($pl, $buf) = @_; 1500 my ($pl, $buf) = @_;
1462 1501
1463 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1502 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1464 1503
1465 if (ref $msg) { 1504 if (ref $msg) {
1466 my ($type, $reply, @payload) = 1505 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1467 "ARRAY" eq ref $msg
1468 ? @$msg
1469 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1470 1506
1471 my @reply; 1507 my @reply;
1472 1508
1473 if (my $cb = $EXTCMD{$type}) { 1509 if (my $cb = $EXTCMD{$type}) {
1474 @reply = $cb->($pl, @payload); 1510 @reply = $cb->($pl, @payload);
… …
1496 }; 1532 };
1497 1533
1498 $grp 1534 $grp
1499} 1535}
1500 1536
1537sub _ext_cfg_reg($$$$) {
1538 my ($rvar, $varname, $cfgname, $default) = @_;
1539
1540 $cfgname = lc $varname
1541 unless length $cfgname;
1542
1543 $EXT_CFG{$cfgname} = [$rvar, $default];
1544
1545 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1546}
1547
1501sub load_extensions { 1548sub load_extensions {
1502 info "loading extensions..."; 1549 info "loading extensions...";
1550
1551 %EXT_CFG = ();
1503 1552
1504 cf::sync_job { 1553 cf::sync_job {
1505 my %todo; 1554 my %todo;
1506 1555
1507 for my $path (<$LIBDIR/*.ext>) { 1556 for my $path (<$LIBDIR/*.ext>) {
… …
1550 unless exists $done{$_}; 1599 unless exists $done{$_};
1551 } 1600 }
1552 1601
1553 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1602 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1554 1603
1604 my $source = $v->{source};
1605
1606 # support "CONF varname :confname = default" pseudo-statements
1607 $source =~ s{
1608 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1609 }{
1610 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1611 }gmxe;
1612
1555 my $active = eval $v->{source}; 1613 my $active = eval $source;
1556 1614
1557 if (length $@) { 1615 if (length $@) {
1558 error "$v->{path}: $@\n"; 1616 error "$v->{path}: $@\n";
1559 1617
1560 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1618 cf::cleanup "mandatory extension '$k' failed to load, exiting."
… …
2267# if $self->per_party; 2325# if $self->per_party;
2268 2326
2269 $self 2327 $self
2270} 2328}
2271 2329
2272# find and load all maps in the 3x3 area around a map
2273sub load_neighbours {
2274 my ($map) = @_;
2275
2276 my @neigh; # diagonal neighbours
2277
2278 for (0 .. 3) {
2279 my $neigh = $map->tile_path ($_)
2280 or next;
2281 $neigh = find $neigh, $map
2282 or next;
2283 $neigh->load;
2284
2285 # now find the diagonal neighbours
2286 push @neigh,
2287 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2288 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2289 }
2290
2291 for (grep defined $_->[0], @neigh) {
2292 my ($path, $origin) = @$_;
2293 my $neigh = find $path, $origin
2294 or next;
2295 $neigh->load;
2296 }
2297}
2298
2299sub find_sync { 2330sub find_sync {
2300 my ($path, $origin) = @_; 2331 my ($path, $origin) = @_;
2301 2332
2302 # it's a bug to call this from the main context 2333 # it's a bug to call this from the main context
2303 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2334 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
… …
2775 # use -1 or undef as default coordinates, not 0, 0 2806 # use -1 or undef as default coordinates, not 0, 0
2776 ($x, $y) = ($map->enter_x, $map->enter_y) 2807 ($x, $y) = ($map->enter_x, $map->enter_y)
2777 if $x <= 0 && $y <= 0; 2808 if $x <= 0 && $y <= 0;
2778 2809
2779 $map->load; 2810 $map->load;
2780 $map->load_neighbours;
2781 2811
2782 return unless $self->contr->active; 2812 return unless $self->contr->active;
2783 2813
2784 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2814 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2785 if ($self->enter_map ($map, $x, $y)) { 2815 if ($self->enter_map ($map, $x, $y)) {
… …
3218=cut 3248=cut
3219 3249
3220sub cf::client::ext_reply($$@) { 3250sub cf::client::ext_reply($$@) {
3221 my ($self, $id, @msg) = @_; 3251 my ($self, $id, @msg) = @_;
3222 3252
3223 if ($self->extcmd == 2) { 3253 return unless $self->extcmd == 2;
3254
3224 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3255 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3225 } elsif ($self->extcmd == 1) {
3226 #TODO: version 1, remove
3227 unshift @msg, msgtype => "reply", msgid => $id;
3228 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3229 }
3230} 3256}
3231 3257
3232=item $success = $client->query ($flags, "text", \&cb) 3258=item $success = $client->query ($flags, "text", \&cb)
3233 3259
3234Queues a query to the client, calling the given callback with 3260Queues a query to the client, calling the given callback with
… …
3289 my ($ns, $buf) = @_; 3315 my ($ns, $buf) = @_;
3290 3316
3291 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3317 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3292 3318
3293 if (ref $msg) { 3319 if (ref $msg) {
3294 my ($type, $reply, @payload) = 3320 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3295 "ARRAY" eq ref $msg
3296 ? @$msg
3297 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3298 3321
3299 my @reply; 3322 my @reply;
3300 3323
3301 if (my $cb = $EXTICMD{$type}) { 3324 if (my $cb = $EXTICMD{$type}) {
3302 @reply = $cb->($ns, @payload); 3325 @reply = $cb->($ns, @payload);
… …
3552 3575
3553 { 3576 {
3554 my $res = $facedata->{resource}; 3577 my $res = $facedata->{resource};
3555 3578
3556 while (my ($name, $info) = each %$res) { 3579 while (my ($name, $info) = each %$res) {
3557 if (defined $info->{type}) { 3580 if (defined (my $type = $info->{type})) {
3581 # TODO: different hash - must free and use new index, or cache ixface data queue
3558 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3582 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3559 3583
3560 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3584 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3561 cf::face::set_type $idx, $info->{type}; 3585 cf::face::set_type $idx, $type;
3586 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3562 } else { 3587 } else {
3563 $RESOURCE{$name} = $info; # unused 3588# $RESOURCE{$name} = $info; # unused
3564 } 3589 }
3565 3590
3566 cf::cede_to_tick; 3591 cf::cede_to_tick;
3567 } 3592 }
3568 } 3593 }
… …
3704 3729
3705sub main { 3730sub main {
3706 cf::init_globals; # initialise logging 3731 cf::init_globals; # initialise logging
3707 3732
3708 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3733 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3709 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3734 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3710 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3735 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3711 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3736 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3712 3737
3713 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3738 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3714 3739
… …
3756 }; 3781 };
3757 3782
3758 cf::object::thawer::errors_are_fatal 0; 3783 cf::object::thawer::errors_are_fatal 0;
3759 info "parse errors in files are no longer fatal from this point on.\n"; 3784 info "parse errors in files are no longer fatal from this point on.\n";
3760 3785
3761 my $free_main; $free_main = EV::idle sub { 3786 AE::postpone {
3762 undef $free_main;
3763 undef &main; # free gobs of memory :) 3787 undef &main; # free gobs of memory :)
3764 }; 3788 };
3765 3789
3766 goto &main_loop; 3790 goto &main_loop;
3767} 3791}
… …
3924 3948
3925 cf::write_runtime_sync; # external watchdog should not bark 3949 cf::write_runtime_sync; # external watchdog should not bark
3926 3950
3927 trace "emergency_perl_save: flushing outstanding aio requests"; 3951 trace "emergency_perl_save: flushing outstanding aio requests";
3928 while (IO::AIO::nreqs || BDB::nreqs) { 3952 while (IO::AIO::nreqs || BDB::nreqs) {
3929 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 3953 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3930 } 3954 }
3931 3955
3932 cf::write_runtime_sync; # external watchdog should not bark 3956 cf::write_runtime_sync; # external watchdog should not bark
3933 }; 3957 };
3934 3958
… …
4171{ 4195{
4172 # configure BDB 4196 # configure BDB
4173 4197
4174 BDB::min_parallel 16; 4198 BDB::min_parallel 16;
4175 BDB::max_poll_reqs $TICK * 0.1; 4199 BDB::max_poll_reqs $TICK * 0.1;
4176 $AnyEvent::BDB::WATCHER->priority (1); 4200 #$AnyEvent::BDB::WATCHER->priority (1);
4177 4201
4178 unless ($DB_ENV) { 4202 unless ($DB_ENV) {
4179 $DB_ENV = BDB::db_env_create; 4203 $DB_ENV = BDB::db_env_create;
4180 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4204 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4181 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4205 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;

Diff Legend

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