File Coverage

blib/lib/Config/Environment.pm

Criterion	Covered	Total	%
statement	140	155	90.3
branch	38	58	65.5
condition	10	17	58.8
subroutine	16	16	100.0
pod	5	10	50.0
total	209	256	81.6

# ABSTRACT: Application Configuration via Environment Variables
package Config::Environment;

use utf8;
use 5.10.0;

use Moo;
use Hash::Flatten ();
use Hash::Merge::Simple ();

our $VERSION = '0.000010'; # VERSION


sub BUILDARGS {
    my ($class, @args) = @_;

    unshift @args, 'domain' if $args[0] && $#args == 0;
    return {@args};
}

sub BUILD {
    my ($self) = @_;

    $self->{domain} = lc $self->{domain};
    if ($self->{domain} =~ s/[^a-zA-Z0-9]+/_/g) {
        my ($dom, $subdom) = split /_/, $self->{domain}, 2;
        $self->{domain}    = $dom;
        $self->{subdomain} = $self->to_sub_key($subdom);
    }

    my $dom = $self->domain;
    $self->{snapshot} = { map {$_ => $ENV{$_}} grep { /^$dom\_/i } keys %ENV };
    return $self->load({%ENV}) if $self->autoload;
}


has autoload => (
    is       => 'ro',
    required => 0,
    default  => 1
);


has domain => (
    is       => 'ro',
    required => 1
);


has lifecycle => (
    is       => 'ro',
    required => 0,
    default  => 0
);


has mirror => (
    is       => 'rw',
    required => 0,
    default  => 1
);


has override => (
    is       => 'rw',
    required => 0,
    default  => 1
);


has stash => (
    is       => 'ro',
    required => 0,
    default  => sub {{}}
);


sub load {
    my ($self, $hash) = @_;
    my $dom = lc $self->domain;
    my $env = { map {$_ => $hash->{$_}} grep { /^$dom\_/i } keys %{$hash} };
    my $reg = $self->{registry} //= {env => {}, map => {}};
    my $map = $reg->{map};

    for my $key (sort keys %{$env}) {
        my $value = delete $env->{$key};

        $key =~ s/_/./g;
        $key =~ s/^$dom\.//gi;

        my $hash = {lc $key => $value};

        if (ref $value) {
            if ('ARRAY' eq ref $value) {
                my $i = 0;
                $value = { map { ++$i => $_ } @{$value} };
            }

            $hash = Hash::Flatten->new->flatten($value);

            for my $refkey (keys %{$hash}) {
                (my $newref = $refkey) =~ s/(\w):(\d+)/"$1.".($2+1)/gpe;
                $hash->{lc "$key.$newref"} = delete $hash->{$refkey};
            }
        }

        $map = Hash::Merge::Simple->merge(
            $map => Hash::Flatten->new->unflatten($hash)
        );

        if ($self->mirror) {
            while (my($key, $val) = each(%{$hash})) {
                $ENV{$self->to_env_key($key)} = $val;
            }
        }
    }

    $reg->{map} = $map;

    return $self;
}


sub param {
    my ($self, $key, $val) = @_;

    return unless defined $key;

    my $dom = $self->domain;

    $key = $self->to_dom_key($key);
    $key =~ s/^$dom(\.)?//;

    if (@_ > 2) {
        my $pairs = Hash::Flatten::flatten({$key => $val});
        while (my($key, $val) = each(%{$pairs})) {
            $key =~ s/(\w):(\d+)/"$1.".($2+1)/gpe;
            $key =~ s/\\//g;
            unless (exists $ENV{$self->to_env_key($key)} && ! $self->override) {
                $self->load({$self->to_env_key($key) => $val});
                $self->{registry}{env}{$key} = $val;
            }
        }
    }

    my $result;

    # env lookup
    if (exists $self->{registry}{env}{$key}) {
        $result = $self->{registry}{env}{$key};
    }

    # env map walk
    if (!$result) {
        my $node  = $self->{registry}{map};
        my @steps = split /\./, $key;
        for (my $i=0; $i<@steps; $i++) {
            my $step = $steps[$i];
            if (exists $node->{$step}) {
                if ($i<@steps && 'HASH' ne ref $node) {
                    undef $node and last;
                }
                $node = $node->{$step};
            }
            else {
                undef $node and last;
            }
        }
        $result = $node;
    }

    # stash walk
    if (!$result) {
        my $key = join '.', grep defined, $self->{subdomain}, $_[1]; #hack
        $key =~ s/\.(\d+)\./".".($1-1)."."/gpe;
        unless ($result = $self->stash->{$key}) {
            my $node  = $self->stash;
            my @steps = split /\./, $key;
            for (my $i=0; $i<@steps; $i++) {
                my $step = $steps[$i];
                if ('ARRAY' eq ref $node) {
                    if ($i<@steps && !defined $node->[$step]) {
                        undef $node and last;
                    }
                    else {
                        $node = $node->[$step];
                    }
                }
                elsif ('HASH' eq ref $node) {
                    if ($i<@steps && !defined $node->{$step}) {
                        undef $node and last;
                    }
                    else {
                        $node = $node->{$step};
                    }
                }
                else {
                    undef $node and last;
                }
            }
            $result = $node;
        }
    }

    return $result;
}


sub params {
    my ($self, @keys) = @_;

    if ($#keys == 0) {
        if ('HASH' eq ref $keys[0]) {
            while (my ($key, $value) = each%{$keys[0]}) {
                $self->param($key, $value);
            }
            return;
        }
    }

    my @vals = map { $self->param($_) } @keys;
    return wantarray ? @vals : $vals[0];
}


sub environment {
    my ($self) = @_;
    my $map = Hash::Merge::Simple->merge(
        Hash::Flatten->new->flatten($self->{registry}{map}),
        Hash::Flatten->new->flatten($self->stash),
    );

    for my $key (keys %{$map}) {
        $map->{$self->to_env_key($key)} = delete $map->{$key};
    }

    return $map;
}


sub subdomain {
    my ($self, $key) = @_;
    my $dom  = $self->domain;
    my $copy = ref($self)->new(
        autoload  => 0,
        override  => $self->override,
        lifecycle => $self->lifecycle,
        mirror    => $self->mirror,
        stash     => $self->stash,
        domain    => $dom
    );

    $copy->{subdomain} = $self->to_sub_key($key);
    $copy->{registry}  = $self->{registry};

    return $copy;
}

sub to_dom_key {
    my ($self, $key) = @_;
    my $dom = $self->domain;

    $key =~ s/^$dom//;

    my @prefix = ($dom);
    push @prefix, $self->{subdomain} if defined $self->{subdomain};

    return lc join '.', @prefix, split /_/, $key;
}

sub to_env_key {
    my ($self, $key) = @_;
    my $dom = $self->domain;

    $key =~ s/^$dom//;

    return uc join '_', $dom, split /\./, $key
}

sub to_sub_key {
    my ($self, $key) = @_;
    my $dom = $self->domain;

    ($key = $self->to_dom_key($key)) =~ s/^$dom(\.)?//;

    return $key;
}

sub DESTROY {
    my ($self) = @_;

    if ($self->lifecycle) {
        my $environment = $self->environment;
        my $snapshot    = $self->{snapshot};

        delete $ENV{$_} for grep { ! exists $snapshot->{$_} }
            keys %{$environment};
        $ENV{$_} = $snapshot->{$_} for keys %{$snapshot};
    }
}

1;

__END__