File Coverage

blib/lib/Test/UnixCmdWrap.pm

Criterion	Covered	Total	%
statement	54	57	94.7
branch	15	16	93.7
condition	11	13	84.6
subroutine	13	13	100.0
pod	2	2	100.0
total	95	101	94.0

# -*- Perl -*-
#
# Test::UnixCmdWrap - test unix commands with various assumptions

package Test::UnixCmdWrap;

use 5.24.0;
use warnings;
use Cwd qw(getcwd);
use Carp qw(croak);
use File::Spec::Functions qw(catfile);
use Moo;
use Test::Cmd ();
use Test::Differences qw(eq_or_diff);
use Test::More;
use Test::UnixExit qw(exit_is exit_is_nonzero);

our $VERSION = '0.05';

has cmd => (
    is      => 'rwp',
    default => sub {
        # t/foo.t -> ./foo with restrictive sanity checks on what is
        # consided valid for a command name--"foo.sh" is not a valid
        # command name, get rid of that dangly thing at the end, or
        # manually supply your own Test::Cmd object. 38 characters is
        # the longest command name I can find on my OpenBSD 6.5 system
        if ( $0 =~ m{^t/([A-Za-z0-9_][A-Za-z0-9_-]{0,127})\.t$} ) {
            my $file = $1;
            return Test::Cmd->new( prog => catfile( getcwd(), $1 ), workdir => '' );
        } else {
            croak "could not extract command name from $0";
        }
    },
);
has prog => ( is => 'lazy', );

sub _build_prog { $_[0]->cmd->prog }

sub BUILD {
    my ( $self, $args ) = @_;
    if ( exists $args->{cmd} and !ref $args->{cmd} ) {
        # TODO may need to fully qualify this path depending on how that
        # interacts with chdir (or if the caller is making any of those)
        $self->_set_cmd( Test::Cmd->new( prog => $args->{cmd}, workdir => '' ) );
    }
    # TODO better way to apply Devel::Cover to only the script runs?
    if ( $ENV{DEVEL_COVER} ) {
        diag "coverage enabled... (slow)";
        `cover -delete`;
        $ENV{PERL5OPT} = '-MDevel::Cover';
    }
}

sub run {
    my ( $self, %p ) = @_;

    $p{env} //= {};
    # no news is good news. and here it is the default
    $p{status} //= 0;
    $p{stderr} //= qr/^$/;
    $p{stdout} //= qr/^$/;

    my $cmd  = $self->cmd;
    my $name = $cmd->prog . ( exists $p{args} ? ' ' . $p{args} : '' );

    local @ENV{ keys $p{env}->%* } = values $p{env}->%*;

    $cmd->run( map { exists $p{$_} ? ( $_ => $p{$_} ) : () } qw(args chdir stdin) );

    # tests relative to the caller so the test failures don't point at
    # lines of this function
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    # probably should be paired with { status => 1 } and that the
    # process being tested is expected to die (with some unknown
    # status code)
    my $status = $?;
    $status = exit_is_nonzero( $status ) if $p{munge_status};

    exit_is( $status, $p{status}, "STATUS $name" );
    # for some commands a regex suffices but for others want to compare
    # expected lines NOTE this is sloppy about trailing whitespace which
    # many but not all things may be forgiving of
    if ( ref $p{stdout} eq 'ARRAY' ) {
        eq_or_diff( [ map { s/\s+$//r } split $/, $cmd->stdout ],
            $p{stdout}, 'STDOUT ' . $name );
    } else {
        ok( $cmd->stdout =~ m/$p{stdout}/, 'STDOUT ' . $name )
          or diag 'STDOUT ' . $cmd->stdout;
    }
    ok( $cmd->stderr =~ m/$p{stderr}/, 'STDERR ' . $name )
      or diag 'STDERR ' . $cmd->stderr;

    # for when the caller needs to poke at the results for something not
    # covered by the above
    return $cmd;
}

1;
__END__