File Coverage

blib/lib/Test2/Tools/Command.pm

Criterion	Covered	Total	%
statement	79	79	100.0
branch	29	30	96.6
condition	14	28	50.0
subroutine	13	13	100.0
pod	1	1	100.0
total	136	151	90.0

# -*- Perl -*-
#
# run unix commands for expected results given particular inputs

package Test2::Tools::Command;
our $VERSION = '0.10';

use 5.10.0;
use strict;
use warnings;
use Cwd ();
use File::chdir;    # $CWD
use IPC::Open3 'open3';
use Symbol 'gensym';
use Test2::API 'context';
use Test2::Tools::Compare;

use base 'Exporter';
our @EXPORT = qw(command);

our @command;         # prefixed on each run, followed by any ->{args}
our $timeout = 30;    # seconds, for alarm()

sub command ($) {
    local $CWD = $_[0]->{chdir} if defined $_[0]->{chdir};
    local @ENV{ keys %{ $_[0]->{env} } } = values %{ $_[0]->{env} };

    my @cmd = ( @command, exists $_[0]->{args} ? @{ $_[0]->{args} } : () );

    my ( $stdout, $stderr );
    eval {
        local $SIG{ALRM} = sub { die "timeout\n" };
        alarm( $_[0]->{timeout} || $timeout );

        my $pid = open3( my $in, my $out, my $err = gensym, @cmd );
        if ( defined $_[0]->{binmode} ) {
            for my $fh ( $in, $out, $err ) { binmode $fh, $_[0]->{binmode} }
        }
        if ( exists $_[0]->{stdin} ) {
            print $in $_[0]->{stdin};
            close $in;
        }
        $stdout = do { local $/; readline $out };
        $stderr = do { local $/; readline $err };
        waitpid $pid, 0;
        alarm 0;
        1;
    } or die $@;
    my $orig_status = $?;
    # the exit status is broken out into a hashref for exact tests on
    # the various components of the 16-bit word (an alternative might be
    # to mangle the value like the shell does)
    my $status = {
        code   => $? >> 8,
        signal => $? & 127,
        iscore => $? & 128 ? 1 : 0
    };
    # the munge are for when the code or signal vary and you only want
    # to know if the value was 0 or not
    $status->{code}   = $status->{code}   ? 1 : 0 if $_[0]->{munge_status};
    $status->{signal} = $status->{signal} ? 1 : 0 if $_[0]->{munge_signal};

    # default exit status word is 0, but need it in hashref form
    if ( exists $_[0]->{status} ) {
        if ( !defined $_[0]->{status} ) {
            $_[0]->{status} = { code => 0, signal => 0, iscore => 0 };
        } elsif ( ref $_[0]->{status} eq '' ) {
            $_[0]->{status} = { code => $_[0]->{status}, signal => 0, iscore => 0 };
        }
        # assume that ->{status} is a hashref
    } else {
        $_[0]->{status} = { code => 0, signal => 0, iscore => 0 };
    }

    my $ctx    = context();
    my $name   = $_[0]->{name} // "@cmd";
    my $result = is $status, $_[0]->{status}, "exit - $name";
    # qr// or assume it's a string
    if (defined $_[0]->{stdout} and ref $_[0]->{stdout} eq 'Regexp') {
        $result ||= like $stdout, $_[0]->{stdout}, "stdout - $name";
    } else {
        $result ||= is $stdout, $_[0]->{stdout} // '', "stdout - $name";
    }
    if (defined $_[0]->{stderr} and ref $_[0]->{stderr} eq 'Regexp') {
        $result ||= like $stderr, $_[0]->{stderr}, "stderr - $name";
    } else {
        $result ||= is $stderr, $_[0]->{stderr} // '', "stderr - $name";
    }
    $ctx->release;
    return $result, $orig_status, \$stdout, \$stderr;
}

1;
__END__