File Coverage

blib/lib/Module/MultiConf.pm

Criterion	Covered	Total	%
statement	96	100	96.0
branch	16	20	80.0
condition	7	9	77.7
subroutine	14	15	93.3
pod	0	2	0.0
total	133	146	91.1

#
# $Id: MultiConf.pm 1384 2007-09-30 13:49:29Z oliver $
#
package Module::MultiConf;

use strict;
use warnings FATAL => 'all';

use Carp;
use Symbol;
use UNIVERSAL;
use Scalar::Util 'blessed';
use Config::Any;
use Params::Validate ':all';
use Class::Data::Inheritable;

our $VERSION = '1.0401';
$VERSION = eval $VERSION; # numify for warning-free dev releases

sub import {
    my $caller = caller(0);
    return if $caller eq 'main'; # testing abuse

    my $class = shift;
    my %args  = @_;

    # fake up use base...
    push @{*{Symbol::qualify_to_ref('ISA',$caller)}},
        'Class::Data::Inheritable', __PACKAGE__;

    # push useful things into caller's namespace
    foreach my $t (qw/SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF
                    SCALARREF HANDLE BOOLEAN UNDEF OBJECT/) {
        *{Symbol::qualify_to_ref($t,$caller)} =
            *{Symbol::qualify_to_ref($t)}{CODE};
    }

    $caller->mk_classdata(Validate => {});
    $caller->mk_classdata(Force    => {});
    $caller->mk_classdata(Defaults => {
        allow_extra   => 1,
        on_fail       => sub { croak $_[0] },
        no_validation => 0,
        %args,
    });
}

*{Symbol::qualify_to_ref('parse')} = \&new;

sub new {
    my $self = shift;
    my @args = @_;

    return $self->_load_args() if scalar @args == 0;

    foreach (@args) {
        my $config = $_;

        # if arg is a filename, "convert" to a hashref by loading
        if (!ref $config) {
            my $loaded = Config::Any->load_files(
                {files => [$config], use_ext => 1});
            croak "Failed to parse contents of filename '$config'"
                if scalar @$loaded == 0;

            (undef, $config) = each %{$loaded->[0]};
        }

        croak "Config does not build a HASHREF"
            unless ref $config eq 'HASH' or blessed $config;

        $self = $self->_load_args($config);
    }

    return $self;
}

sub _load_args {
    my $self = shift;

    # factory
    $self = bless {}, $self if !ref $self;

    my $args = shift || {};
    my %copy = %$self;    # copy for validation and munging
    my $pkg  = ref $self; # package into which we look for Validation spec

    # load in new content
    foreach my $k (keys %$args) {
        croak "Loaded config must be a HASHREF of HASHREFs"
            if ref $args->{$k} ne 'HASH';
        @{$copy{$k}}{keys %{$args->{$k}}} = (values %{$args->{$k}});
    }

    # validate new content
    my $validate = $pkg->Validate;
    my $no_valid = $pkg->Defaults->{'no_validation'} || 0;

    {
        local $Params::Validate::NO_VALIDATION = $no_valid;
        foreach my $k (keys %$validate) {
            %{$copy{$k}} = validate_with(
                params      => $copy{$k} || {},
                spec        => $validate->{$k},
                %{ $pkg->Defaults },
            );
        }
    }

    # squash things which are enforced
    my $force = $pkg->Force;
    foreach my $k (keys %$force) {
        @{$copy{$k}}{keys %{$force->{$k}}} = (values %{$force->{$k}});
    }

    foreach my $k (keys %copy) {
        next if UNIVERSAL::can($self, $k);
        next if UNIVERSAL::can('main', $k); # testing abuse

        *{Symbol::qualify_to_ref($k, $pkg)} = sub {
            my $self = shift;
            my $pkg  = ref $self;

            # squash things which are enforced
            my $force = $pkg->Force;
            foreach my $k (keys %$force) {
                @{$self->{$k}}{keys %{$force->{$k}}} = (values %{$force->{$k}});
            }

            return ( wantarray ? %{$self->{$k}} : $self->{$k} );
        };
    }

    %$self = %copy; # restore validated and merged params into self
    return $self;
}

sub me {
    my $self = shift;
    (my $me = lc (scalar caller(0))) =~ s/::/_/g;
    return $self->$me;
}

1;

__END__