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


line stmt bran cond sub pod time code
1             # -*- Perl -*-
2             #
3             # Test::UnixCmdWrap - test unix commands with various assumptions
4              
5             package Test::UnixCmdWrap;
6              
7 2     2   182557 use 5.24.0;
  2         14  
8 2     2   11 use warnings;
  2         3  
  2         67  
9 2     2   11 use Cwd qw(getcwd);
  2         4  
  2         88  
10 2     2   23 use Carp qw(croak);
  2         5  
  2         107  
11 2     2   968 use File::Spec::Functions qw(catfile);
  2         1766  
  2         129  
12 2     2   1189 use Moo;
  2         23490  
  2         8  
13 2     2   3581 use Test::Cmd ();
  2         18500  
  2         108  
14 2     2   608 use Test::Differences qw(eq_or_diff);
  2         19532  
  2         143  
15 2     2   13 use Test::More;
  2         21  
  2         25  
16 2     2   1792 use Test::UnixExit qw(exit_is exit_is_nonzero);
  2         1437  
  2         1430  
17              
18             our $VERSION = '0.05';
19              
20             has cmd => (
21             is => 'rwp',
22             default => sub {
23             # t/foo.t -> ./foo with restrictive sanity checks on what is
24             # consided valid for a command name--"foo.sh" is not a valid
25             # command name, get rid of that dangly thing at the end, or
26             # manually supply your own Test::Cmd object. 38 characters is
27             # the longest command name I can find on my OpenBSD 6.5 system
28             if ( $0 =~ m{^t/([A-Za-z0-9_][A-Za-z0-9_-]{0,127})\.t$} ) {
29             my $file = $1;
30             return Test::Cmd->new( prog => catfile( getcwd(), $1 ), workdir => '' );
31             } else {
32             croak "could not extract command name from $0";
33             }
34             },
35             );
36             has prog => ( is => 'lazy', );
37              
38 1     1   65 sub _build_prog { $_[0]->cmd->prog }
39              
40             sub BUILD {
41 4     4 1 23705 my ( $self, $args ) = @_;
42 4 100 100     76 if ( exists $args->{cmd} and !ref $args->{cmd} ) {
43             # TODO may need to fully qualify this path depending on how that
44             # interacts with chdir (or if the caller is making any of those)
45 2         26 $self->_set_cmd( Test::Cmd->new( prog => $args->{cmd}, workdir => '' ) );
46             }
47             # TODO better way to apply Devel::Cover to only the script runs?
48 4 50       19172 if ( $ENV{DEVEL_COVER} ) {
49 0         0 diag "coverage enabled... (slow)";
50 0         0 `cover -delete`;
51 0         0 $ENV{PERL5OPT} = '-MDevel::Cover';
52             }
53             }
54              
55             sub run {
56 8     8 1 2691 my ( $self, %p ) = @_;
57              
58 8   100     107 $p{env} //= {};
59             # no news is good news. and here it is the default
60 8   100     46 $p{status} //= 0;
61 8   66     103 $p{stderr} //= qr/^$/;
62 8   66     100 $p{stdout} //= qr/^$/;
63              
64 8         43 my $cmd = $self->cmd;
65 8 100       64 my $name = $cmd->prog . ( exists $p{args} ? ' ' . $p{args} : '' );
66              
67 8         177 local @ENV{ keys $p{env}->%* } = values $p{env}->%*;
68              
69 8 100       35 $cmd->run( map { exists $p{$_} ? ( $_ => $p{$_} ) : () } qw(args chdir stdin) );
  24         115  
70              
71             # tests relative to the caller so the test failures don't point at
72             # lines of this function
73 8         119669 local $Test::Builder::Level = $Test::Builder::Level + 1;
74              
75             # probably should be paired with { status => 1 } and that the
76             # process being tested is expected to die (with some unknown
77             # status code)
78 8         70 my $status = $?;
79 8 100       91 $status = exit_is_nonzero( $status ) if $p{munge_status};
80              
81 8         256 exit_is( $status, $p{status}, "STATUS $name" );
82             # for some commands a regex suffices but for others want to compare
83             # expected lines NOTE this is sloppy about trailing whitespace which
84             # many but not all things may be forgiving of
85 8 100       9628 if ( ref $p{stdout} eq 'ARRAY' ) {
86 2         240 eq_or_diff( [ map { s/\s+$//r } split $/, $cmd->stdout ],
87 1         46 $p{stdout}, 'STDOUT ' . $name );
88             } else {
89 7 100       98 ok( $cmd->stdout =~ m/$p{stdout}/, 'STDOUT ' . $name )
90             or diag 'STDOUT ' . $cmd->stdout;
91             }
92 8 100       7106 ok( $cmd->stderr =~ m/$p{stderr}/, 'STDERR ' . $name )
93             or diag 'STDERR ' . $cmd->stderr;
94              
95             # for when the caller needs to poke at the results for something not
96             # covered by the above
97 8         5177 return $cmd;
98             }
99              
100             1;
101             __END__