This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[patch] blead@25282 - VMS specific fixes. [2nd try]
[perl5.git] / lib / Test / Harness / Straps.pm
CommitLineData
13287dd5 1# -*- Mode: cperl; cperl-indent-level: 4 -*-
13287dd5
MS
2package Test::Harness::Straps;
3
4use strict;
5use vars qw($VERSION);
c0c1f8c2 6$VERSION = '0.23';
13287dd5 7
c0c1f8c2 8use Config;
13287dd5
MS
9use Test::Harness::Assert;
10use Test::Harness::Iterator;
c0c1f8c2 11use Test::Harness::Point;
13287dd5
MS
12
13# Flags used as return values from our methods. Just for internal
14# clarification.
c0c1f8c2
RGS
15my $YES = (1==1);
16my $NO = !$YES;
13287dd5
MS
17
18=head1 NAME
19
20Test::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
43B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
44in incompatible ways. It is otherwise stable.
45
46Test::Harness is limited to printing out its results. This makes
47analysis of the test results difficult for anything but a human. To
48make it easier for programs to work with test results, we provide
49Test::Harness::Straps. Instead of printing the results, straps
50provide them as raw data. You can also configure how the tests are to
51be run.
52
53The interface is currently incomplete. I<Please> contact the author
54if you'd like a feature added or something change or just have
55comments.
56
c0c1f8c2 57=head1 CONSTRUCTION
13287dd5 58
c0c1f8c2 59=head2 new()
13287dd5
MS
60
61 my $strap = Test::Harness::Straps->new;
62
63Initialize a new strap.
64
65=cut
66
67sub new {
3c87ea76 68 my $class = shift;
c0c1f8c2 69 my $self = bless {}, $class;
13287dd5 70
13287dd5
MS
71 $self->_init;
72
73 return $self;
74}
75
c0c1f8c2 76=head2 $strap->_init
13287dd5
MS
77
78 $strap->_init;
79
80Initialize the internal state of a strap to make it ready for parsing.
81
82=cut
83
84sub _init {
85 my($self) = shift;
86
e4fc8a1e
RGS
87 $self->{_is_vms} = ( $^O eq 'VMS' );
88 $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
89 $self->{_is_macos} = ( $^O eq 'MacOS' );
13287dd5
MS
90}
91
c0c1f8c2 92=head1 ANALYSIS
13287dd5 93
3c87ea76 94=head2 $strap->analyze( $name, \@output_lines )
13287dd5 95
c0c1f8c2 96 my %results = $strap->analyze($name, \@test_output);
13287dd5 97
cf2ab31a
JH
98Analyzes the output of a single test, assigning it the given C<$name>
99for use in the total report. Returns the C<%results> of the test.
100See L<Results>.
13287dd5 101
cf2ab31a
JH
102C<@test_output> should be the raw output from the test, including
103newlines.
13287dd5
MS
104
105=cut
106
107sub 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
115sub _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,
308957f5 128
13287dd5
MS
129 details => []
130 );
131
308957f5
JH
132 # Set them up here so callbacks can have them.
133 $self->{totals}{$name} = \%totals;
13287dd5
MS
134 while( defined(my $line = $it->next) ) {
135 $self->_analyze_line($line, \%totals);
136 last if $self->{saw_bailout};
137 }
138
356733da
MS
139 $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
140
a72fde19
JH
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});
13287dd5
MS
145 $totals{passing} = $passed ? 1 : 0;
146
13287dd5
MS
147 return %totals;
148}
149
150
151sub _analyze_line {
c0c1f8c2
RGS
152 my $self = shift;
153 my $line = shift;
154 my $totals = shift;
308957f5 155
13287dd5
MS
156 $self->{line}++;
157
c0c1f8c2
RGS
158 my $linetype;
159 my $point = Test::Harness::Point->from_test_line( $line );
160 if ( $point ) {
161 $linetype = 'test';
13287dd5
MS
162
163 $totals->{seen}++;
c0c1f8c2 164 $point->set_number( $self->{'next'} ) unless $point->number;
13287dd5
MS
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";
c0c1f8c2
RGS
170 if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) {
171 $point->set_ok( 0 );
13287dd5
MS
172 }
173
c0c1f8c2
RGS
174 if ( $self->{todo}{$point->number} ) {
175 $point->set_directive_type( 'todo' );
176 }
13287dd5 177
c0c1f8c2 178 if ( $point->is_todo ) {
13287dd5 179 $totals->{todo}++;
c0c1f8c2 180 $totals->{bonus}++ if $point->ok;
13287dd5 181 }
c0c1f8c2 182 elsif ( $point->is_skip ) {
13287dd5 183 $totals->{skip}++;
13287dd5
MS
184 }
185
c0c1f8c2 186 $totals->{ok}++ if $point->pass;
13287dd5 187
c0c1f8c2
RGS
188 if ( ($point->number > 100000) && ($point->number > $self->{max}) ) {
189 warn "Enormous test number seen [test ", $point->number, "]\n";
356733da
MS
190 warn "Can't detailize, too big.\n";
191 }
192 else {
3c87ea76 193 my $details = {
c0c1f8c2
RGS
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 ),
3c87ea76
RGS
199 };
200
201 assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) );
c0c1f8c2 202 $totals->{details}[$point->number - 1] = $details;
356733da 203 }
c0c1f8c2
RGS
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};
13287dd5 210 }
3c87ea76 211 elsif ( $self->_is_header($line) ) {
c0c1f8c2 212 $linetype = 'header';
3c87ea76
RGS
213
214 $self->{saw_header}++;
215
216 $totals->{max} += $self->{max};
217 }
13287dd5 218 elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
c0c1f8c2 219 $linetype = 'bailout';
13287dd5
MS
220 $self->{saw_bailout} = 1;
221 }
c0c1f8c2
RGS
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 }
13287dd5 228 else {
c0c1f8c2 229 $linetype = 'other';
13287dd5
MS
230 }
231
c0c1f8c2 232 $self->{callback}->($self, $line, $linetype, $totals) if $self->{callback};
13287dd5 233
c0c1f8c2
RGS
234 $self->{'next'} = $point->number + 1 if $point;
235} # _analyze_line
236
237
238sub _is_diagnostic_line {
239 my ($self, $line) = @_;
240 return if index( $line, '# Looks like you failed' ) == 0;
241 $line =~ s/^#\s//;
242 return $line;
13287dd5
MS
243}
244
c0c1f8c2 245=head2 $strap->analyze_fh( $name, $test_filehandle )
13287dd5 246
c0c1f8c2 247 my %results = $strap->analyze_fh($name, $test_filehandle);
13287dd5
MS
248
249Like C<analyze>, but it reads from the given filehandle.
250
251=cut
252
253sub analyze_fh {
254 my($self, $name, $fh) = @_;
255
256 my $it = Test::Harness::Iterator->new($fh);
3c87ea76 257 return $self->_analyze_iterator($name, $it);
13287dd5
MS
258}
259
c0c1f8c2 260=head2 $strap->analyze_file( $test_file )
13287dd5 261
c0c1f8c2 262 my %results = $strap->analyze_file($test_file);
13287dd5 263
cf2ab31a 264Like C<analyze>, but it runs the given C<$test_file> and parses its
356733da 265results. It will also use that name for the total report.
13287dd5
MS
266
267=cut
268
269sub analyze_file {
270 my($self, $file) = @_;
271
0be28027
JH
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
13287dd5 282 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
3c87ea76
RGS
283 if ( $Test::Harness::Debug ) {
284 local $^W=0; # ignore undef warnings
285 print "# PERL5LIB=$ENV{PERL5LIB}\n";
286 }
13287dd5 287
13287dd5 288 # *sigh* this breaks under taint, but open -| is unportable.
e4fc8a1e 289 my $line = $self->_command_line($file);
c0c1f8c2
RGS
290
291 unless ( open(FILE, "$line|" )) {
13287dd5
MS
292 print "can't run $file. $!\n";
293 return;
294 }
295
296 my %results = $self->analyze_fh($file, \*FILE);
c0c1f8c2 297 my $exit = close FILE;
356733da 298 $results{'wait'} = $?;
f0008e52
MS
299 if( $? && $self->{_is_vms} ) {
300 eval q{use vmsish "status"; $results{'exit'} = $?};
301 }
302 else {
6e5a998b 303 $results{'exit'} = _wait2exit($?);
f0008e52 304 }
356733da 305 $results{passing} = 0 unless $? == 0;
13287dd5
MS
306
307 $self->_restore_PERL5LIB();
308
309 return %results;
310}
311
6e5a998b
MS
312
313eval { require POSIX; &POSIX::WEXITSTATUS(0) };
314if( $@ ) {
315 *_wait2exit = sub { $_[0] >> 8 };
316}
317else {
318 *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
319}
320
c0c1f8c2 321=head2 $strap->_command_line( $file )
e4fc8a1e
RGS
322
323Returns the full command line that will be run to test I<$file>.
324
325=cut
326
327sub _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
c0c1f8c2 341=head2 $strap->_command()
e4fc8a1e 342
c0c1f8c2 343Returns the command that runs the test. Combine this with C<_switches()>
e4fc8a1e
RGS
344to build a command line.
345
c0c1f8c2 346Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}>
e4fc8a1e
RGS
347to use a different Perl than what you're running the harness under.
348This might be to run a threaded Perl, for example.
349
350You can also overload this method if you've built your own strap subclass,
351such as a PHP interpreter for a PHP-based strap.
352
353=cut
354
355sub _command {
356 my $self = shift;
357
358 return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
e4fc8a1e
RGS
359 return Win32::GetShortPathName($^X) if $self->{_is_win32};
360 return $^X;
361}
362
6e5a998b 363
c0c1f8c2 364=head2 $strap->_switches( $file )
13287dd5
MS
365
366Formats and returns the switches necessary to run the test.
367
368=cut
369
370sub _switches {
371 my($self, $file) = @_;
372
e4fc8a1e
RGS
373 my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
374 my @derived_switches;
375
13287dd5
MS
376 local *TEST;
377 open(TEST, $file) or print "can't open $file. $!\n";
e4fc8a1e
RGS
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;
11c6125c 390 }
e4fc8a1e 391
60e33a80
RGS
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.
e4fc8a1e 395 for ( @derived_switches ) {
60e33a80 396 $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
11c6125c 397 }
e4fc8a1e
RGS
398 return join( " ", @existing_switches, @derived_switches );
399}
13287dd5 400
c0c1f8c2 401=head2 $strap->_cleaned_switches( @switches_from_user )
13287dd5 402
e4fc8a1e
RGS
403Returns only defined, non-blank, trimmed switches from the parms passed.
404
405=cut
406
407sub _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}
13287dd5 423
c0c1f8c2 424=head2 $strap->_INC2PERL5LIB
13287dd5
MS
425
426 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
427
cf2ab31a
JH
428Takes the current value of C<@INC> and turns it into something suitable
429for putting onto C<PERL5LIB>.
13287dd5
MS
430
431=cut
432
433sub _INC2PERL5LIB {
434 my($self) = shift;
435
436 $self->{_old5lib} = $ENV{PERL5LIB};
437
27caa5c1 438 return join $Config{path_sep}, $self->_filtered_INC;
d5d4ec93 439}
13287dd5 440
c0c1f8c2 441=head2 $strap->_filtered_INC()
13287dd5
MS
442
443 my @filtered_inc = $self->_filtered_INC;
444
cf2ab31a
JH
445Shortens C<@INC> by removing redundant and unnecessary entries.
446Necessary for OSes with limited command line lengths, like VMS.
13287dd5
MS
447
448=cut
449
450sub _filtered_INC {
451 my($self, @inc) = @_;
452 @inc = @INC unless @inc;
453
13287dd5 454 if( $self->{_is_vms} ) {
e4fc8a1e
RGS
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
13287dd5 457 @inc = grep !/perl_root/i, @inc;
e4fc8a1e 458
ca09b021
RGS
459 }
460 elsif ( $self->{_is_win32} ) {
e4fc8a1e
RGS
461 # Lose any trailing backslashes in the Win32 paths
462 s/[\\\/+]$// foreach @inc;
13287dd5
MS
463 }
464
3c87ea76
RGS
465 my %seen;
466 $seen{$_}++ foreach $self->_default_inc();
467 @inc = grep !$seen{$_}++, @inc;
468
469 return @inc;
470}
471
e4fc8a1e 472
3c87ea76
RGS
473sub _default_inc {
474 my $self = shift;
475
476 local $ENV{PERL5LIB};
477 my $perl = $self->_command;
be2fd869 478 my @inc =`$perl -le "print join qq[\\n], \@INC"`;
3c87ea76 479 chomp @inc;
13287dd5
MS
480 return @inc;
481}
482
483
c0c1f8c2 484=head2 $strap->_restore_PERL5LIB()
13287dd5
MS
485
486 $self->_restore_PERL5LIB;
487
cf2ab31a 488This restores the original value of the C<PERL5LIB> environment variable.
13287dd5
MS
489Necessary on VMS, otherwise a no-op.
490
491=cut
492
493sub _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}
d5d4ec93 502
cf2ab31a 503=head1 Parsing
13287dd5
MS
504
505Methods for identifying what sort of line you're looking at.
506
c0c1f8c2 507=head2 C<_is_diagnostic>
13287dd5 508
c0c1f8c2 509 my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
13287dd5
MS
510
511Checks if the given line is a comment. If so, it will place it into
cf2ab31a 512C<$comment> (sans #).
13287dd5
MS
513
514=cut
515
c0c1f8c2 516sub _is_diagnostic {
13287dd5
MS
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
cf2ab31a 528=head2 C<_is_header>
13287dd5
MS
529
530 my $is_header = $strap->_is_header($line);
531
cf2ab31a
JH
532Checks if the given line is a header (1..M) line. If so, it places how
533many tests there will be in C<< $strap->{max} >>, a list of which tests
534are todo in C<< $strap->{todo} >> and if the whole test was skipped
535C<< $strap->{skip_all} >> contains the reason.
13287dd5
MS
536
537=cut
538
539# Regex for parsing a header. Will be run with /x
540my $Extra_Header_Re = <<'REGEX';
541 ^
542 (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
543 (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
544REGEX
545
546sub _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' );
0be28027
JH
552
553 if( defined $extra ) {
13287dd5
MS
554 my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
555
556 $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
557
a72fde19
JH
558 if( $self->{max} == 0 ) {
559 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
560 }
561
562 $self->{skip_all} = $reason;
13287dd5
MS
563 }
564
565 return $YES;
566 }
567 else {
568 return $NO;
569 }
570}
571
cf2ab31a 572=head2 C<_is_bail_out>
13287dd5
MS
573
574 my $is_bail_out = $strap->_is_bail_out($line, \$reason);
575
576Checks if the line is a "Bail out!". Places the reason for bailing
577(if any) in $reason.
578
579=cut
580
581sub _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
cf2ab31a 593=head2 C<_reset_file_state>
13287dd5
MS
594
595 $strap->_reset_file_state;
596
cf2ab31a
JH
597Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
598etc. so it's ready to parse the next file.
13287dd5
MS
599
600=cut
601
602sub _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;
13287dd5
MS
609 $self->{lone_not_line} = 0;
610 $self->{bailout_reason} = '';
611 $self->{'next'} = 1;
612}
613
cf2ab31a 614=head1 Results
13287dd5 615
cf2ab31a
JH
616The C<%results> returned from C<analyze()> contain the following
617information:
13287dd5
MS
618
619 passing true if the whole test is considered a pass
620 (or skipped), false if its a failure
621
356733da
MS
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
13287dd5
MS
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
639So a successful test should have max == seen == ok.
640
641
642There 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] =
c0c1f8c2
RGS
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)
13287dd5
MS
654 };
655
656Element 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
13287dd5
MS
659=head1 EXAMPLES
660
661See F<examples/mini_harness.plx> for an example of use.
662
663=head1 AUTHOR
664
cf2ab31a
JH
665Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
666Andy Lester C<< <andy@petdance.com> >>.
13287dd5
MS
667
668=head1 SEE ALSO
669
670L<Test::Harness>
671
672=cut
673
c0c1f8c2
RGS
674sub _def_or_blank {
675 return $_[0] if defined $_[0];
676 return "";
677}
678
13287dd5 6791;