File Coverage

blib/lib/App/Env.pm

Criterion	Covered	Total	%
statement	251	262	95.8
branch	111	124	89.5
condition	30	36	83.3
subroutine	37	41	90.2
pod	16	17	94.1
total	445	480	92.7

package App::Env;

# ABSTRACT: manage application specific environments

use v5.10;
use strict;
use warnings;

our $VERSION = '1.05';

use Scalar::Util;
use Storable ();
use List::Util 1.33;
use IO::File ();

use Params::Validate ();

use App::Env::_Util;
use App::Env::_app;

use overload
  '%{}'    => '_envhash',
  q{""}    => 'str',
  bool     => sub { 1 },
  fallback => 1;

#-------------------------------------------------------

# Options
my %SharedOptions = (
    Force    => { default  => 0 },
    Cache    => { default  => 1 },
    Site     => { optional => 1 },
    CacheID  => { default  => undef },
    Temp     => { default  => 0 },
    SysFatal => { default  => 0, type => Params::Validate::BOOLEAN },
);

my %ApplicationOptions = (
    AppOpts => { default => {}, type => Params::Validate::HASHREF },
    %SharedOptions,
);

my %CloneOptions
  = %{ Storable::dclone( { map { $_ => $SharedOptions{$_} } qw[ CacheID Cache SysFatal ] } ) };
$CloneOptions{Cache}{default} = 0;

my %TempOptions = %{ Storable::dclone( { map { $_ => $SharedOptions{$_} } qw[ SysFatal Temp ] } ) };

# options for whom defaults may be changed.  The values
# in %OptionDefaults are references to the same hashes as in
# ApplicationOptions & SharedOptions, so modifying them will
# modify the others.
my @OptionDefaults = qw( Force Cache Site SysFatal );
my %OptionDefaults;
@OptionDefaults{@OptionDefaults} = @ApplicationOptions{@OptionDefaults};

#-------------------------------------------------------
#-------------------------------------------------------


# import one or more environments.  this may be called in the following
# contexts:
#
#    * as a class method, i.e.
#       use App:Env qw( application )
#       App:Env->import( $application )
#
#    * as a class function (just so as not to confuse folks
#       App::Env::import( $application )
#
#    * as an object method
#       $env->import

sub import {

    my $this = $_[0];

    # object method?
    if ( Scalar::Util::blessed $this && $this->isa( __PACKAGE__ ) ) {
        my $self = shift;
        App::Env::_Util::croak( __PACKAGE__, "->import: too many arguments\n" )
          if @_;

        $ENV{$_} = $self->{$_} for keys %$self;    ## no critic (Variables::RequireLocalizedPunctuationVars)
    }

    else {

        # if class method, get rid of class in argument list
        shift if !ref $this && $this eq __PACKAGE__;

        # if no arguments, nothing to do.  "use App::Env;" will cause this.
        return unless @_;

        # if the only argument is a hash, it sets defaults
        if ( @_ == 1 && 'HASH' eq ref $_[0] ) {
            config( @_ );
            return;
        }

        App::Env->new( @_ )->import;
    }
}


# class method
# retrieve a cached environment.
sub retrieve {

    my ( $cacheid ) = @_;
    my $self;

    if ( defined( my $app = App::Env::_Util::getCacheEntry( $cacheid ) ) ) {
        $self = __PACKAGE__->new();
        $self->_var( app => $app );
    }

    return $self;
}

#-------------------------------------------------------

sub config {
    my %default = Params::Validate::validate( @_, \%OptionDefaults );
    $OptionDefaults{$_}{default} = $default{$_} for keys %default;
    return;
}

#-------------------------------------------------------

sub new {
    my $class = shift;

    my $opts = 'HASH' eq ref $_[-1] ? pop : {};

    # %{} is overloaded, so an extra reference is required to avoid
    # an infinite loop when doing things like $self->{}.  instead,
    # use $$self->{}
    my $self = bless \{}, $class;

    $self->_load_envs( @_, $opts ) if @_;

    return $self;
}

#-------------------------------------------------------

sub clone {
    my $self = shift;

    my %nopt = Params::Validate::validate( @_, \%CloneOptions );

    my $clone = Storable::dclone( $self );
    delete ${$clone}->{id};

    # create new cache id
    $clone->_app->mk_cacheid(
        CacheID => defined $nopt{CacheID}
        ? $nopt{CacheID}
        : $self->lobject_id,
    );

    my %opt = ( %{ $clone->_opt }, %nopt );
    $clone->_opt( \%opt );

    $clone->cache( $opt{Cache} );

    return $clone;
}

#-------------------------------------------------------

sub _load_envs {
    my $self = shift;
    my @opts = ( pop );
    my @apps = @_;

    # most of the following logic is for the case where multiple applications
    # are being loaded in one call.  Checking caching requires that we generate
    # a cacheid from the applications' cacheids.

    # if import is called as import( [$app, \%opts], \%shared_opts ),
    # this is equivalent to import( $app, { %shared_opts, %opts } ),
    # but we still validate %shared_opts as SharedOptions, just to be
    # precise.

    # if there's a single application passed as a scalar (rather than
    # an array containing the app name and options), treat @opts as
    # ApplicationOptions, else SharedOptions

    my %opts = Params::Validate::validate( @opts, @apps == 1 && !ref( $apps[0] )
        ? \%ApplicationOptions
        : \%SharedOptions );


    $opts{Cache} = 0 if $opts{Temp};

    # iterate through the applications to ensure that any application specific
    # options are valid and to form a basis for a multi-application
    # cacheid to check for cacheing.
    my @cacheids;
    my @Apps;
    for my $app ( @apps ) {
        # initialize the application specific opts from the shared opts
        my %app_opt = %opts;

        # special filtering of options if this is part of a multi-app
        # merge
        if ( @apps > 1 ) {
            # don't use the shared CacheID option
            delete $app_opt{CacheID};

            # don't cache individual apps in a merged environment,
            # as the cached environments will be polluted.
            delete $app_opt{Cache};

            # ignore a Force option.  This will be turned on later;
            # if set now it will prevent proper error checking
            delete $app_opt{Force};
        }

        # handle application specific options.
        if ( 'ARRAY' eq ref( $app ) ) {
            ( $app, my $opts ) = @$app;
            App::Env::_Util::croak( "$app: application options must be a hashref\n" )
              unless 'HASH' eq ref $opts;

            %app_opt = ( %app_opt, %$opts );

            if ( @apps > 1 ) {
                for my $iopt ( qw( Cache Force ) ) {
                    if ( exists $app_opt{$iopt} ) {
                        App::Env::_Util::croak(
                            "$app: do not specify the $iopt option for individual applications in a merge\n" );
                        delete $app_opt{$iopt};
                    }
                }
            }
        }

        # set forced options for apps in multi-app merges, otherwise
        # the defaults will be set by the call to validate below.
        if ( @apps > 1 ) {
            $app_opt{Force} = 1;
            $app_opt{Cache} = 0;
        }

        # validate possible application options and get default
        # values. Params::Validate wants a real array
        my ( @app_opts ) = %app_opt;

        # return an environment object, but don't load it. we need the
        # module name to create a cacheid for the merged environment.
        # don't load now to prevent unnecessary loading of uncached
        # environments if later it turns out this is a cached
        # multi-application environment
        %app_opt = ( Params::Validate::validate( @app_opts, \%ApplicationOptions ) );
        my $appo = App::Env::_app->new(
            pid    => $self->lobject_id,
            app    => $app,
            NoLoad => 1,
            opt    => \%app_opt,
        );
        push @cacheids, $appo->cacheid;
        push @Apps,     $appo;
    }


    # create a cacheid for the multi-app environment
    my $cacheid = $opts{CacheId} // join( $;, @cacheids );
    my $App;

    # use cache if possible
    if ( !$opts{Force} && defined( my $app = App::Env::_Util::getCacheEntry( $cacheid ) ) ) {
        # if this is a temporary object and a cached version exists,
        # clone it and assign a new cache id.
        if ( $opts{Temp} ) {
            $App = Storable::dclone( $app );

            # should really call $self->cacheid here, but $self
            # doesn't have an app attached to it yet so that'll fail.
            $App->cacheid( $self->lobject_id );

            # update Temp compatible options
            $App->opt( { %{ $App->opt }, map { $_ => $opts{$_} } keys %TempOptions } );
        }

        else {
            $App = $app;
        }
    }

    # not cached; is this really just a single application?
    elsif ( @Apps == 1 ) {
        $App = shift @Apps;
        $App->load;
    }

    # ok, create new environment by iteration through the apps
    else {
        # we don't want to merge environments, as apps may
        # modify a variable that we don't know how to merge.
        # PATH is easy, but we have no idea what might be in
        # others.  so, let the apps handle it.

        # apps get loaded in the current environment.
        local %ENV = %ENV;

        my @modules;
        foreach my $app ( @Apps ) {
            push @modules, $app->module;

            # embrace new merged environment
            %ENV = %{ $app->load };    ## no critic (Variables::RequireLocalizedPunctuationVars)
        }

        $App = App::Env::_app->new(
            ref     => $self,
            env     => {%ENV},
            module  => join( $;, @modules ),
            cacheid => $cacheid,
            opt     => \%opts,
        );

        if ( $opts{Cache} ) { $App->cache; }
    }

    # record the final things we need to know.
    $self->_var( app => $App );
}


#-------------------------------------------------------

# simple accessors to reduce confusion because of double reference in $self

sub _var {
    my $self = shift;
    my $var  = shift;

    ${$self}->{$var} = shift if @_;

    return ${$self}->{$var};
}

sub module   { $_[0]->_app->module }
sub cacheid  { $_[0]->_app->cacheid }
sub _cacheid { my $self = shift; $self->app->cacheid( @_ ) }
sub _opt {
    my $self = shift;
    $self->_app->opt( @_ );
}
sub _app     { $_[0]->_var( 'app' ) }
sub _envhash { $_[0]->_app->{ENV} }

# would rather use Object::ID but it uses Hash::FieldHash which
# (through no fault of its own:
# http://rt.cpan.org/Ticket/Display.html?id=58030 ) stringify's the
# passed reference on pre 5.10 perls, which causes problems.

# stolen as much as possible from Object::ID to keep the interface the same
{
    my $Last_ID = 'a';

    sub lobject_id {
        my $self = shift;

        return $self->_var( 'id' ) if defined $self->_var( 'id' );
        return $self->_var( 'id', ++$Last_ID );
    }
}

#-------------------------------------------------------

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

    defined $cache
      or App::Env::_Util::croak( "missing or undefined cache argument\n" );

    if ( $cache ) {
        $self->_app->cache;
    }
    else {
        $self->_app->uncache;
    }
}

sub uncache {
    goto \&App::Env::_Util::uncache;
}


#-------------------------------------------------------

sub env {
    my $self = shift;
    my @opts = ( 'HASH' eq ref $_[-1] ? pop : {} );

    # mostly a duplicate of what's in str(). ick.
    my %opt = Params::Validate::validate(
        @opts,
        {
            Exclude => {
                callbacks => { 'type' => \&App::Env::_Util::exclude_param_check },
                default   => undef,
            },
            AllowIllegalVariableNames => {
                optional => 1,
                default  => !!1,
            },
        } );

    # Exclude is only allowed in scalar calling context where
    # @_ is empty, has more than one element, or the first element
    # is not a scalar.
    App::Env::_Util::croak( "Cannot use Exclude in this calling context\n" )
      if $opt{Exclude} && ( wantarray() || ( @_ == 1 && !ref $_[0] ) );    ## no critic (Community::Wantarray)

    my $include = [ @_ ? @_ : qr/.*/ ];
    my $env     = $self->_envhash;

    my @exclude
      = defined( $opt{Exclude} )
      ? ( 'ARRAY' eq ref $opt{Exclude} ? @{ $opt{Exclude} } : ( $opt{Exclude} ) )
      : ();

    # exclude any variables with non-word characters
    push @exclude, qr/\W/
      unless $opt{AllowIllegalVariableNames};

    my @vars = $self->_filter_env( $include, \@exclude );

    if ( wantarray() ) {    ## no critic (Community::Wantarray)
        return map { exists $env->{$_} ? $env->{$_} : undef } @vars;
    }
    elsif ( @_ == 1 && !ref $_[0] ) {
        return @vars && exists $env->{ $vars[0] } ? $env->{ $vars[0] } : undef;
    }
    else {
        my %env;
        @env{@vars} = map { exists $env->{$_} ? $env->{$_} : undef } @vars;
        return \%env;
    }
}

#-------------------------------------------------------

sub setenv {
    my $self = shift;
    my $var  = shift;

    defined $var
      or App::Env::_Util::croak( "missing variable name argument\n" );

    if ( @_ ) {
        $self->_envhash->{$var} = $_[0];
    }
    else {
        delete $self->_envhash->{$var};
    }
}

#-------------------------------------------------------

# return an env compatible string
sub str {
    my $self = shift;
    my @opts = ( 'HASH' eq ref $_[-1] ? pop : {} );

    # validate type.  Params::Validate doesn't do Regexp, so
    # this is a bit messy.
    my %opt = Params::Validate::validate(
        @opts,
        {
            Exclude => {
                callbacks => { 'type' => \&App::Env::_Util::exclude_param_check },
                optional  => 1,
            },
            AllowIllegalVariableNames => {
                optional => 1,
                default  => !!0,
            },
        } );

    my $include = [ @_ ? @_ : qr/.*/ ];
    my @exclude
      = defined( $opt{Exclude} )
      ? ( 'ARRAY' eq ref $opt{Exclude} ? @{ $opt{Exclude} } : ( $opt{Exclude} ) )
      : ();

    push @exclude, 'TERMCAP'
      if List::Util::none { $_ eq 'TERMCAP' } @$include;

    # exclude any variables with non-word characters
    push @exclude, qr/\W/
      unless $opt{AllowIllegalVariableNames};

    my $env  = $self->_envhash;
    my @vars = grep { exists $env->{$_} } $self->_filter_env( $include, \@exclude );
    return join( q{ }, map { "$_=" . App::Env::_Util::shell_escape( $env->{$_} ) } @vars );
}

#-------------------------------------------------------

# return a list of included variables, in the requested
# order, based upon a list of include and exclude specs.
# variable names  passed as plain strings are not checked
# for existance in the environment.
sub _filter_env {
    my ( $self, $included, $excluded ) = @_;

    my @exclude = $self->_match_var( $excluded );

    my %exclude = map { $_ => 1 } @exclude;
    return grep { !$exclude{$_} } $self->_match_var( $included );
}

#-------------------------------------------------------

# return a list of variables which matched the specifications.
# this takes a list of scalars, coderefs, or regular expressions.
# variable names  passed as plain strings are not checked
# for existance in the environment.
sub _match_var {
    my ( $self, $match ) = @_;

    my $env = $self->_envhash;

    $match = [$match] unless 'ARRAY' eq ref $match;

    my @keys;
    for my $spec ( @$match ) {
        next unless defined $spec;

        ## no critic( ControlStructures::ProhibitCascadingIfElse)
        if ( !ref $spec ) {
            # always return a plain name.  this allows
            #   @values = $env->env( @names) to work.
            push @keys, $spec;
        }
        elsif ( 'Regexp' eq ref $spec ) {
            push @keys, grep { /$spec/ } keys %$env;
        }
        elsif ( 'CODE' eq ref $spec ) {
            push @keys, grep { $spec->( $_, $env->{$_} ) } keys %$env;
        }
        elsif ( 'ARRAY' eq ref $spec ) {
            push @keys, $self->_match_var( $spec );
        }
        else {
            App::Env::_Util::croak( 'match specification is of unsupported type: ', ref $spec, "\n" );
        }
    }

    return @keys;
}

#-------------------------------------------------------


#-------------------------------------------------------


sub system {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my $self = shift;

    local %ENV = %{$self};
    if ( $self->_opt->{SysFatal} ) {
        require IPC::System::Simple;
        return IPC::System::Simple::system( @_ );
    }
    else {
        return CORE::system( @_ );
    }
}

#-------------------------------------------------------

sub qexec {
    my $self = shift;
    local %ENV = %{$self};

    require IPC::System::Simple;

    my ( @res, $res );

    my $wantarray = wantarray;    ## no critic (Community::Wantarray)

    eval {
        if ( $wantarray ) {
            @res = IPC::System::Simple::capture( @_ );
        }
        else {
            $res = IPC::System::Simple::capture( @_ );
        }
        1;
    } // do {
        App::Env::_Util::croak( $@ ) if $self->_opt->{SysFatal};
        # should return false, but need to keep API backwards compat
        return undef;
    };

    return $wantarray ? @res : $res;
}

#-------------------------------------------------------

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

    my $redirect;
    $redirect = pop @args if 'HASH' eq ref $args[-1];

    local %ENV = %{$self};

    my $wantarray = wantarray;    ## no critic (Community::Wantarray)

    require Capture::Tiny;
    require IPC::System::Simple;

    my $exit;

    my $sub
      = $self->_opt->{SysFatal}
      ? sub { $exit = IPC::System::Simple::system( @args ) }
      : sub { $exit = CORE::system( @args ) };

    # Capture::Tiny::capture is prototyped as (&;@). App::Env
    # lazy-loads Capture::Tiny and thus nominally avoids the prototype
    # check. However, if Capture::Tiny is explicitly loaded prior to
    # App::Env, the prototype check will be performed when App::Env is
    # compiled.  In that case the following calls to capture are
    # singled out, as while the calls are correct, the prototype
    # requires an explicit block or sub{}.  So, explicitly
    # ignore prototypes.


    my @return;
    eval {
        ## no critic (AmpersandSigils,AmpersandSubCalls )

        if ( $redirect ) {
            my %redirect;
            for my $stream ( 'stdout', 'stderr' ) {
                next unless exists $redirect->{$stream};
                my $handle = $redirect->{$stream};
                $handle = IO::File->new( $handle, '>' )
                  if ref $handle eq q{};
                $redirect{$stream} = $handle;
            }
            &Capture::Tiny::capture( $sub, %redirect );
            $return[0] = $exit;
        }
        elsif ( $wantarray ) {
            @return = &Capture::Tiny::capture( $sub );
        }
        else {
            $return[0] = &Capture::Tiny::capture( $sub );
        }
        1;
    } // App::Env::_Util::croak( $@ );

    ## no critic (EmptyReturn)
    return if !defined $wantarray;
    return $wantarray ? @return : $return[0];
}

#-------------------------------------------------------

sub exec {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my $self = shift;

    local %ENV = %{$self};
    exec( @_ );
}


#-------------------------------------------------------

sub which {
    require File::Which;
    my $self = shift;

    {
        local %ENV = %{$self};
        return File::Which::which( @_ );
    }
}

1;

#
# This file is part of App-Env
#
# This software is Copyright (c) 2018 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__