File Coverage

blib/lib/Env/Bash.pm

Criterion	Covered	Total	%
statement	115	200	57.5
branch	35	118	29.6
condition	11	41	26.8
subroutine	21	30	70.0
pod	8	8	100.0
total	190	397	47.8

package Env::Bash;

use 5.008;
use strict;
use warnings;

use Data::Dumper;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT    = qw( get_env_var get_env_keys );

our $HAVEBASH = 1;

our $VERSION = '0.04';
$VERSION = eval $VERSION;

=pod

=head1 NAME

Env::Bash - Perl extension for accessing _all_ bash environment variables.

=head1 SYNOPSIS

  use Env::Bash;

Standard interface:

  my @var = get_env_var( "SORCERER_MIRRORS",
                         Source => "/etc/sorcery/config", );
  print "SORCERER_MIRRORS via get_env_var:\n",
  join( "\n", @var ), "\ncount = ", scalar @var, "\n";

  @var = Env::Bash::SORCERER_MIRRORS
      ( Source => "/etc/sorcery/config", );
  print "SORCERER_MIRRORS via name:\n",
  join( "\n", @var ), "\ncount = ", scalar @var, "\n";

  my @keys = get_env_keys( Source => "/etc/sorcery/config",
                           SourceOnly => 1, );
  print "first 10 keys:\n", map { " $_\n" } @keys[0..9];

=cut

# -------------------------
# Implementation - AUTOLOAD
# -------------------------

sub AUTOLOAD {
    my $name = our $AUTOLOAD;
    return if $name =~ /DESTROY$/;
    $name =~ s/^.*:://;
    return unless $name =~ /^[_A-Z][_A-Z0-9]*$/;
    $_[0] && ref $_[0] && $_[0]->isa( 'Env::Bash' ) ?
        shift->get( $name, @_ ) :
        _get_env_var( $name, @_ );
}

# -------------------------
# Implementation - exported
# -------------------------

sub get_env_var
{
    _get_env_var( @_ );
}

sub get_env_keys
{
    _get_env_keys( @_ );
}

=pod

Object oriented interface:

  my $be = Env::Bash->new( Source => "/etc/sorcery/config",
                           Keys => 1, );
  my @var = $be->get( "SORCERER_MIRRORS" );
  print "SORCERER_MIRRORS via get:\n",
  join( "\n", @var ), "\ncount = ", scalar @var, "\n";

  @var = $be->SORCERER_MIRRORS;
  print "SORCERER_MIRRORS via name:\n",
  join( "\n", @var ), "\ncount = ", scalar @var, "\n";

  $be = Env::Bash->new( Keys => 1,);
  @var = $be->HOSTTYPE;
  print "HOSTTYPE via name:\n",
  join( "\n", @var ), "\ncount = ", scalar @var, "\n";

  if( $be->exists( 'BASH_VERSINFO' ) ) {
      print "BASH_VERSINFO =>\n ",
      join( "\n ", $be->BASH_VERSINFO ), "\n";
  }

  my %options = $be->options( [], Keys => 1 );

=cut

# -------------------------
# Implementation - oo i/f
# -------------------------

sub new
{
    my( $invocant, @options ) = @_;
    my $class = ref( $invocant ) || $invocant;
    my $s = { options => {}, };
    bless $s, $class;
    _have_bash();
    $s->options( @options );
    $s->keys() if $s->{options}{Keys};
    $s;
}

sub get
{
    my( $s, $name, @options ) = @_;
    my %options = $s->options( @options );
    _get_env_var( $name, %options );
}

sub exists
{
    my( $s, $key ) = @_;
    unless( $s->{keys} ) {
        $s->{options}{Keys} = 1;
        $s->keys();
    }
    grep /^$key$/, @{$s->{keys}};
}

sub keys
{
    my( $s, @options ) = @_;
    $s->options( @options );
    if( exists $s->{keys} && @{$s->{keys}} ) {
        return unless defined wantarray;
        return wantarray ? @{$s->{keys}} : $s->{keys};
    }
    my @keys = _get_env_keys( %{$s->{options}} );
    $s->{keys} = [ @keys ];
    return unless defined wantarray;
    wantarray ? @keys : \@keys;
}

sub reload_keys
{
    my( $s, @options ) = @_;
    delete $s->{keys};
    $s->keys( @options );
}

sub options
{
    my $s = shift;
    my %options = _options( @_ );
    unless( %options ) {
        return unless defined wantarray;
        return wantarray ? %{$s->{options}} : $s->{options};
    }
    $s->{options} = { %{$s->{options}}, %options };
    return unless defined wantarray;
    return wantarray ? %{$s->{options}} : $s->{options};
}

=pod

Tie HASH interface:

  my %env = ();
  tie %env, "Env::Bash", Source => "/etc/sorcery/config", ForceArray => 1;

  my $var = $env{SORCERER_MIRRORS};
  print "SORCERER_MIRRORS via tied hash:\n",
  join( "\n", @$var ), "\ncount = ", scalar @$var, "\n";

  $var = $env{HOSTTYPE};
  print "HOSTTYPE via tied hash:\n",
  join( "\n", @$var ), "\ncount = ", scalar @$var, "\n";

  while( my( $key, $value ) = each %env ) {
      print "$key =>\n ", join( "\n ", @$value ), "\n";
  }

=cut

# -------------------------
# Implementation - tie hash
# -------------------------

sub TIEHASH
{
    my( $invocant, @options ) = @_;
    my $class = ref( $invocant ) || $invocant;
    my $s = { options => {}, };
    bless $s, $class;
    _have_bash();
    $s->options( @options );
    $s->keys();
    $s;
}

sub FETCH
{
    my( $s, $key ) = @_;
    return undef unless $s->EXISTS( $key );
    _get_env_var( $key, %{$s->{options}} );
}

sub STORE
{
    Carp::croak( "Tied hash is read-only\n" );
}

sub DELETE
{
    Carp::croak( "Tied hash is read-only\n" );
}

sub CLEAR
{
    Carp::croak( "Tied hash is read-only\n" );
}

sub EXISTS
{
    my( $s, $key ) = @_;
    grep /^$key$/, @{$s->{keys}};
}

sub FIRSTKEY
{
    my $s = shift;
    $s->{keys}[0];
}

sub NEXTKEY
{
    my( $s, $prevkey ) = @_;
    my $idx = 0;
    return $s->FIRSTKEY() unless $prevkey;
    for( ; $idx < @{$s->{keys}}; $idx++ ) {
        last if $s->{keys}[$idx] eq $prevkey;
    }
    $s->{keys}[++$idx];
}

# -------------------------
# 'Private' subs
# ( denoted by leading '_' )
# -------------------------

sub _get_env_var
{
    return unless defined wantarray;
    my $name = shift;
    return undef unless $name;

    my @ret = ();
    my %options  = _options( @_ );
    if( _have_bash() ) {
        my @script =
            (
             _sources( %options ),
             _script_contents( $name ),
             );
        my $script = join ";", @script;
        print STDERR "script:\n$script\n" if $options{Debug};

        my $result = _execute_script( $script, %options );

        my $href = _load_contents( $result, %options );
        @ret = $href->{$name} ? @{$href->{$name}} : () ;
    } else {
        push @ret, $ENV{$name} || '';
    }
    if( $options{ForceArray} ) {
        return wantarray ? @ret : \@ret;
    }
    wantarray ? @ret : ( defined $ret[0] ? $ret[0] : '' );
}

sub _get_env_keys
{
    my %options = _options( @_ );
    my $bash = _have_bash();
    my @keys = ();
    if( $bash ) {
        my @sources = _sources( %options );
        my $script = "#!$bash\n" .
            ( @sources ? join( ';', @sources ).';' : '' ) .
            'set';
        my $result = _execute_script( $script, %options );
        my %hkeys = _select_keys( $result, %options );
        if( @sources && $options{SourceOnly} ) {
            $script = "#!$bash\nset";
            $result = _execute_script( $script, %options );
            my %bhkeys = _select_keys( $result, %options );
            map { delete $hkeys{$_} } CORE::keys %bhkeys;
            delete $hkeys{PIPESTATUS}; # magically appears when a script is run
        }
        @keys = sort( CORE::keys %hkeys );
    } else {
        @keys = sort( CORE::keys %ENV );
    }
    return unless defined wantarray;
    wantarray ? @keys : \@keys;
}

sub _select_keys
{
    my $result = shift;
    my %options = _options( @_ );
    my %hkeys = ();
    pos( $result ) = 0;
    while( $result =~ /(.*?)=(?:'.*?'\n|\(.*?\)\n|.*?\n)/sg ) {
        my $name = $1;
        next unless $name;
        next if $name eq 'BASH_EXECUTION_STRING';
        if( $options{SelectRegex} ) {
            next unless $name =~ /$options{SelectRegex}/;
        }
        $hkeys{$name} = 1;
    }
    %hkeys;
}

sub _have_bash
{
    return '' unless $HAVEBASH;
    my $bash;
    $HAVEBASH = 1;
    $bash = $ENV{SHELL};
    return $bash if $bash && -f $bash && -x _;
    return 'bash' if system( 'bash', '-c', '' ) == 0;
    $bash = $ENV{BASH};
    return $bash if $bash && -f $bash && -x _;
    warn "No bash executable found, running as \$ENV{...}\n" if $HAVEBASH;
    $HAVEBASH = 0;
    '';
}

sub _sources
{
    my %options = _options( @_ );
    my @srcs =
        map { split /;/, $_ }
    $options{Source} ?
        ( ref $options{Source} && ref $options{Source} eq 'ARRAY' ?
          @{$options{Source}} : $options{Source} ) : ();
    return () unless @srcs;
    my @sources = ();
    for my $source( @srcs ) {
        next unless $source;
        $source =~ s/^\. //;
        next unless $source;
        unless( -f $source ) {
            warn "Source '$source' not found. Ignored.\n";
            next;
        }
        unless( -x _ ) {
            warn "Source '$source' not executable. Ignored.\n";
            next;
        }
        my $fh;
        unless( open( $fh, $source ) ) {
            warn "Source '$source' open error: $!. Ignored.\n";
            next;
        }
        close $fh;
        push @sources, ". $source";
    }
    @sources;
}

sub _script_contents
{
    my( $name ) = @_;
    (
     "for element in \$(seq 0 \$((\${#${name}[@]} - 1)))",
     "do echo \"<<8774$name>>\${${name}[\$element]}<<4587>>\"",
     "done",
     );
}

sub _execute_script
{
    my $script = shift;
    my %options = _options( @_ );
    print STDERR "script:\n$script\n" if $options{Debug};
    my $result = eval { `$script 2>&1` };
    Carp::croak
        ( "Oops: internal bash script error or your shell is not bash:\n".
          $result ) if $? || $@;
    print STDERR "script output:\n$result\n" if $options{Debug};
    $result;
}

sub _load_contents
{
    my $data = shift;
    my %options = _options( @_ );
    my $content = {};
    pos( $data ) = 0;
    while( $data =~ /<<8774(.+?)>>(.*?|)<<4587>>/sg ) {
        push @{$content->{$1}}, $2;
    }
    print STDERR "content: ", Dumper( $content ) if $options{Debug};
    $content;
}

sub _options
{
    my %options;
    if( $_[0] && ref $_[0] && ref $_[0] eq 'ARRAY' ) {
        shift; %options = ( @_, ForceArray => 1, );
    } else {
        %options = @_;
    }
    unless( %options ) {
        return unless defined wantarray;
        return wantarray ? () : [];
    }
    return unless defined wantarray;
    return wantarray ? %options : \%options;
}

1;

__END__