lib/Test/Harness/Straps.pm

   1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
   2 # $Id: Straps.pm 450 2004-12-20 04:51:42Z andy $
   3
   4 package Test::Harness::Straps;
   5
   6 use strict;
   7 use vars qw($VERSION);
   8 use Config;
   9 $VERSION = '0.20';
  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 $class = shift;
  73
  74     my $self = bless {}, $class;
  75     $self->_init;
  76
  77     return $self;
  78 }
  79
  80 =head2 C<_init>
  81
  82   $strap->_init;
  83
  84 Initialize the internal state of a strap to make it ready for parsing.
  85
  86 =cut
  87
  88 sub _init {
  89     my($self) = shift;
  90
  91     $self->{_is_vms}   = ( $^O eq 'VMS' );
  92     $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
  93     $self->{_is_macos} = ( $^O eq 'MacOS' );
  94 }
  95
  96 =head1 Analysis
  97
  98 =head2 $strap->analyze( $name, \@output_lines )
  99
 100   my %results = $strap->analyze($name, \@test_output);
 101
 102 Analyzes the output of a single test, assigning it the given C<$name>
 103 for use in the total report.  Returns the C<%results> of the test.
 104 See L<Results>.
 105
 106 C<@test_output> should be the raw output from the test, including
 107 newlines.
 108
 109 =cut
 110
 111 sub analyze {
 112     my($self, $name, $test_output) = @_;
 113
 114     my $it = Test::Harness::Iterator->new($test_output);
 115     return $self->_analyze_iterator($name, $it);
 116 }
 117
 118
 119 sub _analyze_iterator {
 120     my($self, $name, $it) = @_;
 121
 122     $self->_reset_file_state;
 123     $self->{file} = $name;
 124     my %totals  = (
 125                    max      => 0,
 126                    seen     => 0,
 127
 128                    ok       => 0,
 129                    todo     => 0,
 130                    skip     => 0,
 131                    bonus    => 0,
 132
 133                    details  => []
 134                   );
 135
 136     # Set them up here so callbacks can have them.
 137     $self->{totals}{$name}         = \%totals;
 138     while( defined(my $line = $it->next) ) {
 139         $self->_analyze_line($line, \%totals);
 140         last if $self->{saw_bailout};
 141     }
 142
 143     $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
 144
 145     my $passed = ($totals{max} == 0 && defined $totals{skip_all}) ||
 146                  ($totals{max} && $totals{seen} &&
 147                   $totals{max} == $totals{seen} &&
 148                   $totals{max} == $totals{ok});
 149     $totals{passing} = $passed ? 1 : 0;
 150
 151     return %totals;
 152 }
 153
 154
 155 sub _analyze_line {
 156     my($self, $line, $totals) = @_;
 157
 158     my %result = ();
 159
 160     $self->{line}++;
 161
 162     my $type;
 163     if ( $self->_is_test($line, \%result) ) {
 164         $type = 'test';
 165
 166         $totals->{seen}++;
 167         $result{number} = $self->{'next'} unless $result{number};
 168
 169         # sometimes the 'not ' and the 'ok' are on different lines,
 170         # happens often on VMS if you do:
 171         #   print "not " unless $test;
 172         #   print "ok $num\n";
 173         if( $self->{saw_lone_not} &&
 174             ($self->{lone_not_line} == $self->{line} - 1) )
 175         {
 176             $result{ok} = 0;
 177         }
 178
 179         my $pass = $result{ok};
 180         $result{type} = 'todo' if $self->{todo}{$result{number}};
 181
 182         if( $result{type} eq 'todo' ) {
 183             $totals->{todo}++;
 184             $pass = 1;
 185             $totals->{bonus}++ if $result{ok}
 186         }
 187         elsif( $result{type} eq 'skip' ) {
 188             $totals->{skip}++;
 189             $pass = 1;
 190         }
 191
 192         $totals->{ok}++ if $pass;
 193
 194         if( $result{number} > 100000 && $result{number} > $self->{max} ) {
 195             warn "Enormous test number seen [test $result{number}]\n";
 196             warn "Can't detailize, too big.\n";
 197         }
 198         else {
 199             #Generates the details based on the last test line seen.  C<$pass> is
 200             #true if it was considered to be a passed test.  C<%test> is the results
 201             #of the test you're summarizing.
 202             my $details = {
 203                 ok         => $pass,
 204                 actual_ok  => $result{ok}
 205             };
 206
 207             assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) );
 208
 209             # We don't want these to be undef because they are often
 210             # checked and don't want the checker to have to deal with
 211             # uninitialized vars.
 212             foreach my $piece (qw(name type reason)) {
 213                 $details->{$piece} = defined $result{$piece} ? $result{$piece} : '';
 214             }
 215             $totals->{details}[$result{number} - 1] = $details;
 216         }
 217
 218         # XXX handle counter mismatch
 219     }
 220     elsif ( $self->_is_header($line) ) {
 221         $type = 'header';
 222
 223         $self->{saw_header}++;
 224
 225         $totals->{max} += $self->{max};
 226     }
 227     elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
 228         $type = 'bailout';
 229         $self->{saw_bailout} = 1;
 230     }
 231     else {
 232         $type = 'other';
 233     }
 234
 235     $self->{callback}->($self, $line, $type, $totals) if $self->{callback};
 236
 237     $self->{'next'} = $result{number} + 1 if $type eq 'test';
 238 }
 239
 240 =head2 C<analyze_fh>
 241
 242   my %results = $strap->analyze_fh($name, $test_filehandle);
 243
 244 Like C<analyze>, but it reads from the given filehandle.
 245
 246 =cut
 247
 248 sub analyze_fh {
 249     my($self, $name, $fh) = @_;
 250
 251     my $it = Test::Harness::Iterator->new($fh);
 252     return $self->_analyze_iterator($name, $it);
 253 }
 254
 255 =head2 C<analyze_file>
 256
 257   my %results = $strap->analyze_file($test_file);
 258
 259 Like C<analyze>, but it runs the given C<$test_file> and parses its
 260 results.  It will also use that name for the total report.
 261
 262 =cut
 263
 264 sub analyze_file {
 265     my($self, $file) = @_;
 266
 267     unless( -e $file ) {
 268         $self->{error} = "$file does not exist";
 269         return;
 270     }
 271
 272     unless( -r $file ) {
 273         $self->{error} = "$file is not readable";
 274         return;
 275     }
 276
 277     local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
 278     if ( $Test::Harness::Debug ) {
 279         local $^W=0; # ignore undef warnings
 280         print "# PERL5LIB=$ENV{PERL5LIB}\n";
 281     }
 282
 283     # *sigh* this breaks under taint, but open -| is unportable.
 284     my $line = $self->_command_line($file);
 285     unless( open(FILE, "$line|") ) {
 286         print "can't run $file. $!\n";
 287         return;
 288     }
 289
 290     my %results = $self->analyze_fh($file, \*FILE);
 291     my $exit = close FILE;
 292     $results{'wait'} = $?;
 293     if( $? && $self->{_is_vms} ) {
 294         eval q{use vmsish "status"; $results{'exit'} = $?};
 295     }
 296     else {
 297         $results{'exit'} = _wait2exit($?);
 298     }
 299     $results{passing} = 0 unless $? == 0;
 300
 301     $self->_restore_PERL5LIB();
 302
 303     return %results;
 304 }
 305
 306
 307 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
 308 if( $@ ) {
 309     *_wait2exit = sub { $_[0] >> 8 };
 310 }
 311 else {
 312     *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
 313 }
 314
 315 =head2 C<_command_line( $file )>
 316
 317   my $command_line = $self->_command_line();
 318
 319 Returns the full command line that will be run to test I<$file>.
 320
 321 =cut
 322
 323 sub _command_line {
 324     my $self = shift;
 325     my $file = shift;
 326
 327     my $command =  $self->_command();
 328     my $switches = $self->_switches($file);
 329
 330     $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
 331     my $line = "$command $switches $file";
 332
 333     return $line;
 334 }
 335
 336
 337 =head2 C<_command>
 338
 339   my $command = $self->_command();
 340
 341 Returns the command that runs the test.  Combine this with _switches()
 342 to build a command line.
 343
 344 Typically this is C<$^X>, but you can set C<$ENV{HARNESS_COMMAND}>
 345 to use a different Perl than what you're running the harness under.
 346 This might be to run a threaded Perl, for example.
 347
 348 You can also overload this method if you've built your own strap subclass,
 349 such as a PHP interpreter for a PHP-based strap.
 350
 351 =cut
 352
 353 sub _command {
 354     my $self = shift;
 355
 356     return $ENV{HARNESS_PERL}           if defined $ENV{HARNESS_PERL};
 357     return "MCR $^X"                    if $self->{_is_vms};
 358     return Win32::GetShortPathName($^X) if $self->{_is_win32};
 359     return $^X;
 360 }
 361
 362
 363 =head2 C<_switches>
 364
 365   my $switches = $self->_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 C<_cleaned_switches>
 403
 404   my @switches = $self->_cleaned_switches( @switches_from_user );
 405
 406 Returns only defined, non-blank, trimmed switches from the parms passed.
 407
 408 =cut
 409
 410 sub _cleaned_switches {
 411     my $self = shift;
 412
 413     local $_;
 414
 415     my @switches;
 416     for ( @_ ) {
 417         my $switch = $_;
 418         next unless defined $switch;
 419         $switch =~ s/^\s+//;
 420         $switch =~ s/\s+$//;
 421         push( @switches, $switch ) if $switch ne "";
 422     }
 423
 424     return @switches;
 425 }
 426
 427 =head2 C<_INC2PERL5LIB>
 428
 429   local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
 430
 431 Takes the current value of C<@INC> and turns it into something suitable
 432 for putting onto C<PERL5LIB>.
 433
 434 =cut
 435
 436 sub _INC2PERL5LIB {
 437     my($self) = shift;
 438
 439     $self->{_old5lib} = $ENV{PERL5LIB};
 440
 441     return join $Config{path_sep}, $self->_filtered_INC;
 442 }
 443
 444 =head2 C<_filtered_INC>
 445
 446   my @filtered_inc = $self->_filtered_INC;
 447
 448 Shortens C<@INC> by removing redundant and unnecessary entries.
 449 Necessary for OSes with limited command line lengths, like VMS.
 450
 451 =cut
 452
 453 sub _filtered_INC {
 454     my($self, @inc) = @_;
 455     @inc = @INC unless @inc;
 456
 457     if( $self->{_is_vms} ) {
 458         # VMS has a 255-byte limit on the length of %ENV entries, so
 459         # toss the ones that involve perl_root, the install location
 460         @inc = grep !/perl_root/i, @inc;
 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 C<_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_comment>
 510
 511   my $is_comment = $strap->_is_comment($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_comment {
 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_test>
 575
 576   my $is_test = $strap->_is_test($line, \%test);
 577
 578 Checks if the $line is a test report (ie. 'ok/not ok').  Reports the
 579 result back in C<%test> which will contain:
 580
 581   ok            did it succeed?  This is the literal 'ok' or 'not ok'.
 582   name          name of the test (if any)
 583   number        test number (if any)
 584
 585   type          'todo' or 'skip' (if any)
 586   reason        why is it todo or skip? (if any)
 587
 588 It will also catch lone 'not' lines, note it saw them in
 589 C<< $strap->{saw_lone_not} >> and the line in C<< $strap->{lone_not_line} >>.
 590
 591 =cut
 592
 593 my $Report_Re = <<'REGEX';
 594                  ^
 595                   (not\ )?               # failure?
 596                   ok\b
 597                   (?:\s+(\d+))?         # optional test number
 598                   \s*
 599                   (.*)                  # and the rest
 600 REGEX
 601
 602 sub _is_test {
 603     my($self, $line, $test) = @_;
 604
 605     # We pulverize the line down into pieces in three parts.
 606     if( my($not, $num, $extra)    = $line  =~ /$Report_Re/ox ) {
 607         ($test->{name}, my $control) = $extra ? split(/(?:[^\\]|^)#/, $extra) : ();
 608         (my $type, $test->{reason})  = $control ? $control =~ /^\s*(\S+)(?:\s+(.*))?$/ : ();
 609
 610         $test->{number} = $num;
 611         $test->{ok}     = $not ? 0 : 1;
 612
 613         if( defined $type ) {
 614             $test->{type}   = $type =~ /^TODO$/i ? 'todo' :
 615                               $type =~ /^Skip/i  ? 'skip' : 0;
 616         }
 617         else {
 618             $test->{type} = '';
 619         }
 620
 621         return $YES;
 622     }
 623     else{
 624         # Sometimes the "not " and "ok" will be on separate lines on VMS.
 625         # We catch this and remember we saw it.
 626         if( $line =~ /^not\s+$/ ) {
 627             $self->{saw_lone_not} = 1;
 628             $self->{lone_not_line} = $self->{line};
 629         }
 630
 631         return $NO;
 632     }
 633 }
 634
 635 =head2 C<_is_bail_out>
 636
 637   my $is_bail_out = $strap->_is_bail_out($line, \$reason);
 638
 639 Checks if the line is a "Bail out!".  Places the reason for bailing
 640 (if any) in $reason.
 641
 642 =cut
 643
 644 sub _is_bail_out {
 645     my($self, $line, $reason) = @_;
 646
 647     if( $line =~ /^Bail out!\s*(.*)/i ) {
 648         $$reason = $1 if $1;
 649         return $YES;
 650     }
 651     else {
 652         return $NO;
 653     }
 654 }
 655
 656 =head2 C<_reset_file_state>
 657
 658   $strap->_reset_file_state;
 659
 660 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
 661 etc. so it's ready to parse the next file.
 662
 663 =cut
 664
 665 sub _reset_file_state {
 666     my($self) = shift;
 667
 668     delete @{$self}{qw(max skip_all todo)};
 669     $self->{line}       = 0;
 670     $self->{saw_header} = 0;
 671     $self->{saw_bailout}= 0;
 672     $self->{saw_lone_not} = 0;
 673     $self->{lone_not_line} = 0;
 674     $self->{bailout_reason} = '';
 675     $self->{'next'}       = 1;
 676 }
 677
 678 =head1 Results
 679
 680 The C<%results> returned from C<analyze()> contain the following
 681 information:
 682
 683   passing           true if the whole test is considered a pass
 684                     (or skipped), false if its a failure
 685
 686   exit              the exit code of the test run, if from a file
 687   wait              the wait code of the test run, if from a file
 688
 689   max               total tests which should have been run
 690   seen              total tests actually seen
 691   skip_all          if the whole test was skipped, this will
 692                       contain the reason.
 693
 694   ok                number of tests which passed
 695                       (including todo and skips)
 696
 697   todo              number of todo tests seen
 698   bonus             number of todo tests which
 699                       unexpectedly passed
 700
 701   skip              number of tests skipped
 702
 703 So a successful test should have max == seen == ok.
 704
 705
 706 There is one final item, the details.
 707
 708   details           an array ref reporting the result of
 709                     each test looks like this:
 710
 711     $results{details}[$test_num - 1] =
 712             { ok        => is the test considered ok?
 713               actual_ok => did it literally say 'ok'?
 714               name      => name of the test (if any)
 715               type      => 'skip' or 'todo' (if any)
 716               reason    => reason for the above (if any)
 717             };
 718
 719 Element 0 of the details is test #1.  I tried it with element 1 being
 720 #1 and 0 being empty, this is less awkward.
 721
 722 =head1 EXAMPLES
 723
 724 See F<examples/mini_harness.plx> for an example of use.
 725
 726 =head1 AUTHOR
 727
 728 Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
 729 Andy Lester C<< <andy@petdance.com> >>.
 730
 731 =head1 SEE ALSO
 732
 733 L<Test::Harness>
 734
 735 =cut
 736
 737 1;