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.574 by root, Sun May 8 21:51:27 2011 UTC vs.
Revision 1.585 by root, Tue Oct 30 20:18:00 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."
… …
3190=cut 3248=cut
3191 3249
3192sub cf::client::ext_reply($$@) { 3250sub cf::client::ext_reply($$@) {
3193 my ($self, $id, @msg) = @_; 3251 my ($self, $id, @msg) = @_;
3194 3252
3195 if ($self->extcmd == 2) { 3253 return unless $self->extcmd == 2;
3254
3196 $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]));
3197 } elsif ($self->extcmd == 1) {
3198 #TODO: version 1, remove
3199 unshift @msg, msgtype => "reply", msgid => $id;
3200 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3201 }
3202} 3256}
3203 3257
3204=item $success = $client->query ($flags, "text", \&cb) 3258=item $success = $client->query ($flags, "text", \&cb)
3205 3259
3206Queues a query to the client, calling the given callback with 3260Queues a query to the client, calling the given callback with
… …
3261 my ($ns, $buf) = @_; 3315 my ($ns, $buf) = @_;
3262 3316
3263 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3317 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3264 3318
3265 if (ref $msg) { 3319 if (ref $msg) {
3266 my ($type, $reply, @payload) = 3320 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3267 "ARRAY" eq ref $msg
3268 ? @$msg
3269 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3270 3321
3271 my @reply; 3322 my @reply;
3272 3323
3273 if (my $cb = $EXTICMD{$type}) { 3324 if (my $cb = $EXTICMD{$type}) {
3274 @reply = $cb->($ns, @payload); 3325 @reply = $cb->($ns, @payload);
… …
3452=cut 3503=cut
3453 3504
3454############################################################################# 3505#############################################################################
3455# the server's init and main functions 3506# the server's init and main functions
3456 3507
3508our %FACEHASH; # hash => idx, #d# HACK for http server
3509
3457sub load_facedata($) { 3510sub load_facedata($) {
3458 my ($path) = @_; 3511 my ($path) = @_;
3459 3512
3460 # 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
3461 # for this (global event?) 3514 # for this (global event?)
… …
3480 cf::cede_to_tick; 3533 cf::cede_to_tick;
3481 3534
3482 { 3535 {
3483 my $faces = $facedata->{faceinfo}; 3536 my $faces = $facedata->{faceinfo};
3484 3537
3485 while (my ($face, $info) = each %$faces) { 3538 for my $face (sort keys %$faces) {
3539 my $info = $faces->{$face};
3486 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3540 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3487 3541
3488 cf::face::set_visibility $idx, $info->{visibility}; 3542 cf::face::set_visibility $idx, $info->{visibility};
3489 cf::face::set_magicmap $idx, $info->{magicmap}; 3543 cf::face::set_magicmap $idx, $info->{magicmap};
3490 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3544 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3491 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3545 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3492 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#
3493 3548
3494 cf::cede_to_tick; 3549 cf::cede_to_tick;
3495 } 3550 }
3496 3551
3497 while (my ($face, $info) = each %$faces) { 3552 while (my ($face, $info) = each %$faces) {
… …
3524 3579
3525 { 3580 {
3526 my $res = $facedata->{resource}; 3581 my $res = $facedata->{resource};
3527 3582
3528 while (my ($name, $info) = each %$res) { 3583 while (my ($name, $info) = each %$res) {
3529 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
3530 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3586 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3531 3587
3532 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3588 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3533 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#
3534 } else { 3592 } else {
3535 $RESOURCE{$name} = $info; # unused 3593# $RESOURCE{$name} = $info; # unused
3536 } 3594 }
3537 3595
3538 cf::cede_to_tick; 3596 cf::cede_to_tick;
3539 } 3597 }
3540 } 3598 }
… …
3676 3734
3677sub main { 3735sub main {
3678 cf::init_globals; # initialise logging 3736 cf::init_globals; # initialise logging
3679 3737
3680 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3738 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3681 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.";
3682 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3740 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3683 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3741 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3684 3742
3685 $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
3686 3744
… …
3728 }; 3786 };
3729 3787
3730 cf::object::thawer::errors_are_fatal 0; 3788 cf::object::thawer::errors_are_fatal 0;
3731 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";
3732 3790
3733 my $free_main; $free_main = EV::idle sub { 3791 AE::postpone {
3734 undef $free_main;
3735 undef &main; # free gobs of memory :) 3792 undef &main; # free gobs of memory :)
3736 }; 3793 };
3737 3794
3738 goto &main_loop; 3795 goto &main_loop;
3739} 3796}
… …
3896 3953
3897 cf::write_runtime_sync; # external watchdog should not bark 3954 cf::write_runtime_sync; # external watchdog should not bark
3898 3955
3899 trace "emergency_perl_save: flushing outstanding aio requests"; 3956 trace "emergency_perl_save: flushing outstanding aio requests";
3900 while (IO::AIO::nreqs || BDB::nreqs) { 3957 while (IO::AIO::nreqs || BDB::nreqs) {
3901 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
3902 } 3959 }
3903 3960
3904 cf::write_runtime_sync; # external watchdog should not bark 3961 cf::write_runtime_sync; # external watchdog should not bark
3905 }; 3962 };
3906 3963
… …
4143{ 4200{
4144 # configure BDB 4201 # configure BDB
4145 4202
4146 BDB::min_parallel 16; 4203 BDB::min_parallel 16;
4147 BDB::max_poll_reqs $TICK * 0.1; 4204 BDB::max_poll_reqs $TICK * 0.1;
4148 $AnyEvent::BDB::WATCHER->priority (1); 4205 #$AnyEvent::BDB::WATCHER->priority (1);
4149 4206
4150 unless ($DB_ENV) { 4207 unless ($DB_ENV) {
4151 $DB_ENV = BDB::db_env_create; 4208 $DB_ENV = BDB::db_env_create;
4152 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4209 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4153 $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