SecurityTests/regressions/inc/Test/Harness/Straps.pm

   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;