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.571 by root, Wed May 4 19:04:45 2011 UTC vs.
Revision 1.583 by root, Mon Oct 29 23:12:37 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.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the Affero GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>. 18# <http://www.gnu.org/licenses/>.
19# 19#
20# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
21# 21#
22 22
23package cf; 23package cf;
24 24
… …
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."
… …
2239 2297
2240 unless ($self->{deny_activate}) { 2298 unless ($self->{deny_activate}) {
2241 $self->decay_objects; 2299 $self->decay_objects;
2242 $self->fix_auto_apply; 2300 $self->fix_auto_apply;
2243 $self->update_buttons; 2301 $self->update_buttons;
2244 $self->post_load_physics;
2245 cf::cede_to_tick; 2302 cf::cede_to_tick;
2246 #$self->activate; # no longer activate maps automatically 2303 #$self->activate; # no longer activate maps automatically
2247 } 2304 }
2248 2305
2249 $self->{last_save} = $cf::RUNTIME; 2306 $self->{last_save} = $cf::RUNTIME;
… …
2268# if $self->per_party; 2325# if $self->per_party;
2269 2326
2270 $self 2327 $self
2271} 2328}
2272 2329
2273# find and load all maps in the 3x3 area around a map
2274sub load_neighbours {
2275 my ($map) = @_;
2276
2277 my @neigh; # diagonal neighbours
2278
2279 for (0 .. 3) {
2280 my $neigh = $map->tile_path ($_)
2281 or next;
2282 $neigh = find $neigh, $map
2283 or next;
2284 $neigh->load;
2285
2286 # now find the diagonal neighbours
2287 push @neigh,
2288 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2289 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2290 }
2291
2292 for (grep defined $_->[0], @neigh) {
2293 my ($path, $origin) = @$_;
2294 my $neigh = find $path, $origin
2295 or next;
2296 $neigh->load;
2297 }
2298}
2299
2300sub find_sync { 2330sub find_sync {
2301 my ($path, $origin) = @_; 2331 my ($path, $origin) = @_;
2302 2332
2303 # it's a bug to call this from the main context 2333 # it's a bug to call this from the main context
2304 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2334 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
… …
2322 2352
2323sub find_async { 2353sub find_async {
2324 my ($path, $origin, $load) = @_; 2354 my ($path, $origin, $load) = @_;
2325 2355
2326 $path = normalise $path, $origin; 2356 $path = normalise $path, $origin;
2327 2357
2328 if (my $map = $cf::MAP{$path}) { 2358 if (my $map = $cf::MAP{$path}) {
2329 return $map if !$load || $map->linkable; 2359 return $map if !$load || $map->linkable;
2330 } 2360 }
2331 2361
2332 $MAP_PREFETCH{$path} |= $load; 2362 $MAP_PREFETCH{$path} |= $load;
… …
2776 # use -1 or undef as default coordinates, not 0, 0 2806 # use -1 or undef as default coordinates, not 0, 0
2777 ($x, $y) = ($map->enter_x, $map->enter_y) 2807 ($x, $y) = ($map->enter_x, $map->enter_y)
2778 if $x <= 0 && $y <= 0; 2808 if $x <= 0 && $y <= 0;
2779 2809
2780 $map->load; 2810 $map->load;
2781 $map->load_neighbours;
2782 2811
2783 return unless $self->contr->active; 2812 return unless $self->contr->active;
2784 2813
2785 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2814 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2786 if ($self->enter_map ($map, $x, $y)) { 2815 if ($self->enter_map ($map, $x, $y)) {
… …
3219=cut 3248=cut
3220 3249
3221sub cf::client::ext_reply($$@) { 3250sub cf::client::ext_reply($$@) {
3222 my ($self, $id, @msg) = @_; 3251 my ($self, $id, @msg) = @_;
3223 3252
3224 if ($self->extcmd == 2) { 3253 return unless $self->extcmd == 2;
3254
3225 $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]));
3226 } elsif ($self->extcmd == 1) {
3227 #TODO: version 1, remove
3228 unshift @msg, msgtype => "reply", msgid => $id;
3229 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3230 }
3231} 3256}
3232 3257
3233=item $success = $client->query ($flags, "text", \&cb) 3258=item $success = $client->query ($flags, "text", \&cb)
3234 3259
3235Queues a query to the client, calling the given callback with 3260Queues a query to the client, calling the given callback with
… …
3290 my ($ns, $buf) = @_; 3315 my ($ns, $buf) = @_;
3291 3316
3292 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3317 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3293 3318
3294 if (ref $msg) { 3319 if (ref $msg) {
3295 my ($type, $reply, @payload) = 3320 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3296 "ARRAY" eq ref $msg
3297 ? @$msg
3298 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3299 3321
3300 my @reply; 3322 my @reply;
3301 3323
3302 if (my $cb = $EXTICMD{$type}) { 3324 if (my $cb = $EXTICMD{$type}) {
3303 @reply = $cb->($ns, @payload); 3325 @reply = $cb->($ns, @payload);
… …
3553 3575
3554 { 3576 {
3555 my $res = $facedata->{resource}; 3577 my $res = $facedata->{resource};
3556 3578
3557 while (my ($name, $info) = each %$res) { 3579 while (my ($name, $info) = each %$res) {
3558 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
3559 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3582 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3560 3583
3561 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3584 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3562 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
3563 } else { 3587 } else {
3564 $RESOURCE{$name} = $info; # unused 3588# $RESOURCE{$name} = $info; # unused
3565 } 3589 }
3566 3590
3567 cf::cede_to_tick; 3591 cf::cede_to_tick;
3568 } 3592 }
3569 } 3593 }
… …
3705 3729
3706sub main { 3730sub main {
3707 cf::init_globals; # initialise logging 3731 cf::init_globals; # initialise logging
3708 3732
3709 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3733 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3710 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.";
3711 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3735 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3712 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3736 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3713 3737
3714 $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
3715 3739
… …
3757 }; 3781 };
3758 3782
3759 cf::object::thawer::errors_are_fatal 0; 3783 cf::object::thawer::errors_are_fatal 0;
3760 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";
3761 3785
3762 my $free_main; $free_main = EV::idle sub { 3786 AE::postpone {
3763 undef $free_main;
3764 undef &main; # free gobs of memory :) 3787 undef &main; # free gobs of memory :)
3765 }; 3788 };
3766 3789
3767 goto &main_loop; 3790 goto &main_loop;
3768} 3791}
… …
3925 3948
3926 cf::write_runtime_sync; # external watchdog should not bark 3949 cf::write_runtime_sync; # external watchdog should not bark
3927 3950
3928 trace "emergency_perl_save: flushing outstanding aio requests"; 3951 trace "emergency_perl_save: flushing outstanding aio requests";
3929 while (IO::AIO::nreqs || BDB::nreqs) { 3952 while (IO::AIO::nreqs || BDB::nreqs) {
3930 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
3931 } 3954 }
3932 3955
3933 cf::write_runtime_sync; # external watchdog should not bark 3956 cf::write_runtime_sync; # external watchdog should not bark
3934 }; 3957 };
3935 3958
… …
4172{ 4195{
4173 # configure BDB 4196 # configure BDB
4174 4197
4175 BDB::min_parallel 16; 4198 BDB::min_parallel 16;
4176 BDB::max_poll_reqs $TICK * 0.1; 4199 BDB::max_poll_reqs $TICK * 0.1;
4177 $AnyEvent::BDB::WATCHER->priority (1); 4200 #$AnyEvent::BDB::WATCHER->priority (1);
4178 4201
4179 unless ($DB_ENV) { 4202 unless ($DB_ENV) {
4180 $DB_ENV = BDB::db_env_create; 4203 $DB_ENV = BDB::db_env_create;
4181 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4204 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4182 $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