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 =for private $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 =for private $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 =for private $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 =for private $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 qq["$^X"]            if $self->{_is_win32} && ($^X =~ /[^\w\.\/\\]/);
 362     return $^X;
 363 }
 364
 365
 366 =for private $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 =for private $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 =for private $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 =for private $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 { # Without caching, _default_inc() takes a huge amount of time
 476     my %cache;
 477     sub _default_inc {
 478         my $self = shift;
 479         my $perl = $self->_command;
 480         $cache{$perl} ||= [do {
 481             local $ENV{PERL5LIB};
 482             my @inc =`$perl -le "print join qq[\\n], \@INC"`;
 483             chomp @inc;
 484         }];
 485         return @{$cache{$perl}};
 486     }
 487 }
 488
 489
 490 =for private $strap->_restore_PERL5LIB()
 491
 492   $self->_restore_PERL5LIB;
 493
 494 This restores the original value of the C<PERL5LIB> environment variable.
 495 Necessary on VMS, otherwise a no-op.
 496
 497 =cut
 498
 499 sub _restore_PERL5LIB {
 500     my($self) = shift;
 501
 502     return unless $self->{_is_vms};
 503
 504     if (defined $self->{_old5lib}) {
 505         $ENV{PERL5LIB} = $self->{_old5lib};
 506     }
 507 }
 508
 509 =head1 Parsing
 510
 511 Methods for identifying what sort of line you're looking at.
 512
 513 =for private _is_diagnostic
 514
 515     my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
 516
 517 Checks if the given line is a comment.  If so, it will place it into
 518 C<$comment> (sans #).
 519
 520 =cut
 521
 522 sub _is_diagnostic {
 523     my($self, $line, $comment) = @_;
 524
 525     if( $line =~ /^\s*\#(.*)/ ) {
 526         $$comment = $1;
 527         return $YES;
 528     }
 529     else {
 530         return $NO;
 531     }
 532 }
 533
 534 =for private _is_header
 535
 536   my $is_header = $strap->_is_header($line);
 537
 538 Checks if the given line is a header (1..M) line.  If so, it places how
 539 many tests there will be in C<< $strap->{max} >>, a list of which tests
 540 are todo in C<< $strap->{todo} >> and if the whole test was skipped
 541 C<< $strap->{skip_all} >> contains the reason.
 542
 543 =cut
 544
 545 # Regex for parsing a header.  Will be run with /x
 546 my $Extra_Header_Re = <<'REGEX';
 547                        ^
 548                         (?: \s+ todo \s+ ([\d \t]+) )?      # optional todo set
 549                         (?: \s* \# \s* ([\w:]+\s?) (.*) )?     # optional skip with optional reason
 550 REGEX
 551
 552 sub _is_header {
 553     my($self, $line) = @_;
 554
 555     if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
 556         $self->{max}  = $max;
 557         assert( $self->{max} >= 0,  'Max # of tests looks right' );
 558
 559         if( defined $extra ) {
 560             my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
 561
 562             $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
 563
 564             if( $self->{max} == 0 ) {
 565                 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
 566             }
 567
 568             $self->{skip_all} = $reason;
 569         }
 570
 571         return $YES;
 572     }
 573     else {
 574         return $NO;
 575     }
 576 }
 577
 578 =for private _is_bail_out
 579
 580   my $is_bail_out = $strap->_is_bail_out($line, \$reason);
 581
 582 Checks if the line is a "Bail out!".  Places the reason for bailing
 583 (if any) in $reason.
 584
 585 =cut
 586
 587 sub _is_bail_out {
 588     my($self, $line, $reason) = @_;
 589
 590     if( $line =~ /^Bail out!\s*(.*)/i ) {
 591         $$reason = $1 if $1;
 592         return $YES;
 593     }
 594     else {
 595         return $NO;
 596     }
 597 }
 598
 599 =for private _reset_file_state
 600
 601   $strap->_reset_file_state;
 602
 603 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
 604 etc. so it's ready to parse the next file.
 605
 606 =cut
 607
 608 sub _reset_file_state {
 609     my($self) = shift;
 610
 611     delete @{$self}{qw(max skip_all todo too_many_tests)};
 612     $self->{line}       = 0;
 613     $self->{saw_header} = 0;
 614     $self->{saw_bailout}= 0;
 615     $self->{lone_not_line} = 0;
 616     $self->{bailout_reason} = '';
 617     $self->{'next'}       = 1;
 618 }
 619
 620 =head1 Results
 621
 622 The C<%results> returned from C<analyze()> contain the following
 623 information:
 624
 625   passing           true if the whole test is considered a pass
 626                     (or skipped), false if its a failure
 627
 628   exit              the exit code of the test run, if from a file
 629   wait              the wait code of the test run, if from a file
 630
 631   max               total tests which should have been run
 632   seen              total tests actually seen
 633   skip_all          if the whole test was skipped, this will
 634                       contain the reason.
 635
 636   ok                number of tests which passed
 637                       (including todo and skips)
 638
 639   todo              number of todo tests seen
 640   bonus             number of todo tests which
 641                       unexpectedly passed
 642
 643   skip              number of tests skipped
 644
 645 So a successful test should have max == seen == ok.
 646
 647
 648 There is one final item, the details.
 649
 650   details           an array ref reporting the result of
 651                     each test looks like this:
 652
 653     $results{details}[$test_num - 1] =
 654             { ok          => is the test considered ok?
 655               actual_ok   => did it literally say 'ok'?
 656               name        => name of the test (if any)
 657               diagnostics => test diagnostics (if any)
 658               type        => 'skip' or 'todo' (if any)
 659               reason      => reason for the above (if any)
 660             };
 661
 662 Element 0 of the details is test #1.  I tried it with element 1 being
 663 #1 and 0 being empty, this is less awkward.
 664
 665 =head1 EXAMPLES
 666
 667 See F<examples/mini_harness.plx> for an example of use.
 668
 669 =head1 AUTHOR
 670
 671 Michael G Schwern C<< <schwern at pobox.com> >>, currently maintained by
 672 Andy Lester C<< <andy at petdance.com> >>.
 673
 674 =head1 SEE ALSO
 675
 676 L<Test::Harness>
 677
 678 =cut
 679
 680 sub _def_or_blank {
 681     return $_[0] if defined $_[0];
 682     return "";
 683 }
 684
 685 1;