File Coverage

blib/lib/Mnet/T.pm
Criterion Covered Total %
statement 48 63 76.1
branch 18 32 56.2
condition 2 9 22.2
subroutine 6 6 100.0
pod 0 1 0.0
total 74 111 66.6


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 30     30   328340 use warnings;
  30         242  
  30         1067  
7 30     30   207 use strict;
  30         51  
  30         587  
8 30     30   146 use Carp;
  30         62  
  30         2617  
9 30     30   19241 use Test::More;
  30         1979896  
  30         258  
10              
11              
12              
13             sub test_perl {
14              
15             # $result = Mnet::T::test_perl(\%specs)
16             # purpose: test w/pre/perl/post/filter/expect/debug, for mnet .t scripts
17             # \%specs: input test specification hash reference, see below
18             # $result: true if test passed
19             #
20             # $specs {
21             # name => $test_name, # test name used in Test::More::is call
22             # pre => $sh_code, # shell code to execute before perl code
23             # perl => $perl_code, # perl code piped to perl interpretor
24             # args => $perl_args, # passed to perl code
25             # post => $sh_code', # shell code to execute after perl code
26             # filter => $sh_command, # shell code perl output is piped through
27             # expect => $text, # match with filtered output for pass/fail
28             # debug => $debug_args, # perl args to re-run test after failure
29             # }
30             #
31             # note that leading spaces are removed lines of text stored in exect key
32             # note that debug re-run exports MNET_TEST_PERL_DEBUG=1, even if null
33             #
34             # use Mnet::T qw( test_perl );
35             # test_perl({
36             # name => 'test',
37             # perl => <<' perl-eof',
38             # use warnings;
39             # use strict;
40             # use Mnet::Log;
41             # use Mnet::Log::Test;
42             # syswrite STDOUT, "extra\n";
43             # syswrite STDOUT, "stdout\n";
44             # perl-eof
45             # filter => <<' filter-eof'
46             # grep -v Mnet::Opts::Cli \
47             # | grep -v extra
48             # filter-eof
49             # expect => <<' expect-eof',
50             # --- - Mnet::Log - started
51             # stdout
52             # --- - Mnet::Log finished with no errors
53             # expect-eof
54             # debug => '--debug',
55             # });
56             #
57             # troubleshoot a single test with: INIT { our $mnet_test_perl = $name_re }
58              
59             # read input specs
60 148     148 0 17852 my $specs = shift;
61              
62             # note test name and caller info
63 148         735 my $name = $specs->{name};
64 148         986 my @caller = caller();
65              
66             # skip if global mnet_test_perl var is set and test doesn't match
67             # makes it easy to troubleshoot one test in a .t script full of tests
68 148 50 33     1080 if ($main::mnet_test_perl and $name !~ /\Q$main::mnet_test_perl\E/) {
69 0         0 SKIP: { skip("$name (main::mnet_test_perl)", 1); };
  0         0  
70 0         0 return 1;
71             }
72              
73             # check for requried input keys
74 148         926 foreach my $key (qw/ name perl expect /) {
75 444 50       1490 croak("missing $key key") if not defined $specs->{$key};
76             }
77              
78             # prepare command for test
79 148         1463 my $command = _test_perl_command($specs);
80              
81             # append filter to test command, if one was specified
82             # remove leading and trailing blank lines before shell piping
83 148 100       745 if ($specs->{filter}) {
84 81         1434 $specs->{filter} =~ s/(^\s+|\s+$)//mg;
85 81         511 $command .= "| $specs->{filter}";
86             }
87              
88             # trim expect text, allows for indents
89             # remove leading spaces on each line, to allow for indents when calling
90             # also remove leading/trailing blank lines
91 148         1426 $specs->{expect} =~ s/^\s+//mg;
92 148         2805 $specs->{expect} =~ s/(^\n+|\n+$)//g;
93              
94             # get output from command, remove leading/trailing blank lines
95 148         62476831 ( my $output = `$command` ) =~ s/(^\n+|\n+$)//g;
96              
97             # compare command output to expected output
98             # added leading cr makes for cleaner Test::More::is output
99 148         12937 my $result = Test::More::is( "\n$output", "\n$specs->{expect}", $name);
100              
101             # re-run test with debug args if test failed and debug key was set
102 148 50       140451 if (not $result) {
103 0 0 0     0 if ($specs->{debug} or $specs->{filter}) {
104 0         0 my $output = "\npre/perl/post debug for failed '$name'\n";
105 0         0 $output .= " called from $caller[1] line $caller[2]\n\n";
106 0         0 my $command = _test_perl_command($specs, "debug");
107 0         0 $output .= "COMMAND STARTING\n$command\nCOMMAND FINISHED\n";
108 0         0 $output .= "UNFILTERED OUTPUT STARTING";
109 0         0 $output .= `( export MNET_TEST_PERL_DEBUG=1; $command ) 2>&1`;
110 0         0 $output .= "UNFILTERED OUTPUT FINISHED\n";
111             $output .= "FILTER STARTING\n$specs->{filter}\nFILTER FINISHED\n"
112 0 0       0 if $specs->{filter};
113 0         0 syswrite STDERR, "## $_\n" foreach split(/\n/, $output);
114 0         0 syswrite STDERR, "##\n";
115             } else {
116 0         0 syswrite STDERR, "## called from $caller[1] line $caller[2]\n\n";
117             }
118             }
119              
120             # finished test_perl function, return result
121 148         4251 return $result;
122             }
123              
124              
125              
126             sub _test_perl_command {
127              
128             # $command = _test_perl_command(\%specs, $debug)
129             # purpose: prepare pre, perl, and post test command string
130             # \%specs: hash ref of test specifications, refer to test_perl function
131             # $debug: optional debug arguments, set when test needs to be re-run after fail
132             # $command: output command string ready to run with Test::More::is
133              
134             # read input specs hash ref and debug flag
135 148     148   741 my ($specs, $debug) = (shift, shift);
136              
137             # init output command
138 148         374 my $command = undef;
139              
140             # append pre shell code, if specified
141 148 100       731 if ($specs->{pre}) {
142 43         1888 $specs->{pre} =~ s/(^\s+|\s+$)//g;
143 43 50       292 $command .= "echo 'PRE STARTING';" if $debug;
144 43         328 $command .= "$specs->{pre};";
145 43 50       299 $command .= "echo 'PRE FINISHED'; echo;" if $debug;
146             }
147              
148             # append perl shell code, if specified
149 148 50       1157 croak("missing perl key") if not $specs->{perl};
150 148         1165 ( my $perl = $specs->{perl} ) =~ s/'/'"'"'/g;
151 148         1007 $command .= "echo '$perl' | $^X - ";
152 148 100       859 $command .= $specs->{args} if defined $specs->{args};
153 148 50 33     839 $command .= " " . $specs->{debug} if $debug and defined $specs->{debug};
154 148         606 $command .= ";";
155              
156             # append post shell code, if specified
157 148 100       820 if ($specs->{post}) {
158 20         185 $specs->{post} =~ s/(^\s+|\s+$)//g;
159 20 50       74 $command .= "echo; echo 'POST STARTING';" if $debug;
160 20         87 $command .= "$specs->{post};";
161 20 50       116 $command .= "echo 'POST FINISHED';" if $debug;
162             }
163              
164             # use subshell and redirection to capture all command output
165 148 50       1294 $command = "( echo; $command ) 2>&1" if $command;
166              
167             # finished _test_per_command, return command
168 148         831 return $command;
169             }
170              
171              
172              
173             # normal end of package
174             1;
175