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.586 by root, Wed Oct 31 15:02:02 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;
… …
335)) { 336)) {
336 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 337 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
337} 338}
338 339
339$EV::DIED = sub { 340$EV::DIED = sub {
340 Carp::cluck "error in event callback: @_"; 341 warn "error in event callback: $@";
341}; 342};
342 343
343############################################################################# 344#############################################################################
344 345
345sub fork_call(&@); 346sub fork_call(&@);
… …
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);
… …
3480=cut 3503=cut
3481 3504
3482############################################################################# 3505#############################################################################
3483# the server's init and main functions 3506# the server's init and main functions
3484 3507
3508our %FACEHASH; # hash => idx, #d# HACK for http server
3509
3485sub load_facedata($) { 3510sub load_facedata($) {
3486 my ($path) = @_; 3511 my ($path) = @_;
3487 3512
3488 # HACK to clear player env face cache, we need some signal framework 3513 # HACK to clear player env face cache, we need some signal framework
3489 # for this (global event?) 3514 # for this (global event?)
… …
3508 cf::cede_to_tick; 3533 cf::cede_to_tick;
3509 3534
3510 { 3535 {
3511 my $faces = $facedata->{faceinfo}; 3536 my $faces = $facedata->{faceinfo};
3512 3537
3513 while (my ($face, $info) = each %$faces) { 3538 for my $face (sort keys %$faces) {
3539 my $info = $faces->{$face};
3514 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3540 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3515 3541
3516 cf::face::set_visibility $idx, $info->{visibility}; 3542 cf::face::set_visibility $idx, $info->{visibility};
3517 cf::face::set_magicmap $idx, $info->{magicmap}; 3543 cf::face::set_magicmap $idx, $info->{magicmap};
3518 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3544 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3519 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3545 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3520 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3546 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3547 $FACEHASH{$info->{hash64}} = $idx;#d#
3521 3548
3522 cf::cede_to_tick; 3549 cf::cede_to_tick;
3523 } 3550 }
3524 3551
3525 while (my ($face, $info) = each %$faces) { 3552 while (my ($face, $info) = each %$faces) {
… …
3552 3579
3553 { 3580 {
3554 my $res = $facedata->{resource}; 3581 my $res = $facedata->{resource};
3555 3582
3556 while (my ($name, $info) = each %$res) { 3583 while (my ($name, $info) = each %$res) {
3557 if (defined $info->{type}) { 3584 if (defined (my $type = $info->{type})) {
3585 # 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; 3586 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3559 3587
3560 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3588 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3561 cf::face::set_type $idx, $info->{type}; 3589 cf::face::set_type $idx, $type;
3590 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3591 $FACEHASH{$info->{hash}} = $idx;#d#
3562 } else { 3592 } else {
3563 $RESOURCE{$name} = $info; # unused 3593# $RESOURCE{$name} = $info; # unused
3564 } 3594 }
3565 3595
3566 cf::cede_to_tick; 3596 cf::cede_to_tick;
3567 } 3597 }
3568 } 3598 }
… …
3704 3734
3705sub main { 3735sub main {
3706 cf::init_globals; # initialise logging 3736 cf::init_globals; # initialise logging
3707 3737
3708 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3738 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3709 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3739 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3710 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3740 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3711 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3741 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3712 3742
3713 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3743 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3714 3744
… …
3756 }; 3786 };
3757 3787
3758 cf::object::thawer::errors_are_fatal 0; 3788 cf::object::thawer::errors_are_fatal 0;
3759 info "parse errors in files are no longer fatal from this point on.\n"; 3789 info "parse errors in files are no longer fatal from this point on.\n";
3760 3790
3761 my $free_main; $free_main = EV::idle sub { 3791 AE::postpone {
3762 undef $free_main;
3763 undef &main; # free gobs of memory :) 3792 undef &main; # free gobs of memory :)
3764 }; 3793 };
3765 3794
3766 goto &main_loop; 3795 goto &main_loop;
3767} 3796}
… …
3924 3953
3925 cf::write_runtime_sync; # external watchdog should not bark 3954 cf::write_runtime_sync; # external watchdog should not bark
3926 3955
3927 trace "emergency_perl_save: flushing outstanding aio requests"; 3956 trace "emergency_perl_save: flushing outstanding aio requests";
3928 while (IO::AIO::nreqs || BDB::nreqs) { 3957 while (IO::AIO::nreqs || BDB::nreqs) {
3929 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 3958 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3930 } 3959 }
3931 3960
3932 cf::write_runtime_sync; # external watchdog should not bark 3961 cf::write_runtime_sync; # external watchdog should not bark
3933 }; 3962 };
3934 3963
… …
4171{ 4200{
4172 # configure BDB 4201 # configure BDB
4173 4202
4174 BDB::min_parallel 16; 4203 BDB::min_parallel 16;
4175 BDB::max_poll_reqs $TICK * 0.1; 4204 BDB::max_poll_reqs $TICK * 0.1;
4176 $AnyEvent::BDB::WATCHER->priority (1); 4205 #$AnyEvent::BDB::WATCHER->priority (1);
4177 4206
4178 unless ($DB_ENV) { 4207 unless ($DB_ENV) {
4179 $DB_ENV = BDB::db_env_create; 4208 $DB_ENV = BDB::db_env_create;
4180 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4209 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4181 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4210 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;

Diff Legend

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