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