File Coverage

blib/lib/Config/App.pm

Criterion	Covered	Total	%
statement	190	225	84.4
branch	69	102	67.6
condition	27	43	62.7
subroutine	28	31	90.3
pod	8	8	100.0
total	322	409	78.7

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

use 5.010;
use strict;
use warnings;

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

our $VERSION = '1.20'; # VERSION

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

sub _locate_root_config {
    my ($config_location) = @_;
    if ($config_location) {
        return undef, $config_location if ( URI->new($config_location)->scheme );
        return ( -f $config_location ) ? ( '/', $config_location ) : ( undef, undef )
            if ( substr( $config_location, 0, 1 ) eq '/' );
    }

    my $locate = sub {
        my ( $abs_paths, $rel_config_locations ) = @_;

        for my $abs_paths (@$abs_paths) {
            for my $test_location (@$rel_config_locations) {
                my @search_path = split( '/', $abs_paths );
                while (@search_path) {
                    my $test_path = join( '/', @search_path );
                    return $test_path || '/', $test_location if ( -f $test_path . '/' . $test_location );
                    pop @search_path;
                }
            }
        }
    };

    my ( $root_dir, $config_file ) = $locate->(
        [ $FindBin::Bin, getcwd() ],
        [ ($config_location) ? $config_location : (
            ( $ENV{CONFIGAPPINIT} ) ? $ENV{CONFIGAPPINIT} : (),
            qw(
                config/app.yaml
                etc/config.yaml
                etc/conf.yaml
                etc/app.yaml
                config.yaml
                conf.yaml
                app.yaml
            )
        ) ],
    );

    return ( length $root_dir and length $config_file ) ? ( $root_dir, $config_file ) : undef;
}

sub _add_to_inc {
    my ( $root_dir, @libs ) = @_;

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

    return;
}

sub import {
    my $self = shift;

    my ( $root_dir, $config_file, @libs );
    for ( @_, undef ) {
        my @locate_root_config = _locate_root_config($_);

        unless ( $locate_root_config[0] ) {
            push( @libs, $_ );
        }
        elsif ( not $root_dir ) {
            ( $root_dir, $config_file ) = @locate_root_config;
        }
    }

    die "Config::App unable to locate configuration file\n" unless ($config_file);

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

    my $error = do {
        local $@;
        eval { $self->new($config_file) };
        $@;
    };
    chomp($error);
    die $error . "\n" if $error;

    return;
}

{
    my $singleton;

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

        ( my $box = ( POSIX::uname )[1] ) =~ s/\..*$//;
        my $conf  = {};

        _process_location({
            box      => $box,
            user     => getpwuid($>) || POSIX::cuserid,
            env      => $ENV{CONFIGAPPENV},
            conf     => $conf,
            optional => 0,
            location => $location,
        });

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

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

        return $self;
    }

    sub deimport {
        my $self = shift;

        delete $self->{_conf} if ( __PACKAGE__ eq ref $self );
        $singleton = undef;

        {
            no strict 'refs';
            @{ __PACKAGE__ . '::ISA' } = ();
            my $symbol_table = __PACKAGE__ . '::';
            for my $symbol ( keys %$symbol_table ) {
                next if ( $symbol =~ /\A[^:]+::\z/ );
                delete $symbol_table->{$symbol};
            }
        }

        delete $INC{ join( '/', split qr{(?:'|::)}, __PACKAGE__ ) . '.pm' };

        return;
    }
}

sub find {
    my $class = shift;

    my $self;
    local $@;
    eval {
        $self = $class->new(@_);
    };
    if ($@) {
        return;
    }

    return $self;
}

sub root_dir {
    my ($self) = @_;
    return $self->get( qw( config_app root_dir ) );
}

sub includes {
    my ($self) = @_;
    return $self->get( qw( config_app includes ) );
}

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 _process_location {
    my ($input) = @_;
    my ( $root_dir, $config_file ) = _locate_root_config( $input->{location} );

    my $include = join( '/', grep { defined and $_ ne '/' } $root_dir, $config_file );
    my $sources = [ grep { defined } @{ $input->{sources} || [] }, $input->{location} ];

    my $raw_config = _get_raw_config({
        include  => $include,
        location => $input->{location},
        optional => $input->{optional},
        sources  => $sources,
    });
    return unless $raw_config;

    $input->{conf}->{config_app}{root_dir} = $root_dir
        if ( defined $root_dir and not exists $input->{conf}->{config_app}{root_dir} );

    unless ( grep { $_ eq $include } @{ $input->{conf}->{config_app}{includes} } ) {
        push( @{ $input->{conf}->{config_app}{includes} }, $include );
    }
    else {
        carp "Configuration include recursion encountered when trying to include: $include";
        return;
    }

    my $set = _parse_config({
        raw_config => $raw_config,
        include    => $include,
        sources    => $sources,
    });

    my ( $box, $user, $env ) = @$input{ qw( box user env ) };
    _merge_settings( $input->{conf}, $_, $input->{reverse} ) 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 ],
            )
        )
    );

    my $sub_process_location = sub {
        _process_location({
            box      => $input->{box},
            user     => $input->{user},
            env      => $input->{env},
            conf     => $input->{conf},
            sources  => $sources,
            location => $_[0],
            optional => $_[1],
            reverse  => $_[2],
        });
    };

    for (
        [ '',          'pre' ],
        [ 'optional_', 'pre' ],
        [ '',          ''    ],
        [ 'optional_', ''    ],
    ) {
        my $type = join( '', @$_, 'include' );
        $sub_process_location->( $set->{$type},                     @$_ ) if ( $set->{$type}           );
        $sub_process_location->( delete( $input->{conf}->{$type} ), @$_ ) if ( $input->{conf}->{$type} );
    }

    return;
}

{
    my $ua;

    sub _get_raw_config {
        my ($input) = @_;

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

            my $res = $ua->get( $input->{include} );

            if ( $res->is_success ) {
                return $res->decoded_content;
            }
            else {
                croak 'Failed to get '
                    . join( ' -> ', map { "\"$_\"" } @{ $input->{sources} } )
                    . '; '
                    . $res->status_line
                    unless $input->{optional};
                return;
            }
        }
        else {
            unless ( $input->{include} ) {
                croak 'Failed to find ' .
                    join( ' -> ', map { "\"$_\"" } @{ $input->{sources} } )
                    unless $input->{optional};
                return;
            }
            else {
                open( my $include_fh, '<', $input->{include} )
                    or croak "Failed to read $input->{include}; $!";
                return join( '', <$include_fh> );
            }
        }
    }
}

{
    my $json_xs;

    sub _parse_config {
        my ($input) = @_;

        my @types = qw( yaml json );
        if ( $input->{include} =~ /\.yaml$/i or $input->{include} =~ /\.yml$/i ) {
            @types = ( 'yaml', grep { $_ ne 'yaml' } @types );
        }
        elsif ( $input->{include} =~ /\.json$/i or $input->{include} =~ /\.js$/i ) {
            @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( $input->{raw_config} );
                    }
                    else {
                        $config = YAML::XS::Load( $input->{raw_config} );
                    }
                };
                $@;
            };

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

            last if $config;
        }

        return $config;
    }
}

sub _merge_settings {
    my ( $merge, $source, $reverse, $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' ) {
        my $handle_keys = sub {
            my ( $origin, $target ) = @_;
            for my $key ( keys %{$origin} ) {
                if (
                    exists $target->{$key}
                    and ref $target->{$key} eq 'HASH'
                    and ref $origin->{$key} eq 'HASH'
                ) {
                    _merge_settings( $target->{$key}, $origin->{$key}, 0, 1 );
                }
                else {
                    $target->{$key} = _clone( $origin->{$key} );
                }
            }
        };

        $handle_keys->( $merge, $source ) if ($reverse);
        $handle_keys->( $source, $merge );
    }
    elsif ( ref $merge eq 'ARRAY' ) {
        push( @$source, @$merge );
    }

    return;
}

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

1;

__END__