File Coverage

blib/lib/Test2/Tools/Command.pm

Criterion	Covered	Total	%
statement	89	89	100.0
branch	39	40	97.5
condition	18	22	81.8
subroutine	11	11	100.0
pod	1	1	100.0
total	158	163	96.9

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

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

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

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} };

    # what to run, and possibly also a string to include in the test name
    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;
        }
        # this may be bad if the utility produces too much output
        $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 it into a number like the shell does)
    my $status = {
        code   => $? >> 8,
        signal => $? & 127,
        iscore => $? & 128 ? 1 : 0
    };
    # the munge are for when the code or signal vary (for portability or
    # for reasons out of your control) and you only want to know if the
    # value was 0 or not. lots of CPAN Tester systems did not set the
    # iscore flag following a CORE::dump by a test program...
    $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, $name, $result ) = ( context(), $_[0]->{name} // "@cmd", 1 );

    if (    $_[0]->{status}{code} == $status->{code}
        and $_[0]->{status}{signal} == $status->{signal}
        and $_[0]->{status}{iscore} == $status->{iscore} ) {
        $ctx->pass("exit - $name");
    } else {
        $ctx->fail(
            "exit - $name",
            sprintf(
                "code\t%d\tsignal\t%d\tiscore\t%d want",
                $_[0]->{status}{code},
                $_[0]->{status}{signal},
                $_[0]->{status}{iscore}
            ),
            sprintf(
                "code\t%d\tsignal\t%d\tiscore\t%d got",
                $status->{code}, $status->{signal}, $status->{iscore}
            )
        );
        $result = 0;
    }
    # qr// or assume it's a string
    if ( defined $_[0]->{stdout} and ref $_[0]->{stdout} eq 'Regexp' ) {
        if ( $stdout =~ m/$_[0]->{stdout}/ ) {
            $ctx->pass("stdout - $name");
        } else {
            $ctx->fail( "stdout - $name", "expected match on $_[0]->{stdout}" );
            $result = 0;
        }
    } else {
        my $want = $_[0]->{stdout} // '';
        if ( $stdout eq $want ) {
            $ctx->pass("stdout - $name");
        } else {
            $ctx->fail( "stdout - $name", "expected equality with q{$want}" );
            $result = 0;
        }
    }
    if ( defined $_[0]->{stderr} and ref $_[0]->{stderr} eq 'Regexp' ) {
        if ( $stderr =~ m/$_[0]->{stderr}/ ) {
            $ctx->pass("stderr - $name");
        } else {
            $ctx->fail( "stderr - $name", "expected match on $_[0]->{stderr}" );
            $result = 0;
        }
    } else {
        my $want = $_[0]->{stderr} // '';
        if ( $stderr eq $want ) {
            $ctx->pass("stderr - $name");
        } else {
            $ctx->fail( "stderr - $name", "expected equality with q{$want}" );
            $result = 0;
        }
    }
    $ctx->release;
    return $result, $orig_status, \$stdout, \$stderr;
}

1;
__END__