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