74ddaa57ba625f69a3c6fef5e0c53070260b5464
[perl.git] / lib / Test / Harness / Straps.pm
1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
2 package Test::Harness::Straps;
3
4 use strict;
5 use vars qw($VERSION);
6 $VERSION = '0.23';
7
8 use Config;
9 use Test::Harness::Assert;
10 use Test::Harness::Iterator;
11 use Test::Harness::Point;
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     my $class = shift;
69     my $self  = bless {}, $class;
70
71     $self->_init;
72
73     return $self;
74 }
75
76 =head2 $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     my($self) = shift;
86
87     $self->{_is_vms}   = ( $^O eq 'VMS' );
88     $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
89     $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     my($self, $name, $test_output) = @_;
109
110     my $it = Test::Harness::Iterator->new($test_output);
111     return $self->_analyze_iterator($name, $it);
112 }
113
114
115 sub _analyze_iterator {
116     my($self, $name, $it) = @_;
117
118     $self->_reset_file_state;
119     $self->{file} = $name;
120     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     $self->{totals}{$name}         = \%totals;
134     while( defined(my $line = $it->next) ) {
135         $self->_analyze_line($line, \%totals);
136         last if $self->{saw_bailout};
137     }
138
139     $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
140
141     my $passed = ($totals{max} == 0 && defined $totals{skip_all}) ||
142                  ($totals{max} && $totals{seen} &&
143                   $totals{max} == $totals{seen} && 
144                   $totals{max} == $totals{ok});
145     $totals{passing} = $passed ? 1 : 0;
146
147     return %totals;
148 }
149
150
151 sub _analyze_line {
152     my $self = shift;
153     my $line = shift;
154     my $totals = shift;
155
156     $self->{line}++;
157
158     my $linetype;
159     my $point = Test::Harness::Point->from_test_line( $line );
160     if ( $point ) {
161         $linetype = 'test';
162
163         $totals->{seen}++;
164         $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         if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) {
171             $point->set_ok( 0 );
172         }
173
174         if ( $self->{todo}{$point->number} ) {
175             $point->set_directive_type( 'todo' );
176         }
177
178         if ( $point->is_todo ) {
179             $totals->{todo}++;
180             $totals->{bonus}++ if $point->ok;
181         }
182         elsif ( $point->is_skip ) {
183             $totals->{skip}++;
184         }
185
186         $totals->{ok}++ if $point->pass;
187
188         if ( ($point->number > 100000) && ($point->number > $self->{max}) ) {
189             warn "Enormous test number seen [test ", $point->number, "]\n";
190             warn "Can't detailize, too big.\n";
191         }
192         else {
193             my $details = {
194                 ok          => $point->pass,
195                 actual_ok   => $point->ok,
196                 name        => _def_or_blank( $point->description ),
197                 type        => _def_or_blank( $point->directive_type ),
198                 reason      => _def_or_blank( $point->directive_reason ),
199             };
200
201             assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) );
202             $totals->{details}[$point->number - 1] = $details;
203         }
204     } # test point
205     elsif ( $line =~ /^not\s+$/ ) {
206         $linetype = 'other';
207         # Sometimes the "not " and "ok" will be on separate lines on VMS.
208         # We catch this and remember we saw it.
209         $self->{lone_not_line} = $self->{line};
210     }
211     elsif ( $self->_is_header($line) ) {
212         $linetype = 'header';
213
214         $self->{saw_header}++;
215
216         $totals->{max} += $self->{max};
217     }
218     elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
219         $linetype = 'bailout';
220         $self->{saw_bailout} = 1;
221     }
222     elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) {
223         $linetype = 'other';
224         my $test = $totals->{details}[-1];
225         $test->{diagnostics} ||=  '';
226         $test->{diagnostics}  .= $diagnostics;
227     }
228     else {
229         $linetype = 'other';
230     }
231
232     $self->{callback}->($self, $line, $linetype, $totals) if $self->{callback};
233
234     $self->{'next'} = $point->number + 1 if $point;
235 } # _analyze_line
236
237
238 sub _is_diagnostic_line {
239     my ($self, $line) = @_;
240     return if index( $line, '# Looks like you failed' ) == 0;
241     $line =~ s/^#\s//;
242     return $line;
243 }
244
245 =head2 $strap->analyze_fh( $name, $test_filehandle )
246
247     my %results = $strap->analyze_fh($name, $test_filehandle);
248
249 Like C<analyze>, but it reads from the given filehandle.
250
251 =cut
252
253 sub analyze_fh {
254     my($self, $name, $fh) = @_;
255
256     my $it = Test::Harness::Iterator->new($fh);
257     return $self->_analyze_iterator($name, $it);
258 }
259
260 =head2 $strap->analyze_file( $test_file )
261
262     my %results = $strap->analyze_file($test_file);
263
264 Like C<analyze>, but it runs the given C<$test_file> and parses its
265 results.  It will also use that name for the total report.
266
267 =cut
268
269 sub analyze_file {
270     my($self, $file) = @_;
271
272     unless( -e $file ) {
273         $self->{error} = "$file does not exist";
274         return;
275     }
276
277     unless( -r $file ) {
278         $self->{error} = "$file is not readable";
279         return;
280     }
281
282     local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
283     if ( $Test::Harness::Debug ) {
284         local $^W=0; # ignore undef warnings
285         print "# PERL5LIB=$ENV{PERL5LIB}\n";
286     }
287
288     # *sigh* this breaks under taint, but open -| is unportable.
289     my $line = $self->_command_line($file);
290
291     unless ( open(FILE, "$line|" )) {
292         print "can't run $file. $!\n";
293         return;
294     }
295
296     my %results = $self->analyze_fh($file, \*FILE);
297     my $exit    = close FILE;
298     $results{'wait'} = $?;
299     if( $? && $self->{_is_vms} ) {
300         eval q{use vmsish "status"; $results{'exit'} = $?};
301     }
302     else {
303         $results{'exit'} = _wait2exit($?);
304     }
305     $results{passing} = 0 unless $? == 0;
306
307     $self->_restore_PERL5LIB();
308
309     return %results;
310 }
311
312
313 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
314 if( $@ ) {
315     *_wait2exit = sub { $_[0] >> 8 };
316 }
317 else {
318     *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
319 }
320
321 =head2 $strap->_command_line( $file )
322
323 Returns the full command line that will be run to test I<$file>.
324
325 =cut
326
327 sub _command_line {
328     my $self = shift;
329     my $file = shift;
330
331     my $command =  $self->_command();
332     my $switches = $self->_switches($file);
333
334     $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
335     my $line = "$command $switches $file";
336
337     return $line;
338 }
339
340
341 =head2 $strap->_command()
342
343 Returns the command that runs the test.  Combine this with C<_switches()>
344 to build a command line.
345
346 Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}>
347 to use a different Perl than what you're running the harness under.
348 This might be to run a threaded Perl, for example.
349
350 You can also overload this method if you've built your own strap subclass,
351 such as a PHP interpreter for a PHP-based strap.
352
353 =cut
354
355 sub _command {
356     my $self = shift;
357
358     return $ENV{HARNESS_PERL}           if defined $ENV{HARNESS_PERL};
359     return "MCR $^X"                    if $self->{_is_vms};
360     return Win32::GetShortPathName($^X) if $self->{_is_win32};
361     return $^X;
362 }
363
364
365 =head2 $strap->_switches( $file )
366
367 Formats and returns the switches necessary to run the test.
368
369 =cut
370
371 sub _switches {
372     my($self, $file) = @_;
373
374     my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
375     my @derived_switches;
376
377     local *TEST;
378     open(TEST, $file) or print "can't open $file. $!\n";
379     my $shebang = <TEST>;
380     close(TEST) or print "can't close $file. $!\n";
381
382     my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
383     push( @derived_switches, "-$1" ) if $taint;
384
385     # When taint mode is on, PERL5LIB is ignored.  So we need to put
386     # all that on the command line as -Is.
387     # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
388     if ( $taint || $self->{_is_macos} ) {
389         my @inc = $self->_filtered_INC;
390         push @derived_switches, map { "-I$_" } @inc;
391     }
392
393     # Quote the argument if there's any whitespace in it, or if
394     # we're VMS, since VMS requires all parms quoted.  Also, don't quote
395     # it if it's already quoted.
396     for ( @derived_switches ) {
397         $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
398     }
399     return join( " ", @existing_switches, @derived_switches );
400 }
401
402 =head2 $strap->_cleaned_switches( @switches_from_user )
403
404 Returns only defined, non-blank, trimmed switches from the parms passed.
405
406 =cut
407
408 sub _cleaned_switches {
409     my $self = shift;
410
411     local $_;
412
413     my @switches;
414     for ( @_ ) {
415         my $switch = $_;
416         next unless defined $switch;
417         $switch =~ s/^\s+//;
418         $switch =~ s/\s+$//;
419         push( @switches, $switch ) if $switch ne "";
420     }
421
422     return @switches;
423 }
424
425 =head2 $strap->_INC2PERL5LIB
426
427   local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
428
429 Takes the current value of C<@INC> and turns it into something suitable
430 for putting onto C<PERL5LIB>.
431
432 =cut
433
434 sub _INC2PERL5LIB {
435     my($self) = shift;
436
437     $self->{_old5lib} = $ENV{PERL5LIB};
438
439     return join $Config{path_sep}, $self->_filtered_INC;
440 }
441
442 =head2 $strap->_filtered_INC()
443
444   my @filtered_inc = $self->_filtered_INC;
445
446 Shortens C<@INC> by removing redundant and unnecessary entries.
447 Necessary for OSes with limited command line lengths, like VMS.
448
449 =cut
450
451 sub _filtered_INC {
452     my($self, @inc) = @_;
453     @inc = @INC unless @inc;
454
455     if( $self->{_is_vms} ) {
456         # VMS has a 255-byte limit on the length of %ENV entries, so
457         # toss the ones that involve perl_root, the install location
458         @inc = grep !/perl_root/i, @inc;
459
460     }
461     elsif ( $self->{_is_win32} ) {
462         # Lose any trailing backslashes in the Win32 paths
463         s/[\\\/+]$// foreach @inc;
464     }
465
466     my %seen;
467     $seen{$_}++ foreach $self->_default_inc();
468     @inc = grep !$seen{$_}++, @inc;
469
470     return @inc;
471 }
472
473
474 sub _default_inc {
475     my $self = shift;
476
477     local $ENV{PERL5LIB};
478     my $perl = $self->_command;
479     my @inc =`$perl -le "print join qq[\\n], \@INC"`;
480     chomp @inc;
481     return @inc;
482 }
483
484
485 =head2 $strap->_restore_PERL5LIB()
486
487   $self->_restore_PERL5LIB;
488
489 This restores the original value of the C<PERL5LIB> environment variable.
490 Necessary on VMS, otherwise a no-op.
491
492 =cut
493
494 sub _restore_PERL5LIB {
495     my($self) = shift;
496
497     return unless $self->{_is_vms};
498
499     if (defined $self->{_old5lib}) {
500         $ENV{PERL5LIB} = $self->{_old5lib};
501     }
502 }
503
504 =head1 Parsing
505
506 Methods for identifying what sort of line you're looking at.
507
508 =head2 C<_is_diagnostic>
509
510     my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
511
512 Checks if the given line is a comment.  If so, it will place it into
513 C<$comment> (sans #).
514
515 =cut
516
517 sub _is_diagnostic {
518     my($self, $line, $comment) = @_;
519
520     if( $line =~ /^\s*\#(.*)/ ) {
521         $$comment = $1;
522         return $YES;
523     }
524     else {
525         return $NO;
526     }
527 }
528
529 =head2 C<_is_header>
530
531   my $is_header = $strap->_is_header($line);
532
533 Checks if the given line is a header (1..M) line.  If so, it places how
534 many tests there will be in C<< $strap->{max} >>, a list of which tests
535 are todo in C<< $strap->{todo} >> and if the whole test was skipped
536 C<< $strap->{skip_all} >> contains the reason.
537
538 =cut
539
540 # Regex for parsing a header.  Will be run with /x
541 my $Extra_Header_Re = <<'REGEX';
542                        ^
543                         (?: \s+ todo \s+ ([\d \t]+) )?      # optional todo set
544                         (?: \s* \# \s* ([\w:]+\s?) (.*) )?     # optional skip with optional reason
545 REGEX
546
547 sub _is_header {
548     my($self, $line) = @_;
549
550     if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
551         $self->{max}  = $max;
552         assert( $self->{max} >= 0,  'Max # of tests looks right' );
553
554         if( defined $extra ) {
555             my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
556
557             $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
558
559             if( $self->{max} == 0 ) {
560                 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
561             }
562
563             $self->{skip_all} = $reason;
564         }
565
566         return $YES;
567     }
568     else {
569         return $NO;
570     }
571 }
572
573 =head2 C<_is_bail_out>
574
575   my $is_bail_out = $strap->_is_bail_out($line, \$reason);
576
577 Checks if the line is a "Bail out!".  Places the reason for bailing
578 (if any) in $reason.
579
580 =cut
581
582 sub _is_bail_out {
583     my($self, $line, $reason) = @_;
584
585     if( $line =~ /^Bail out!\s*(.*)/i ) {
586         $$reason = $1 if $1;
587         return $YES;
588     }
589     else {
590         return $NO;
591     }
592 }
593
594 =head2 C<_reset_file_state>
595
596   $strap->_reset_file_state;
597
598 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
599 etc. so it's ready to parse the next file.
600
601 =cut
602
603 sub _reset_file_state {
604     my($self) = shift;
605
606     delete @{$self}{qw(max skip_all todo)};
607     $self->{line}       = 0;
608     $self->{saw_header} = 0;
609     $self->{saw_bailout}= 0;
610     $self->{lone_not_line} = 0;
611     $self->{bailout_reason} = '';
612     $self->{'next'}       = 1;
613 }
614
615 =head1 Results
616
617 The C<%results> returned from C<analyze()> contain the following
618 information:
619
620   passing           true if the whole test is considered a pass 
621                     (or skipped), false if its a failure
622
623   exit              the exit code of the test run, if from a file
624   wait              the wait code of the test run, if from a file
625
626   max               total tests which should have been run
627   seen              total tests actually seen
628   skip_all          if the whole test was skipped, this will 
629                       contain the reason.
630
631   ok                number of tests which passed 
632                       (including todo and skips)
633
634   todo              number of todo tests seen
635   bonus             number of todo tests which 
636                       unexpectedly passed
637
638   skip              number of tests skipped
639
640 So a successful test should have max == seen == ok.
641
642
643 There is one final item, the details.
644
645   details           an array ref reporting the result of 
646                     each test looks like this:
647
648     $results{details}[$test_num - 1] = 
649             { ok          => is the test considered ok?
650               actual_ok   => did it literally say 'ok'?
651               name        => name of the test (if any)
652               diagnostics => test diagnostics (if any)
653               type        => 'skip' or 'todo' (if any)
654               reason      => reason for the above (if any)
655             };
656
657 Element 0 of the details is test #1.  I tried it with element 1 being
658 #1 and 0 being empty, this is less awkward.
659
660 =head1 EXAMPLES
661
662 See F<examples/mini_harness.plx> for an example of use.
663
664 =head1 AUTHOR
665
666 Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
667 Andy Lester C<< <andy@petdance.com> >>.
668
669 =head1 SEE ALSO
670
671 L<Test::Harness>
672
673 =cut
674
675 sub _def_or_blank {
676     return $_[0] if defined $_[0];
677     return "";
678 }
679
680 1;