Shell::GetEnv - extract the environment from a shell after executing commands

  use Shell::GetEnv;

  $env = Shell::GetEnv->new( $shell, $command );
  $envs = $env->envs( %opts )
  $env->import_envs( %opts );

          http://www.gnu.org/licenses

# --8<--8<--8<--8<--
#
# Copyright (C) 2007 Smithsonian Astrophysical Observatory
#
# This file is part of Shell::GetEnv
#
# Shell::GetEnv is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
# -->8-->8-->8-->8--

package Shell::GetEnv;

require 5.008000;
use strict;
use warnings;

use Carp;

use File::Temp;
use Shell::GetEnv::Dumper;

our $VERSION = '0.08';


# a compendium of shells
my %shells = (
	      bash => {
		       Interactive     => 'i',
		       NoStartup => '--noprofile',
		       Verbose   => 'v',
		       Echo      => 'x',
		      },

	      dash => {
		       Interactive     => 'i',
		       Verbose   => 'v',
		       Echo      => 'x',
		      },

	      sh => {
		     Interactive     => 'i',
		     Verbose   => 'v',
		     Echo      => 'x',
		    },

	      ksh => {
		      Interactive     => 'i',
		      NoStartup => 'p',
		      Verbose   => 'v',
		      Echo      => 'x',
		     },

	      csh => {
		      Interactive     => 'i',
		      NoStartup => 'f',
		      Echo      => 'x',
		      Verbose   => 'v',
		     },

	      tcsh => {
		       Interactive     => 'i',
		       NoStartup => 'f',
		       Echo      => 'x',
		       Verbose   => 'v',
		      },
	     );


my %Opts = ( Startup => 1,
	     Debug => 0,
	     Echo    => 0,
	     Verbose => 0,
	     Interactive => 0,
	     Redirect => 1,
	     STDERR  => undef,
	     STDOUT  => undef,
	     Expect  => 0,
	     Timeout => 10,
	     ShellOpts => undef,
	   );


sub new
{
    my $class = shift;
    my $shell = shift;

    croak( __PACKAGE__, "->new: unsupported shell: $shell\n" )
      unless defined $shells{$shell};

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

    my @notvalid = grep { ! exists $Opts{$_} } keys %$opt;
    croak( __PACKAGE__, "->new: illegal option(s): @notvalid\n" )
      if @notvalid;

    my $self = bless { %Opts, %$opt,
		       Cmds => [@_],
		       Shell => $shell
		     } , $class;

    # needed to get correct hash key for %shells
    $self->{NoStartup} = ! $self->{Startup};

    $self->_getenv;

    return $self;
}

# use temporary script files and output files to get the environment
# requires that a shell have a '-i' flag to act as an interactive shell
sub _getenv
{
    my $self = shift;

    # file to hold the environment
    my $fh_e = File::Temp->new( )
      or croak( __PACKAGE__, ": unable to create temporary environment file" );

    # create script to dump environmental variables to the above file
    push @{$self->{Cmds}},
      $self->_dumper_script( $fh_e->filename ),
      'exit' ;

    # construct list of command line options for the shell
    $self->_shell_options;

    # redirect i/o streams
    $self->_stream_redir if $self->{Redirect};


    if ( $self->{Debug} )
    {
	warn( "Shell: $self->{Shell}\n",
	      "Options: ", join( ' ', @{$self->{ShellOptions}} ), "\n",
	      "Cmds: \n", join( "\n", @{$self->{Cmds}}), "\n" );
    }


    eval {
	if ( $self->{Expect} )
	{
	    $self->_getenv_expect( $fh_e->filename);
	}
	else
	{
	    $self->_getenv_pipe( $fh_e->filename);
	}
    };
    my $error = $@;

    # reset i/o streams
    $self->_stream_reset if $self->{Redirect};

    if ( $error )
    {
	local $Carp::CarpLevel = 1;
	croak $error;
    }


    # retrieve environment
    $self->_retrieve_env( $fh_e->filename );
}

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

    # this invokes the module directly, using the Perl which was
    # used to invoke the parent process.  It uses the fact that we
    # use()'d Shell::GetEnv::Dumper and Perl stored the absolute path
    # to it in %INC;
    return qq{$^X '$INC{'Shell/GetEnv/Dumper.pm'}' $filename};
}



# redirect STDOUT and STDERR
sub _stream_redir
{
    my ( $self ) = @_;

    # redirect STDERR & STDOUT to either /dev/null or somewhere the user points
    # us to.

    my $stdout = $self->{STDOUT} || File::Spec->devnull();
    my $stderr = $self->{STDERR} || File::Spec->devnull();

    open( $self->{oSTDOUT}, ">&STDOUT" )
      or croak( __PACKAGE__,  ': error duping STDOUT' );
    open( $self->{oSTDERR}, ">&STDERR" )
      or croak( __PACKAGE__,  ': error duping STDERR' );

    open( STDERR, '>', $stderr ) or
      croak( __PACKAGE__, ": unable to redirect STDERR to $stderr" );
    open( STDOUT, '>', $stdout ) or
      croak( __PACKAGE__, ": unable to redirect STDOUT to $stdout" );

    select STDERR; $| = 1;
    select STDOUT; $| = 1;
}

# reset STDOUT and STDERR
sub _stream_reset
{
    my ( $self ) = @_;

    close STDOUT;
    close STDERR;

    open STDOUT, '>&', $self->{oSTDOUT};
    open STDERR, '>&', $self->{oSTDERR};

    close delete $self->{oSTDOUT};
    close delete $self->{oSTDERR};
}

# create shell options
sub _shell_options
{
    my ( $self, $scriptfile ) = @_;

    my $shell = $shells{$self->{Shell}};

    ## no critic (ProhibitAccessOfPrivateData)

    my @options = 
      map { $shell->{$_} }
	grep { exists $shell->{$_} && $self->{$_} }
	  qw( NoStartup Echo Verbose Interactive )
	    ;

    ## use critic


    # bundled options are those without a leading hyphen or plus
    my %options = map { ( $_ => 1 ) } @options;
    my @bundled = grep{ ! /^[-+]/ } keys %options;
    delete @options{@bundled};

    my $bundled = @bundled ? '-' . join( '', @bundled ) : undef;

    # long options; bash treats these differently
    my @longopts = grep{ /^--/ } keys %options;
    delete @options{@longopts};

    # everything else
    my @otheropts = keys %options;

    $self->{ShellOptions} =
			[ 
			 # long options go first (bash complains)
			 @longopts,
			 ( $bundled ? $bundled : () ),
			 @otheropts,
			  defined $self->{ShellOpts}
			    ?  'ARRAY' eq ref($self->{ShellOpts})
			       ? @{$self->{ShellOpts}}
			       : $self->{ShellOpts}
			    : (),
			];
}

# communicate with the shell using a pipe
sub _getenv_pipe
{
    my ( $self ) = @_;

    local $" = ' ';
    open( my $pipe, '|-' , $self->{Shell}, @{$self->{ShellOptions}} )
      or die( __PACKAGE__, ": error opening pipe to $self->{Shell}: $!\n" );

    print $pipe ( join( "\n", @{$self->{Cmds}}), "\n");
    close $pipe
      or die( __PACKAGE__, ": error closing pipe to $self->{Shell}: $!\n" );
}

# communicate with the shell using Expect
sub _getenv_expect
{
    my ( $self, $filename ) = @_;

    require Expect;
    my $exp = Expect->new;
    $exp->raw_pty(1);
    $exp->spawn( $self->{Shell}, @{$self->{ShellOptions}} )
      or die( __PACKAGE__, ": error spawning $self->{Shell}\n" );
    $exp->send( map { $_ . "\n" } @{$self->{Cmds}} );
    $exp->expect( $self->{Timeout} );
}

# extract environmental variables from a dumped file
sub _retrieve_env
{
    my ( $self, $filename ) = @_;

    $self->{envs} = Shell::GetEnv::Dumper::read_envs( $filename );
}

# return variables
sub envs
{
    my ( $self, %iopt ) = @_;

    my %opt = ( DiffsOnly  => 0,
		Exclude    => [],
		EnvStr     => 0,
		ZapDeleted => 0,
	      );

    my @unknown = grep { !exists $opt{$_} } keys %iopt;
    croak( __PACKAGE__, "->envs: unknown options: @unknown\n" )
      if @unknown;

    %opt = ( %opt, %iopt );

    my %env = %{$self->{envs}};


    ###
    # filter out excluded variables

    # ensure that scalars are handled correctly
    $opt{Exclude} = [ $opt{Exclude} ]
      unless 'ARRAY' eq ref $opt{Exclude};

    foreach my $exclude ( @{$opt{Exclude}} )
    {
	my @delkeys;

	if ( 'Regexp' eq ref $exclude )
	{
	    @delkeys = grep { /$exclude/ } keys %env;
	}
	elsif ( 'CODE' eq ref $exclude )
	{
	    @delkeys = grep { $exclude->($_, $env{$_}) } keys %env;
	}
	else
	{
	    @delkeys = grep { $_ eq $exclude } keys %env;
	}

	delete @env{@delkeys};
    }


    # return only variables which are new or differ from the current
    # environment
    if ( $opt{DiffsOnly} )
    {
	my @delkeys =
	  grep { exists $ENV{$_} && $env{$_} eq $ENV{$_} } keys %env;

	delete @env{@delkeys};
    }



    if ( $opt{EnvStr} )
    {
	my @set = map { "$_=" . _shell_escape($env{$_}) } keys %env;
	my @unset;

	if ( $opt{ZapDeleted} )
	{
	    my @deleted;
	    @deleted = grep { exists $ENV{$_} && ! exists $self->{envs}{$_} }
	      keys %ENV;

	    @unset = map { "-u $_" } @deleted;
	}

	return join( ' ', @unset, @set );
    }

    return \%env;
}


sub _shell_escape
{
  my $str = shift;

  # empty string
  if ( $str eq '' )
  {
    $str = "''";
  }

  # if there's white space, single quote the entire word.  however,
  # since single quotes can't be escaped inside single quotes,
  # isolate them from the single quoted part and escape them.
  # i.e., the string a 'b turns into 'a '\''b' 
  elsif ( $str =~ /\s/ )
  {
    # isolate the lone single quotes
    $str =~ s/'/'\\''/g;

    # quote the whole string
    $str = "'$str'";

    # remove obvious duplicate quotes.
    $str =~ s/(^|[^\\])''/$1/g;
  }

  # otherwise, quote all of the non-word characters
  else
  {
    $str =~  s/(\W)/\\$1/go;
  }

  $str;
}


sub import_envs
{
    my ( $self, %iopt ) = @_;

    my %opt = ( Exclude    => [],
		ZapDeleted => 1,
	      );

    my @unknown = grep { !exists $opt{$_} } keys %iopt;
    croak( __PACKAGE__, "->import_envs: unknown options: @unknown\n" )
      if @unknown;

    %opt = ( %opt, %iopt );
    my $env = $self->envs( %opt );

    # store new values
    while( my ( $key, $val ) = each %$env )
    {
	$ENV{$key} = $val;
    }


    # remove deleted ones, if requested
    if ( $opt{ZapDeleted} )
    {
	delete @ENV{grep { exists $ENV{$_} && ! exists $self->{envs}{$_} }
		      keys %ENV };
    }
}


1;
__END__