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 .= qq[ "-$1" ] if $first =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
 319     $s .= join " ", map {qq["-I$_"]} $self->_filtered_INC;
 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         if( defined $extra ) {
 447             my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
 448
 449             $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
 450
 451             $self->{skip_all} = $reason if defined $skip and $skip =~ /^Skip/i;
 452         }
 453
 454         return $YES;
 455     }
 456     else {
 457         return $NO;
 458     }
 459 }
 460
 461 =item B<_is_test>
 462
 463   my $is_test = $strap->_is_test($line, \%test);
 464
 465 Checks if the $line is a test report (ie. 'ok/not ok').  Reports the
 466 result back in %test which will contain:
 467
 468   ok            did it succeed?  This is the literal 'ok' or 'not ok'.
 469   name          name of the test (if any)
 470   number        test number (if any)
 471
 472   type          'todo' or 'skip' (if any)
 473   reason        why is it todo or skip? (if any)
 474
 475 If will also catch lone 'not' lines, note it saw them
 476 $strap->{saw_lone_not} and the line in $strap->{lone_not_line}.
 477
 478 =cut
 479
 480 my $Report_Re = <<'REGEX';
 481                  ^
 482                   (not\ )?               # failure?
 483                   ok\b
 484                   (?:\s+(\d+))?         # optional test number
 485                   \s*
 486                   (.*)                  # and the rest
 487 REGEX
 488
 489 my $Extra_Re = <<'REGEX';
 490                  ^
 491                   (.*?) (?:(?:[^\\]|^)# (.*))?
 492                  $
 493 REGEX
 494
 495 sub _is_test {
 496     my($self, $line, $test) = @_;
 497
 498     # We pulverize the line down into pieces in three parts.
 499     if( my($not, $num, $extra)    = $line  =~ /$Report_Re/ox ) {
 500         my($name, $control) = split /(?:[^\\]|^)#/, $extra if $extra;
 501         my($type, $reason)  = $control =~ /^\s*(\S+)(?:\s+(.*))?$/ if $control;
 502
 503         $test->{number} = $num;
 504         $test->{ok}     = $not ? 0 : 1;
 505         $test->{name}   = $name;
 506
 507         if( defined $type ) {
 508             $test->{type}   = $type =~ /^TODO$/i ? 'todo' :
 509                               $type =~ /^Skip/i  ? 'skip' : 0;
 510         }
 511         else {
 512             $test->{type} = '';
 513         }
 514         $test->{reason} = $reason;
 515
 516         return $YES;
 517     }
 518     else{
 519         # Sometimes the "not " and "ok" will be on seperate lines on VMS.
 520         # We catch this and remember we saw it.
 521         if( $line =~ /^not\s+$/ ) {
 522             $self->{saw_lone_not} = 1;
 523             $self->{lone_not_line} = $self->{line};
 524         }
 525
 526         return $NO;
 527     }
 528 }
 529
 530 =item B<_is_bail_out>
 531
 532   my $is_bail_out = $strap->_is_bail_out($line, \$reason);
 533
 534 Checks if the line is a "Bail out!".  Places the reason for bailing
 535 (if any) in $reason.
 536
 537 =cut
 538
 539 sub _is_bail_out {
 540     my($self, $line, $reason) = @_;
 541
 542     if( $line =~ /^Bail out!\s*(.*)/i ) {
 543         $$reason = $1 if $1;
 544         return $YES;
 545     }
 546     else {
 547         return $NO;
 548     }
 549 }
 550
 551 =item B<_reset_file_state>
 552
 553   $strap->_reset_file_state;
 554
 555 Resets things like $strap->{max}, $strap->{skip_all}, etc... so its
 556 ready to parse the next file.
 557
 558 =cut
 559
 560 sub _reset_file_state {
 561     my($self) = shift;
 562
 563     delete @{$self}{qw(max skip_all todo)};
 564     $self->{line}       = 0;
 565     $self->{saw_header} = 0;
 566     $self->{saw_bailout}= 0;
 567     $self->{saw_lone_not} = 0;
 568     $self->{lone_not_line} = 0;
 569     $self->{bailout_reason} = '';
 570     $self->{'next'}       = 1;
 571 }
 572
 573 =back
 574
 575 =end _private
 576
 577
 578 =head2 Results
 579
 580 The %results returned from analyze() contain the following information:
 581
 582   passing           true if the whole test is considered a pass
 583                     (or skipped), false if its a failure
 584
 585   exit              the exit code of the test run, if from a file
 586   wait              the wait code of the test run, if from a file
 587
 588   max               total tests which should have been run
 589   seen              total tests actually seen
 590   skip_all          if the whole test was skipped, this will
 591                       contain the reason.
 592
 593   ok                number of tests which passed
 594                       (including todo and skips)
 595
 596   todo              number of todo tests seen
 597   bonus             number of todo tests which
 598                       unexpectedly passed
 599
 600   skip              number of tests skipped
 601
 602 So a successful test should have max == seen == ok.
 603
 604
 605 There is one final item, the details.
 606
 607   details           an array ref reporting the result of
 608                     each test looks like this:
 609
 610     $results{details}[$test_num - 1] =
 611             { ok        => is the test considered ok?
 612               actual_ok => did it literally say 'ok'?
 613               name      => name of the test (if any)
 614               type      => 'skip' or 'todo' (if any)
 615               reason    => reason for the above (if any)
 616             };
 617
 618 Element 0 of the details is test #1.  I tried it with element 1 being
 619 #1 and 0 being empty, this is less awkward.
 620
 621 =begin _private
 622
 623 =over 4
 624
 625 =item B<_detailize>
 626
 627   my %details = $strap->_detailize($pass, \%test);
 628
 629 Generates the details based on the last test line seen.  $pass is true
 630 if it was considered to be a passed test.  %test is the results of the
 631 test you're summarizing.
 632
 633 =cut
 634
 635 sub _detailize {
 636     my($self, $pass, $test) = @_;
 637
 638     my %details = ( ok         => $pass,
 639                     actual_ok  => $test->{ok}
 640                   );
 641
 642     assert( !(grep !defined $details{$_}, keys %details),
 643             'test contains the ok and actual_ok info' );
 644
 645     # We don't want these to be undef because they are often
 646     # checked and don't want the checker to have to deal with
 647     # uninitialized vars.
 648     foreach my $piece (qw(name type reason)) {
 649         $details{$piece} = defined $test->{$piece} ? $test->{$piece} : '';
 650     }
 651
 652     return %details;
 653 }
 654
 655 =back
 656
 657 =end _private
 658
 659 =head1 EXAMPLES
 660
 661 See F<examples/mini_harness.plx> for an example of use.
 662
 663 =head1 AUTHOR
 664
 665 Michael G Schwern E<lt>schwern@pobox.comE<gt>
 666
 667 =head1 SEE ALSO
 668
 669 L<Test::Harness>
 670
 671 =cut
 672
 673
 674 1;