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         1188     my $command = $self->_command();
334 58         1921     my $switches = $self->_switches($file);
335              
336 58 50 33     1848     $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
337 58         648     my $line = "$command $switches $file";
338              
339 58         779     return $line;
340             }
341              
342              
343             =for private $strap->_command()
344            
345             Returns the command that runs the test. Combine this with C<_switches()>
346             to build a command line.
347            
348             Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}>
349             to use a different Perl than what you're running the harness under.
350             This might be to run a threaded Perl, for example.
351            
352             You can also overload this method if you've built your own strap subclass,
353             such as a PHP interpreter for a PHP-based strap.
354            
355             =cut
356              
357             sub _command {
358 116     116   1225     my $self = shift;
359              
360 116 50       2872     return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
361 116 50 33     1282     return qq["$^X"] if $self->{_is_win32} && ($^X =~ /[^\w\.\/\\]/);
362 116         2257     return $^X;
363             }
364              
365              
366             =for private $strap->_switches( $file )
367            
368             Formats and returns the switches necessary to run the test.
369            
370             =cut
371              
372             sub _switches {
373 58     58   1910     my($self, $file) = @_;
374              
375 58         835     my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
376 58         555     my @derived_switches;
377              
378 58         800     local *TEST;
379 58 50       7215     open(TEST, $file) or print "can't open $file. $!\n";
380 58         975979     my $shebang = <TEST>;
381 58 50       6491     close(TEST) or print "can't close $file. $!\n";
382              
383 58         4023     my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
384 58 50       624     push( @derived_switches, "-$1" ) if $taint;
385              
386             # When taint mode is on, PERL5LIB is ignored. So we need to put
387             # all that on the command line as -Is.
388             # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
389 58 50 33     2300     if ( $taint || $self->{_is_macos} ) {
390 0         0 my @inc = $self->_filtered_INC;
391 0         0 push @derived_switches, map { "-I$_" } @inc;
  0         0  
392                 }
393              
394             # Quote the argument if there's any whitespace in it, or if
395             # we're VMS, since VMS requires all parms quoted. Also, don't quote
396             # it if it's already quoted.
397 58         3067     for ( @derived_switches ) {
398 0 0 0     0 $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
      0        
399                 }
400 58         3453     return join( " ", @existing_switches, @derived_switches );
401             }
402              
403             =for private $strap->_cleaned_switches( @switches_from_user )
404            
405             Returns only defined, non-blank, trimmed switches from the parms passed.
406            
407             =cut
408              
409             sub _cleaned_switches {
410 58     58   649     my $self = shift;
411              
412 58         564     local $_;
413              
414 58         486     my @switches;
415 58         766     for ( @_ ) {
416 116         1102 my $switch = $_;
417 116 100       3792 next unless defined $switch;
418 58         2512 $switch =~ s/^\s+//;
419 58         876 $switch =~ s/\s+$//;
420 58 50       1650 push( @switches, $switch ) if $switch ne "";
421                 }
422              
423 58         814     return @switches;
424             }
425              
426             =for private $strap->_INC2PERL5LIB
427            
428             local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
429            
430             Takes the current value of C<@INC> and turns it into something suitable
431             for putting onto C<PERL5LIB>.
432            
433             =cut
434              
435             sub _INC2PERL5LIB {
436 58     58   534     my($self) = shift;
437              
438 58         593     $self->{_old5lib} = $ENV{PERL5LIB};
439              
440 58         6354     return join $Config{path_sep}, $self->_filtered_INC;
441             }
442              
443             =for private $strap->_filtered_INC()
444            
445             my @filtered_inc = $self->_filtered_INC;
446            
447             Shortens C<@INC> by removing redundant and unnecessary entries.
448             Necessary for OSes with limited command line lengths, like VMS.
449            
450             =cut
451              
452             sub _filtered_INC {
453 58     58   10289     my($self, @inc) = @_;
454 58 50       4038     @inc = @INC unless @inc;
455              
456 58 50       970     if( $self->{_is_vms} ) {
    50          
457             # VMS has a 255-byte limit on the length of %ENV entries, so
458             # toss the ones that involve perl_root, the install location
459 0         0         @inc = grep !/perl_root/i, @inc;
460              
461                 }
462                 elsif ( $self->{_is_win32} ) {
463             # Lose any trailing backslashes in the Win32 paths
464 0         0 s/[\\\/+]$// foreach @inc;
  0         0  
465                 }
466              
467 58         466     my %seen;
468 58         1981     $seen{$_}++ foreach $self->_default_inc();
  58         831  
469 58         19973     @inc = grep !$seen{$_}++, @inc;
470              
471 58         4842     return @inc;
472             }
473              
474              
475             { # Without caching, _default_inc() takes a huge amount of time
476                 my %cache;
477                 sub _default_inc {
478 58     58   2142         my $self = shift;
479 58         1820         my $perl = $self->_command;
480 58   100     1809         $cache{$perl} ||= [do {
481 1         53             local $ENV{PERL5LIB};
482 1         5289673             my @inc =`$perl -le "print join qq[\\n], \@INC"`;
483 1         404             chomp @inc;
484                     }];
485 58         593         return @{$cache{$perl}};
  58         4901  
486                 }
487             }
488              
489              
490             =for private $strap->_restore_PERL5LIB()
491            
492             $self->_restore_PERL5LIB;
493            
494             This restores the original value of the C<PERL5LIB> environment variable.
495             Necessary on VMS, otherwise a no-op.
496            
497             =cut
498              
499             sub _restore_PERL5LIB {
500 59     59   706     my($self) = shift;
501              
502 59 50       2947     return unless $self->{_is_vms};
503              
504 0 0       0     if (defined $self->{_old5lib}) {
505 0         0         $ENV{PERL5LIB} = $self->{_old5lib};
506                 }
507             }
508              
509             =head1 Parsing
510            
511             Methods for identifying what sort of line you're looking at.
512            
513             =for private _is_diagnostic
514            
515             my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
516            
517             Checks if the given line is a comment. If so, it will place it into
518             C<$comment> (sans #).
519            
520             =cut
521              
522             sub _is_diagnostic {
523 0     0   0     my($self, $line, $comment) = @_;
524              
525 0 0       0     if( $line =~ /^\s*\#(.*)/ ) {
526 0         0         $$comment = $1;
527 0         0         return $YES;
528                 }
529                 else {
530 0         0         return $NO;
531                 }
532             }
533              
534             =for private _is_header
535            
536             my $is_header = $strap->_is_header($line);
537            
538             Checks if the given line is a header (1..M) line. If so, it places how
539             many tests there will be in C<< $strap->{max} >>, a list of which tests
540             are todo in C<< $strap->{todo} >> and if the whole test was skipped
541             C<< $strap->{skip_all} >> contains the reason.
542            
543             =cut
544              
545             # Regex for parsing a header. Will be run with /x
546             my $Extra_Header_Re = <<'REGEX';
547             ^
548             (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
549             (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
550             REGEX
551              
552             sub _is_header {
553 36950     36950   885154     my($self, $line) = @_;
554              
555 36950 100       869210     if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
556 58         912         $self->{max} = $max;
557 58         4746         assert( $self->{max} >= 0, 'Max # of tests looks right' );
558              
559 58 50       592         if( defined $extra ) {
560 58         5774             my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
561              
562 58 50       586             $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
  0         0  
563              
564 58 50       709             if( $self->{max} == 0 ) {
565 0 0 0     0                 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
566                         }
567              
568 58         932             $self->{skip_all} = $reason;
569                     }
570              
571 58         971         return $YES;
572                 }
573                 else {
574 36892         1084261         return $NO;
575                 }
576             }
577              
578             =for private _is_bail_out
579            
580             my $is_bail_out = $strap->_is_bail_out($line, \$reason);
581            
582             Checks if the line is a "Bail out!". Places the reason for bailing
583             (if any) in $reason.
584            
585             =cut
586              
587             sub _is_bail_out {
588 36892     36892   769841     my($self, $line, $reason) = @_;
589              
590 36892 50       1175075     if( $line =~ /^Bail out!\s*(.*)/i ) {
591 0 0       0         $$reason = $1 if $1;
592 0         0         return $YES;
593                 }
594                 else {
595 36892         838541         return $NO;
596                 }
597             }
598              
599             =for private _reset_file_state
600            
601             $strap->_reset_file_state;
602            
603             Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
604             etc. so it's ready to parse the next file.
605            
606             =cut
607              
608             sub _reset_file_state {
609 58     58   578     my($self) = shift;
610              
611 58         510     delete @{$self}{qw(max skip_all todo too_many_tests)};
  58         34676  
612 58         610     $self->{line} = 0;
613 58         497     $self->{saw_header} = 0;
614 58         637     $self->{saw_bailout}= 0;
615 58         596     $self->{lone_not_line} = 0;
616 58         3332     $self->{bailout_reason} = '';
617 58         1008     $self->{'next'} = 1;
618             }
619              
620             =head1 Results
621            
622             The C<%results> returned from C<analyze()> contain the following
623             information:
624            
625             passing true if the whole test is considered a pass
626             (or skipped), false if its a failure
627            
628             exit the exit code of the test run, if from a file
629             wait the wait code of the test run, if from a file
630            
631             max total tests which should have been run
632             seen total tests actually seen
633             skip_all if the whole test was skipped, this will
634             contain the reason.
635            
636             ok number of tests which passed
637             (including todo and skips)
638            
639             todo number of todo tests seen
640             bonus number of todo tests which
641             unexpectedly passed
642            
643             skip number of tests skipped
644            
645             So a successful test should have max == seen == ok.
646            
647            
648             There is one final item, the details.
649            
650             details an array ref reporting the result of
651             each test looks like this:
652            
653             $results{details}[$test_num - 1] =
654             { ok => is the test considered ok?
655             actual_ok => did it literally say 'ok'?
656             name => name of the test (if any)
657             diagnostics => test diagnostics (if any)
658             type => 'skip' or 'todo' (if any)
659             reason => reason for the above (if any)
660             };
661            
662             Element 0 of the details is test #1. I tried it with element 1 being
663             #1 and 0 being empty, this is less awkward.
664            
665             =head1 EXAMPLES
666            
667             See F<examples/mini_harness.plx> for an example of use.
668            
669             =head1 AUTHOR
670            
671             Michael G Schwern C<< <schwern at pobox.com> >>, currently maintained by
672             Andy Lester C<< <andy at petdance.com> >>.
673            
674             =head1 SEE ALSO
675            
676             L<Test::Harness>
677            
678             =cut
679              
680             sub _def_or_blank {
681 151002 100   151002   5512552     return $_[0] if defined $_[0];
682 147216         7473828     return "";
683             }
684              
685             1;
686