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