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.581 by root, Fri Feb 3 02:04:11 2012 UTC vs.
Revision 1.591 by root, Tue Nov 6 23:33:15 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,2012 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
… …
32use Safe; 32use Safe;
33use Safe::Hole; 33use Safe::Hole;
34use Storable (); 34use Storable ();
35use Carp (); 35use Carp ();
36 36
37use Guard (); 37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
40
38use Coro (); 41use Coro ();
39use Coro::State; 42use Coro::State;
40use Coro::Handle; 43use Coro::Handle;
41use Coro::EV; 44use Coro::EV;
42use Coro::AnyEvent; 45use Coro::AnyEvent;
… …
48use Coro::AIO; 51use Coro::AIO;
49use Coro::BDB 1.6; 52use Coro::BDB 1.6;
50use Coro::Storable; 53use Coro::Storable;
51use Coro::Util (); 54use Coro::Util ();
52 55
56use Guard ();
53use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
54use BDB (); 58use BDB ();
55use Data::Dumper; 59use Data::Dumper;
56use Fcntl; 60use Fcntl;
57use YAML::XS (); 61use YAML::XS ();
… …
129our $DB_ENV; 133our $DB_ENV;
130 134
131our @EXTRA_MODULES = qw(pod match mapscript incloader); 135our @EXTRA_MODULES = qw(pod match mapscript incloader);
132 136
133our %CFG; 137our %CFG;
138our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
134 139
135our $UPTIME; $UPTIME ||= time; 140our $UPTIME; $UPTIME ||= time;
136our $RUNTIME = 0; 141our $RUNTIME = 0;
137our $SERVER_TICK = 0; 142our $SERVER_TICK = 0;
138our $NOW; 143our $NOW;
… …
219=item $cf::RUNTIME 224=item $cf::RUNTIME
220 225
221The time this server has run, starts at 0 and is increased by $cf::TICK on 226The time this server has run, starts at 0 and is increased by $cf::TICK on
222every server tick. 227every server tick.
223 228
224=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 229=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
225$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 230$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
226$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 231$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
227 232
228Various directories - "/etc", read-only install directory, perl-library 233Various directories - "/etc", read-only install directory, perl-library
229directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 234directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
230unique-items directory, player file directory, random maps directory and 235unique-items directory, player file directory, random maps directory and
231database environment. 236database environment.
… …
335)) { 340)) {
336 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 341 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
337} 342}
338 343
339$EV::DIED = sub { 344$EV::DIED = sub {
340 Carp::cluck "error in event callback: @_"; 345 warn "error in event callback: $@";
341}; 346};
342 347
343############################################################################# 348#############################################################################
344 349
345sub fork_call(&@); 350sub fork_call(&@);
… …
1531 }; 1536 };
1532 1537
1533 $grp 1538 $grp
1534} 1539}
1535 1540
1541sub _ext_cfg_reg($$$$) {
1542 my ($rvar, $varname, $cfgname, $default) = @_;
1543
1544 $cfgname = lc $varname
1545 unless length $cfgname;
1546
1547 $EXT_CFG{$cfgname} = [$rvar, $default];
1548
1549 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1550}
1551
1536sub load_extensions { 1552sub load_extensions {
1537 info "loading extensions..."; 1553 info "loading extensions...";
1554
1555 %EXT_CFG = ();
1538 1556
1539 cf::sync_job { 1557 cf::sync_job {
1540 my %todo; 1558 my %todo;
1541 1559
1542 for my $path (<$LIBDIR/*.ext>) { 1560 for my $path (<$LIBDIR/*.ext>) {
… …
1585 unless exists $done{$_}; 1603 unless exists $done{$_};
1586 } 1604 }
1587 1605
1588 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1606 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1589 1607
1608 my $source = $v->{source};
1609
1610 # support "CONF varname :confname = default" pseudo-statements
1611 $source =~ s{
1612 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1613 }{
1614 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1615 }gmxe;
1616
1590 my $active = eval $v->{source}; 1617 my $active = eval $source;
1591 1618
1592 if (length $@) { 1619 if (length $@) {
1593 error "$v->{path}: $@\n"; 1620 error "$v->{path}: $@\n";
1594 1621
1595 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1622 cf::cleanup "mandatory extension '$k' failed to load, exiting."
… …
3208=cut 3235=cut
3209 3236
3210sub cf::client::ext_msg($$@) { 3237sub cf::client::ext_msg($$@) {
3211 my ($self, $type, @msg) = @_; 3238 my ($self, $type, @msg) = @_;
3212 3239
3213 if ($self->extcmd == 2) {
3214 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3240 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3215 } elsif ($self->extcmd == 1) { # TODO: remove
3216 push @msg, msgtype => "event_$type";
3217 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3218 }
3219} 3241}
3220 3242
3221=item $client->ext_reply ($msgid, @msg) 3243=item $client->ext_reply ($msgid, @msg)
3222 3244
3223Sends an ext reply to the client. 3245Sends an ext reply to the client.
3224 3246
3225=cut 3247=cut
3226 3248
3227sub cf::client::ext_reply($$@) { 3249sub cf::client::ext_reply($$@) {
3228 my ($self, $id, @msg) = @_; 3250 my ($self, $id, @msg) = @_;
3229
3230 return unless $self->extcmd == 2;
3231 3251
3232 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3252 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3233} 3253}
3234 3254
3235=item $success = $client->query ($flags, "text", \&cb) 3255=item $success = $client->query ($flags, "text", \&cb)
… …
3480=cut 3500=cut
3481 3501
3482############################################################################# 3502#############################################################################
3483# the server's init and main functions 3503# the server's init and main functions
3484 3504
3505our %FACEHASH; # hash => idx, #d# HACK for http server
3506
3507# internal api, not fianlised
3508sub add_face {
3509 my ($name, $type, $data) = @_;
3510
3511 my $idx = cf::face::find $name;
3512
3513 if ($idx) {
3514 delete $FACEHASH{cf::face::get_chksum $idx};
3515 } else {
3516 $idx = cf::face::alloc $name;
3517 }
3518
3519 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
3520
3521 cf::face::set_type $idx, $type;
3522 cf::face::set_data $idx, 0, $data, $hash;
3523 cf::face::set_meta $idx, $type & 1 ? undef : undef;
3524 $FACEHASH{$hash} = $idx;#d#
3525
3526 $idx
3527}
3528
3485sub load_facedata($) { 3529sub load_facedata($) {
3486 my ($path) = @_; 3530 my ($path) = @_;
3487 3531
3488 # HACK to clear player env face cache, we need some signal framework 3532 # HACK to clear player env face cache, we need some signal framework
3489 # for this (global event?) 3533 # for this (global event?)
… …
3496 my $facedata = decode_storable load_file $path; 3540 my $facedata = decode_storable load_file $path;
3497 3541
3498 $facedata->{version} == 2 3542 $facedata->{version} == 2
3499 or cf::cleanup "$path: version mismatch, cannot proceed."; 3543 or cf::cleanup "$path: version mismatch, cannot proceed.";
3500 3544
3501 # patch in the exptable
3502 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3503 $facedata->{resource}{"res/exp_table"} = {
3504 type => FT_RSRC,
3505 data => $exp_table,
3506 hash => (Digest::MD5::md5 $exp_table),
3507 };
3508 cf::cede_to_tick; 3545 cf::cede_to_tick;
3509 3546
3510 { 3547 {
3511 my $faces = $facedata->{faceinfo}; 3548 my $faces = $facedata->{faceinfo};
3512 3549
3513 while (my ($face, $info) = each %$faces) { 3550 for my $face (sort keys %$faces) {
3551 my $info = $faces->{$face};
3514 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3552 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3515 3553
3516 cf::face::set_visibility $idx, $info->{visibility}; 3554 cf::face::set_visibility $idx, $info->{visibility};
3517 cf::face::set_magicmap $idx, $info->{magicmap}; 3555 cf::face::set_magicmap $idx, $info->{magicmap};
3518 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3556 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3519 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3557 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3520 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3558 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3559 $FACEHASH{$info->{hash64}} = $idx;#d#
3521 3560
3522 cf::cede_to_tick; 3561 cf::cede_to_tick;
3523 } 3562 }
3524 3563
3525 while (my ($face, $info) = each %$faces) { 3564 while (my ($face, $info) = each %$faces) {
… …
3556 while (my ($name, $info) = each %$res) { 3595 while (my ($name, $info) = each %$res) {
3557 if (defined (my $type = $info->{type})) { 3596 if (defined (my $type = $info->{type})) {
3558 # TODO: different hash - must free and use new index, or cache ixface data queue 3597 # 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; 3598 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3560 3599
3600 cf::face::set_type $idx, $type;
3561 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3601 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3562 cf::face::set_type $idx, $type;
3563 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already 3602 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3603 $FACEHASH{$info->{hash}} = $idx;#d#
3564 } else { 3604 } else {
3565# $RESOURCE{$name} = $info; # unused 3605# $RESOURCE{$name} = $info; # unused
3566 } 3606 }
3567 3607
3568 cf::cede_to_tick; 3608 cf::cede_to_tick;
… …
3588 my $status = load_resource_file_ $_[0]; 3628 my $status = load_resource_file_ $_[0];
3589 get_slot 0.1, 100; 3629 get_slot 0.1, 100;
3590 cf::arch::commit_load; 3630 cf::arch::commit_load;
3591 3631
3592 $status 3632 $status
3633}
3634
3635sub reload_exp_table {
3636 _reload_exp_table;
3637
3638 add_face "res/exp_table" => FT_RSRC,
3639 JSON::XS->new->utf8->canonical->encode (
3640 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3641 );
3642}
3643
3644sub reload_materials {
3645 _reload_materials;
3593} 3646}
3594 3647
3595sub reload_regions { 3648sub reload_regions {
3596 # HACK to clear player env face cache, we need some signal framework 3649 # HACK to clear player env face cache, we need some signal framework
3597 # for this (global event?) 3650 # for this (global event?)
… …
3612} 3665}
3613 3666
3614sub reload_archetypes { 3667sub reload_archetypes {
3615 load_resource_file "$DATADIR/archetypes" 3668 load_resource_file "$DATADIR/archetypes"
3616 or die "unable to load archetypes\n"; 3669 or die "unable to load archetypes\n";
3670
3671 add_face "res/skill_info" => FT_RSRC,
3672 JSON::XS->new->utf8->canonical->encode (
3673 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3674 );
3675 add_face "res/spell_paths" => FT_RSRC,
3676 JSON::XS->new->utf8->canonical->encode (
3677 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3678 );
3617} 3679}
3618 3680
3619sub reload_treasures { 3681sub reload_treasures {
3620 load_resource_file "$DATADIR/treasures" 3682 load_resource_file "$DATADIR/treasures"
3621 or die "unable to load treasurelists\n"; 3683 or die "unable to load treasurelists\n";
… …
3639 my $face = cf::face::find "sound/$v"; 3701 my $face = cf::face::find "sound/$v";
3640 cf::sound::set $k => $face; 3702 cf::sound::set $k => $face;
3641 } 3703 }
3642} 3704}
3643 3705
3706sub reload_pod {
3707 trace "loading pods $PODDIR\n";
3708
3709 my @command_help;
3710
3711 for (
3712 [0, "command_help"],
3713 [1, "emote_help"],
3714 [2, "dmcommand_help"],
3715 ) {
3716 my ($type, $path) = @$_;
3717
3718 my $paragraphs = &cf::pod::load_pod ("$PODDIR/$path.pod")
3719 or die "unable to load $path";
3720
3721 my $level = 1e9;
3722
3723 for my $par (@$paragraphs) {
3724 if ($par->{type} eq "head2") {
3725 # this code taken almost verbatim from DC/Protocol.pm
3726
3727 if ($par->{markup} =~ /^(\S+) (?:\s+ \( ([^\)]*) \) )?/x) {
3728 my $cmd = $1;
3729 my @args = split /\|/, $2;
3730 @args = (".*") unless @args;
3731
3732 $_ = $_ eq ".*" ? "" : " $_"
3733 for @args;
3734
3735 my @variants = map "$cmd$_", sort { (length $a) <=> (length $b) } @args;
3736
3737 push @command_help, [$type, \@variants, &cf::pod::as_cfpod ([$par])];
3738 $level = $par->{level};
3739 } else {
3740 error "$par->{markup}: unparsable command heading";
3741 }
3742 } elsif ($par->{level} > $level) {
3743 $command_help[-1][2] .= &cf::pod::as_cfpod ([$par]);
3744 }
3745
3746 cf::cede_to_tick;
3747 }
3748 }
3749
3750 @command_help = sort {
3751 $a->[0] <=> $b->[0]
3752 or $a->[1] cmp $b->[1]
3753 } @command_help;
3754
3755 cf::cede_to_tick;
3756
3757 add_face "res/command_help" => FT_RSRC,
3758 JSON::XS->new->utf8->encode (\@command_help);
3759}
3760
3644sub reload_resources { 3761sub reload_resources {
3645 trace "reloading resource files...\n"; 3762 trace "reloading resource files...\n";
3646 3763
3647 reload_exp_table;
3648 reload_materials; 3764 reload_materials;
3649 reload_facedata; 3765 reload_facedata;
3766 reload_exp_table;
3650 reload_sound; 3767 reload_sound;
3651 reload_archetypes; 3768 reload_archetypes;
3652 reload_regions; 3769 reload_regions;
3653 reload_treasures; 3770 reload_treasures;
3771 reload_pod;
3654 3772
3655 trace "finished reloading resource files\n"; 3773 trace "finished reloading resource files\n";
3656} 3774}
3657 3775
3658sub reload_config { 3776sub reload_config {
… …
3713 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3831 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3714 3832
3715 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3833 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3716 3834
3717 # we must not ever block the main coroutine 3835 # we must not ever block the main coroutine
3718 local $Coro::idle = sub { 3836 $Coro::idle = sub {
3719 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3837 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3720 (async { 3838 (async {
3721 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3839 $Coro::current->{desc} = "IDLE BUG HANDLER";
3722 EV::loop EV::LOOP_ONESHOT; 3840 EV::loop EV::LOOP_ONESHOT;
3723 })->prio (Coro::PRIO_MAX); 3841 })->prio (Coro::PRIO_MAX);
… …
3726 evthread_start IO::AIO::poll_fileno; 3844 evthread_start IO::AIO::poll_fileno;
3727 3845
3728 cf::sync_job { 3846 cf::sync_job {
3729 cf::incloader::init (); 3847 cf::incloader::init ();
3730 3848
3849 db_init;
3850
3731 cf::init_anim; 3851 cf::init_anim;
3732 cf::init_attackmess; 3852 cf::init_attackmess;
3733 cf::init_dynamic; 3853 cf::init_dynamic;
3734 3854
3735 cf::load_settings; 3855 cf::load_settings;
3736 3856
3737 reload_resources; 3857 reload_resources;
3738 reload_config; 3858 reload_config;
3739 db_init;
3740 3859
3741 cf::init_uuid; 3860 cf::init_uuid;
3742 cf::init_signals; 3861 cf::init_signals;
3743 cf::init_skills; 3862 cf::init_skills;
3744 3863
… …
4169 } 4288 }
4170} 4289}
4171 4290
4172{ 4291{
4173 # configure BDB 4292 # configure BDB
4293 info "initialising database";
4174 4294
4175 BDB::min_parallel 16; 4295 BDB::min_parallel 16;
4176 BDB::max_poll_reqs $TICK * 0.1; 4296 BDB::max_poll_reqs $TICK * 0.1;
4177 #$AnyEvent::BDB::WATCHER->priority (1); 4297 #$AnyEvent::BDB::WATCHER->priority (1);
4178 4298
… …
4207 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4327 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4208 }; 4328 };
4209 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4329 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4210 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4330 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4211 }; 4331 };
4332
4333 info "database initialised";
4212} 4334}
4213 4335
4214{ 4336{
4215 # configure IO::AIO 4337 # configure IO::AIO
4216 4338
4339 info "initialising aio";
4217 IO::AIO::min_parallel 8; 4340 IO::AIO::min_parallel 8;
4218 IO::AIO::max_poll_time $TICK * 0.1; 4341 IO::AIO::max_poll_time $TICK * 0.1;
4219 undef $AnyEvent::AIO::WATCHER; 4342 undef $AnyEvent::AIO::WATCHER;
4343 info "aio initialised";
4220} 4344}
4221 4345
4222our $_log_backtrace; 4346our $_log_backtrace;
4223our $_log_backtrace_last; 4347our $_log_backtrace_last;
4224 4348

Diff Legend

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