lib/Test/Harness/Straps.pm

   1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
   2 # $Id: Straps.pm,v 1.35 2003/12/31 02:34:22 andy Exp $
   3
   4 package Test::Harness::Straps;
   5
   6 use strict;
   7 use vars qw($VERSION);
   8 use Config;
   9 $VERSION = '0.19';
  10
  11 use Test::Harness::Assert;
  12 use Test::Harness::Iterator;
  13
  14 # Flags used as return values from our methods.  Just for internal
  15 # clarification.
  16 my $TRUE  = (1==1);
  17 my $FALSE = !$TRUE;
  18 my $YES   = $TRUE;
  19 my $NO    = $FALSE;
  20
  21
  22 =head1 NAME
  23
  24 Test::Harness::Straps - detailed analysis of test results
  25
  26 =head1 SYNOPSIS
  27
  28   use Test::Harness::Straps;
  29
  30   my $strap = Test::Harness::Straps->new;
  31
  32   # Various ways to interpret a test
  33   my %results = $strap->analyze($name, \@test_output);
  34   my %results = $strap->analyze_fh($name, $test_filehandle);
  35   my %results = $strap->analyze_file($test_file);
  36
  37   # UNIMPLEMENTED
  38   my %total = $strap->total_results;
  39
  40   # Altering the behavior of the strap  UNIMPLEMENTED
  41   my $verbose_output = $strap->dump_verbose();
  42   $strap->dump_verbose_fh($output_filehandle);
  43
  44
  45 =head1 DESCRIPTION
  46
  47 B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
  48 in incompatible ways.  It is otherwise stable.
  49
  50 Test::Harness is limited to printing out its results.  This makes
  51 analysis of the test results difficult for anything but a human.  To
  52 make it easier for programs to work with test results, we provide
  53 Test::Harness::Straps.  Instead of printing the results, straps
  54 provide them as raw data.  You can also configure how the tests are to
  55 be run.
  56
  57 The interface is currently incomplete.  I<Please> contact the author
  58 if you'd like a feature added or something change or just have
  59 comments.
  60
  61 =head1 Construction
  62
  63 =head2 C<new>
  64
  65   my $strap = Test::Harness::Straps->new;
  66
  67 Initialize a new strap.
  68
  69 =cut
  70
  71 sub new {
  72     my($proto) = shift;
  73     my($class) = ref $proto || $proto;
  74
  75     my $self = bless {}, $class;
  76     $self->_init;
  77
  78     return $self;
  79 }
  80
  81 =head2 C<_init>
  82
  83   $strap->_init;
  84
  85 Initialize the internal state of a strap to make it ready for parsing.
  86
  87 =cut
  88
  89 sub _init {
  90     my($self) = shift;
  91
  92     $self->{_is_vms}   = ( $^O eq 'VMS' );
  93     $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
  94     $self->{_is_macos} = ( $^O eq 'MacOS' );
  95 }
  96
  97 =head1 Analysis
  98
  99 =head2 C<analyze>
 100
 101   my %results = $strap->analyze($name, \@test_output);
 102
 103 Analyzes the output of a single test, assigning it the given C<$name>
 104 for use in the total report.  Returns the C<%results> of the test.
 105 See L<Results>.
 106
 107 C<@test_output> should be the raw output from the test, including
 108 newlines.
 109
 110 =cut
 111
 112 sub analyze {
 113     my($self, $name, $test_output) = @_;
 114
 115     my $it = Test::Harness::Iterator->new($test_output);
 116     return $self->_analyze_iterator($name, $it);
 117 }
 118
 119
 120 sub _analyze_iterator {
 121     my($self, $name, $it) = @_;
 122
 123     $self->_reset_file_state;
 124     $self->{file} = $name;
 125     my %totals  = (
 126                    max      => 0,
 127                    seen     => 0,
 128
 129                    ok       => 0,
 130                    todo     => 0,
 131                    skip     => 0,
 132                    bonus    => 0,
 133
 134                    details  => []
 135                   );
 136
 137     # Set them up here so callbacks can have them.
 138     $self->{totals}{$name}         = \%totals;
 139     while( defined(my $line = $it->next) ) {
 140         $self->_analyze_line($line, \%totals);
 141         last if $self->{saw_bailout};
 142     }
 143
 144     $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
 145
 146     my $passed = ($totals{max} == 0 && defined $totals{skip_all}) ||
 147                  ($totals{max} && $totals{seen} &&
 148                   $totals{max} == $totals{seen} &&
 149                   $totals{max} == $totals{ok});
 150     $totals{passing} = $passed ? 1 : 0;
 151
 152     return %totals;
 153 }
 154
 155
 156 sub _analyze_line {
 157     my($self, $line, $totals) = @_;
 158
 159     my %result = ();
 160
 161     $self->{line}++;
 162
 163     my $type;
 164     if( $self->_is_header($line) ) {
 165         $type = 'header';
 166
 167         $self->{saw_header}++;
 168
 169         $totals->{max} += $self->{max};
 170     }
 171     elsif( $self->_is_test($line, \%result) ) {
 172         $type = 'test';
 173
 174         $totals->{seen}++;
 175         $result{number} = $self->{'next'} unless $result{number};
 176
 177         # sometimes the 'not ' and the 'ok' are on different lines,
 178         # happens often on VMS if you do:
 179         #   print "not " unless $test;
 180         #   print "ok $num\n";
 181         if( $self->{saw_lone_not} &&
 182             ($self->{lone_not_line} == $self->{line} - 1) )
 183         {
 184             $result{ok} = 0;
 185         }
 186
 187         my $pass = $result{ok};
 188         $result{type} = 'todo' if $self->{todo}{$result{number}};
 189
 190         if( $result{type} eq 'todo' ) {
 191             $totals->{todo}++;
 192             $pass = 1;
 193             $totals->{bonus}++ if $result{ok}
 194         }
 195         elsif( $result{type} eq 'skip' ) {
 196             $totals->{skip}++;
 197             $pass = 1;
 198         }
 199
 200         $totals->{ok}++ if $pass;
 201
 202         if( $result{number} > 100000 && $result{number} > $self->{max} ) {
 203             warn "Enormous test number seen [test $result{number}]\n";
 204             warn "Can't detailize, too big.\n";
 205         }
 206         else {
 207             $totals->{details}[$result{number} - 1] =
 208                                {$self->_detailize($pass, \%result)};
 209         }
 210
 211         # XXX handle counter mismatch
 212     }
 213     elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
 214         $type = 'bailout';
 215         $self->{saw_bailout} = 1;
 216     }
 217     else {
 218         $type = 'other';
 219     }
 220
 221     $self->{callback}->($self, $line, $type, $totals) if $self->{callback};
 222
 223     $self->{'next'} = $result{number} + 1 if $type eq 'test';
 224 }
 225
 226 =head2 C<analyze_fh>
 227
 228   my %results = $strap->analyze_fh($name, $test_filehandle);
 229
 230 Like C<analyze>, but it reads from the given filehandle.
 231
 232 =cut
 233
 234 sub analyze_fh {
 235     my($self, $name, $fh) = @_;
 236
 237     my $it = Test::Harness::Iterator->new($fh);
 238     $self->_analyze_iterator($name, $it);
 239 }
 240
 241 =head2 C<analyze_file>
 242
 243   my %results = $strap->analyze_file($test_file);
 244
 245 Like C<analyze>, but it runs the given C<$test_file> and parses its
 246 results.  It will also use that name for the total report.
 247
 248 =cut
 249
 250 sub analyze_file {
 251     my($self, $file) = @_;
 252
 253     unless( -e $file ) {
 254         $self->{error} = "$file does not exist";
 255         return;
 256     }
 257
 258     unless( -r $file ) {
 259         $self->{error} = "$file is not readable";
 260         return;
 261     }
 262
 263     local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
 264
 265     # *sigh* this breaks under taint, but open -| is unportable.
 266     my $line = $self->_command_line($file);
 267     unless( open(FILE, "$line|") ) {
 268         print "can't run $file. $!\n";
 269         return;
 270     }
 271
 272     my %results = $self->analyze_fh($file, \*FILE);
 273     my $exit = close FILE;
 274     $results{'wait'} = $?;
 275     if( $? && $self->{_is_vms} ) {
 276         eval q{use vmsish "status"; $results{'exit'} = $?};
 277     }
 278     else {
 279         $results{'exit'} = _wait2exit($?);
 280     }
 281     $results{passing} = 0 unless $? == 0;
 282
 283     $self->_restore_PERL5LIB();
 284
 285     return %results;
 286 }
 287
 288
 289 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
 290 if( $@ ) {
 291     *_wait2exit = sub { $_[0] >> 8 };
 292 }
 293 else {
 294     *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
 295 }
 296
 297 =head2 C<_command_line( $file )>
 298
 299   my $command_line = $self->_command_line();
 300
 301 Returns the full command line that will be run to test I<$file>.
 302
 303 =cut
 304
 305 sub _command_line {
 306     my $self = shift;
 307     my $file = shift;
 308
 309     my $command =  $self->_command();
 310     my $switches = $self->_switches($file);
 311
 312     $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
 313     my $line = "$command $switches $file";
 314
 315     return $line;
 316 }
 317
 318
 319 =head2 C<_command>
 320
 321   my $command = $self->_command();
 322
 323 Returns the command that runs the test.  Combine this with _switches()
 324 to build a command line.
 325
 326 Typically this is C<$^X>, but you can set C<$ENV{HARNESS_COMMAND}>
 327 to use a different Perl than what you're running the harness under.
 328 This might be to run a threaded Perl, for example.
 329
 330 You can also overload this method if you've built your own strap subclass,
 331 such as a PHP interpreter for a PHP-based strap.
 332
 333 =cut
 334
 335 sub _command {
 336     my $self = shift;
 337
 338     return $ENV{HARNESS_PERL}           if defined $ENV{HARNESS_PERL};
 339     return "MCR $^X"                    if $self->{_is_vms};
 340     return Win32::GetShortPathName($^X) if $self->{_is_win32};
 341     return $^X;
 342 }
 343
 344
 345 =head2 C<_switches>
 346
 347   my $switches = $self->_switches($file);
 348
 349 Formats and returns the switches necessary to run the test.
 350
 351 =cut
 352
 353 sub _switches {
 354     my($self, $file) = @_;
 355
 356     my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
 357     my @derived_switches;
 358
 359     local *TEST;
 360     open(TEST, $file) or print "can't open $file. $!\n";
 361     my $shebang = <TEST>;
 362     close(TEST) or print "can't close $file. $!\n";
 363
 364     my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
 365     push( @derived_switches, "-$1" ) if $taint;
 366
 367     # When taint mode is on, PERL5LIB is ignored.  So we need to put
 368     # all that on the command line as -Is.
 369     # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
 370     if ( $taint || $self->{_is_macos} ) {
 371         my @inc = $self->_filtered_INC;
 372         push @derived_switches, map { "-I$_" } @inc;
 373     }
 374
 375     # Quote the argument if there's any whitespace in it, or if
 376     # we're VMS, since VMS requires all parms quoted.  Also, don't quote
 377     # it if it's already quoted.
 378     for ( @derived_switches ) {
 379         $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
 380     }
 381     return join( " ", @existing_switches, @derived_switches );
 382 }
 383
 384 =head2 C<_cleaned_switches>
 385
 386   my @switches = $self->_cleaned_switches( @switches_from_user );
 387
 388 Returns only defined, non-blank, trimmed switches from the parms passed.
 389
 390 =cut
 391
 392 sub _cleaned_switches {
 393     my $self = shift;
 394
 395     local $_;
 396
 397     my @switches;
 398     for ( @_ ) {
 399         my $switch = $_;
 400         next unless defined $switch;
 401         $switch =~ s/^\s+//;
 402         $switch =~ s/\s+$//;
 403         push( @switches, $switch ) if $switch ne "";
 404     }
 405
 406     return @switches;
 407 }
 408
 409 =head2 C<_INC2PERL5LIB>
 410
 411   local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
 412
 413 Takes the current value of C<@INC> and turns it into something suitable
 414 for putting onto C<PERL5LIB>.
 415
 416 =cut
 417
 418 sub _INC2PERL5LIB {
 419     my($self) = shift;
 420
 421     $self->{_old5lib} = $ENV{PERL5LIB};
 422
 423     return join $Config{path_sep}, $self->_filtered_INC;
 424 }
 425
 426 =head2 C<_filtered_INC>
 427
 428   my @filtered_inc = $self->_filtered_INC;
 429
 430 Shortens C<@INC> by removing redundant and unnecessary entries.
 431 Necessary for OSes with limited command line lengths, like VMS.
 432
 433 =cut
 434
 435 sub _filtered_INC {
 436     my($self, @inc) = @_;
 437     @inc = @INC unless @inc;
 438
 439     if( $self->{_is_vms} ) {
 440         # VMS has a 255-byte limit on the length of %ENV entries, so
 441         # toss the ones that involve perl_root, the install location
 442         @inc = grep !/perl_root/i, @inc;
 443
 444     } elsif ( $self->{_is_win32} ) {
 445         # Lose any trailing backslashes in the Win32 paths
 446         s/[\\\/+]$// foreach @inc;
 447     }
 448
 449     my %dupes;
 450     @inc = grep !$dupes{$_}++, @inc;
 451
 452     return @inc;
 453 }
 454
 455
 456 =head2 C<_restore_PERL5LIB>
 457
 458   $self->_restore_PERL5LIB;
 459
 460 This restores the original value of the C<PERL5LIB> environment variable.
 461 Necessary on VMS, otherwise a no-op.
 462
 463 =cut
 464
 465 sub _restore_PERL5LIB {
 466     my($self) = shift;
 467
 468     return unless $self->{_is_vms};
 469
 470     if (defined $self->{_old5lib}) {
 471         $ENV{PERL5LIB} = $self->{_old5lib};
 472     }
 473 }
 474
 475 =head1 Parsing
 476
 477 Methods for identifying what sort of line you're looking at.
 478
 479 =head2 C<_is_comment>
 480
 481   my $is_comment = $strap->_is_comment($line, \$comment);
 482
 483 Checks if the given line is a comment.  If so, it will place it into
 484 C<$comment> (sans #).
 485
 486 =cut
 487
 488 sub _is_comment {
 489     my($self, $line, $comment) = @_;
 490
 491     if( $line =~ /^\s*\#(.*)/ ) {
 492         $$comment = $1;
 493         return $YES;
 494     }
 495     else {
 496         return $NO;
 497     }
 498 }
 499
 500 =head2 C<_is_header>
 501
 502   my $is_header = $strap->_is_header($line);
 503
 504 Checks if the given line is a header (1..M) line.  If so, it places how
 505 many tests there will be in C<< $strap->{max} >>, a list of which tests
 506 are todo in C<< $strap->{todo} >> and if the whole test was skipped
 507 C<< $strap->{skip_all} >> contains the reason.
 508
 509 =cut
 510
 511 # Regex for parsing a header.  Will be run with /x
 512 my $Extra_Header_Re = <<'REGEX';
 513                        ^
 514                         (?: \s+ todo \s+ ([\d \t]+) )?      # optional todo set
 515                         (?: \s* \# \s* ([\w:]+\s?) (.*) )?     # optional skip with optional reason
 516 REGEX
 517
 518 sub _is_header {
 519     my($self, $line) = @_;
 520
 521     if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
 522         $self->{max}  = $max;
 523         assert( $self->{max} >= 0,  'Max # of tests looks right' );
 524
 525         if( defined $extra ) {
 526             my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
 527
 528             $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
 529
 530             if( $self->{max} == 0 ) {
 531                 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
 532             }
 533
 534             $self->{skip_all} = $reason;
 535         }
 536
 537         return $YES;
 538     }
 539     else {
 540         return $NO;
 541     }
 542 }
 543
 544 =head2 C<_is_test>
 545
 546   my $is_test = $strap->_is_test($line, \%test);
 547
 548 Checks if the $line is a test report (ie. 'ok/not ok').  Reports the
 549 result back in C<%test> which will contain:
 550
 551   ok            did it succeed?  This is the literal 'ok' or 'not ok'.
 552   name          name of the test (if any)
 553   number        test number (if any)
 554
 555   type          'todo' or 'skip' (if any)
 556   reason        why is it todo or skip? (if any)
 557
 558 If will also catch lone 'not' lines, note it saw them
 559 C<< $strap->{saw_lone_not} >> and the line in C<< $strap->{lone_not_line} >>.
 560
 561 =cut
 562
 563 my $Report_Re = <<'REGEX';
 564                  ^
 565                   (not\ )?               # failure?
 566                   ok\b
 567                   (?:\s+(\d+))?         # optional test number
 568                   \s*
 569                   (.*)                  # and the rest
 570 REGEX
 571
 572 my $Extra_Re = <<'REGEX';
 573                  ^
 574                   (.*?) (?:(?:[^\\]|^)# (.*))?
 575                  $
 576 REGEX
 577
 578 sub _is_test {
 579     my($self, $line, $test) = @_;
 580
 581     # We pulverize the line down into pieces in three parts.
 582     if( my($not, $num, $extra)    = $line  =~ /$Report_Re/ox ) {
 583         my ($name, $control) = $extra ? split(/(?:[^\\]|^)#/, $extra) : ();
 584         my ($type, $reason)  = $control ? $control =~ /^\s*(\S+)(?:\s+(.*))?$/ : ();
 585
 586         $test->{number} = $num;
 587         $test->{ok}     = $not ? 0 : 1;
 588         $test->{name}   = $name;
 589
 590         if( defined $type ) {
 591             $test->{type}   = $type =~ /^TODO$/i ? 'todo' :
 592                               $type =~ /^Skip/i  ? 'skip' : 0;
 593         }
 594         else {
 595             $test->{type} = '';
 596         }
 597         $test->{reason} = $reason;
 598
 599         return $YES;
 600     }
 601     else{
 602         # Sometimes the "not " and "ok" will be on separate lines on VMS.
 603         # We catch this and remember we saw it.
 604         if( $line =~ /^not\s+$/ ) {
 605             $self->{saw_lone_not} = 1;
 606             $self->{lone_not_line} = $self->{line};
 607         }
 608
 609         return $NO;
 610     }
 611 }
 612
 613 =head2 C<_is_bail_out>
 614
 615   my $is_bail_out = $strap->_is_bail_out($line, \$reason);
 616
 617 Checks if the line is a "Bail out!".  Places the reason for bailing
 618 (if any) in $reason.
 619
 620 =cut
 621
 622 sub _is_bail_out {
 623     my($self, $line, $reason) = @_;
 624
 625     if( $line =~ /^Bail out!\s*(.*)/i ) {
 626         $$reason = $1 if $1;
 627         return $YES;
 628     }
 629     else {
 630         return $NO;
 631     }
 632 }
 633
 634 =head2 C<_reset_file_state>
 635
 636   $strap->_reset_file_state;
 637
 638 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
 639 etc. so it's ready to parse the next file.
 640
 641 =cut
 642
 643 sub _reset_file_state {
 644     my($self) = shift;
 645
 646     delete @{$self}{qw(max skip_all todo)};
 647     $self->{line}       = 0;
 648     $self->{saw_header} = 0;
 649     $self->{saw_bailout}= 0;
 650     $self->{saw_lone_not} = 0;
 651     $self->{lone_not_line} = 0;
 652     $self->{bailout_reason} = '';
 653     $self->{'next'}       = 1;
 654 }
 655
 656 =head1 Results
 657
 658 The C<%results> returned from C<analyze()> contain the following
 659 information:
 660
 661   passing           true if the whole test is considered a pass
 662                     (or skipped), false if its a failure
 663
 664   exit              the exit code of the test run, if from a file
 665   wait              the wait code of the test run, if from a file
 666
 667   max               total tests which should have been run
 668   seen              total tests actually seen
 669   skip_all          if the whole test was skipped, this will
 670                       contain the reason.
 671
 672   ok                number of tests which passed
 673                       (including todo and skips)
 674
 675   todo              number of todo tests seen
 676   bonus             number of todo tests which
 677                       unexpectedly passed
 678
 679   skip              number of tests skipped
 680
 681 So a successful test should have max == seen == ok.
 682
 683
 684 There is one final item, the details.
 685
 686   details           an array ref reporting the result of
 687                     each test looks like this:
 688
 689     $results{details}[$test_num - 1] =
 690             { ok        => is the test considered ok?
 691               actual_ok => did it literally say 'ok'?
 692               name      => name of the test (if any)
 693               type      => 'skip' or 'todo' (if any)
 694               reason    => reason for the above (if any)
 695             };
 696
 697 Element 0 of the details is test #1.  I tried it with element 1 being
 698 #1 and 0 being empty, this is less awkward.
 699
 700 =head2 C<_detailize>
 701
 702   my %details = $strap->_detailize($pass, \%test);
 703
 704 Generates the details based on the last test line seen.  C<$pass> is
 705 true if it was considered to be a passed test.  C<%test> is the results
 706 of the test you're summarizing.
 707
 708 =cut
 709
 710 sub _detailize {
 711     my($self, $pass, $test) = @_;
 712
 713     my %details = ( ok         => $pass,
 714                     actual_ok  => $test->{ok}
 715                   );
 716
 717     assert( !(grep !defined $details{$_}, keys %details),
 718             'test contains the ok and actual_ok info' );
 719
 720     # We don't want these to be undef because they are often
 721     # checked and don't want the checker to have to deal with
 722     # uninitialized vars.
 723     foreach my $piece (qw(name type reason)) {
 724         $details{$piece} = defined $test->{$piece} ? $test->{$piece} : '';
 725     }
 726
 727     return %details;
 728 }
 729
 730 =head1 EXAMPLES
 731
 732 See F<examples/mini_harness.plx> for an example of use.
 733
 734 =head1 AUTHOR
 735
 736 Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
 737 Andy Lester C<< <andy@petdance.com> >>.
 738
 739 =head1 SEE ALSO
 740
 741 L<Test::Harness>
 742
 743 =cut
 744
 745 1;