| 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'; |
| 7 | |
| 8 | use Config; |
| 9 | use Test::Harness::Assert; |
| 10 | use Test::Harness::Iterator; |
| 11 | use Test::Harness::Point; |
| 12 | |
| 13 | # Flags used as return values from our methods. Just for internal |
| 14 | # clarification. |
| 15 | my $YES = (1==1); |
| 16 | my $NO = !$YES; |
| 17 | |
| 18 | =head1 NAME |
| 19 | |
| 20 | Test::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 | |
| 43 | B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change |
| 44 | in incompatible ways. It is otherwise stable. |
| 45 | |
| 46 | Test::Harness is limited to printing out its results. This makes |
| 47 | analysis of the test results difficult for anything but a human. To |
| 48 | make it easier for programs to work with test results, we provide |
| 49 | Test::Harness::Straps. Instead of printing the results, straps |
| 50 | provide them as raw data. You can also configure how the tests are to |
| 51 | be run. |
| 52 | |
| 53 | The interface is currently incomplete. I<Please> contact the author |
| 54 | if you'd like a feature added or something change or just have |
| 55 | comments. |
| 56 | |
| 57 | =head1 CONSTRUCTION |
| 58 | |
| 59 | =head2 new() |
| 60 | |
| 61 | my $strap = Test::Harness::Straps->new; |
| 62 | |
| 63 | Initialize a new strap. |
| 64 | |
| 65 | =cut |
| 66 | |
| 67 | sub new { |
| 68 | my $class = shift; |
| 69 | my $self = bless {}, $class; |
| 70 | |
| 71 | $self->_init; |
| 72 | |
| 73 | return $self; |
| 74 | } |
| 75 | |
| 76 | =head2 $strap->_init |
| 77 | |
| 78 | $strap->_init; |
| 79 | |
| 80 | Initialize the internal state of a strap to make it ready for parsing. |
| 81 | |
| 82 | =cut |
| 83 | |
| 84 | sub _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 | |
| 98 | Analyzes the output of a single test, assigning it the given C<$name> |
| 99 | for use in the total report. Returns the C<%results> of the test. |
| 100 | See L<Results>. |
| 101 | |
| 102 | C<@test_output> should be the raw output from the test, including |
| 103 | newlines. |
| 104 | |
| 105 | =cut |
| 106 | |
| 107 | sub 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 | |
| 115 | sub _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 | |
| 151 | sub _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 | |
| 240 | sub _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 | =head2 $strap->analyze_fh( $name, $test_filehandle ) |
| 248 | |
| 249 | my %results = $strap->analyze_fh($name, $test_filehandle); |
| 250 | |
| 251 | Like C<analyze>, but it reads from the given filehandle. |
| 252 | |
| 253 | =cut |
| 254 | |
| 255 | sub 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 | |
| 266 | Like C<analyze>, but it runs the given C<$test_file> and parses its |
| 267 | results. It will also use that name for the total report. |
| 268 | |
| 269 | =cut |
| 270 | |
| 271 | sub 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 | |
| 315 | eval { require POSIX; &POSIX::WEXITSTATUS(0) }; |
| 316 | if( $@ ) { |
| 317 | *_wait2exit = sub { $_[0] >> 8 }; |
| 318 | } |
| 319 | else { |
| 320 | *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) } |
| 321 | } |
| 322 | |
| 323 | =head2 $strap->_command_line( $file ) |
| 324 | |
| 325 | Returns the full command line that will be run to test I<$file>. |
| 326 | |
| 327 | =cut |
| 328 | |
| 329 | sub _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 | =head2 $strap->_command() |
| 344 | |
| 345 | Returns the command that runs the test. Combine this with C<_switches()> |
| 346 | to build a command line. |
| 347 | |
| 348 | Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}> |
| 349 | to use a different Perl than what you're running the harness under. |
| 350 | This might be to run a threaded Perl, for example. |
| 351 | |
| 352 | You can also overload this method if you've built your own strap subclass, |
| 353 | such as a PHP interpreter for a PHP-based strap. |
| 354 | |
| 355 | =cut |
| 356 | |
| 357 | sub _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 | =head2 $strap->_switches( $file ) |
| 367 | |
| 368 | Formats and returns the switches necessary to run the test. |
| 369 | |
| 370 | =cut |
| 371 | |
| 372 | sub _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 | =head2 $strap->_cleaned_switches( @switches_from_user ) |
| 404 | |
| 405 | Returns only defined, non-blank, trimmed switches from the parms passed. |
| 406 | |
| 407 | =cut |
| 408 | |
| 409 | sub _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 | =head2 $strap->_INC2PERL5LIB |
| 427 | |
| 428 | local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; |
| 429 | |
| 430 | Takes the current value of C<@INC> and turns it into something suitable |
| 431 | for putting onto C<PERL5LIB>. |
| 432 | |
| 433 | =cut |
| 434 | |
| 435 | sub _INC2PERL5LIB { |
| 436 | my($self) = shift; |
| 437 | |
| 438 | $self->{_old5lib} = $ENV{PERL5LIB}; |
| 439 | |
| 440 | return join $Config{path_sep}, $self->_filtered_INC; |
| 441 | } |
| 442 | |
| 443 | =head2 $strap->_filtered_INC() |
| 444 | |
| 445 | my @filtered_inc = $self->_filtered_INC; |
| 446 | |
| 447 | Shortens C<@INC> by removing redundant and unnecessary entries. |
| 448 | Necessary for OSes with limited command line lengths, like VMS. |
| 449 | |
| 450 | =cut |
| 451 | |
| 452 | sub _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 | sub _default_inc { |
| 476 | my $self = shift; |
| 477 | |
| 478 | local $ENV{PERL5LIB}; |
| 479 | my $perl = $self->_command; |
| 480 | my @inc =`$perl -le "print join qq[\\n], \@INC"`; |
| 481 | chomp @inc; |
| 482 | return @inc; |
| 483 | } |
| 484 | |
| 485 | |
| 486 | =head2 $strap->_restore_PERL5LIB() |
| 487 | |
| 488 | $self->_restore_PERL5LIB; |
| 489 | |
| 490 | This restores the original value of the C<PERL5LIB> environment variable. |
| 491 | Necessary on VMS, otherwise a no-op. |
| 492 | |
| 493 | =cut |
| 494 | |
| 495 | sub _restore_PERL5LIB { |
| 496 | my($self) = shift; |
| 497 | |
| 498 | return unless $self->{_is_vms}; |
| 499 | |
| 500 | if (defined $self->{_old5lib}) { |
| 501 | $ENV{PERL5LIB} = $self->{_old5lib}; |
| 502 | } |
| 503 | } |
| 504 | |
| 505 | =head1 Parsing |
| 506 | |
| 507 | Methods for identifying what sort of line you're looking at. |
| 508 | |
| 509 | =head2 C<_is_diagnostic> |
| 510 | |
| 511 | my $is_diagnostic = $strap->_is_diagnostic($line, \$comment); |
| 512 | |
| 513 | Checks if the given line is a comment. If so, it will place it into |
| 514 | C<$comment> (sans #). |
| 515 | |
| 516 | =cut |
| 517 | |
| 518 | sub _is_diagnostic { |
| 519 | my($self, $line, $comment) = @_; |
| 520 | |
| 521 | if( $line =~ /^\s*\#(.*)/ ) { |
| 522 | $$comment = $1; |
| 523 | return $YES; |
| 524 | } |
| 525 | else { |
| 526 | return $NO; |
| 527 | } |
| 528 | } |
| 529 | |
| 530 | =head2 C<_is_header> |
| 531 | |
| 532 | my $is_header = $strap->_is_header($line); |
| 533 | |
| 534 | Checks if the given line is a header (1..M) line. If so, it places how |
| 535 | many tests there will be in C<< $strap->{max} >>, a list of which tests |
| 536 | are todo in C<< $strap->{todo} >> and if the whole test was skipped |
| 537 | C<< $strap->{skip_all} >> contains the reason. |
| 538 | |
| 539 | =cut |
| 540 | |
| 541 | # Regex for parsing a header. Will be run with /x |
| 542 | my $Extra_Header_Re = <<'REGEX'; |
| 543 | ^ |
| 544 | (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set |
| 545 | (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason |
| 546 | REGEX |
| 547 | |
| 548 | sub _is_header { |
| 549 | my($self, $line) = @_; |
| 550 | |
| 551 | if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) { |
| 552 | $self->{max} = $max; |
| 553 | assert( $self->{max} >= 0, 'Max # of tests looks right' ); |
| 554 | |
| 555 | if( defined $extra ) { |
| 556 | my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo; |
| 557 | |
| 558 | $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo; |
| 559 | |
| 560 | if( $self->{max} == 0 ) { |
| 561 | $reason = '' unless defined $skip and $skip =~ /^Skip/i; |
| 562 | } |
| 563 | |
| 564 | $self->{skip_all} = $reason; |
| 565 | } |
| 566 | |
| 567 | return $YES; |
| 568 | } |
| 569 | else { |
| 570 | return $NO; |
| 571 | } |
| 572 | } |
| 573 | |
| 574 | =head2 C<_is_bail_out> |
| 575 | |
| 576 | my $is_bail_out = $strap->_is_bail_out($line, \$reason); |
| 577 | |
| 578 | Checks if the line is a "Bail out!". Places the reason for bailing |
| 579 | (if any) in $reason. |
| 580 | |
| 581 | =cut |
| 582 | |
| 583 | sub _is_bail_out { |
| 584 | my($self, $line, $reason) = @_; |
| 585 | |
| 586 | if( $line =~ /^Bail out!\s*(.*)/i ) { |
| 587 | $$reason = $1 if $1; |
| 588 | return $YES; |
| 589 | } |
| 590 | else { |
| 591 | return $NO; |
| 592 | } |
| 593 | } |
| 594 | |
| 595 | =head2 C<_reset_file_state> |
| 596 | |
| 597 | $strap->_reset_file_state; |
| 598 | |
| 599 | Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>, |
| 600 | etc. so it's ready to parse the next file. |
| 601 | |
| 602 | =cut |
| 603 | |
| 604 | sub _reset_file_state { |
| 605 | my($self) = shift; |
| 606 | |
| 607 | delete @{$self}{qw(max skip_all todo too_many_tests)}; |
| 608 | $self->{line} = 0; |
| 609 | $self->{saw_header} = 0; |
| 610 | $self->{saw_bailout}= 0; |
| 611 | $self->{lone_not_line} = 0; |
| 612 | $self->{bailout_reason} = ''; |
| 613 | $self->{'next'} = 1; |
| 614 | } |
| 615 | |
| 616 | =head1 Results |
| 617 | |
| 618 | The C<%results> returned from C<analyze()> contain the following |
| 619 | information: |
| 620 | |
| 621 | passing true if the whole test is considered a pass |
| 622 | (or skipped), false if its a failure |
| 623 | |
| 624 | exit the exit code of the test run, if from a file |
| 625 | wait the wait code of the test run, if from a file |
| 626 | |
| 627 | max total tests which should have been run |
| 628 | seen total tests actually seen |
| 629 | skip_all if the whole test was skipped, this will |
| 630 | contain the reason. |
| 631 | |
| 632 | ok number of tests which passed |
| 633 | (including todo and skips) |
| 634 | |
| 635 | todo number of todo tests seen |
| 636 | bonus number of todo tests which |
| 637 | unexpectedly passed |
| 638 | |
| 639 | skip number of tests skipped |
| 640 | |
| 641 | So a successful test should have max == seen == ok. |
| 642 | |
| 643 | |
| 644 | There is one final item, the details. |
| 645 | |
| 646 | details an array ref reporting the result of |
| 647 | each test looks like this: |
| 648 | |
| 649 | $results{details}[$test_num - 1] = |
| 650 | { ok => is the test considered ok? |
| 651 | actual_ok => did it literally say 'ok'? |
| 652 | name => name of the test (if any) |
| 653 | diagnostics => test diagnostics (if any) |
| 654 | type => 'skip' or 'todo' (if any) |
| 655 | reason => reason for the above (if any) |
| 656 | }; |
| 657 | |
| 658 | Element 0 of the details is test #1. I tried it with element 1 being |
| 659 | #1 and 0 being empty, this is less awkward. |
| 660 | |
| 661 | =head1 EXAMPLES |
| 662 | |
| 663 | See F<examples/mini_harness.plx> for an example of use. |
| 664 | |
| 665 | =head1 AUTHOR |
| 666 | |
| 667 | Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by |
| 668 | Andy Lester C<< <andy@petdance.com> >>. |
| 669 | |
| 670 | =head1 SEE ALSO |
| 671 | |
| 672 | L<Test::Harness> |
| 673 | |
| 674 | =cut |
| 675 | |
| 676 | sub _def_or_blank { |
| 677 | return $_[0] if defined $_[0]; |
| 678 | return ""; |
| 679 | } |
| 680 | |
| 681 | 1; |