File Coverage

blib/lib/Config/App.pm

Criterion	Covered	Total	%
statement	181	193	93.7
branch	64	88	72.7
condition	28	40	70.0
subroutine	25	25	100.0
pod	4	4	100.0
total	302	350	86.2

package Config::App;
# ABSTRACT: Cascading merged application configuration

use 5.008;
use strict;
use warnings;

use URI ();
use LWP::UserAgent ();
use Carp qw( croak carp );
use FindBin ();
use JSON::XS ();
use YAML::XS ();
use POSIX ();

our $VERSION = '1.13'; # VERSION

$Carp::Internal{ (__PACKAGE__) }++;

sub _location {
    return $ENV{CONFIGAPPINIT} || 'config/app.yaml';
}

sub _add_to_inc {
    my ( $root_dir, @libs ) = @_;
    for my $lib ( map { $root_dir . '/' . $_ } @libs ) {
        unshift( @INC, $lib ) unless ( grep { $_ eq $lib } @INC );
    }
}

sub import {
    my $self = shift;

    my ( $root_dir, $config_file, $location, @libs );
    for (
        ( @_ > 1 )  ? ( $_[0], $_[-1], _location() ) :
        ( @_ == 1 ) ? ( $_[0], _location() )         : _location()
    ) {
        ( $root_dir, $config_file ) = _find_root_dir($_);
        if ( -f $config_file ) {
            $location = substr( $config_file, length($root_dir) + 1 );
            @libs     = grep { $location ne $_ } @_;
            last;
        }
    }

    _add_to_inc( $root_dir, ( @libs || 'lib' ) );

    my $error = do {
        local $@;
        eval {
            $self->new($location);
        };
        $@;
    };

    die $error . "\n" if ($error);
    return;
}

{
    my $singleton;

    sub new {
        my ( $self, $location, $no_singleton ) = @_;
        return $singleton if ( not $no_singleton and $singleton );

        $location ||= _location();

        ( my $box = ( POSIX::uname )[1] ) =~ s/\..*$//;
        my $user  = getpwuid($>) || POSIX::cuserid;
        my $env   = $ENV{CONFIGAPPENV};
        my $conf  = {};

        _location_fetch( $box, $user, $env, $conf, $location );

        $self = bless( { _conf => $conf }, $self );
        $singleton = $self unless ($no_singleton);

        if ( my $libs = $self->get('libs') ) {
            _add_to_inc(
                $self->get( qw( config_app root_dir ) ),
                ( ref $libs eq 'ARRAY' ) ? @$libs : $libs,
            );
        }

        return $self;
    }
}

sub get {
    my $self = shift;
    my $data = $self->{_conf};

    $data = $data->{$_} for (@_);
    return _clone($data);
}

sub put {
    my $self      = shift;
    my $new_value = pop;
    my $path      = [@_];
    my $node      = pop @{$path};
    my $error     = do {
        local $@;
        eval {
            my $data = $self->{_conf};
            $data = $data->{$_} for ( @{$path} );
            $data->{$node} = $new_value;
        };
        $@;
    };

    return ($error) ? 0 : 1;
}

sub conf {
    my $self = shift;
    _merge_settings( $self->{_conf}, $_ ) for (@_);
    return _clone( $self->{_conf} );
}

sub _clone {
    return YAML::XS::Load( YAML::XS::Dump(@_) );
}

sub _location_fetch {
    my ( $box, $user, $env, $conf, $location, @source_path ) = @_;

    my ( $raw_config, $root_dir ) = _get_raw_config( $location, @source_path );
    return unless ($raw_config);

    $conf->{config_app}{root_dir} ||= $root_dir if ($root_dir);

    my $include = $root_dir . '/' . ( ( ref $location ) ? $$location : $location );
    unless ( grep { $_ eq $include } @{ $conf->{config_app}{includes} } ) {
        push( @{ $conf->{config_app}{includes} }, $include );
    }
    else {
        carp(
            'Configuration include recursion encountered when trying to include: ' .
            ( ( ref $location ) ? $$location : $location )
        );
        return;
    }

    my $set = _parse_config( $raw_config, $location, @source_path );

    my $location_fetch = sub { _location_fetch( $box, $user, $env, $conf, $_[0], $location, @source_path ) };
    my $fetch_block    = sub {
        my $include  = ( ( $_[0] ) ? 'pre' : '' ) . 'include';
        my $optional = 'optional_' . $include;

        $location_fetch->( $set->{$include}               ) if ( $set->{$include}   );
        $location_fetch->( delete( $conf->{$include} )    ) if ( $conf->{$include}  );
        $location_fetch->( \$set->{$optional}             ) if ( $set->{$optional}  );
        $location_fetch->( \ delete( $conf->{$optional} ) ) if ( $conf->{$optional} );
    };

    $fetch_block->(1);

    _merge_settings( $conf, $_ ) for (
        grep { defined } (
            map {
                $set->{ join( '|', ( grep { defined } @$_ ) ) }
            } (
                [ 'default'         ],
                [ '+',  '+',   '+'  ], [ '+',  '+'   ],  [ '+'  ],
                [ $box, '+',   '+'  ], [ $box, '+'   ],  [ $box ],
                [ '+',  $user, '+'  ], [ '+',  $user ],
                [ $box, $user, '+'  ], [ $box, $user ],
                [ '+',  '+',   $env ],
                [ '+',  $user, $env ],
                [ $box, '+',   $env ],
                [ $box, $user, $env ],
            )
        )
    );

    $fetch_block->();

    return;
}

sub _get_raw_config {
    my ( $location, @source_path ) = @_;

    my $optional = 0;
    if ( ref $location ) {
        $location = $$location;
        $optional = 1;
    }

    if ( URI->new($location)->scheme ) {
        my $ua = LWP::UserAgent->new(
            agent      => 'Config-App',
            cookie_jar => {},
            env_proxy  => 1,
        );

        my $res = $ua->get($location);

        if ( $res->is_success ) {
            return $res->decoded_content;
        }
        else {
            unless ($optional) {
                croak 'Failed to get '
                    . join( ' -> ', map { "\"$_\"" } @source_path, $location )
                    . '; '
                    . $res->status_line;
            }
            else {
                return '', '';
            }
        }
    }
    else {
        my ( $root_dir, $config_file ) = _find_root_dir($location);

        unless ( -f $config_file ) {
            unless ($optional) {
                croak 'Failed to find ' . join( ' -> ', map { "\"$_\"" } @source_path, $location );
            }
            else {
                return '', '';
            }
        }
        else {
            open( my $config_fh, '<', $config_file ) or croak "Failed to read $config_file; $!";
            return join( '', <$config_fh> ), $root_dir;
        }
    }
}

sub _find_root_dir {
    my ($location) = @_;
    $location ||= location();
    my ( $root_dir, $config_file );

    my @search_path = split( '/', $FindBin::Bin );
    while ( @search_path > 1 ) {
        $root_dir = join( '/', @search_path );
        $config_file = $root_dir . '/' . $location;
        last if ( -f $config_file );
        pop @search_path;
    }

    return $root_dir, $config_file;
}

{
    my $json_xs;

    sub _parse_config {
        my ( $raw_config, $location, @source_path ) = @_;

        my @types = qw( yaml json );
        if ( $location =~ /\.yaml$/ or $location =~ /\.yml$/ ) {
            @types = ( 'yaml', grep { $_ ne 'yaml' } @types );
        }
        elsif ( $location =~ /\.json$/ or $location =~ /\.js$/ ) {
            @types = ( 'json', grep { $_ ne 'json' } @types );
        }

        my ( $config, @errors );
        for my $type (@types) {
            my $error = do {
                local $@;
                eval {
                    if ( $type eq 'json' ) {
                        $json_xs ||= JSON::XS->new
                            ->utf8
                            ->relaxed
                            ->allow_nonref
                            ->allow_unknown
                            ->allow_blessed
                            ->allow_tags;

                        $config = $json_xs->decode($raw_config);
                    }
                    else {
                        $config = YAML::XS::Load($raw_config);
                    }
                };
                $@;
            };

            if ($error) {
                my $message =
                    'Failed to parse ' .
                    join( ' -> ', map { "\"$_\"" } @source_path, $location ) . '; ' .
                    $error;
                croak($message) if ( not $config );
                carp($message);
            }

            last if ($config);
        }

        return $config;
    }
}

sub _merge_settings {
    my ( $merge, $source, $is_deep_call ) = @_;
    return unless $source;

    if ( not $is_deep_call and ref $merge eq 'HASH' and ref $source eq 'HASH' ) {
        if ( my $libs = delete $source->{libs} ) {
            if ( not exists $merge->{libs} ) {
                $merge->{libs} = $libs;
            }
            elsif ( ref $merge->{libs} eq 'ARRAY' ) {
                my %libs = map { $_ => 1 } @{ $merge->{libs} }, ( ref $libs eq 'ARRAY' ) ? @$libs : $libs;
                $merge->{libs} = [ sort keys %libs ];
            }
            else {
                my %libs = map { $_ => 1 } $merge->{libs}, ( ref $libs eq 'ARRAY' ) ? @$libs : $libs;
                $merge->{libs} = [ sort keys %libs ];
            }
        }
    }

    if ( ref $merge eq 'HASH' ) {
        for my $key ( keys %{$source} ) {
            if ( exists $merge->{$key} and ref $merge->{$key} eq 'HASH' and ref $source->{$key} eq 'HASH' ) {
                _merge_settings( $merge->{$key}, $source->{$key}, 1 );
            }
            else {
                $merge->{$key} = _clone( $source->{$key} );
            }
        }
    }
    elsif ( ref $merge eq 'ARRAY' ) {
        push( @$source, @$merge );
    }

    return;
}

1;

__END__