File Coverage

blib/lib/Mnet/T.pm
Criterion Covered Total %
statement 54 69 78.2
branch 18 32 56.2
condition 2 9 22.2
subroutine 8 8 100.0
pod 0 1 0.0
total 82 119 68.9


line stmt bran cond sub pod time code
1             package Mnet::T;
2              
3             # purpose: functions for use in Mnet distribution .t test scripts
4              
5             # required modules
6 31     31   348560 use warnings;
  31         260  
  31         1118  
7 31     31   169 use strict;
  31         50  
  31         638  
8 31     31   262 use Carp;
  31         71  
  31         2877  
9 31     31   271 use Config;
  31         83  
  31         1655  
10 31     31   14510 use Mnet;
  31         78  
  31         921  
11 31     31   18619 use Test::More;
  31         2080964  
  31         311  
12              
13              
14              
15             sub test_perl {
16              
17             # $result = Mnet::T::test_perl(\%specs)
18             # purpose: test w/pre/perl/post/filter/expect/debug, for mnet .t scripts
19             # \%specs: input test specification hash reference, see below
20             # $result: true if test passed
21             #
22             # $specs {
23             # name => $test_name, # test name used in Test::More::is call
24             # pre => $sh_code, # shell code to execute before perl code
25             # perl => $perl_code, # perl code piped to perl interpretor
26             # args => $perl_args, # passed to perl code
27             # post => $sh_code', # shell code to execute after perl code
28             # filter => $sh_command, # shell code perl output is piped through
29             # expect => $text, # match with filtered output for pass/fail
30             # debug => $debug_args, # perl args to re-run test after failure
31             # }
32             #
33             # note that leading spaces are removed lines of text stored in exect key
34             # note that debug re-run exports MNET_TEST_PERL_DEBUG=1, even if null
35             #
36             # use Mnet::T qw( test_perl );
37             # test_perl({
38             # name => 'test',
39             # perl => <<' perl-eof',
40             # use warnings;
41             # use strict;
42             # use Mnet::Log;
43             # use Mnet::Log::Test;
44             # syswrite STDOUT, "extra\n";
45             # syswrite STDOUT, "stdout\n";
46             # perl-eof
47             # filter => <<' filter-eof'
48             # grep -v Mnet::Opts::Cli \
49             # | grep -v extra
50             # filter-eof
51             # expect => <<' expect-eof',
52             # --- - Mnet::Log - started
53             # stdout
54             # --- - Mnet::Log finished with no errors
55             # expect-eof
56             # debug => '--debug',
57             # });
58             #
59             # troubleshoot a single test with: INIT { our $mnet_test_perl = $name_re }
60              
61             #? problem on cpantesters with grep on one sparc64-openbsd system
62             # test filters with grep get error 'grep: -: No such file or directory'
63             # no sed errors, no defined aliases, both commands in /usr/bin, in $PATH
64             # grep gives this error if run with no stdin, example: `grep test -`
65             # dosn't matter if it's one grep command, or multiple, complex or simple
66             # debuged with new if-block for not $result, syswrite stderr with extra info
67             # $Config::Config{archname} code can skip, better to simple/accurate/fail
68              
69             # read input specs
70 165     165 0 17777 my $specs = shift;
71              
72             # note test name and caller info
73 165         725 my $name = $specs->{name};
74 165         973 my @caller = caller();
75              
76             # skip if global mnet_test_perl var is set and test doesn't match
77             # makes it easy to troubleshoot one test in a .t script full of tests
78 165 50 33     1026 if ($main::mnet_test_perl and $name !~ /\Q$main::mnet_test_perl\E/) {
79 0         0 SKIP: { skip("$name (main::mnet_test_perl)", 1); };
  0         0  
80 0         0 return 1;
81             }
82              
83             # check for requried input keys
84 165         793 foreach my $key (qw/ name perl expect /) {
85 495 50       1597 croak("missing $key key") if not defined $specs->{$key};
86             }
87              
88             # prepare command for test
89 165         1558 my $command = _test_perl_command($specs);
90              
91             # append filter to test command, if one was specified
92             # remove leading and trailing blank lines before shell piping
93 165 100       696 if ($specs->{filter}) {
94 83         1475 $specs->{filter} =~ s/(^\s+|\s+$)//mg;
95 83         541 $command .= "| $specs->{filter}";
96             }
97              
98             # trim expect text, allows for indents
99             # remove leading spaces on each line, to allow for indents when calling
100             # also remove leading/trailing blank lines
101 165         1261 $specs->{expect} =~ s/^\s+//mg;
102 165         2470 $specs->{expect} =~ s/(^\n+|\n+$)//g;
103              
104             # get output from command, remove leading/trailing blank lines
105 165         65911238 ( my $output = `( $command ) 2>&1` ) =~ s/(^\n+|\n+$)//g;
106              
107             # compare command output to expected output
108             # added leading cr makes for cleaner Test::More::is output
109 165         10322 my $result = Test::More::is( "\n$output", "\n$specs->{expect}", $name);
110              
111             # re-run test with debug args if test failed and debug key was set
112 165 50       135618 if (not $result) {
113 0 0 0     0 if ($specs->{debug} or $specs->{filter}) {
114 0         0 my $output = "\npre/perl/post debug for failed '$name'\n";
115 0         0 $output .= " called from $caller[1] line $caller[2]\n\n";
116 0         0 my $command = _test_perl_command($specs, "debug");
117 0         0 $output .= "COMMAND STARTING\n$command\nCOMMAND FINISHED\n";
118 0         0 $output .= "UNFILTERED OUTPUT STARTING";
119 0         0 $output .= `( export MNET_TEST_PERL_DEBUG=1; $command ) 2>&1`;
120 0         0 $output .= "UNFILTERED OUTPUT FINISHED\n";
121             $output .= "FILTER STARTING\n$specs->{filter}\nFILTER FINISHED\n"
122 0 0       0 if $specs->{filter};
123 0         0 syswrite STDERR, "## $_\n" foreach split(/\n/, $output);
124 0         0 syswrite STDERR, "##\n";
125             } else {
126 0         0 syswrite STDERR, "## called from $caller[1] line $caller[2]\n\n";
127             }
128             }
129              
130             # finished test_perl function, return result
131 165         3445 return $result;
132             }
133              
134              
135              
136             sub _test_perl_command {
137              
138             # $command = _test_perl_command(\%specs, $debug)
139             # purpose: prepare pre, perl, and post test command string
140             # \%specs: hash ref of test specifications, refer to test_perl function
141             # $debug: optional debug arguments, set when test needs to be re-run after fail
142             # $command: output command string ready to run with Test::More::is
143              
144             # read input specs hash ref and debug flag
145 165     165   1154 my ($specs, $debug) = (shift, shift);
146              
147             # init output command
148 165         443 my $command = undef;
149              
150             # append pre shell code, if specified
151 165 100       676 if ($specs->{pre}) {
152 45         1761 $specs->{pre} =~ s/(^\s+|\s+$)//g;
153 45 50       217 $command .= "echo 'PRE STARTING';" if $debug;
154 45         206 $command .= "$specs->{pre};";
155 45 50       276 $command .= "echo 'PRE FINISHED'; echo;" if $debug;
156             }
157              
158             # append perl shell code, if specified
159 165 50       1210 croak("missing perl key") if not $specs->{perl};
160 165         1115 ( my $perl = $specs->{perl} ) =~ s/'/'"'"'/g;
161 165         1200 $command .= "echo '$perl' | $^X - ";
162 165 100       884 $command .= $specs->{args} if defined $specs->{args};
163 165 50 33     846 $command .= " " . $specs->{debug} if $debug and defined $specs->{debug};
164 165         692 $command .= ";";
165              
166             # append post shell code, if specified
167 165 100       757 if ($specs->{post}) {
168 20         251 $specs->{post} =~ s/(^\s+|\s+$)//g;
169 20 50       77 $command .= "echo; echo 'POST STARTING';" if $debug;
170 20         73 $command .= "$specs->{post};";
171 20 50       75 $command .= "echo 'POST FINISHED';" if $debug;
172             }
173              
174             # use subshell and redirection to capture all command output
175 165 50       1366 $command = "( echo; $command ) 2>&1" if $command;
176              
177             # finished _test_per_command, return command
178 165         777 return $command;
179             }
180              
181              
182              
183             # normal end of package
184             1;
185