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