File Coverage

support/Test/Harness/Straps.pm
Criterion Covered Total %
statement 168 210 80.0
branch 50 100 50.0
condition 16 51 31.4
subroutine 26 28 92.9
pod 3 4 75.0
total 263 393 66.9


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; cperl-indent-level: 4 -*-
2             package Test::Harness::Straps;
3              
4 1     1   16 use strict;
  1         9  
  1         4110  
5 1     1   1505 use vars qw($VERSION);
  1         18  
  1         17  
6             $VERSION = '0.26';
7              
8 1     1   15 use Config;
  1         9  
  1         87  
9 1     1   34 use Test::Harness::Assert;
  1         10  
  1         21  
10 1     1   37 use Test::Harness::Iterator;
  1         11  
  1         19  
11 1     1   36 use Test::Harness::Point;
  1         10  
  1         23  
12              
13             # Flags used as return values from our methods. Just for internal
14             # clarification.
15             my $YES = (1==1);
16             my $NO = !$YES;
17              
18             =head1 NAME
19            
20             Test::Harness::Straps - detailed analysis of test results
21            
22             =head1 SYNOPSIS
23            
24             use Test::Harness::Straps;
25            
26             my $strap = Test::Harness::Straps->new;
27            
28             # Various ways to interpret a test
29             my %results = $strap->analyze($name, \@test_output);
30             my %results = $strap->analyze_fh($name, $test_filehandle);
31             my %results = $strap->analyze_file($test_file);
32            
33             # UNIMPLEMENTED
34             my %total = $strap->total_results;
35            
36             # Altering the behavior of the strap UNIMPLEMENTED
37             my $verbose_output = $strap->dump_verbose();
38             $strap->dump_verbose_fh($output_filehandle);
39            
40            
41             =head1 DESCRIPTION
42            
43             B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
44             in incompatible ways. It is otherwise stable.
45            
46             Test::Harness is limited to printing out its results. This makes
47             analysis of the test results difficult for anything but a human. To
48             make it easier for programs to work with test results, we provide
49             Test::Harness::Straps. Instead of printing the results, straps
50             provide them as raw data. You can also configure how the tests are to
51             be run.
52            
53             The interface is currently incomplete. I<Please> contact the author
54             if you'd like a feature added or something change or just have
55             comments.
56            
57             =head1 CONSTRUCTION
58            
59             =head2 new()
60            
61             my $strap = Test::Harness::Straps->new;
62            
63             Initialize a new strap.
64            
65             =cut
66              
67             sub new {
68 1     1 1 11     my $class = shift;
69 1         12     my $self = bless {}, $class;
70              
71 1         12     $self->_init;
72              
73 1         11     return $self;
74             }
75              
76             =for private $strap->_init
77            
78             $strap->_init;
79            
80             Initialize the internal state of a strap to make it ready for parsing.
81            
82             =cut
83              
84             sub _init {
85 1     1   10     my($self) = shift;
86              
87 1         15     $self->{_is_vms} = ( $^O eq 'VMS' );
88 1         15     $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
89 1         15     $self->{_is_macos} = ( $^O eq 'MacOS' );
90             }
91              
92             =head1 ANALYSIS
93            
94             =head2 $strap->analyze( $name, \@output_lines )
95            
96             my %results = $strap->analyze($name, \@test_output);
97            
98             Analyzes the output of a single test, assigning it the given C<$name>
99             for use in the total report. Returns the C<%results> of the test.
100             See L<Results>.
101            
102             C<@test_output> should be the raw output from the test, including
103             newlines.
104            
105             =cut
106              
107             sub analyze {
108 0     0 1 0     my($self, $name, $test_output) = @_;
109              
110 0         0     my $it = Test::Harness::Iterator->new($test_output);
111 0         0     return $self->_analyze_iterator($name, $it);
112             }
113              
114              
115             sub _analyze_iterator {
116 58     58   1671     my($self, $name, $it) = @_;
117              
118 58         14171     $self->_reset_file_state;
119 58         1582     $self->{file} = $name;
120 58         5516     my %totals = (
121                                max => 0,
122                                seen => 0,
123              
124                                ok => 0,
125                                todo => 0,
126                                skip => 0,
127                                bonus => 0,
128              
129                                details => []
130                               );
131              
132             # Set them up here so callbacks can have them.
133 58         3775     $self->{totals}{$name} = \%totals;
134 58         5266     while( defined(my $line = $it->next) ) {
135 87284         2264894         $self->_analyze_line($line, \%totals);
136 87284 50       3213463         last if $self->{saw_bailout};
137                 }
138              
139 58 50       1338     $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
140              
141 58   33     8949     my $passed = ($totals{max} == 0 && defined $totals{skip_all}) ||
      33        
      33        
      33        
      33        
142                              ($totals{max} && $totals{seen} &&
143                               $totals{max} == $totals{seen} &&
144                               $totals{max} == $totals{ok});
145 58 50       2448     $totals{passing} = $passed ? 1 : 0;
146              
147 58         12974     return %totals;
148             }
149              
150              
151             sub _analyze_line {
152 87284     87284   1558794     my $self = shift;
153 87284         3187160     my $line = shift;
154 87284         1888805     my $totals = shift;
155              
156 87284         2127332     $self->{line}++;
157              
158 87284         1418215     my $linetype;
159 87284         2756669     my $point = Test::Harness::Point->from_test_line( $line );
160 87284 100       2066115     if ( $point ) {
    50          
    100          
    50          
    50          
161 50334         1170293         $linetype = 'test';
162              
163 50334         1283105         $totals->{seen}++;
164 50334 50       6802319         $point->set_number( $self->{'next'} ) unless $point->number;
165              
166             # sometimes the 'not ' and the 'ok' are on different lines,
167             # happens often on VMS if you do:
168             # print "not " unless $test;
169             # print "ok $num\n";
170 50334 50 33     1991445         if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) {
171 0         0             $point->set_ok( 0 );
172                     }
173              
174 50334 50       1872482         if ( $self->{todo}{$point->number} ) {
175 0         0             $point->set_directive_type( 'todo' );
176                     }
177              
178 50334 50       1905046         if ( $point->is_todo ) {
    100          
179 0         0             $totals->{todo}++;
180 0 0       0             $totals->{bonus}++ if $point->ok;
181                     }
182                     elsif ( $point->is_skip ) {
183 556         6160             $totals->{skip}++;
184                     }
185              
186 50334 50       1469357         $totals->{ok}++ if $point->pass;
187              
188 50334 50 0     2036761         if ( ($point->number > 100_000) && ($point->number > ($self->{max}||100_000)) ) {
      33        
189 0 0       0             if ( !$self->{too_many_tests}++ ) {
190 0         0                 warn "Enormous test number seen [test ", $point->number, "]\n";
191 0         0                 warn "Can't detailize, too big.\n";
192                         }
193                     }
194                     else {
195 50334         2211907             my $details = {
196                             ok => $point->pass,
197                             actual_ok => $point->ok,
198                             name => _def_or_blank( $point->description ),
199                             type => _def_or_blank( $point->directive_type ),
200                             reason => _def_or_blank( $point->directive_reason ),
201                         };
202              
203 50334   33     2840460             assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) );
204 50334         1359360             $totals->{details}[$point->number - 1] = $details;
205                     }
206                 } # test point
207                 elsif ( $line =~ /^not\s+$/ ) {
208 0         0         $linetype = 'other';
209             # Sometimes the "not " and "ok" will be on separate lines on VMS.
210             # We catch this and remember we saw it.
211 0         0         $self->{lone_not_line} = $self->{line};
212                 }
213                 elsif ( $self->_is_header($line) ) {
214 58         544         $linetype = 'header';
215              
216 58         11044         $self->{saw_header}++;
217              
218 58         650         $totals->{max} += $self->{max};
219                 }
220                 elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
221 0         0         $linetype = 'bailout';
222 0         0         $self->{saw_bailout} = 1;
223                 }
224                 elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) {
225 36892         522896         $linetype = 'other';
226 36892         602687         my $test = $totals->{details}[-1];
227 36892   100     1470718         $test->{diagnostics} ||= '';
228 36892         981032         $test->{diagnostics} .= $diagnostics;
229                 }
230                 else {
231 0         0         $linetype = 'other';
232                 }
233              
234 87284 50       5458468     $self->{callback}->($self, $line, $linetype, $totals) if $self->{callback};
235              
236 87284 100       4001054     $self->{'next'} = $point->number + 1 if $point;
237             } # _analyze_line
238              
239              
240             sub _is_diagnostic_line {
241 36892     36892   549578     my ($self, $line) = @_;
242 36892 50       737672     return if index( $line, '# Looks like you failed' ) == 0;
243 36892         595360     $line =~ s/^#\s//;
244 36892         594245     return $line;
245             }
246              
247             =for private $strap->analyze_fh( $name, $test_filehandle )
248            
249             my %results = $strap->analyze_fh($name, $test_filehandle);
250            
251             Like C<analyze>, but it reads from the given filehandle.
252            
253             =cut
254              
255             sub analyze_fh {
256 58     58 0 4301     my($self, $name, $fh) = @_;
257              
258 58         35089     my $it = Test::Harness::Iterator->new($fh);
259 58         13603     return $self->_analyze_iterator($name, $it);
260             }
261              
262             =head2 $strap->analyze_file( $test_file )
263            
264             my %results = $strap->analyze_file($test_file);
265            
266             Like C<analyze>, but it runs the given C<$test_file> and parses its
267             results. It will also use that name for the total report.
268            
269             =cut
270              
271             sub analyze_file {
272 58     58 1 5555     my($self, $file) = @_;
273              
274 58 50       6367     unless( -e $file ) {
275 0         0         $self->{error} = "$file does not exist";
276 0         0         return;
277                 }
278              
279 58 50       1022     unless( -r $file ) {
280 0         0         $self->{error} = "$file is not readable";
281 0         0         return;
282                 }
283              
284 58         2487     local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
285 58 50       1229     if ( $Test::Harness::Debug ) {
286 0         0         local $^W=0; # ignore undef warnings
287 0         0         print "# PERL5LIB=$ENV{PERL5LIB}\n";
288                 }
289              
290             # *sigh* this breaks under taint, but open -| is unportable.
291 58         1911     my $line = $self->_command_line($file);
292              
293 58 50       3208118     unless ( open(FILE, "$line|" )) {
294 0         0         print "can't run $file. $!\n";
295 0         0         return;
296                 }
297              
298 58         22061     my %results = $self->analyze_fh($file, \*FILE);
299 58         8993     my $exit = close FILE;
300 58         15452     $results{'wait'} = $?;
301 58 50 33     893     if( $? && $self->{_is_vms} ) {
302 0         0         eval q{use vmsish "status"; $results{'exit'} = $?};
303                 }
304                 else {
305 58         2052         $results{'exit'} = _wait2exit($?);
306                 }
307 58 50       4921     $results{passing} = 0 unless $? == 0;
308              
309 58         5026     $self->_restore_PERL5LIB();
310              
311 58         11783     return %results;
312             }
313              
314              
315             eval { require POSIX; &POSIX::WEXITSTATUS(0) };
316             if( $@ ) {
317                 *_wait2exit = sub { $_[0] >> 8 };
318             }
319             else {
320 58     58   8145     *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
321             }
322              
323             =for private $strap->_command_line( $file )
324            
325             Returns the full command line that will be run to test I<$file>.
326            
327             =cut
328              
329             sub _command_line {
330 58     58   663     my $self = shift;
331 58         1530     my $file = shift;
332              
333 58   </