File Coverage

blib/lib/Shell.pm

Criterion	Covered	Total	%
statement	58	64	90.6
branch	16	24	66.6
condition	7	11	63.6
subroutine	12	13	92.3
pod	0	1	0.0
total	93	113	82.3

package Shell;
use 5.006_001;
use strict;
use warnings;
use File::Spec::Functions;

our($capture_stderr, $raw, $VERSION, $AUTOLOAD);

$VERSION = '0.72_01';
$VERSION = eval $VERSION;

sub new { bless \my $foo, shift }
sub DESTROY { }

sub import {
    my $self = shift;
    my ($callpack, $callfile, $callline) = caller;
    my @EXPORT;
    if (@_) {
        @EXPORT = @_;
    } else {
        @EXPORT = 'AUTOLOAD';
    }
    foreach my $sym (@EXPORT) {
        no strict 'refs';
        *{"${callpack}::$sym"} = \&{"Shell::$sym"};
    }
}

# NOTE: this is used to enable constant folding in
# expressions like (OS eq 'MSWin32') and
# (OS eq 'os2') just like it happened in  0.6  version
# which used eval "string" to install subs on the fly.
use constant OS => $^O;

=begin private

=item B<_make_cmd>

  $sub = _make_cmd($cmd);
  $sub = $shell->_make_cmd($cmd);

Creates a closure which invokes the system command C<$cmd>.

=end private

=cut

sub _make_cmd {
    shift if ref $_[0] && $_[0]->isa( 'Shell' );
    my $cmd = shift;
    my $null = File::Spec::Functions::devnull();
    $Shell::capture_stderr ||= 0;
    # closing over $^O, $cmd, and $null
    return sub {
            shift if ref $_[0] && $_[0]->isa( 'Shell' );
            if (@_ < 1) {
                $Shell::capture_stderr ==  1 ? `$cmd 2>&1` :
                $Shell::capture_stderr == -1 ? `$cmd 2>$null` :
                `$cmd`;
            } elsif (OS eq 'os2') {
                local(*SAVEOUT, *READ, *WRITE);

                open SAVEOUT, '>&STDOUT' or die;
                pipe READ, WRITE or die;
                open STDOUT, '>&WRITE' or die;
                close WRITE;

                my $pid = system(1, $cmd, @_);
                die "Can't execute $cmd: $!\n" if $pid < 0;

                open STDOUT, '>&SAVEOUT' or die;
                close SAVEOUT;

                if (wantarray) {
                    my @ret = ;
                    close READ;
                    waitpid $pid, 0;
                    @ret;
                } else {
                    local($/) = undef;
                    my $ret = ;
                    close READ;
                    waitpid $pid, 0;
                    $ret;
                }
            } else {
                my $a;
                my @arr = @_;
                unless( $Shell::raw ){
                  if (OS eq 'MSWin32') {
                    # XXX this special-casing should not be needed
                    # if we do quoting right on Windows. :-(
                    #
                    # First, escape all quotes.  Cover the case where we
                    # want to pass along a quote preceded by a backslash
                    # (i.e., C<"param \""" end">).
                    # Ugly, yup?  You know, windoze.
                    # Enclose in quotes only the parameters that need it:
                    #   try this: c:> dir "/w"
                    #   and this: c:> dir /w
                    for (@arr) {
                        s/"/\\"/g;
                        s/\\\\"/\\\\"""/g;
                        $_ = qq["$_"] if /\s/;
                    }
                  } else {
                    for (@arr) {
                        s/(['\\])/\\$1/g;
                        $_ = $_;
                     }
                  }
                }
                push @arr, '2>&1'        if $Shell::capture_stderr ==  1;
                push @arr, '2>$null' if $Shell::capture_stderr == -1;
                open(SUBPROC, join(' ', $cmd, @arr, '|'))
                    or die "Can't exec $cmd: $!\n";
                if (wantarray) {
                    my @ret = ;
                    close SUBPROC;        # XXX Oughta use a destructor.
                    @ret;
                } else {
                    local($/) = undef;
                    my $ret = ;
                    close SUBPROC;
                    $ret;
                }
            }
        };
        }

sub AUTOLOAD {
    shift if ref $_[0] && $_[0]->isa( 'Shell' );
    my $cmd = $AUTOLOAD;
    $cmd =~ s/^.*:://;
    no strict 'refs';
    *$AUTOLOAD = _make_cmd($cmd);
    goto &$AUTOLOAD;
}

1;

__END__