File Coverage

blib/lib/PerlX/bash.pm

Criterion	Covered	Total	%
statement	103	103	100.0
branch	67	70	95.7
condition	13	15	86.6
subroutine	18	18	100.0
pod	4	4	100.0
total	205	210	97.6

package PerlX::bash;

use strict;
use warnings;

use Exporter 'import';
our @EXPORT = ('bash');
our @EXPORT_OK = (@EXPORT, qw< shq pwd head tail >);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

our $VERSION = '0.04_02'; # TRIAL VERSION


use Carp;
use Contextual::Return;
use List::Util 1.33 qw< min max any >;
use Scalar::Util qw< blessed >;
use IPC::System::Simple qw< run capture EXIT_ANY $EXITVAL >;

my $BASH_SPECIAL_CHARS = qr/[ \$'"\\#\[\]!<>|;{}()~]/;
my $BASH_REDIRECTION   = qr/^\d[<>].+/;



my @AUTOQUOTE =
(
	sub {	ref shift eq 'Regexp'						},
	sub {	blessed $_[0] and $_[0]->can('basename')	},
);

sub _should_quote ()
{
	my $arg = $_;
	local $_;
	return 1 if any { $_->($arg) } @AUTOQUOTE;
	return 0 if $arg =~ /^$BASH_SPECIAL_CHARS/;
	return 0 if $arg =~ $BASH_REDIRECTION;
	return 1 if $arg =~ $BASH_SPECIAL_CHARS;
	return 0;
}

sub _process_bash_arg ()
{
	# incoming arg is in $_
	my $arg = $_;				# make a copy
	croak("Use of uninitialized argument to bash") unless defined $arg;
	$arg = shq($arg) if _should_quote;
	return $arg;
}



sub bash (@)
{
	my (@opts, $capture);
	my $exit_codes = [0..125];

	my $dash_c_cmd;
	while ( $_[0] and ($_[0] =~ /^-/ or ref $_[0]) )
	{
		my $arg = shift;
		if (ref $arg)
		{
			croak("bash: multiple capture specifications") if $capture;
			$capture = $$arg;
		}
		elsif ($arg eq '-c')
		{
			$dash_c_cmd = shift;
			croak("Missing argument for bash -c") unless length($dash_c_cmd);
		}
		elsif ($arg eq '-e')
		{
			$exit_codes = [0];
		}
		else
		{
			push @opts, $arg;
		}
	}
	if (defined $dash_c_cmd)
	{
		croak("Too many arguments for bash -c") if @_;
	}
	else
	{
		croak("Not enough arguments for bash") unless @_;
		$dash_c_cmd = shift if @_ == 1 and $_[0] and $_[0] =~ /\s/;
	}

	my $filter;
	$filter = pop if ref $_[-1] eq 'CODE';
	croak("bash: multiple output redirects") if $capture and $filter;

	my @cmd = 'bash';
	push @cmd, @opts;
	push @cmd, '-c';

	my $bash_cmd = $dash_c_cmd ? $dash_c_cmd : join(' ', map { _process_bash_arg } @_);
	push @cmd, $bash_cmd;

	if ($capture)
	{
		my $IFS = $ENV{IFS};
		$IFS = " \t\n" unless defined $IFS;

		my $output = capture $exit_codes, qw< bash -c >, $bash_cmd;
		if ($capture eq 'string')
		{
			chomp $output;
			return $output;
		}
		elsif ($capture eq 'lines')
		{
			my @lines = split("\n", $output);
			return wantarray ? @lines : $lines[0];
		}
		elsif ($capture eq 'words')
		{
			my @words = split(/[$IFS]+/, $output);
			return wantarray ? @words : $words[0];
		}
		else
		{
			die("bash: unrecognized capture specification [$capture]");
		}
	}
	elsif ($filter)
	{
		$cmd[-1] =~ s/\s*(?
		$cmd[-1] .= ' 2>&1' if $1;

		# This is pretty much straight out of `man perlipc`.
		local *CHILD;
		my $pid = open(CHILD, "-|");
		defined($pid) or die("bash: can't fork [$!]");

		if ($pid)				# parent
		{
			local $_;
			while ()
			{
				chomp;
				$filter->($_);
			}
			unless (close(CHILD))
			{
				# You know how IPC::System::Simple says that `_process_child_error` is not intended
				# to be called directly?  Yeah, well, the alternatives are worse ...
				IPC::System::Simple::_process_child_error($?, 'bash', $exit_codes);
			}
		}
		else					# child
		{
			exec(@cmd) or die("bash: can't exec program [$!]");
		}
	}
	else
	{
		run $exit_codes, @cmd;
		return
			BOOL	{	$EXITVAL == 0	}
			SCALAR	{	$EXITVAL		}
		;
	}
}


sub shq
{
	local $_ = shift;
	#$_ = "$_";					# stringify
	s/'/'\\''/g;				# handle internal single quotes
	"'$_'";						# quote with single quotes
}



use Cwd ();
*pwd = \&Cwd::cwd;



sub head
{
	my $num = shift;
	$num = $num < 0 ? @_ + $num : min($num, scalar @_);
	@_[0..$num-1];
}

sub tail
{
	my $num = shift;
	return () unless $num;
	$num = $num < 0 ? max(@_ + $num, 0) : $num - 1 ;
	@_[$num..$#_];
}


1;

# ABSTRACT: tighter integration between Perl and bash
# COPYRIGHT
#
# This module is similar to the solution presented here:
# http://stackoverflow.com/questions/571368/how-can-i-use-bash-syntax-in-perls-system

__END__