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;