File Coverage

blib/lib/Config/Entities.pm

Criterion	Covered	Total	%
statement	111	115	96.5
branch	46	58	79.3
condition	15	21	71.4
subroutine	18	18	100.0
pod	4	4	100.0
total	194	216	89.8

use strict;
use warnings;

package Config::Entities;
$Config::Entities::VERSION = '1.05';
# ABSTRACT: An multi-level overridable perl based configuration module
# PODNAME: Config::Entities

use Cwd qw(abs_path);
use Data::Dumper;
use File::Find;
use File::Spec;
use Log::Any;

my $logger = Log::Any->get_logger();

sub new {
    my ( $class, @args ) = @_;
    return bless( {}, $class )->_init(@args);
}

sub as_hashref {
    return _copy(@_);
}

sub _copy {
    my ($value) = @_;

    my $ref = ref($value);
    if ($ref) {
        if ( $ref eq 'ARRAY' ) {
            return [ map { _copy($_) } @$value ];
        }
        elsif ( $ref eq 'HASH' || $value->isa('Config::Entities') ) {
            return { map { $_ => _copy( $value->{$_} ) } keys(%$value) };
        }
        elsif ( $ref eq 'SCALAR' ) {
            return $value;
        }
        else {
            croak("unsupported type '$ref'");
        }
    }
    else {
        return $value;
    }
}

sub _add_properties {
    my ( $self, $properties, $more_properties ) = @_;

    foreach my $key ( keys( %{$more_properties} ) ) {
        $properties->{$key} = $more_properties->{$key};
    }
}

sub fill {
    my ( $self, $coordinate, $hashref, %options ) = @_;

    my @entity = $self->get_entity( $coordinate, %options );
    foreach my $key ( keys(%$hashref) ) {
        if ( ref( $entity[0] ) eq 'HASH' && exists( $entity[0]->{$key} ) ) {
            $hashref->{$key} = $entity[0]->{$key};
        }
        elsif ( $hashref->{$key} && $hashref->{$key} eq 'Config::Entities::entity' ) {
            $hashref->{$key} = $entity[0];
        }
        elsif ( $options{ancestry} ) {
            for ( my $index = 1; $index < scalar(@entity); $index++ ) {
                if ( defined( $entity[$index]->{$key} ) ) {
                    $hashref->{$key} = $entity[$index]->{$key};
                    last;
                }
            }
        }
    }

    return $hashref;
}

sub get_entity {
    my ( $self, $coordinate, %options ) = @_;

    my @result = ($self);
    if ($coordinate) {
        foreach my $coordinate_part ( split( /\./, $coordinate ) ) {
            my $child = $result[0]->{$coordinate_part};
            return if ( !$child );
            unshift( @result, $child );
        }
    }
    return $options{ancestry} ? @result : shift(@result);
}

sub _init {
    my ( $self, @args ) = @_;

    # if last arg is a hash, it is an options hash
    my $options =
        ref( $args[$#args] ) eq 'HASH'
        ? pop(@args)
        : {};

    # all other args are entities roots
    my @entities_roots = @args;

    my $properties = {};
    if ( $options->{properties_file} ) {

        # merge in properties from files
        my @properties_files =
            ref( $options->{properties_file} ) eq 'ARRAY'
            ? @{ $options->{properties_file} }
            : ( $options->{properties_file} );

        foreach my $properties_file (@properties_files) {
            $self->_add_properties( $properties, do($properties_file) );
        }
    }
    if ( $options->{properties} ) {

        # merge in direct properties
        $self->_add_properties( $properties, $options->{properties} );
    }

    if ( $options->{entity} ) {
        foreach my $key ( keys( %{ $options->{entity} } ) ) {
            _merge( $self, $key, $options->{entity}{$key} );
        }
    }

    if ( scalar(@entities_roots) ) {
        find(
            sub {
                if ( $_ =~ /^(.*)\.pmc?$/ && -f $File::Find::name ) {
                    my $key = $1;

                    my $hashref     = $self;
                    my @directories = File::Spec->splitdir(
                        substr( $File::Find::dir, length($File::Find::topdir) ) );
                    if ( scalar(@directories) ) {
                        shift(@directories) while ( !$directories[0] );
                        foreach my $dir (@directories) {
                            if ( !defined( $hashref->{$dir} ) ) {
                                $hashref->{$dir} = {};
                            }
                            $hashref = $hashref->{$dir};
                        }
                    }

                    my $entity;
                    {
                        # export %properties to the entity file
                        local $Config::Entities::properties = $properties;
                        ## no critic (ProhibitNoStrict)
                        no strict 'vars';
                        local %properties = $properties ? %$properties : ();
                        $entity = do($File::Find::name);
                        ## use critic
                    }
                    $logger->warn( 'unable to compile ', $File::Find::name, ': ', $@, "\n" )
                        if ($@);
                    _merge( $hashref, $key, $entity );
                }
            },
            map { Cwd::abs_path($_) } @entities_roots
        );
    }

    _inherit( undef, $self );

    return $self;
}

sub _inherit {
    my ( $parent, $child ) = @_;
    if ( $child && ( ref($child) eq 'HASH' || ref($child) eq 'Config::Entities' ) ) {
        if ( $parent && $child->{'Config::Entities::inherit'} ) {
            my $inherit = delete( $child->{'Config::Entities::inherit'} );
            if ($inherit) {
                foreach my $key (@$inherit) {
                    if ( defined( $parent->{$key} ) ) {
                        $child->{$key} = $parent->{$key} unless ( defined( $child->{$key} ) );
                    }
                }
            }
        }
        _inherit( $child, $child->{$_} ) foreach keys(%$child);
    }
}

sub _merge {
    my ( $hashref, $key, $value ) = @_;

    if ( ref($value) eq 'HASH' ) {

        # transfer key/value pairs from hashref
        # will merge rather than replace...
        if ( !defined( $hashref->{$key} ) ) {
            $hashref->{$key} = {};
        }
        $hashref = $hashref->{$key};

        while ( my ( $sub_key, $sub_value ) = each(%$value) ) {
            _merge( $hashref, $sub_key, $sub_value );
        }
    }
    else {
        # anything not a hashref will replace
        $hashref->{$key} = $value;
    }
}

1;

__END__