lib/Test/Harness/Straps.pm

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