lib/Test/Harness/Straps.pm

   1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
   2 # $Id: Straps.pm,v 1.11 2002/06/16 06:55:10 schwern Exp $
   3
   4 package Test::Harness::Straps;
   5
   6 use strict;
   7 use vars qw($VERSION);
   8 use Config;
   9 $VERSION = '0.13';
  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     # When taint mode is on, PERL5LIB is ignored.  So we need to put
 330     # all that on the command line as -Is.
 331     $s .= join " ", qq[ "-$1"], map {qq["-I$_"]} $self->_filtered_INC
 332       if $first =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
 333
 334     close(TEST) or print "can't close $file. $!\n";
 335
 336     return $s;
 337 }
 338
 339
 340 =item B<_INC2PERL5LIB>
 341
 342   local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
 343
 344 Takes the current value of @INC and turns it into something suitable
 345 for putting onto PERL5LIB.
 346
 347 =cut
 348
 349 sub _INC2PERL5LIB {
 350     my($self) = shift;
 351
 352     $self->{_old5lib} = $ENV{PERL5LIB};
 353
 354     return join $Config{path_sep}, $self->_filtered_INC;
 355 }
 356
 357 =item B<_filtered_INC>
 358
 359   my @filtered_inc = $self->_filtered_INC;
 360
 361 Shortens @INC by removing redundant and unnecessary entries.
 362 Necessary for OS's with limited command line lengths, like VMS.
 363
 364 =cut
 365
 366 sub _filtered_INC {
 367     my($self, @inc) = @_;
 368     @inc = @INC unless @inc;
 369
 370     # VMS has a 255-byte limit on the length of %ENV entries, so
 371     # toss the ones that involve perl_root, the install location
 372     # for VMS
 373     if( $self->{_is_vms} ) {
 374         @inc = grep !/perl_root/i, @inc;
 375     }
 376
 377     return @inc;
 378 }
 379
 380
 381 =item B<_restore_PERL5LIB>
 382
 383   $self->_restore_PERL5LIB;
 384
 385 This restores the original value of the PERL5LIB environment variable.
 386 Necessary on VMS, otherwise a no-op.
 387
 388 =cut
 389
 390 sub _restore_PERL5LIB {
 391     my($self) = shift;
 392
 393     return unless $self->{_is_vms};
 394
 395     if (defined $self->{_old5lib}) {
 396         $ENV{PERL5LIB} = $self->{_old5lib};
 397     }
 398 }
 399
 400
 401 =end _private
 402
 403 =back
 404
 405
 406 =begin _private
 407
 408 =head2 Parsing
 409
 410 Methods for identifying what sort of line you're looking at.
 411
 412 =over 4
 413
 414 =item B<_is_comment>
 415
 416   my $is_comment = $strap->_is_comment($line, \$comment);
 417
 418 Checks if the given line is a comment.  If so, it will place it into
 419 $comment (sans #).
 420
 421 =cut
 422
 423 sub _is_comment {
 424     my($self, $line, $comment) = @_;
 425
 426     if( $line =~ /^\s*\#(.*)/ ) {
 427         $$comment = $1;
 428         return $YES;
 429     }
 430     else {
 431         return $NO;
 432     }
 433 }
 434
 435 =item B<_is_header>
 436
 437   my $is_header = $strap->_is_header($line);
 438
 439 Checks if the given line is a header (1..M) line.  If so, it places
 440 how many tests there will be in $strap->{max}, a list of which tests
 441 are todo in $strap->{todo} and if the whole test was skipped
 442 $strap->{skip_all} contains the reason.
 443
 444 =cut
 445
 446 # Regex for parsing a header.  Will be run with /x
 447 my $Extra_Header_Re = <<'REGEX';
 448                        ^
 449                         (?: \s+ todo \s+ ([\d \t]+) )?      # optional todo set
 450                         (?: \s* \# \s* ([\w:]+\s?) (.*) )?     # optional skip with optional reason
 451 REGEX
 452
 453 sub _is_header {
 454     my($self, $line) = @_;
 455
 456     if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
 457         $self->{max}  = $max;
 458         assert( $self->{max} >= 0,  'Max # of tests looks right' );
 459
 460         if( defined $extra ) {
 461             my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
 462
 463             $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
 464
 465             $self->{skip_all} = $reason if defined $skip and $skip =~ /^Skip/i;
 466         }
 467
 468         return $YES;
 469     }
 470     else {
 471         return $NO;
 472     }
 473 }
 474
 475 =item B<_is_test>
 476
 477   my $is_test = $strap->_is_test($line, \%test);
 478
 479 Checks if the $line is a test report (ie. 'ok/not ok').  Reports the
 480 result back in %test which will contain:
 481
 482   ok            did it succeed?  This is the literal 'ok' or 'not ok'.
 483   name          name of the test (if any)
 484   number        test number (if any)
 485
 486   type          'todo' or 'skip' (if any)
 487   reason        why is it todo or skip? (if any)
 488
 489 If will also catch lone 'not' lines, note it saw them
 490 $strap->{saw_lone_not} and the line in $strap->{lone_not_line}.
 491
 492 =cut
 493
 494 my $Report_Re = <<'REGEX';
 495                  ^
 496                   (not\ )?               # failure?
 497                   ok\b
 498                   (?:\s+(\d+))?         # optional test number
 499                   \s*
 500                   (.*)                  # and the rest
 501 REGEX
 502
 503 my $Extra_Re = <<'REGEX';
 504                  ^
 505                   (.*?) (?:(?:[^\\]|^)# (.*))?
 506                  $
 507 REGEX
 508
 509 sub _is_test {
 510     my($self, $line, $test) = @_;
 511
 512     # We pulverize the line down into pieces in three parts.
 513     if( my($not, $num, $extra)    = $line  =~ /$Report_Re/ox ) {
 514         my($name, $control) = split /(?:[^\\]|^)#/, $extra if $extra;
 515         my($type, $reason)  = $control =~ /^\s*(\S+)(?:\s+(.*))?$/ if $control;
 516
 517         $test->{number} = $num;
 518         $test->{ok}     = $not ? 0 : 1;
 519         $test->{name}   = $name;
 520
 521         if( defined $type ) {
 522             $test->{type}   = $type =~ /^TODO$/i ? 'todo' :
 523                               $type =~ /^Skip/i  ? 'skip' : 0;
 524         }
 525         else {
 526             $test->{type} = '';
 527         }
 528         $test->{reason} = $reason;
 529
 530         return $YES;
 531     }
 532     else{
 533         # Sometimes the "not " and "ok" will be on seperate lines on VMS.
 534         # We catch this and remember we saw it.
 535         if( $line =~ /^not\s+$/ ) {
 536             $self->{saw_lone_not} = 1;
 537             $self->{lone_not_line} = $self->{line};
 538         }
 539
 540         return $NO;
 541     }
 542 }
 543
 544 =item B<_is_bail_out>
 545
 546   my $is_bail_out = $strap->_is_bail_out($line, \$reason);
 547
 548 Checks if the line is a "Bail out!".  Places the reason for bailing
 549 (if any) in $reason.
 550
 551 =cut
 552
 553 sub _is_bail_out {
 554     my($self, $line, $reason) = @_;
 555
 556     if( $line =~ /^Bail out!\s*(.*)/i ) {
 557         $$reason = $1 if $1;
 558         return $YES;
 559     }
 560     else {
 561         return $NO;
 562     }
 563 }
 564
 565 =item B<_reset_file_state>
 566
 567   $strap->_reset_file_state;
 568
 569 Resets things like $strap->{max}, $strap->{skip_all}, etc... so its
 570 ready to parse the next file.
 571
 572 =cut
 573
 574 sub _reset_file_state {
 575     my($self) = shift;
 576
 577     delete @{$self}{qw(max skip_all todo)};
 578     $self->{line}       = 0;
 579     $self->{saw_header} = 0;
 580     $self->{saw_bailout}= 0;
 581     $self->{saw_lone_not} = 0;
 582     $self->{lone_not_line} = 0;
 583     $self->{bailout_reason} = '';
 584     $self->{'next'}       = 1;
 585 }
 586
 587 =back
 588
 589 =end _private
 590
 591
 592 =head2 Results
 593
 594 The %results returned from analyze() contain the following information:
 595
 596   passing           true if the whole test is considered a pass
 597                     (or skipped), false if its a failure
 598
 599   exit              the exit code of the test run, if from a file
 600   wait              the wait code of the test run, if from a file
 601
 602   max               total tests which should have been run
 603   seen              total tests actually seen
 604   skip_all          if the whole test was skipped, this will
 605                       contain the reason.
 606
 607   ok                number of tests which passed
 608                       (including todo and skips)
 609
 610   todo              number of todo tests seen
 611   bonus             number of todo tests which
 612                       unexpectedly passed
 613
 614   skip              number of tests skipped
 615
 616 So a successful test should have max == seen == ok.
 617
 618
 619 There is one final item, the details.
 620
 621   details           an array ref reporting the result of
 622                     each test looks like this:
 623
 624     $results{details}[$test_num - 1] =
 625             { ok        => is the test considered ok?
 626               actual_ok => did it literally say 'ok'?
 627               name      => name of the test (if any)
 628               type      => 'skip' or 'todo' (if any)
 629               reason    => reason for the above (if any)
 630             };
 631
 632 Element 0 of the details is test #1.  I tried it with element 1 being
 633 #1 and 0 being empty, this is less awkward.
 634
 635 =begin _private
 636
 637 =over 4
 638
 639 =item B<_detailize>
 640
 641   my %details = $strap->_detailize($pass, \%test);
 642
 643 Generates the details based on the last test line seen.  $pass is true
 644 if it was considered to be a passed test.  %test is the results of the
 645 test you're summarizing.
 646
 647 =cut
 648
 649 sub _detailize {
 650     my($self, $pass, $test) = @_;
 651
 652     my %details = ( ok         => $pass,
 653                     actual_ok  => $test->{ok}
 654                   );
 655
 656     assert( !(grep !defined $details{$_}, keys %details),
 657             'test contains the ok and actual_ok info' );
 658
 659     # We don't want these to be undef because they are often
 660     # checked and don't want the checker to have to deal with
 661     # uninitialized vars.
 662     foreach my $piece (qw(name type reason)) {
 663         $details{$piece} = defined $test->{$piece} ? $test->{$piece} : '';
 664     }
 665
 666     return %details;
 667 }
 668
 669 =back
 670
 671 =end _private
 672
 673 =head1 EXAMPLES
 674
 675 See F<examples/mini_harness.plx> for an example of use.
 676
 677 =head1 AUTHOR
 678
 679 Michael G Schwern E<lt>schwern@pobox.comE<gt>
 680
 681 =head1 SEE ALSO
 682
 683 L<Test::Harness>
 684
 685 =cut
 686
 687
 688 1;