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     } 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;