File Coverage

blib/lib/CGI/Application/Plugin/Config/Any.pm

Criterion	Covered	Total	%
statement	99	120	82.5
branch	37	56	66.0
condition	16	31	51.6
subroutine	13	15	86.6
pod	6	6	100.0
total	171	228	75.0

## --------------------------------------------------------------------
## C::A::Plugin to use Config::Any
## --------------------------------------------------------------------

package CGI::Application::Plugin::Config::Any;
use strict;
use warnings;

use base 'Exporter';
use vars qw/ @EXPORT @EXPORT_OK %EXPORT_TAGS /;

@EXPORT      = qw( config );
@EXPORT_OK   = qw( config_init config_name config_section config_read );
%EXPORT_TAGS = (
    'all' =>  [
        qw( config config_init config_name config_section config_read )
    ]
);

use Config::Any;

my $prefix = '__CONFIG_ANY_';

$CGI::Application::Plugin::Config::Any::DEBUG = 0;


=head1 NAME

CGI::Application::Plugin::Config::Any - Add Config::Any Support to CGI::Application

=head1 VERSION

Version 0.13

=cut

$CGI::Application::Plugin::Config::Any::VERSION = '0.14';


=head1 SYNOPSIS

There are two ways to initialize this module.

B

    my $app = WebApp->new(
        PARAMS => {
            config_dir    => '/path/to/configfiles',
            config_files  => [ 'app.conf' ],
            config_name   => 'main',
            config_params => {
                ## passed to Config::Any->load_files;
                ## see Config::Any for valid params
            }
        }
    );
    $app->run();

B-based module:>

    use base 'CGI::Application';
    use CGI::Application::Plugin::Config::Any;

    sub cgiapp_init {
        my $self = shift;

        # Set config file and other options
        $self->config_init(
            config_dir    => '/path/to/configfiles',
            config_files  => [ 'app.conf' ],
            config_name   => 'main',
            config_params => {
                ## passed to Config::Any->load_files;
                ## see Config::Any for valid params
            }
        );
    }

Later...

    ## get a complete config section as a hashref
    my $section = $self->config_section( 'sectionname' );

    ## get a single config param
    my $param = $self->config( 'paramname' );


=head1 DESCRIPTION

This module allows to use L for config files inside a
CGI::Application based application.

B

(L provides a facility for Perl applications and libraries
to load configuration data from multiple different file formats. It
supports XML, YAML, JSON, Apache-style configuration, Windows INI
files, and even Perl code.)


=head1 EXPORTS

By default, only the L() method is exported.

B

=over 4

=item config_init

=item config_name

=item config_section

=item config_read

=back

You can import them explicitly, or use ':all':

    use CGI::Application::Plugin::Config::Any qw( :all );


=head1 METHODS

=head2 config

This method is exported to your C::A based application as an accessor
to the configuration params.

There are several ways to retrieve a config param:

    $self->config_section('mysection');
    $self->config('mysetting');
    # set section to 'mysection' before retrieving 'mysetting'

    $self->config('mysetting', section => 'mysection' );
    # more convenient way to do the same as above

    $self->config('mysection.mysetting');
    # another way to do the same as above

    $self->config('mysetting');
    # let the module find a param named 'mysetting' without
    # knowing or bothering the section name

See also L!

=cut

#-------------------------------------------------------------------
# METHOD:     config
# + author:   Bianka Martinovic
# + reviewed: Bianka Martinovic
# + purpose:
#-------------------------------------------------------------------
sub config {
    my $self    = shift;
    my $param   = shift;

    my %attrs = (
        section => $self->{$prefix.'CURRENT_SECTION'},
        name    => $self->{$prefix.'CONFIG_NAME'} || 'default',
        @_
    );

    my $section = $attrs{'section'};

    if ( $param && $param =~ /^(.*)\.(.*)$/ ) {
        $section = $1;
        $param   = $2;
    }

    $CGI::Application::Plugin::Config::Any::DEBUG
        and __PACKAGE__->_debug(
              "    config name [$attrs{'name'}]\n"
            . "          param [$param]\n"
            . "        section [$section]\n"
        );

    return _load(
        $self,
        section => $section,
        param   => $param,
        name    => $attrs{'name'}
    );
}   # --- end sub config ---


=head2 config_init

Initializes the plugin.

    $self->config_init(
        config_dir   => '/path/to/configfiles',
        config_files => [ 'app.conf' ],
    );

Valid params:

=over 4

=item config_dir SCALAR

Path where the config files reside in.

=item config_files ARRAY

A list of files to load.

=item config_name SCALAR

You can use more than one configuration at the same time by using config
names. For example:

    $self->config_init(
        config_name   => 'database',
        config_files  => [ 'db.conf' ],
    );
    $self->config_init(
        config_name   => 'template',
        config_files  => [ 'tpl.conf' ],
    );

    ...

    my $connection_options  = $self->config_section('connection', name => 'database' );
    my $template_file       = $self->config( 'file', name => 'template' );

=item config_names HASHREF



=item config_params HASHREF

Options to pass to Config::Any->load_files().

B

    $self->config_init(
        config_files  => [ 'default.yml' ],
        config_params => {
            'use_ext' => 1,
        }
    );

See L for details.

=back

=cut

#-------------------------------------------------------------------
# METHOD:     config_init
# + author:   Bianka Martinovic
# + reviewed: Bianka Martinovic
# + purpose:
#-------------------------------------------------------------------
sub config_init {
    my $self = shift;

    my %args = (
        'config_names'  => $self->param('config_names')  || {},
        'config_dir'    => $self->param('config_dir')    || undef,
        'config_files'  => $self->param('config_files')  || [],
        'config_params' => $self->param('config_params') || {},
        'config_name'   => $self->param('config_name')   || 'default',
        @_
    );

    foreach ( keys %args ) {
        $self->{ $prefix . uc($_) } = delete $args{$_};
    }

    $CGI::Application::Plugin::Config::Any::DEBUG
        and __PACKAGE__->_debug(
              "initialized with:\n"
            . "\tconfig_names: $self->{$prefix.'CONFIG_NAMES'}\n"
            . "\tconfig_dir  : $self->{$prefix.'CONFIG_DIR'}\n"
            . "\tconfig_files: "
            . join( ', ', @{ $self->{$prefix.'CONFIG_FILES'} } )
        );

    return 1;

}   # --- end sub config_init ---

=head2 config_name

Set the name of the config to use.

=cut

#-------------------------------------------------------------------
# METHOD:     config_name
# + author:   Bianka Martinovic
# + reviewed: Bianka Martinovic
# + purpose:  set the name of the current config
#-------------------------------------------------------------------
sub config_name {
    my $self = shift;
    my $name = shift;

    return unless $name;

    $CGI::Application::Plugin::Config::Any::DEBUG
        and __PACKAGE__->_debug( "setting config name: $name" );

    $self->{$prefix.'CONFIG_NAME'} = $name;

    return $name;

}   # --- end sub config_name ---


=head2 config_section

Retrieve a complete section from your configuration, or set the name
of the current "default section" for later use with C.

    my $hash = $self->config_section('mysection');

=cut

#-------------------------------------------------------------------
# METHOD:     config_section
# + author:   Bianka Martinovic
# + reviewed: Bianka Martinovic
# + purpose:
#-------------------------------------------------------------------
sub config_section {
    my $self    = shift;
    my $section = shift;

    $self->{$prefix.'CURRENT_SECTION'} = $section;

    $CGI::Application::Plugin::Config::Any::DEBUG
        and __PACKAGE__->_debug(
            "loading section [$section]"
        );

    return _load( $self, section => $section, @_ ) if defined wantarray;

    return;

}   # --- end sub config_section ---


=head2 config_read

Get complete configuration as a hashref.

    my $config = $self->config_read();

=cut

#-------------------------------------------------------------------
# METHOD:     config_read
# + author:   Bianka Martinovic
# + reviewed: Bianka Martinovic
# + purpose:
#-------------------------------------------------------------------
sub config_read {
    my $self = shift;

    return _load( $self, @_ );

}   # --- end sub config_read ---


=head2 std_config

For CGI::Application::Standard::Config compatibility. Just returns
'TRUE'.

=cut

#-------------------------------------------------------------------
# METHOD:     std_config
# + author:   Bianka Martinovic
# + reviewed: Bianka Martinovic
# + purpose:  CGI::Application::Standard::Config compatibility
#-------------------------------------------------------------------
sub std_config { return 1; }


#-------------------------------------------------------------------
#               + + + + + INTERNAL METHODS + + + + +
#-------------------------------------------------------------------

#-------------------------------------------------------------------
# METHOD:     _load
# + author:   Bianka Martinovic
# + reviewed: 07-11-14 Bianka Martinovic
# + purpose:  load config file(s)
#-------------------------------------------------------------------
sub _load {
    my $self = shift;

    my %args = (
        section   => undef,
        param     => undef,
        name      => $self->{$prefix.'CONFIG_NAME'} || 'default',
        @_
    );

    my $name = $args{'name'};

    unless ( $self->{$prefix.'CONFIG_CONFIG'} ) {
        $self->config_init( %args );
    }

    my %config = ();

    ## config already loaded?
    unless ( $self->{$prefix.'CONFIG_CONFIG'}->{ $name } ) {

        $CGI::Application::Plugin::Config::Any::DEBUG
            and __PACKAGE__->_debug(
                "loading config named [$name]"
            );

        if ( exists $self->{$prefix.'CONFIG_NAMES'}->{ $name } ) {

            my $this = $self->{$prefix.'CONFIG_NAMES'}->{ $name };

            foreach ( qw/ config_dir config_files config_params / ) {
                my $key = $prefix.uc($_);
                if ( exists $this->{ $_ } ) {
                    $self->{$key} = $this->{$_};
                }
                $self->{$prefix.'CONFIG_FILES'}
                    = $self->{$prefix.'CONFIG_NAMES'}->{ $name }->{'config_files'};
            }
        }

        if ( $self->{$prefix.'CONFIG_FILES'}
          && ref $self->{$prefix.'CONFIG_FILES'} ne 'ARRAY'
        ) {
            $self->{$prefix.'CONFIG_FILES'} = [ $self->{$prefix.'CONFIG_FILES'} ];
        }

        $self->{$prefix.'CONFIG_FILES'}
            = [
                map { $self->{$prefix.'CONFIG_DIR'}.'/'.$self->{$prefix.'CONFIG_FILES'}[$_] }
                    0 .. $#{ $self->{$prefix.'CONFIG_FILES'} }
              ];

        $CGI::Application::Plugin::Config::Any::DEBUG
            and __PACKAGE__->_debug(
                "searching files: "
              . join( ', ', @{$self->{$prefix.'CONFIG_FILES'}} )
            );

        ## load the files using Config::Any
        my $cfg = Config::Any->load_files(
                      {
                          files   => $self->{$prefix.'CONFIG_FILES'},
                          %{ $self->{$prefix.'CONFIG_PARAMS'} }
                      }
                  );

        $CGI::Application::Plugin::Config::Any::DEBUG
            and __PACKAGE__->_debug(
                "found [" . scalar @$cfg . "] config files"
            );

        ## import settings
        for ( @$cfg ) {

            my ( $filename, $thisconfig ) = each %$_;

            foreach ( keys %$thisconfig ) {
                $config{$_} = $thisconfig->{$_};
            }

        }

        $self->{$prefix.'CONFIG_CONFIG'}->{ $args{'name'} } = \%config;

    }
    else {
        %config = %{ $self->{$prefix.'CONFIG_CONFIG'}->{ $args{'name'} } };
    }

    ## return a section
    if ( $args{'section'} && ! $args{'param'} ) {

        $CGI::Application::Plugin::Config::Any::DEBUG
            and __PACKAGE__->_debug(
                "returning complete section [$args{'section'}]"
            );

        return $config{ $args{'section'} };

    }

    if ( $args{'param'} ) {

        no strict 'vars';

        my $value;

        if ( exists $config{ $args{'param'} } ) {
            $value = $config{ $args{'param'} };
        }
        elsif ( $args{'section'}
             && $config{ $args{'section'} }
             && $config{ $args{'section'} }->{ $args{'param'} }
        ) {
            $value = $config{ $args{'section'} }->{ $args{'param'} };
        }

        unless ( defined $value ) {
            $CGI::Application::Plugin::Config::Any::DEBUG
                and __PACKAGE__->_debug(
                    "trying to find key [$args{'param'}]"
                );
            $value = _find_key( $self, $args{'param'}, \%config );
        }

        return $value;

    }

    return \%config;# unless wantarray;

}   # --- end sub _load ---

#-------------------------------------------------------------------
# METHOD:     _find_key
# + author:   Bianka Martinovic
# + reviewed: Bianka Martinovic
# + purpose:  find a key in the config data structure
#-------------------------------------------------------------------
sub _find_key {
    my $self   = shift;
    my $key    = shift;
    my $config = shift;

    unless ( ref $config eq 'HASH' ) {
        return;
    }

    if ( exists $config->{ $key } ) {
        $CGI::Application::Plugin::Config::Any::DEBUG
                and __PACKAGE__->_debug(
                    "key [$key] found"
                );
        return $config->{ $key };
    }

    foreach my $subkey ( keys %{ $config } ) {
        my $value = _find_key( $self, $key, $config->{$subkey} );
        return $value if $value;
    }

    return;

}   # --- end sub _find_key ---


=pod

=head1 DEBUGGING

This module provides some internal debugging. Any debug messages go to
STDOUT, so beware of enabling debugging when running in a web
environment. (This will end up with "Internal Server Error"s in most
cases.)

There are two ways to enable the debug mode:

=over 4

=item In the module

Find line

    $CGI::Application::Plugin::Config::Any::DEBUG = 0;

and set it to any "true" value. ("1", "TRUE", ... )

=item From outside the module

Add this line B calling C:

    $CGI::Application::Plugin::Config::Any::DEBUG = 1;

=back

=cut

#-------------------------------------------------------------------
# METHOD:     _debug
# + author:   Bianka Martinovic
# + reviewed: 07-11-14 Bianka Martinovic
# + purpose:  print out formatted _debug messages
#-------------------------------------------------------------------
sub _debug {
    my $self = shift;
    my $msg  = shift;

    my $dump;
    if ( @_ ) {
        if ( scalar ( @_ ) % 2 == 2 ) {
            %{ $dump } = ( @_ );
        }
        else {
            $dump = \@_;
        }
    }

    my ( $package, $line, $sub ) = (caller())[0,2,3];
    my ( $callerpackage, $callerline, $callersub )
        = (caller(1))[0,2,3];

    $sub ||= '-';

    print "\n",
          join( ' | ', $package, $line, $sub ),
          "\n\tcaller: ",
          join( ' | ', $callerpackage, $callerline, $callersub ),
          "\n\t$msg",
          "\n\n";

    #if ( $dump ) {
    #    print $self->_dump( $dump );
    #}

    return;
}   # --- end sub _debug ---

1;

__END__