File Coverage

blib/lib/MPMinus/Configuration.pm

Criterion	Covered	Total	%
statement	18	142	12.6
branch	0	48	0.0
condition	0	78	0.0
subroutine	6	16	37.5
pod	7	7	100.0
total	31	291	10.6

package MPMinus::Configuration; # $Id: Configuration.pm 151 2013-05-29 14:31:19Z minus $
use strict;

=head1 NAME

MPMinus::Configuration - Configuration of MPMinus

=head1 VERSION

Version 1.33

=head1 SYNOPSIS

    package MPM::foo::Handlers;
    use strict;

    sub handler {
        my $r = shift;
        my $m = MPMinus->m;
        $m->conf_init($r, __PACKAGE__);

        ...

        my $project = $m->conf('project');

        ...
    }

=head1 DESCRIPTION

The module works with the configuration data of the resource on the platform mod_perl.
The configuration data are relevant at the global level, and they are the same for all
users at once!

=head1 METHODS

=over 8

=item B<conf_init>

    $m->conf_init( $r, $pkg );

=item B<conf, get_conf, config, get_config>

    my $value = $m->conf( 'key' );

=item B<set_conf, set_config>

    $m->set_conf( 'key', $value );

=back

=head1 HISTORY

=over 8

=item B<1.00 / 27.02.2008>

Init version on base mod_main 1.00.0002

=item B<1.10 / 01.04.2008>

Module is merged into the global module level

=item B<1.20 / 19.04.2010>

Added new type (DSN) support: Oracle

=item B<1.30 / 08.01.2012>

Added server_port variable

=item B<1.31 / Wed Apr 24 14:53:38 2013 MSK>

General refactoring

=item B<1.32 / Wed May  8 12:25:30 2013 MSK>

Added locked_keys parameter

=back

=head1 AUTHOR

Serz Minus (Lepenkov Sergey) L<http://serzik.ru> E<lt>[e-mail]<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2013 D&D Corporation. All Rights Reserved

=head1 LICENSE

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

See C<LICENSE> file

=cut

use CTK::Util qw/ :BASE /; # Óòèëèòàðèé
use MPMinus::MainTools; # Ìîäóëü äëÿ äâóõ ôóíêöèé getHiTime è getSID
use Config::General;
use Try::Tiny;

use vars qw($VERSION);
$VERSION = 1.33;

sub conf_init {
    # Èíèöèàëèçàöèÿ. Çàïóñêàåòñÿ èç ãëàâíîãî õýíäëåðà!!
    my $m = shift;
    croak("The method call is made ActionCheck not in the style of OOP") unless ref($m) =~ /MPMinus/;
    my $r   = shift;
    croak("Object Apache2::RequestRec not defined") unless ref($r) eq 'Apache2::RequestRec';
    my $pkg = shift || ''; # Ïàêåò, êîòîðûé âûçâàë èíèöèàëèçàöèþ
    croak("Package name missing!") unless $pkg && $pkg =~ /Handlers$/;

    # Óñòàíàâëèâàåì ãëàâííûé îáúåêò Apache2::RequestRec è çàâèñèìûå ïàêåòû
    $m->set(r => $r);
    my $s = $r->server; # ñåðâåð
    my $c = $r->connection; # Ñîåäèíåíèå

    # Âíóòðåííèé ìàññèâ
    my %conf;

    ##########################################################################
    # !!! Ïàðàìåòðû, óñòàíàâëèâàåìûå êàæäûé ïåðåçàïóñê !!!
    ##########################################################################

    # Ïàêåò äîëæåí âîçãëàâëÿòü ñïèñîê
    my $i = $m->conf('package') ? ($m->conf('package')->[1] + 1) : 0;
    $i = 1 if $i > 65534; # Íà ñëó÷àé ïåðåïîëíåíèÿ ñòåêà
    $conf{package} = [$pkg,$i]; # Ïîëíîå èìÿ ïàêåòà è êîëè÷åñòâî èíèöèàëèçàöèé çà äî÷êó. 0 - ïåðâûé ðàç

    # Äîîïðåäåëÿåì ïàðàìåòðû
    $conf{sid}    = getSID(16,'m'); # ID Ñåññèè (SID) - Äëÿ êîíòðîëÿ ñåññèè
    $conf{hitime} = getHiTime();

    #
    # Îñíîâíûå çíà÷åíèÿ (ÍÅ ÐÅÄÀÊÒÈÐÓÅÌÛÅ)
    #
    my $prj = '';
    if ($pkg =~ /([^\:]+?)\:\:Handlers$/) {
        $prj = $1;
        $conf{project} = $prj;
        $conf{prefix} = lc($prj);
    } else {
        $conf{project} = '';
        $conf{prefix} = '';
    }
    $conf{preffix} = $conf{prefix}; # Äëÿ îáðàòíîé ñîâìåñòèìîñòè ïîòîì óäàëèòü !!

    #
    # Ïåðåìåííûå "îêðóæåíèÿ" Apache
    #
    $conf{request_uri}    = $r->uri() || ""; # ïîëó÷åííàÿ GET ñòðîêà
    $conf{request_method} = $r->method() || ""; # ïîëó÷åííàÿ ìåòîäà
    $conf{remote_addr}    = $c->remote_ip || ""; # IP êëèåíòà
    $conf{remote_user}    = $r->user() || ""; # Èìÿ ïîëüçîâàòåëÿ

    $conf{server_admin}   = $s->server_admin() || ""; # Àäðåñ ýëåêòðîííîé ïî÷òû
    $conf{server_name}    = $s->server_hostname() || ""; # Èìÿ ñåðâåðà (ãëàâíîãî õîñòà)
    $conf{server_port}    = $s->port() || 80; # Ïîðò ñåðâåðà (ãëàâíîãî õîñòà)
    # HTTP_HOST = SERVER_NAME:SERVER_PORT if SERVER_PORT <> {80|443}
    $conf{http_host}    = $r->hostname() || ""; # Èìÿ õîñòà (âèðòóàëüíîãî õîñòà, îáðàùåíèÿ)
    if ($conf{server_port} != 80 and $conf{server_port} != 443 and $conf{server_name} eq $conf{http_host}) {
        $conf{http_host} = join ':', $conf{server_name}, $conf{server_port};
    }

    # ÀÁÑÎËÞÒÍÛÉ ïóòü îò êîðíÿ ñåðâåðà äî êîðíÿ ñàéòà. Áàçîâûé ïóòü äëÿ ðåñóðñà
    $conf{document_root} =  $r->document_root || '';
    # ÀÁÑÎËÞÒÍÛÉ ïóòü îò êîðíÿ ñåðâåðà äî êîðíÿ modperl. Áàçîâûé ïóòü äëÿ modperl (îò íåãî îòòàëêèâàåìñÿ !!)
    $conf{modperl_root} = $r->dir_config('ModperlRoot') || $conf{document_root};

    # Ñïèñîê çàáëîêèðîâàííûõ êëþ÷åé
    my @locked_keys = keys %conf;

    # Íå ïðîèçâîäèì äåéñòâèé â ñëó÷àå åñëè èíèöèàëèçàöèÿ âûçûâàåòñÿ íå ïåðâûé ðàç!
    # Òî ÷òî ïîëó÷èëîñü çàêèäûâàåì â ãëîáàâëüíûé îáúåêò
    if ($i > 0) {
        my %tconf = %{$m->get('conf')};
        foreach (keys %conf) { $tconf{$_} = $conf{$_} }
        $m->set(conf=>{%tconf});
        return 1
    }

    ##########################################################################
    # !!! Ïàðàìåòðû, óñòàíàâëèâàåìûå òîëüêî 1 ðàç íà æèçíü âñåõ ïðîöåññîâ !!!
    ##########################################################################
    my $modperl_root = $conf{modperl_root}; # Ýòîò ïóòü äëÿ âñåõ óìîë÷àíèé !!

    # Ôîðìèðóåì èìÿ êîíôèãóðàöèîííîãî ôàéëà. Íàïðèìåð, foo.conf
    $conf{fileconf} = $r->dir_config('FileConf') || catfile($modperl_root,$conf{prefix}.".conf");
    $conf{configloadstatus} = 0; # See _loadconfig

    #
    # Îòíîñèòåëüíûå ïóòè ê äèðåêòîðèÿì (îòíîñèòåëüíî document_root)
    #
    $conf{dir_conf}  = "conf";  # Äèðåêòîðèÿ ê ôàéëàì êîíôèãóðàöèè
    $conf{dir_logs}  = "log";   # Äèðåêòîðèÿ ê ëîãàì îòíîñèòåëüíî document_root
    $conf{dir_cache} = "cache"; # Äèðåêòîðèÿ ê ôàéëàì êýøà
    $conf{dir_db}    = "db";    # Äèðåêòîðèÿ ê ôàéëîâûì äàííûì
    $conf{dir_shtml} = "shtml"; # Äèðåêòîðèÿ ê ôàéëàì øàáëîíîâ è ôàéëîâ ssi

    #
    # Àáñîëþòíûå ïóòè ê äèðåêòîðèÿì îòíîñèòåëüíî êîðíÿ ñåðâåðà (ÍÅ ÐÅÄÀÊÒÈÐÓÅÌÛÅ)
    #
    my $logdir = syslogdir();
    unless (-e $logdir) {
        $logdir = catdir($modperl_root, $conf{dir_logs});
        preparedir($logdir) unless -e $logdir;
    }
    $conf{logdir} = $logdir;
    $conf{confdir} = $r->dir_config('ConfDir') || catdir($modperl_root,$conf{dir_conf});

    #
    # Èìåíà ôàëîâ (ÍÅ ÐÅÄÀÊÒÈÐÓÅÌÛÅ)
    #

    # Ïðåôèêñíûå èìåíà ôàéëîâ
    my $fprefix = ($conf{prefix} ? ('mpminus-'.$conf{prefix}.'_') : 'mpminus-'); # Ïðåôèêñ èì¸í
    $conf{file_error}   = $fprefix."error.log";   # Èìÿ ôàéëà îøèáîê (log)
    $conf{file_debug}   = $fprefix."debug.log";   # Èìÿ ôàéëà îòëàäêè (log)
    $conf{file_connect} = $fprefix."connect.log"; # Èìÿ ôàéëà ñîåäèíåíèé ñ ÁÄ (log)
    $conf{file_mail}    = $fprefix."mail.log";    # Èìÿ ôàéëà ïèñåì (log)
    $conf{file_mpminfo} = "mpminfo.shtml";        # Èìÿ ôàéëà øàáëîíà mpminfo (shtml)

    # Àáñîëþòíûå ïóòè (ÍÅ ÐÅÄÀÊÒÈÐÓÅÌÛÅ)
    $conf{errorlog} = catfile($logdir,$conf{file_error});
    $conf{debuglog} = catfile($logdir,$conf{file_debug});

    # Áàçîâûå URL
    my $urlsfx = '';
    my $urlpfx = 'http://';
    $urlsfx = ':'.$conf{server_port} if (1
        and $conf{server_port} != 80
        and $conf{server_port} != 443
        and $conf{http_host}
        and $conf{http_host} !~ /\:\d+$/
       );
    $urlpfx = 'https://' if $conf{server_port} == 443;
    $conf{url}        = $urlpfx.$conf{http_host}.$urlsfx;
    $conf{urls}       = "https://".$conf{http_host}.$urlsfx;
    $conf{url_shtml}  = $conf{url}.'/'.$conf{dir_shtml};
    $conf{urls_shtml} = $conf{urls}.'/'.$conf{dir_shtml};

    #
    # Ôëàãè (äèðåêòèâû ñ ïðåôôèêñîì è ñóôôèêñîì _ )
    #
    $conf{_debug_}         = $r->dir_config('_debug_') || 0; # Ôëàã îòëàäêè
    $conf{_errorsendmail_} = $r->dir_config('_errorsendmail_') || 0; # Ôëàã îòïðàâêè ñîîáùåíèÿ ïî ïî÷òå ïðè îøèáêàõ
    $conf{_sendmail_}      = $r->dir_config('_sendmail_') || 0; # Ôëàã îòïðàâêè ñîîáùåíèÿ (äëÿ âñåõ)
    $conf{_syslog_}        = $r->dir_config('_syslog_') || 0; # Ôëàã èñïîëüçîâàíèÿ Apache äëÿ îòðàáîòêè ôóíêöèé log è debug
    push @locked_keys, qw/_debug_ _errorsendmail_ _sendmail_/; # áëîêèðóåì!

    push @locked_keys, grep {/dir|file|log|url/} keys(%conf); # áëîêèðóåì!
    push @locked_keys, qw/configloadstatus locked_keys/;
    $conf{locked_keys} = [sort(@locked_keys)];

    #
    # SMTP (ïî÷òà)
    #
    $conf{smtp_host} = $r->dir_config('smtp_host') || '';
    $conf{smtp_user} = $r->dir_config('smtp_user') || '';
    $conf{smtp_password} = $r->dir_config('smtp_password') || '';

    #
    # Áàçà äàííûõ (ëþáàÿ)
    #
    for (qw/
            db_driver db_dsn db_host db_name db_port db_user db_password
            db_timeout_connect db_timeout_request
           /
        ) {
            $conf{$_} = defined $r->dir_config($_) ? $r->dir_config($_) : '';
    }

    #
    # Áàçà äàííûõ MySQL
    #
    for (qw/ db_mysql_host db_mysql_name db_mysql_user db_mysql_password /) {
        $conf{$_} = defined $r->dir_config($_) ? $r->dir_config($_) : '';
    }

    #
    # Áàçà äàííûõ Oracle
    #
    for (qw/ db_oracle_host db_oracle_name db_oracle_user db_oracle_password /) {
        $conf{$_} = defined $r->dir_config($_) ? $r->dir_config($_) : '';
    }

    #
    # ñòàíäàðòû âûâîäà è ïðî÷èå ïàðàìåòðû
    #
    $conf{content_type} = $r->dir_config('content_type') || ''; # Äåôîëòíûé Content-type

    # Òî ÷òî ïîëó÷èëîñü çàêèäûâàåì â ãëîáàâëüíûé îáúåêò, ïðåäâàðèòåëüíî äîçàãðóçèâ äàííûå èç âíåøåíåé êîíôèãóðàöèè
    _loadconfig(\%conf, @locked_keys); # ×òåíèå ôàéëà êîíôèãóðàöèè
    $m->set(conf=>{%conf});
    return 1;
}
sub conf {
    # Ïðî÷èòàòü óêàçàííûé ïàðàìåòð êîíôèãóðàöèè
    my $self = shift;
    my $key  = shift;
    return undef unless $self->{conf};
    return $self->{conf}->{$key};
}
sub get_conf { goto &conf };
sub config { goto &conf };
sub get_config { goto &conf };
sub set_conf {
    # Óñòàíîâèòü óêàçàííûé ïàðàìåòð êîíôèãóðàöèè
    my $self = shift;
    my $key  = shift;
    my $val  = shift;
    $self->{conf} = {} unless $self->{conf};
    $self->{conf}->{$key} = $val;
}
sub set_config { goto &set_conf };
sub _loadconfig {
    my $lconf = shift;
    my @lkeys = @_;
    return 0 unless $lconf && ref($lconf) eq 'HASH';
    return 0 unless $lconf->{fileconf} && -e $lconf->{fileconf};

    # Ïûòàåìñÿ ïðî÷èòàòü êîíôèãóðàöèîííûå äàííûå
    my $cfg;
    try {
        $cfg = new Config::General(
            -ConfigFile         => $lconf->{fileconf},
            -ConfigPath         => [$lconf->{modperl_root}, $lconf->{confdir}],
            -ApacheCompatible   => 1,
            -LowerCaseNames     => 1,
            -AutoTrue           => 1,
        );
    } catch {
        carp($_);
    };

    my %newconfig = $cfg->getall if $cfg && $cfg->can('getall');
    $lconf->{configfiles} = [];
    $lconf->{configfiles} = [$cfg->files] if $cfg && $cfg->can('files');

    # Çàïèñûâàåì òîëüêî ðàçðåøåííûå êëþ÷èêè
    foreach my $k (keys(%newconfig)) {
        $lconf->{$k} = $newconfig{$k} if 1 == 1
            && $k
            && !(grep {$_ eq $k} @lkeys)
    }

    $lconf->{configloadstatus} = 1 if %newconfig;
    return 1;
}

1;