File Coverage

blib/lib/Shell/GetEnv.pm

Criterion	Covered	Total	%
statement	153	165	92.7
branch	43	72	59.7
condition	4	15	26.6
subroutine	18	18	100.0
pod	4	4	100.0
total	222	274	81.0

# --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 .
#
# -->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.10';

my $status_var = 'p5_SHELL_GETENV_STATUS';

# a compendium of shells
my %shells = (
    bash => {
        interactive => 'i',
        nostartup   => '--noprofile',
        verbose     => 'v',
        echo        => 'x',
        login       => 'l',
        save_status => qq[export $status_var=\$?],
    },

    zsh => {
        interactive => 'i',
        nostartup   => 'p',
        verbose     => 'v',
        echo        => 'x',
        login       => 'l',
        save_status => qq[export $status_var=\$?],
    },

    dash => {
        interactive => 'i',
        verbose     => 'v',
        echo        => 'x',
        login       => 'l',
        save_status => qq[export $status_var=\$?],
    },

    sh => {
        interactive => 'i',
        verbose     => 'v',
        echo        => 'x',
        login       => 'l',
        save_status => qq[$status_var=\$?; export $status_var],
    },

    ksh => {
        interactive => 'i',
        nostartup   => 'p',
        verbose     => 'v',
        echo        => 'x',
        login       => 'l',
        save_status => qq[export $status_var=\$?],
    },

    csh => {
        interactive => 'i',
        nostartup   => 'f',
        echo        => 'x',
        verbose     => 'v',
        login       => 'l',
        save_status => qq[setenv $status_var \$status],
    },

    tcsh => {
        interactive => 'i',
        nostartup   => 'f',
        echo        => 'x',
        verbose     => 'v',
        login       => 'l',
        save_status => qq[setenv $status_var \$status],
    },
);


my %Opts = (
    startup     => 1,
    login       => 0,
    debug       => 0,
    echo        => 0,
    login       => 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 : {} };

    # now want lc, but keep backwards compat
    $opt{lc $_} = delete $opt{$_} for keys %opt;

    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}},
      $shells{$self->{shell}}{save_status},
      $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 login )
	    ;

    my @shellopts
      = defined $self->{shellopts}
      ? 'ARRAY' eq ref( $self->{shellopts} )
          ? @{ $self->{shellopts} }
          : $self->{shellopts}
      : ();

    ## use critic

    croak( "cannot combine 'login' with any other options for $self->{shell}\n" )
	  if ( $self->{shell} eq 'csh' or $self->{shell} eq 'tcsh' )
	      && $self->{login}
	      && @options + @shellopts > 1;

    # 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,
			 @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 );
    $self->{status} = delete $self->{envs}{$status_var};
}

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

    my %opt = ( diffsonly  => 0,
		exclude    => [],
		envstr     => 0,
		zapdeleted => 0,
	      );

    # now want lc, but keep backwards compat
    $iopt{lc $_} = delete $iopt{$_} for keys %iopt;

    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 status { $_[0]->{status} }

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__