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