lib/Test/Harness/Straps.pm

   1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
   2 # $Id: Straps.pm,v 1.34 2003/11/23 00:02:11 andy Exp $
   3
   4 package Test::Harness::Straps;
   5
   6 use strict;
   7 use vars qw($VERSION);
   8 use Config;
   9 $VERSION = '0.18';
  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 all switches to prevent shell interference, or VMS downcasing
 376     for ( @derived_switches ) {
 377         $_ = qq["$_"] if /\S/ && !/^".*"$/;
 378     }
 379     return join( " ", @existing_switches, @derived_switches );
 380 }
 381
 382 =head2 C<_cleaned_switches>
 383
 384   my @switches = $self->_cleaned_switches( @switches_from_user );
 385
 386 Returns only defined, non-blank, trimmed switches from the parms passed.
 387
 388 =cut
 389
 390 sub _cleaned_switches {
 391     my $self = shift;
 392
 393     local $_;
 394
 395     my @switches;
 396     for ( @_ ) {
 397         my $switch = $_;
 398         next unless defined $switch;
 399         $switch =~ s/^\s+//;
 400         $switch =~ s/\s+$//;
 401         push( @switches, $switch ) if $switch ne "";
 402     }
 403
 404     return @switches;
 405 }
 406
 407 =head2 C<_INC2PERL5LIB>
 408
 409   local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
 410
 411 Takes the current value of C<@INC> and turns it into something suitable
 412 for putting onto C<PERL5LIB>.
 413
 414 =cut
 415
 416 sub _INC2PERL5LIB {
 417     my($self) = shift;
 418
 419     $self->{_old5lib} = $ENV{PERL5LIB};
 420
 421     return join $Config{path_sep}, $self->_filtered_INC;
 422 }
 423
 424 =head2 C<_filtered_INC>
 425
 426   my @filtered_inc = $self->_filtered_INC;
 427
 428 Shortens C<@INC> by removing redundant and unnecessary entries.
 429 Necessary for OSes with limited command line lengths, like VMS.
 430
 431 =cut
 432
 433 sub _filtered_INC {
 434     my($self, @inc) = @_;
 435     @inc = @INC unless @inc;
 436
 437     if( $self->{_is_vms} ) {
 438         # VMS has a 255-byte limit on the length of %ENV entries, so
 439         # toss the ones that involve perl_root, the install location
 440         @inc = grep !/perl_root/i, @inc;
 441
 442     } elsif ( $self->{_is_win32} ) {
 443         # Lose any trailing backslashes in the Win32 paths
 444         s/[\\\/+]$// foreach @inc;
 445     }
 446
 447     my %dupes;
 448     @inc = grep !$dupes{$_}++, @inc;
 449
 450     return @inc;
 451 }
 452
 453
 454 =head2 C<_restore_PERL5LIB>
 455
 456   $self->_restore_PERL5LIB;
 457
 458 This restores the original value of the C<PERL5LIB> environment variable.
 459 Necessary on VMS, otherwise a no-op.
 460
 461 =cut
 462
 463 sub _restore_PERL5LIB {
 464     my($self) = shift;
 465
 466     return unless $self->{_is_vms};
 467
 468     if (defined $self->{_old5lib}) {
 469         $ENV{PERL5LIB} = $self->{_old5lib};
 470     }
 471 }
 472
 473 =head1 Parsing
 474
 475 Methods for identifying what sort of line you're looking at.
 476
 477 =head2 C<_is_comment>
 478
 479   my $is_comment = $strap->_is_comment($line, \$comment);
 480
 481 Checks if the given line is a comment.  If so, it will place it into
 482 C<$comment> (sans #).
 483
 484 =cut
 485
 486 sub _is_comment {
 487     my($self, $line, $comment) = @_;
 488
 489     if( $line =~ /^\s*\#(.*)/ ) {
 490         $$comment = $1;
 491         return $YES;
 492     }
 493     else {
 494         return $NO;
 495     }
 496 }
 497
 498 =head2 C<_is_header>
 499
 500   my $is_header = $strap->_is_header($line);
 501
 502 Checks if the given line is a header (1..M) line.  If so, it places how
 503 many tests there will be in C<< $strap->{max} >>, a list of which tests
 504 are todo in C<< $strap->{todo} >> and if the whole test was skipped
 505 C<< $strap->{skip_all} >> contains the reason.
 506
 507 =cut
 508
 509 # Regex for parsing a header.  Will be run with /x
 510 my $Extra_Header_Re = <<'REGEX';
 511                        ^
 512                         (?: \s+ todo \s+ ([\d \t]+) )?      # optional todo set
 513                         (?: \s* \# \s* ([\w:]+\s?) (.*) )?     # optional skip with optional reason
 514 REGEX
 515
 516 sub _is_header {
 517     my($self, $line) = @_;
 518
 519     if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
 520         $self->{max}  = $max;
 521         assert( $self->{max} >= 0,  'Max # of tests looks right' );
 522
 523         if( defined $extra ) {
 524             my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
 525
 526             $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
 527
 528             if( $self->{max} == 0 ) {
 529                 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
 530             }
 531
 532             $self->{skip_all} = $reason;
 533         }
 534
 535         return $YES;
 536     }
 537     else {
 538         return $NO;
 539     }
 540 }
 541
 542 =head2 C<_is_test>
 543
 544   my $is_test = $strap->_is_test($line, \%test);
 545
 546 Checks if the $line is a test report (ie. 'ok/not ok').  Reports the
 547 result back in C<%test> which will contain:
 548
 549   ok            did it succeed?  This is the literal 'ok' or 'not ok'.
 550   name          name of the test (if any)
 551   number        test number (if any)
 552
 553   type          'todo' or 'skip' (if any)
 554   reason        why is it todo or skip? (if any)
 555
 556 If will also catch lone 'not' lines, note it saw them
 557 C<< $strap->{saw_lone_not} >> and the line in C<< $strap->{lone_not_line} >>.
 558
 559 =cut
 560
 561 my $Report_Re = <<'REGEX';
 562                  ^
 563                   (not\ )?               # failure?
 564                   ok\b
 565                   (?:\s+(\d+))?         # optional test number
 566                   \s*
 567                   (.*)                  # and the rest
 568 REGEX
 569
 570 my $Extra_Re = <<'REGEX';
 571                  ^
 572                   (.*?) (?:(?:[^\\]|^)# (.*))?
 573                  $
 574 REGEX
 575
 576 sub _is_test {
 577     my($self, $line, $test) = @_;
 578
 579     # We pulverize the line down into pieces in three parts.
 580     if( my($not, $num, $extra)    = $line  =~ /$Report_Re/ox ) {
 581         my ($name, $control) = $extra ? split(/(?:[^\\]|^)#/, $extra) : ();
 582         my ($type, $reason)  = $control ? $control =~ /^\s*(\S+)(?:\s+(.*))?$/ : ();
 583
 584         $test->{number} = $num;
 585         $test->{ok}     = $not ? 0 : 1;
 586         $test->{name}   = $name;
 587
 588         if( defined $type ) {
 589             $test->{type}   = $type =~ /^TODO$/i ? 'todo' :
 590                               $type =~ /^Skip/i  ? 'skip' : 0;
 591         }
 592         else {
 593             $test->{type} = '';
 594         }
 595         $test->{reason} = $reason;
 596
 597         return $YES;
 598     }
 599     else{
 600         # Sometimes the "not " and "ok" will be on separate lines on VMS.
 601         # We catch this and remember we saw it.
 602         if( $line =~ /^not\s+$/ ) {
 603             $self->{saw_lone_not} = 1;
 604             $self->{lone_not_line} = $self->{line};
 605         }
 606
 607         return $NO;
 608     }
 609 }
 610
 611 =head2 C<_is_bail_out>
 612
 613   my $is_bail_out = $strap->_is_bail_out($line, \$reason);
 614
 615 Checks if the line is a "Bail out!".  Places the reason for bailing
 616 (if any) in $reason.
 617
 618 =cut
 619
 620 sub _is_bail_out {
 621     my($self, $line, $reason) = @_;
 622
 623     if( $line =~ /^Bail out!\s*(.*)/i ) {
 624         $$reason = $1 if $1;
 625         return $YES;
 626     }
 627     else {
 628         return $NO;
 629     }
 630 }
 631
 632 =head2 C<_reset_file_state>
 633
 634   $strap->_reset_file_state;
 635
 636 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
 637 etc. so it's ready to parse the next file.
 638
 639 =cut
 640
 641 sub _reset_file_state {
 642     my($self) = shift;
 643
 644     delete @{$self}{qw(max skip_all todo)};
 645     $self->{line}       = 0;
 646     $self->{saw_header} = 0;
 647     $self->{saw_bailout}= 0;
 648     $self->{saw_lone_not} = 0;
 649     $self->{lone_not_line} = 0;
 650     $self->{bailout_reason} = '';
 651     $self->{'next'}       = 1;
 652 }
 653
 654 =head1 Results
 655
 656 The C<%results> returned from C<analyze()> contain the following
 657 information:
 658
 659   passing           true if the whole test is considered a pass
 660                     (or skipped), false if its a failure
 661
 662   exit              the exit code of the test run, if from a file
 663   wait              the wait code of the test run, if from a file
 664
 665   max               total tests which should have been run
 666   seen              total tests actually seen
 667   skip_all          if the whole test was skipped, this will
 668                       contain the reason.
 669
 670   ok                number of tests which passed
 671                       (including todo and skips)
 672
 673   todo              number of todo tests seen
 674   bonus             number of todo tests which
 675                       unexpectedly passed
 676
 677   skip              number of tests skipped
 678
 679 So a successful test should have max == seen == ok.
 680
 681
 682 There is one final item, the details.
 683
 684   details           an array ref reporting the result of
 685                     each test looks like this:
 686
 687     $results{details}[$test_num - 1] =
 688             { ok        => is the test considered ok?
 689               actual_ok => did it literally say 'ok'?
 690               name      => name of the test (if any)
 691               type      => 'skip' or 'todo' (if any)
 692               reason    => reason for the above (if any)
 693             };
 694
 695 Element 0 of the details is test #1.  I tried it with element 1 being
 696 #1 and 0 being empty, this is less awkward.
 697
 698 =head2 C<_detailize>
 699
 700   my %details = $strap->_detailize($pass, \%test);
 701
 702 Generates the details based on the last test line seen.  C<$pass> is
 703 true if it was considered to be a passed test.  C<%test> is the results
 704 of the test you're summarizing.
 705
 706 =cut
 707
 708 sub _detailize {
 709     my($self, $pass, $test) = @_;
 710
 711     my %details = ( ok         => $pass,
 712                     actual_ok  => $test->{ok}
 713                   );
 714
 715     assert( !(grep !defined $details{$_}, keys %details),
 716             'test contains the ok and actual_ok info' );
 717
 718     # We don't want these to be undef because they are often
 719     # checked and don't want the checker to have to deal with
 720     # uninitialized vars.
 721     foreach my $piece (qw(name type reason)) {
 722         $details{$piece} = defined $test->{$piece} ? $test->{$piece} : '';
 723     }
 724
 725     return %details;
 726 }
 727
 728 =head1 EXAMPLES
 729
 730 See F<examples/mini_harness.plx> for an example of use.
 731
 732 =head1 AUTHOR
 733
 734 Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
 735 Andy Lester C<< <andy@petdance.com> >>.
 736
 737 =head1 SEE ALSO
 738
 739 L<Test::Harness>
 740
 741 =cut
 742
 743 1;