lib/Test/Harness/Straps.pm

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