[Summary view] [Print] [Text view]

   1  # -*- Mode: cperl; cperl-indent-level: 4 -*-
   2  package Test::Harness::Straps;
   3  
   4  use strict;
   5  use vars qw($VERSION);
   6  $VERSION = '0.26_01';
   7  
   8  use Config;
   9  use Test::Harness::Assert;
  10  use Test::Harness::Iterator;
  11  use Test::Harness::Point;
  12  use Test::Harness::Results;
  13  
  14  # Flags used as return values from our methods.  Just for internal 
  15  # clarification.
  16  my $YES   = (1==1);
  17  my $NO    = !$YES;
  18  
  19  =head1 NAME
  20  
  21  Test::Harness::Straps - detailed analysis of test results
  22  
  23  =head1 SYNOPSIS
  24  
  25    use Test::Harness::Straps;
  26  
  27    my $strap = Test::Harness::Straps->new;
  28  
  29    # Various ways to interpret a test
  30    my $results = $strap->analyze($name, \@test_output);
  31    my $results = $strap->analyze_fh($name, $test_filehandle);
  32    my $results = $strap->analyze_file($test_file);
  33  
  34    # UNIMPLEMENTED
  35    my %total = $strap->total_results;
  36  
  37    # Altering the behavior of the strap  UNIMPLEMENTED
  38    my $verbose_output = $strap->dump_verbose();
  39    $strap->dump_verbose_fh($output_filehandle);
  40  
  41  
  42  =head1 DESCRIPTION
  43  
  44  B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
  45  in incompatible ways.  It is otherwise stable.
  46  
  47  Test::Harness is limited to printing out its results.  This makes
  48  analysis of the test results difficult for anything but a human.  To
  49  make it easier for programs to work with test results, we provide
  50  Test::Harness::Straps.  Instead of printing the results, straps
  51  provide them as raw data.  You can also configure how the tests are to
  52  be run.
  53  
  54  The interface is currently incomplete.  I<Please> contact the author
  55  if you'd like a feature added or something change or just have
  56  comments.
  57  
  58  =head1 CONSTRUCTION
  59  
  60  =head2 new()
  61  
  62    my $strap = Test::Harness::Straps->new;
  63  
  64  Initialize a new strap.
  65  
  66  =cut
  67  
  68  sub new {
  69      my $class = shift;
  70      my $self  = bless {}, $class;
  71  
  72      $self->_init;
  73  
  74      return $self;
  75  }
  76  
  77  =for private $strap->_init
  78  
  79    $strap->_init;
  80  
  81  Initialize the internal state of a strap to make it ready for parsing.
  82  
  83  =cut
  84  
  85  sub _init {
  86      my($self) = shift;
  87  
  88      $self->{_is_vms}   = ( $^O eq 'VMS' );
  89      $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
  90      $self->{_is_macos} = ( $^O eq 'MacOS' );
  91  }
  92  
  93  =head1 ANALYSIS
  94  
  95  =head2 $strap->analyze( $name, \@output_lines )
  96  
  97      my $results = $strap->analyze($name, \@test_output);
  98  
  99  Analyzes the output of a single test, assigning it the given C<$name>
 100  for use in the total report.  Returns the C<$results> of the test.
 101  See L<Results>.
 102  
 103  C<@test_output> should be the raw output from the test, including
 104  newlines.
 105  
 106  =cut
 107  
 108  sub analyze {
 109      my($self, $name, $test_output) = @_;
 110  
 111      my $it = Test::Harness::Iterator->new($test_output);
 112      return $self->_analyze_iterator($name, $it);
 113  }
 114  
 115  
 116  sub _analyze_iterator {
 117      my($self, $name, $it) = @_;
 118  
 119      $self->_reset_file_state;
 120      $self->{file} = $name;
 121  
 122      my $results = Test::Harness::Results->new;
 123  
 124      # Set them up here so callbacks can have them.
 125      $self->{totals}{$name} = $results;
 126      while( defined(my $line = $it->next) ) {
 127          $self->_analyze_line($line, $results);
 128          last if $self->{saw_bailout};
 129      }
 130  
 131      $results->set_skip_all( $self->{skip_all} ) if defined $self->{skip_all};
 132  
 133      my $passed =
 134          (($results->max == 0) && defined $results->skip_all) ||
 135          ($results->max &&
 136           $results->seen &&
 137           $results->max == $results->seen &&
 138           $results->max == $results->ok);
 139  
 140      $results->set_passing( $passed ? 1 : 0 );
 141  
 142      return $results;
 143  }
 144  
 145  
 146  sub _analyze_line {
 147      my $self = shift;
 148      my $line = shift;
 149      my $results = shift;
 150  
 151      $self->{line}++;
 152  
 153      my $linetype;
 154      my $point = Test::Harness::Point->from_test_line( $line );
 155      if ( $point ) {
 156          $linetype = 'test';
 157  
 158          $results->inc_seen;
 159          $point->set_number( $self->{'next'} ) unless $point->number;
 160  
 161          # sometimes the 'not ' and the 'ok' are on different lines,
 162          # happens often on VMS if you do:
 163          #   print "not " unless $test;
 164          #   print "ok $num\n";
 165          if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) {
 166              $point->set_ok( 0 );
 167          }
 168  
 169          if ( $self->{todo}{$point->number} ) {
 170              $point->set_directive_type( 'todo' );
 171          }
 172  
 173          if ( $point->is_todo ) {
 174              $results->inc_todo;
 175              $results->inc_bonus if $point->ok;
 176          }
 177          elsif ( $point->is_skip ) {
 178              $results->inc_skip;
 179          }
 180  
 181          $results->inc_ok if $point->pass;
 182  
 183          if ( ($point->number > 100_000) && ($point->number > ($self->{max}||100_000)) ) {
 184              if ( !$self->{too_many_tests}++ ) {
 185                  warn "Enormous test number seen [test ", $point->number, "]\n";
 186                  warn "Can't detailize, too big.\n";
 187              }
 188          }
 189          else {
 190              my $details = {
 191                  ok          => $point->pass,
 192                  actual_ok   => $point->ok,
 193                  name        => _def_or_blank( $point->description ),
 194                  type        => _def_or_blank( $point->directive_type ),
 195                  reason      => _def_or_blank( $point->directive_reason ),
 196              };
 197  
 198              assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) );
 199              $results->set_details( $point->number, $details );
 200          }
 201      } # test point
 202      elsif ( $line =~ /^not\s+$/ ) {
 203          $linetype = 'other';
 204          # Sometimes the "not " and "ok" will be on separate lines on VMS.
 205          # We catch this and remember we saw it.
 206          $self->{lone_not_line} = $self->{line};
 207      }
 208      elsif ( $self->_is_header($line) ) {
 209          $linetype = 'header';
 210  
 211          $self->{saw_header}++;
 212  
 213          $results->inc_max( $self->{max} );
 214      }
 215      elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
 216          $linetype = 'bailout';
 217          $self->{saw_bailout} = 1;
 218      }
 219      elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) {
 220          $linetype = 'other';
 221          # XXX We can throw this away, really.
 222          my $test = $results->details->[-1];
 223          $test->{diagnostics} ||=  '';
 224          $test->{diagnostics}  .= $diagnostics;
 225      }
 226      else {
 227          $linetype = 'other';
 228      }
 229  
 230      $self->callback->($self, $line, $linetype, $results) if $self->callback;
 231  
 232      $self->{'next'} = $point->number + 1 if $point;
 233  } # _analyze_line
 234  
 235  
 236  sub _is_diagnostic_line {
 237      my ($self, $line) = @_;
 238      return if index( $line, '# Looks like you failed' ) == 0;
 239      $line =~ s/^#\s//;
 240      return $line;
 241  }
 242  
 243  =for private $strap->analyze_fh( $name, $test_filehandle )
 244  
 245      my $results = $strap->analyze_fh($name, $test_filehandle);
 246  
 247  Like C<analyze>, but it reads from the given filehandle.
 248  
 249  =cut
 250  
 251  sub analyze_fh {
 252      my($self, $name, $fh) = @_;
 253  
 254      my $it = Test::Harness::Iterator->new($fh);
 255      return $self->_analyze_iterator($name, $it);
 256  }
 257  
 258  =head2 $strap->analyze_file( $test_file )
 259  
 260      my $results = $strap->analyze_file($test_file);
 261  
 262  Like C<analyze>, but it runs the given C<$test_file> and parses its
 263  results.  It will also use that name for the total report.
 264  
 265  =cut
 266  
 267  sub analyze_file {
 268      my($self, $file) = @_;
 269  
 270      unless( -e $file ) {
 271          $self->{error} = "$file does not exist";
 272          return;
 273      }
 274  
 275      unless( -r $file ) {
 276          $self->{error} = "$file is not readable";
 277          return;
 278      }
 279  
 280      local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
 281      if ( $Test::Harness::Debug ) {
 282          local $^W=0; # ignore undef warnings
 283          print "# PERL5LIB=$ENV{PERL5LIB}\n";
 284      }
 285  
 286      # *sigh* this breaks under taint, but open -| is unportable.
 287      my $line = $self->_command_line($file);
 288  
 289      unless ( open(FILE, "$line|" )) {
 290          print "can't run $file. $!\n";
 291          return;
 292      }
 293  
 294      my $results = $self->analyze_fh($file, \*FILE);
 295      my $exit    = close FILE;
 296  
 297      $results->set_wait($?);
 298      if ( $? && $self->{_is_vms} ) {
 299          $results->set_exit($?);
 300      }
 301      else {
 302          $results->set_exit( _wait2exit($?) );
 303      }
 304      $results->set_passing(0) unless $? == 0;
 305  
 306      $self->_restore_PERL5LIB();
 307  
 308      return $results;
 309  }
 310  
 311  
 312  eval { require POSIX; &POSIX::WEXITSTATUS(0) };
 313  if( $@ ) {
 314      *_wait2exit = sub { $_[0] >> 8 };
 315  }
 316  else {
 317      *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
 318  }
 319  
 320  =for private $strap->_command_line( $file )
 321  
 322  Returns the full command line that will be run to test I<$file>.
 323  
 324  =cut
 325  
 326  sub _command_line {
 327      my $self = shift;
 328      my $file = shift;
 329  
 330      my $command =  $self->_command();
 331      my $switches = $self->_switches($file);
 332  
 333      $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
 334      my $line = "$command $switches $file";
 335  
 336      return $line;
 337  }
 338  
 339  
 340  =for private $strap->_command()
 341  
 342  Returns the command that runs the test.  Combine this with C<_switches()>
 343  to build a command line.
 344  
 345  Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}>
 346  to use a different Perl than what you're running the harness under.
 347  This might be to run a threaded Perl, for example.
 348  
 349  You can also overload this method if you've built your own strap subclass,
 350  such as a PHP interpreter for a PHP-based strap.
 351  
 352  =cut
 353  
 354  sub _command {
 355      my $self = shift;
 356  
 357      return $ENV{HARNESS_PERL}   if defined $ENV{HARNESS_PERL};
 358      #return qq["$^X"]            if $self->{_is_win32} && ($^X =~ /[^\w\.\/\\]/);
 359      return qq["$^X"]            if $^X =~ /\s/ and $^X !~ /^["']/;
 360      return $^X;
 361  }
 362  
 363  
 364  =for private $strap->_switches( $file )
 365  
 366  Formats and returns the switches necessary to run the test.
 367  
 368  =cut
 369  
 370  sub _switches {
 371      my($self, $file) = @_;
 372  
 373      my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
 374      my @derived_switches;
 375  
 376      local *TEST;
 377      open(TEST, $file) or print "can't open $file. $!\n";
 378      my $shebang = <TEST>;
 379      close(TEST) or print "can't close $file. $!\n";
 380  
 381      my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
 382      push( @derived_switches, "-$1" ) if $taint;
 383  
 384      # When taint mode is on, PERL5LIB is ignored.  So we need to put
 385      # all that on the command line as -Is.
 386      # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
 387      if ( $taint || $self->{_is_macos} ) {
 388      my @inc = $self->_filtered_INC;
 389      push @derived_switches, map { "-I$_" } @inc;
 390      }
 391  
 392      # Quote the argument if there's any whitespace in it, or if
 393      # we're VMS, since VMS requires all parms quoted.  Also, don't quote
 394      # it if it's already quoted.
 395      for ( @derived_switches ) {
 396      $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
 397      }
 398      return join( " ", @existing_switches, @derived_switches );
 399  }
 400  
 401  =for private $strap->_cleaned_switches( @switches_from_user )
 402  
 403  Returns only defined, non-blank, trimmed switches from the parms passed.
 404  
 405  =cut
 406  
 407  sub _cleaned_switches {
 408      my $self = shift;
 409  
 410      local $_;
 411  
 412      my @switches;
 413      for ( @_ ) {
 414      my $switch = $_;
 415      next unless defined $switch;
 416      $switch =~ s/^\s+//;
 417      $switch =~ s/\s+$//;
 418      push( @switches, $switch ) if $switch ne "";
 419      }
 420  
 421      return @switches;
 422  }
 423  
 424  =for private $strap->_INC2PERL5LIB
 425  
 426    local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
 427  
 428  Takes the current value of C<@INC> and turns it into something suitable
 429  for putting onto C<PERL5LIB>.
 430  
 431  =cut
 432  
 433  sub _INC2PERL5LIB {
 434      my($self) = shift;
 435  
 436      $self->{_old5lib} = $ENV{PERL5LIB};
 437  
 438      return join $Config{path_sep}, $self->_filtered_INC;
 439  }
 440  
 441  =for private $strap->_filtered_INC()
 442  
 443    my @filtered_inc = $self->_filtered_INC;
 444  
 445  Shortens C<@INC> by removing redundant and unnecessary entries.
 446  Necessary for OSes with limited command line lengths, like VMS.
 447  
 448  =cut
 449  
 450  sub _filtered_INC {
 451      my($self, @inc) = @_;
 452      @inc = @INC unless @inc;
 453  
 454      if( $self->{_is_vms} ) {
 455      # VMS has a 255-byte limit on the length of %ENV entries, so
 456      # toss the ones that involve perl_root, the install location
 457          @inc = grep !/perl_root/i, @inc;
 458  
 459      }
 460      elsif ( $self->{_is_win32} ) {
 461      # Lose any trailing backslashes in the Win32 paths
 462      s/[\\\/+]$// foreach @inc;
 463      }
 464  
 465      my %seen;
 466      $seen{$_}++ foreach $self->_default_inc();
 467      @inc = grep !$seen{$_}++, @inc;
 468  
 469      return @inc;
 470  }
 471  
 472  
 473  { # Without caching, _default_inc() takes a huge amount of time
 474      my %cache;
 475      sub _default_inc {
 476          my $self = shift;
 477          my $perl = $self->_command;
 478          $cache{$perl} ||= [do {
 479              local $ENV{PERL5LIB};
 480              my @inc =`$perl -le "print join qq[\\n], \@INC"`;
 481              chomp @inc;
 482          }];
 483          return @{$cache{$perl}};
 484      }
 485  }
 486  
 487  
 488  =for private $strap->_restore_PERL5LIB()
 489  
 490    $self->_restore_PERL5LIB;
 491  
 492  This restores the original value of the C<PERL5LIB> environment variable.
 493  Necessary on VMS, otherwise a no-op.
 494  
 495  =cut
 496  
 497  sub _restore_PERL5LIB {
 498      my($self) = shift;
 499  
 500      return unless $self->{_is_vms};
 501  
 502      if (defined $self->{_old5lib}) {
 503          $ENV{PERL5LIB} = $self->{_old5lib};
 504      }
 505  }
 506  
 507  =head1 Parsing
 508  
 509  Methods for identifying what sort of line you're looking at.
 510  
 511  =for private _is_diagnostic
 512  
 513      my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
 514  
 515  Checks if the given line is a comment.  If so, it will place it into
 516  C<$comment> (sans #).
 517  
 518  =cut
 519  
 520  sub _is_diagnostic {
 521      my($self, $line, $comment) = @_;
 522  
 523      if( $line =~ /^\s*\#(.*)/ ) {
 524          $$comment = $1;
 525          return $YES;
 526      }
 527      else {
 528          return $NO;
 529      }
 530  }
 531  
 532  =for private _is_header
 533  
 534    my $is_header = $strap->_is_header($line);
 535  
 536  Checks if the given line is a header (1..M) line.  If so, it places how
 537  many tests there will be in C<< $strap->{max} >>, a list of which tests
 538  are todo in C<< $strap->{todo} >> and if the whole test was skipped
 539  C<< $strap->{skip_all} >> contains the reason.
 540  
 541  =cut
 542  
 543  # Regex for parsing a header.  Will be run with /x
 544  my $Extra_Header_Re = <<'REGEX';
 545                         ^
 546                          (?: \s+ todo \s+ ([\d \t]+) )?      # optional todo set
 547                          (?: \s* \# \s* ([\w:]+\s?) (.*) )?     # optional skip with optional reason
 548  REGEX
 549  
 550  sub _is_header {
 551      my($self, $line) = @_;
 552  
 553      if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
 554          $self->{max}  = $max;
 555          assert( $self->{max} >= 0,  'Max # of tests looks right' );
 556  
 557          if( defined $extra ) {
 558              my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
 559  
 560              $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
 561  
 562              if( $self->{max} == 0 ) {
 563                  $reason = '' unless defined $skip and $skip =~ /^Skip/i;
 564              }
 565  
 566              $self->{skip_all} = $reason;
 567          }
 568  
 569          return $YES;
 570      }
 571      else {
 572          return $NO;
 573      }
 574  }
 575  
 576  =for private _is_bail_out
 577  
 578    my $is_bail_out = $strap->_is_bail_out($line, \$reason);
 579  
 580  Checks if the line is a "Bail out!".  Places the reason for bailing
 581  (if any) in $reason.
 582  
 583  =cut
 584  
 585  sub _is_bail_out {
 586      my($self, $line, $reason) = @_;
 587  
 588      if( $line =~ /^Bail out!\s*(.*)/i ) {
 589          $$reason = $1 if $1;
 590          return $YES;
 591      }
 592      else {
 593          return $NO;
 594      }
 595  }
 596  
 597  =for private _reset_file_state
 598  
 599    $strap->_reset_file_state;
 600  
 601  Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
 602  etc. so it's ready to parse the next file.
 603  
 604  =cut
 605  
 606  sub _reset_file_state {
 607      my($self) = shift;
 608  
 609      delete @{$self}{qw(max skip_all todo too_many_tests)};
 610      $self->{line}       = 0;
 611      $self->{saw_header} = 0;
 612      $self->{saw_bailout}= 0;
 613      $self->{lone_not_line} = 0;
 614      $self->{bailout_reason} = '';
 615      $self->{'next'}       = 1;
 616  }
 617  
 618  =head1 EXAMPLES
 619  
 620  See F<examples/mini_harness.plx> for an example of use.
 621  
 622  =head1 AUTHOR
 623  
 624  Michael G Schwern C<< <schwern at pobox.com> >>, currently maintained by
 625  Andy Lester C<< <andy at petdance.com> >>.
 626  
 627  =head1 SEE ALSO
 628  
 629  L<Test::Harness>
 630  
 631  =cut
 632  
 633  sub _def_or_blank {
 634      return $_[0] if defined $_[0];
 635      return "";
 636  }
 637  
 638  sub set_callback {
 639      my $self = shift;
 640      $self->{callback} = shift;
 641  }
 642  
 643  sub callback {
 644      my $self = shift;
 645      return $self->{callback};
 646  }
 647  
 648  1;