view release on metacpan or  search on metacpan

script/appexec  view on Meta::CPAN

#!perl

use v5.10;
use strict;
use warnings;

# ABSTRACT: execute a command under a specified environment
# PODNAME: appexec

use Getopt::Long qw( :config require_order );

use File::Basename;
use File::Spec::Functions qw( file_name_is_absolute );
use File::Which;
use App::Env;
use List::Util 1.33 'any';
use App::Env::_Util;

our $VERSION = '1.05';
my $prog = basename( $0, '.pl' );

my %ShellMap = (
    ksh  => 'korn',
    bash => 'bash',
    tcsh => 'tc',
    sh   => 'bourne',
    csh  => 'c',
);

# program options; see parse_args();
my %opt;

eval { main() } // do {
    say STDERR "# $prog: $_" foreach split /\n/, $@;    ## no critic(InputOutput::RequireCheckedSyscalls)
    exit 1;
};

exit 0;

sub main {
    parse_args();

    help( 1 ) if $opt{help};
    help( 2 ) if $opt{usage};

    return ( print "$prog $VERSION\n" )
      if $opt{version};

    die "please specify an environment\n"
      unless defined $opt{env};

    if ( $opt{clear} ) {
        ## no critic( Variables::RequireLocalizedPunctuationVars )
        %ENV = map { $_ => $ENV{$_} }
          grep { exists $ENV{$_} } qw[ HOME LOGNAME SHELL ];
    }

    my @envs = split( /,/, $opt{env} );

    # if more than one environment, sort out possible environment specific appopts
    my %appopts;
    @appopts{@envs} = map { {} } 1 .. @envs;

    if ( @envs > 1 ) {

        for my $k ( keys %{ $opt{appopts} } ) {
            my ( $env, $key ) = $k =~ /^([^:]*):(.*)$/;

            die( "appopts ($key) not specific to one of the specified environments" )
              unless exists $appopts{$env};

            $appopts{$env}{$key} = $opt{appopts}->{$k};
        }
    }

    else {
        $appopts{ $envs[0] } = $opt{appopts};
    }

    my $env = eval {
        App::Env->new(
            ( map { [ $_ => { AppOpts => $appopts{$_} } ] } @envs ),
            { ( defined $opt{site} ? ( Site => $opt{site} ) : () ), } );
    } // die( "error setting up environment `$opt{env}': $@\n" );

    $env->setenv( $_ ) for @{ $opt{delete} };
    $env->setenv( $_, $opt{define}{$_} ) for keys %{ $opt{define} };

    dumpenv( $env, $opt{dumpenv}, $opt{dumpvar} ) if $opt{dumpenv};

    if ( @ARGV ) {
        say join( q{ }, @ARGV )    ## no critic(InputOutput::RequireCheckedSyscalls)
          if $opt{verbose};

        %ENV = %$env;              ## no critic( Variables::RequireLocalizedPunctuationVars )

        die( "$ARGV[0] does not exist, is not executable, or is not in PATH\n" )
          unless ( file_name_is_absolute( $ARGV[0] ) && -e $ARGV[0] )
          || defined which( $ARGV[0] );

        exec { $ARGV[0] } @ARGV
          or die( "can't exec $ARGV[0]: not in path?\n" );
    }

    return !!1;
}

sub _is_valid_env_name {
    my $name = shift;
    return $name !~ /\P{IsWord}/ && substr( $name, 0, 1 ) =~ /\P{IsDigit}/;
}

sub dumpenv {
    my ( $env, $fmt, $vars ) = @_;

    $vars = [ keys %$env ] unless @$vars;

    ## no critic (InputOutput::RequireCheckedSyscalls)
    ## no critic (ControlStructures::ProhibitCascadingIfElse)
    if ( $fmt eq 'raw' ) {
        say "$_=",
          (
            length $env->{$_}
            ? App::Env::_Util::shell_escape( $env->{$_} )
            : q{}
          ) for @$vars;
    }

    elsif ( $fmt eq 'unquoted' ) {
        say "$_=$env->{$_}" for @$vars;
    }

    elsif ( $fmt eq 'values' ) {
        say $env->{$_} for @$vars;
    }

    elsif ( $fmt eq 'json' ) {
        require JSON::PP;
        say JSON::PP::encode_json( { map { $_ => $env->{$_} } @$vars } );
    }

    elsif ( $fmt eq 'delta-json' ) {
        my ( $delete, $add ) = delta( $env );
        require JSON::PP;
        say JSON::PP::encode_json( {
            delete => $delete,
            add    => { map { $_ => $env->{$_} } @$add },
        } );
    }

    elsif ( $fmt eq 'delta-args' ) {
        my ( $delete, $add ) = delta( $env );
        say join q{ }, ( map { "-X $_" } @$delete ),
          ( map { "-D $_=" . App::Env::_Util::shell_escape( $env->{$_} ) } @$add );
    }

    else {
        require Shell::Guess;

        if ( $fmt eq 'auto' ) {
            $fmt = Shell::Guess->running_shell;
        }
        else {
            die( "unknown dump format: $fmt\n" )
              unless my $mth = Shell::Guess->can( ( $ShellMap{$fmt} // $fmt ) . '_shell' );
            $fmt = Shell::Guess->$mth;
        }
        require Shell::Config::Generate;
        my $config    = Shell::Config::Generate->new;
        my $extracted = $env->env( $vars, { AllowIllegalVariableNames => !!0 } );
        $config->set( $_, $extracted->{$_} ) for keys %$extracted;
        print $config->generate( $fmt );
    }

    return;
}

sub delta {
    my ( $env ) = @_;
    my @delete = grep { !exists $env->{$_} } keys %ENV;

    my @add
      = grep { !exists $ENV{$_} || exists $ENV{$_} && exists $env->{$_} && $ENV{$_} ne $env->{$_} }
      keys %$env;
    return ( \@delete, \@add );
}

sub parse_args {

    %opt = (
        appopts => {},
        clear   => 0,
        define  => {},
        delete  => [],
        dumpvar => [],
        verbose => 0,
        version => 0,
        usage   => 0,
        help    => 0,
    );

    eval {
        local $SIG{__WARN__} = sub { die $_[0] };

        Getopt::Long::Configure( 'no_ignore_case' );

        GetOptions(
            \%opt,
            qw/
              env=s
              appopts|o=s%
              define|D=s%
              delete|X=s@