lib/Test/Harness/Straps.pm

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