lib/Test/Harness/Straps.pm

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