1#line 1 2package Test::Builder; 3 4use 5.004; 5 6# $^C was only introduced in 5.005-ish. We do this to prevent 7# use of uninitialized value warnings in older perls. 8$^C ||= 0; 9 10use strict; 11use vars qw($VERSION); 12$VERSION = '0.74'; 13$VERSION = eval $VERSION; # make the alpha version come out as a number 14 15# Make Test::Builder thread-safe for ithreads. 16BEGIN { 17 use Config; 18 # Load threads::shared when threads are turned on. 19 # 5.8.0's threads are so busted we no longer support them. 20 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) { 21 require threads::shared; 22 23 # Hack around YET ANOTHER threads::shared bug. It would 24 # occassionally forget the contents of the variable when sharing it. 25 # So we first copy the data, then share, then put our copy back. 26 *share = sub (\[$@%]) { 27 my $type = ref $_[0]; 28 my $data; 29 30 if( $type eq 'HASH' ) { 31 %$data = %{$_[0]}; 32 } 33 elsif( $type eq 'ARRAY' ) { 34 @$data = @{$_[0]}; 35 } 36 elsif( $type eq 'SCALAR' ) { 37 $$data = ${$_[0]}; 38 } 39 else { 40 die("Unknown type: ".$type); 41 } 42 43 $_[0] = &threads::shared::share($_[0]); 44 45 if( $type eq 'HASH' ) { 46 %{$_[0]} = %$data; 47 } 48 elsif( $type eq 'ARRAY' ) { 49 @{$_[0]} = @$data; 50 } 51 elsif( $type eq 'SCALAR' ) { 52 ${$_[0]} = $$data; 53 } 54 else { 55 die("Unknown type: ".$type); 56 } 57 58 return $_[0]; 59 }; 60 } 61 # 5.8.0's threads::shared is busted when threads are off 62 # and earlier Perls just don't have that module at all. 63 else { 64 *share = sub { return $_[0] }; 65 *lock = sub { 0 }; 66 } 67} 68 69 70#line 128 71 72my $Test = Test::Builder->new; 73sub new { 74 my($class) = shift; 75 $Test ||= $class->create; 76 return $Test; 77} 78 79 80#line 150 81 82sub create { 83 my $class = shift; 84 85 my $self = bless {}, $class; 86 $self->reset; 87 88 return $self; 89} 90 91#line 169 92 93use vars qw($Level); 94 95sub reset { 96 my ($self) = @_; 97 98 # We leave this a global because it has to be localized and localizing 99 # hash keys is just asking for pain. Also, it was documented. 100 $Level = 1; 101 102 $self->{Test_Died} = 0; 103 $self->{Have_Plan} = 0; 104 $self->{No_Plan} = 0; 105 $self->{Original_Pid} = $$; 106 107 share($self->{Curr_Test}); 108 $self->{Curr_Test} = 0; 109 $self->{Test_Results} = &share([]); 110 111 $self->{Exported_To} = undef; 112 $self->{Expected_Tests} = 0; 113 114 $self->{Skip_All} = 0; 115 116 $self->{Use_Nums} = 1; 117 118 $self->{No_Header} = 0; 119 $self->{No_Ending} = 0; 120 121 $self->_dup_stdhandles unless $^C; 122 123 return undef; 124} 125 126#line 221 127 128sub exported_to { 129 my($self, $pack) = @_; 130 131 if( defined $pack ) { 132 $self->{Exported_To} = $pack; 133 } 134 return $self->{Exported_To}; 135} 136 137#line 243 138 139sub plan { 140 my($self, $cmd, $arg) = @_; 141 142 return unless $cmd; 143 144 local $Level = $Level + 1; 145 146 if( $self->{Have_Plan} ) { 147 $self->croak("You tried to plan twice"); 148 } 149 150 if( $cmd eq 'no_plan' ) { 151 $self->no_plan; 152 } 153 elsif( $cmd eq 'skip_all' ) { 154 return $self->skip_all($arg); 155 } 156 elsif( $cmd eq 'tests' ) { 157 if( $arg ) { 158 local $Level = $Level + 1; 159 return $self->expected_tests($arg); 160 } 161 elsif( !defined $arg ) { 162 $self->croak("Got an undefined number of tests"); 163 } 164 elsif( !$arg ) { 165 $self->croak("You said to run 0 tests"); 166 } 167 } 168 else { 169 my @args = grep { defined } ($cmd, $arg); 170 $self->croak("plan() doesn't understand @args"); 171 } 172 173 return 1; 174} 175 176#line 290 177 178sub expected_tests { 179 my $self = shift; 180 my($max) = @_; 181 182 if( @_ ) { 183 $self->croak("Number of tests must be a positive integer. You gave it '$max'") 184 unless $max =~ /^\+?\d+$/ and $max > 0; 185 186 $self->{Expected_Tests} = $max; 187 $self->{Have_Plan} = 1; 188 189 $self->_print("1..$max\n") unless $self->no_header; 190 } 191 return $self->{Expected_Tests}; 192} 193 194 195#line 315 196 197sub no_plan { 198 my $self = shift; 199 200 $self->{No_Plan} = 1; 201 $self->{Have_Plan} = 1; 202} 203 204#line 330 205 206sub has_plan { 207 my $self = shift; 208 209 return($self->{Expected_Tests}) if $self->{Expected_Tests}; 210 return('no_plan') if $self->{No_Plan}; 211 return(undef); 212}; 213 214 215#line 348 216 217sub skip_all { 218 my($self, $reason) = @_; 219 220 my $out = "1..0"; 221 $out .= " # Skip $reason" if $reason; 222 $out .= "\n"; 223 224 $self->{Skip_All} = 1; 225 226 $self->_print($out) unless $self->no_header; 227 exit(0); 228} 229 230#line 382 231 232sub ok { 233 my($self, $test, $name) = @_; 234 235 # $test might contain an object which we don't want to accidentally 236 # store, so we turn it into a boolean. 237 $test = $test ? 1 : 0; 238 239 $self->_plan_check; 240 241 lock $self->{Curr_Test}; 242 $self->{Curr_Test}++; 243 244 # In case $name is a string overloaded object, force it to stringify. 245 $self->_unoverload_str(\$name); 246 247 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/; 248 You named your test '$name'. You shouldn't use numbers for your test names. 249 Very confusing. 250ERR 251 252 my($pack, $file, $line) = $self->caller; 253 254 my $todo = $self->todo($pack); 255 $self->_unoverload_str(\$todo); 256 257 my $out; 258 my $result = &share({}); 259 260 unless( $test ) { 261 $out .= "not "; 262 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); 263 } 264 else { 265 @$result{ 'ok', 'actual_ok' } = ( 1, $test ); 266 } 267 268 $out .= "ok"; 269 $out .= " $self->{Curr_Test}" if $self->use_numbers; 270 271 if( defined $name ) { 272 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. 273 $out .= " - $name"; 274 $result->{name} = $name; 275 } 276 else { 277 $result->{name} = ''; 278 } 279 280 if( $todo ) { 281 $out .= " # TODO $todo"; 282 $result->{reason} = $todo; 283 $result->{type} = 'todo'; 284 } 285 else { 286 $result->{reason} = ''; 287 $result->{type} = ''; 288 } 289 290 $self->{Test_Results}[$self->{Curr_Test}-1] = $result; 291 $out .= "\n"; 292 293 $self->_print($out); 294 295 unless( $test ) { 296 my $msg = $todo ? "Failed (TODO)" : "Failed"; 297 $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; 298 299 if( defined $name ) { 300 $self->diag(qq[ $msg test '$name'\n]); 301 $self->diag(qq[ at $file line $line.\n]); 302 } 303 else { 304 $self->diag(qq[ $msg test at $file line $line.\n]); 305 } 306 } 307 308 return $test ? 1 : 0; 309} 310 311 312sub _unoverload { 313 my $self = shift; 314 my $type = shift; 315 316 $self->_try(sub { require overload } ) || return; 317 318 foreach my $thing (@_) { 319 if( $self->_is_object($$thing) ) { 320 if( my $string_meth = overload::Method($$thing, $type) ) { 321 $$thing = $$thing->$string_meth(); 322 } 323 } 324 } 325} 326 327 328sub _is_object { 329 my($self, $thing) = @_; 330 331 return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0; 332} 333 334 335sub _unoverload_str { 336 my $self = shift; 337 338 $self->_unoverload(q[""], @_); 339} 340 341sub _unoverload_num { 342 my $self = shift; 343 344 $self->_unoverload('0+', @_); 345 346 for my $val (@_) { 347 next unless $self->_is_dualvar($$val); 348 $$val = $$val+0; 349 } 350} 351 352 353# This is a hack to detect a dualvar such as $! 354sub _is_dualvar { 355 my($self, $val) = @_; 356 357 local $^W = 0; 358 my $numval = $val+0; 359 return 1 if $numval != 0 and $numval ne $val; 360} 361 362 363 364#line 530 365 366sub is_eq { 367 my($self, $got, $expect, $name) = @_; 368 local $Level = $Level + 1; 369 370 $self->_unoverload_str(\$got, \$expect); 371 372 if( !defined $got || !defined $expect ) { 373 # undef only matches undef and nothing else 374 my $test = !defined $got && !defined $expect; 375 376 $self->ok($test, $name); 377 $self->_is_diag($got, 'eq', $expect) unless $test; 378 return $test; 379 } 380 381 return $self->cmp_ok($got, 'eq', $expect, $name); 382} 383 384sub is_num { 385 my($self, $got, $expect, $name) = @_; 386 local $Level = $Level + 1; 387 388 $self->_unoverload_num(\$got, \$expect); 389 390 if( !defined $got || !defined $expect ) { 391 # undef only matches undef and nothing else 392 my $test = !defined $got && !defined $expect; 393 394 $self->ok($test, $name); 395 $self->_is_diag($got, '==', $expect) unless $test; 396 return $test; 397 } 398 399 return $self->cmp_ok($got, '==', $expect, $name); 400} 401 402sub _is_diag { 403 my($self, $got, $type, $expect) = @_; 404 405 foreach my $val (\$got, \$expect) { 406 if( defined $$val ) { 407 if( $type eq 'eq' ) { 408 # quote and force string context 409 $$val = "'$$val'" 410 } 411 else { 412 # force numeric context 413 $self->_unoverload_num($val); 414 } 415 } 416 else { 417 $$val = 'undef'; 418 } 419 } 420 421 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect); 422 got: %s 423 expected: %s 424DIAGNOSTIC 425 426} 427 428#line 608 429 430sub isnt_eq { 431 my($self, $got, $dont_expect, $name) = @_; 432 local $Level = $Level + 1; 433 434 if( !defined $got || !defined $dont_expect ) { 435 # undef only matches undef and nothing else 436 my $test = defined $got || defined $dont_expect; 437 438 $self->ok($test, $name); 439 $self->_cmp_diag($got, 'ne', $dont_expect) unless $test; 440 return $test; 441 } 442 443 return $self->cmp_ok($got, 'ne', $dont_expect, $name); 444} 445 446sub isnt_num { 447 my($self, $got, $dont_expect, $name) = @_; 448 local $Level = $Level + 1; 449 450 if( !defined $got || !defined $dont_expect ) { 451 # undef only matches undef and nothing else 452 my $test = defined $got || defined $dont_expect; 453 454 $self->ok($test, $name); 455 $self->_cmp_diag($got, '!=', $dont_expect) unless $test; 456 return $test; 457 } 458 459 return $self->cmp_ok($got, '!=', $dont_expect, $name); 460} 461 462 463#line 660 464 465sub like { 466 my($self, $this, $regex, $name) = @_; 467 468 local $Level = $Level + 1; 469 $self->_regex_ok($this, $regex, '=~', $name); 470} 471 472sub unlike { 473 my($self, $this, $regex, $name) = @_; 474 475 local $Level = $Level + 1; 476 $self->_regex_ok($this, $regex, '!~', $name); 477} 478 479 480#line 685 481 482 483my %numeric_cmps = map { ($_, 1) } 484 ("<", "<=", ">", ">=", "==", "!=", "<=>"); 485 486sub cmp_ok { 487 my($self, $got, $type, $expect, $name) = @_; 488 489 # Treat overloaded objects as numbers if we're asked to do a 490 # numeric comparison. 491 my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' 492 : '_unoverload_str'; 493 494 $self->$unoverload(\$got, \$expect); 495 496 497 my $test; 498 { 499 local($@,$!,$SIG{__DIE__}); # isolate eval 500 501 my $code = $self->_caller_context; 502 503 # Yes, it has to look like this or 5.4.5 won't see the #line directive. 504 # Don't ask me, man, I just work here. 505 $test = eval " 506$code" . "\$got $type \$expect;"; 507 508 } 509 local $Level = $Level + 1; 510 my $ok = $self->ok($test, $name); 511 512 unless( $ok ) { 513 if( $type =~ /^(eq|==)$/ ) { 514 $self->_is_diag($got, $type, $expect); 515 } 516 else { 517 $self->_cmp_diag($got, $type, $expect); 518 } 519 } 520 return $ok; 521} 522 523sub _cmp_diag { 524 my($self, $got, $type, $expect) = @_; 525 526 $got = defined $got ? "'$got'" : 'undef'; 527 $expect = defined $expect ? "'$expect'" : 'undef'; 528 return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect); 529 %s 530 %s 531 %s 532DIAGNOSTIC 533} 534 535 536sub _caller_context { 537 my $self = shift; 538 539 my($pack, $file, $line) = $self->caller(1); 540 541 my $code = ''; 542 $code .= "#line $line $file\n" if defined $file and defined $line; 543 544 return $code; 545} 546 547#line 771 548 549sub BAIL_OUT { 550 my($self, $reason) = @_; 551 552 $self->{Bailed_Out} = 1; 553 $self->_print("Bail out! $reason"); 554 exit 255; 555} 556 557#line 784 558 559*BAILOUT = \&BAIL_OUT; 560 561 562#line 796 563 564sub skip { 565 my($self, $why) = @_; 566 $why ||= ''; 567 $self->_unoverload_str(\$why); 568 569 $self->_plan_check; 570 571 lock($self->{Curr_Test}); 572 $self->{Curr_Test}++; 573 574 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 575 'ok' => 1, 576 actual_ok => 1, 577 name => '', 578 type => 'skip', 579 reason => $why, 580 }); 581 582 my $out = "ok"; 583 $out .= " $self->{Curr_Test}" if $self->use_numbers; 584 $out .= " # skip"; 585 $out .= " $why" if length $why; 586 $out .= "\n"; 587 588 $self->_print($out); 589 590 return 1; 591} 592 593 594#line 838 595 596sub todo_skip { 597 my($self, $why) = @_; 598 $why ||= ''; 599 600 $self->_plan_check; 601 602 lock($self->{Curr_Test}); 603 $self->{Curr_Test}++; 604 605 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 606 'ok' => 1, 607 actual_ok => 0, 608 name => '', 609 type => 'todo_skip', 610 reason => $why, 611 }); 612 613 my $out = "not ok"; 614 $out .= " $self->{Curr_Test}" if $self->use_numbers; 615 $out .= " # TODO & SKIP $why\n"; 616 617 $self->_print($out); 618 619 return 1; 620} 621 622 623#line 916 624 625 626sub maybe_regex { 627 my ($self, $regex) = @_; 628 my $usable_regex = undef; 629 630 return $usable_regex unless defined $regex; 631 632 my($re, $opts); 633 634 # Check for qr/foo/ 635 if( ref $regex eq 'Regexp' ) { 636 $usable_regex = $regex; 637 } 638 # Check for '/foo/' or 'm,foo,' 639 elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or 640 (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx 641 ) 642 { 643 $usable_regex = length $opts ? "(?$opts)$re" : $re; 644 } 645 646 return $usable_regex; 647}; 648 649sub _regex_ok { 650 my($self, $this, $regex, $cmp, $name) = @_; 651 652 my $ok = 0; 653 my $usable_regex = $self->maybe_regex($regex); 654 unless (defined $usable_regex) { 655 $ok = $self->ok( 0, $name ); 656 $self->diag(" '$regex' doesn't look much like a regex to me."); 657 return $ok; 658 } 659 660 { 661 my $test; 662 my $code = $self->_caller_context; 663 664 local($@, $!, $SIG{__DIE__}); # isolate eval 665 666 # Yes, it has to look like this or 5.4.5 won't see the #line directive. 667 # Don't ask me, man, I just work here. 668 $test = eval " 669$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; 670 671 $test = !$test if $cmp eq '!~'; 672 673 local $Level = $Level + 1; 674 $ok = $self->ok( $test, $name ); 675 } 676 677 unless( $ok ) { 678 $this = defined $this ? "'$this'" : 'undef'; 679 my $match = $cmp eq '=~' ? "doesn't match" : "matches"; 680 $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex); 681 %s 682 %13s '%s' 683DIAGNOSTIC 684 685 } 686 687 return $ok; 688} 689 690 691# I'm not ready to publish this. It doesn't deal with array return 692# values from the code or context. 693 694#line 1000 695 696sub _try { 697 my($self, $code) = @_; 698 699 local $!; # eval can mess up $! 700 local $@; # don't set $@ in the test 701 local $SIG{__DIE__}; # don't trip an outside DIE handler. 702 my $return = eval { $code->() }; 703 704 return wantarray ? ($return, $@) : $return; 705} 706 707#line 1022 708 709sub is_fh { 710 my $self = shift; 711 my $maybe_fh = shift; 712 return 0 unless defined $maybe_fh; 713 714 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref 715 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob 716 717 return eval { $maybe_fh->isa("IO::Handle") } || 718 # 5.5.4's tied() and can() doesn't like getting undef 719 eval { (tied($maybe_fh) || '')->can('TIEHANDLE') }; 720} 721 722 723#line 1067 724 725sub level { 726 my($self, $level) = @_; 727 728 if( defined $level ) { 729 $Level = $level; 730 } 731 return $Level; 732} 733 734 735#line 1100 736 737sub use_numbers { 738 my($self, $use_nums) = @_; 739 740 if( defined $use_nums ) { 741 $self->{Use_Nums} = $use_nums; 742 } 743 return $self->{Use_Nums}; 744} 745 746 747#line 1134 748 749foreach my $attribute (qw(No_Header No_Ending No_Diag)) { 750 my $method = lc $attribute; 751 752 my $code = sub { 753 my($self, $no) = @_; 754 755 if( defined $no ) { 756 $self->{$attribute} = $no; 757 } 758 return $self->{$attribute}; 759 }; 760 761 no strict 'refs'; 762 *{__PACKAGE__.'::'.$method} = $code; 763} 764 765 766#line 1188 767 768sub diag { 769 my($self, @msgs) = @_; 770 771 return if $self->no_diag; 772 return unless @msgs; 773 774 # Prevent printing headers when compiling (i.e. -c) 775 return if $^C; 776 777 # Smash args together like print does. 778 # Convert undef to 'undef' so its readable. 779 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; 780 781 # Escape each line with a #. 782 $msg =~ s/^/# /gm; 783 784 # Stick a newline on the end if it needs it. 785 $msg .= "\n" unless $msg =~ /\n\Z/; 786 787 local $Level = $Level + 1; 788 $self->_print_diag($msg); 789 790 return 0; 791} 792 793#line 1225 794 795sub _print { 796 my($self, @msgs) = @_; 797 798 # Prevent printing headers when only compiling. Mostly for when 799 # tests are deparsed with B::Deparse 800 return if $^C; 801 802 my $msg = join '', @msgs; 803 804 local($\, $", $,) = (undef, ' ', ''); 805 my $fh = $self->output; 806 807 # Escape each line after the first with a # so we don't 808 # confuse Test::Harness. 809 $msg =~ s/\n(.)/\n# $1/sg; 810 811 # Stick a newline on the end if it needs it. 812 $msg .= "\n" unless $msg =~ /\n\Z/; 813 814 print $fh $msg; 815} 816 817#line 1259 818 819sub _print_diag { 820 my $self = shift; 821 822 local($\, $", $,) = (undef, ' ', ''); 823 my $fh = $self->todo ? $self->todo_output : $self->failure_output; 824 print $fh @_; 825} 826 827#line 1296 828 829sub output { 830 my($self, $fh) = @_; 831 832 if( defined $fh ) { 833 $self->{Out_FH} = $self->_new_fh($fh); 834 } 835 return $self->{Out_FH}; 836} 837 838sub failure_output { 839 my($self, $fh) = @_; 840 841 if( defined $fh ) { 842 $self->{Fail_FH} = $self->_new_fh($fh); 843 } 844 return $self->{Fail_FH}; 845} 846 847sub todo_output { 848 my($self, $fh) = @_; 849 850 if( defined $fh ) { 851 $self->{Todo_FH} = $self->_new_fh($fh); 852 } 853 return $self->{Todo_FH}; 854} 855 856 857sub _new_fh { 858 my $self = shift; 859 my($file_or_fh) = shift; 860 861 my $fh; 862 if( $self->is_fh($file_or_fh) ) { 863 $fh = $file_or_fh; 864 } 865 else { 866 $fh = do { local *FH }; 867 open $fh, ">$file_or_fh" or 868 $self->croak("Can't open test output log $file_or_fh: $!"); 869 _autoflush($fh); 870 } 871 872 return $fh; 873} 874 875 876sub _autoflush { 877 my($fh) = shift; 878 my $old_fh = select $fh; 879 $| = 1; 880 select $old_fh; 881} 882 883 884sub _dup_stdhandles { 885 my $self = shift; 886 887 $self->_open_testhandles; 888 889 # Set everything to unbuffered else plain prints to STDOUT will 890 # come out in the wrong order from our own prints. 891 _autoflush(\*TESTOUT); 892 _autoflush(\*STDOUT); 893 _autoflush(\*TESTERR); 894 _autoflush(\*STDERR); 895 896 $self->output(\*TESTOUT); 897 $self->failure_output(\*TESTERR); 898 $self->todo_output(\*TESTOUT); 899} 900 901 902my $Opened_Testhandles = 0; 903sub _open_testhandles { 904 return if $Opened_Testhandles; 905 # We dup STDOUT and STDERR so people can change them in their 906 # test suites while still getting normal test output. 907 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; 908 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; 909 $Opened_Testhandles = 1; 910} 911 912 913#line 1396 914 915sub _message_at_caller { 916 my $self = shift; 917 918 local $Level = $Level + 1; 919 my($pack, $file, $line) = $self->caller; 920 return join("", @_) . " at $file line $line.\n"; 921} 922 923sub carp { 924 my $self = shift; 925 warn $self->_message_at_caller(@_); 926} 927 928sub croak { 929 my $self = shift; 930 die $self->_message_at_caller(@_); 931} 932 933sub _plan_check { 934 my $self = shift; 935 936 unless( $self->{Have_Plan} ) { 937 local $Level = $Level + 2; 938 $self->croak("You tried to run a test without a plan"); 939 } 940} 941 942#line 1444 943 944sub current_test { 945 my($self, $num) = @_; 946 947 lock($self->{Curr_Test}); 948 if( defined $num ) { 949 unless( $self->{Have_Plan} ) { 950 $self->croak("Can't change the current test number without a plan!"); 951 } 952 953 $self->{Curr_Test} = $num; 954 955 # If the test counter is being pushed forward fill in the details. 956 my $test_results = $self->{Test_Results}; 957 if( $num > @$test_results ) { 958 my $start = @$test_results ? @$test_results : 0; 959 for ($start..$num-1) { 960 $test_results->[$_] = &share({ 961 'ok' => 1, 962 actual_ok => undef, 963 reason => 'incrementing test number', 964 type => 'unknown', 965 name => undef 966 }); 967 } 968 } 969 # If backward, wipe history. Its their funeral. 970 elsif( $num < @$test_results ) { 971 $#{$test_results} = $num - 1; 972 } 973 } 974 return $self->{Curr_Test}; 975} 976 977 978#line 1489 979 980sub summary { 981 my($self) = shift; 982 983 return map { $_->{'ok'} } @{ $self->{Test_Results} }; 984} 985 986#line 1544 987 988sub details { 989 my $self = shift; 990 return @{ $self->{Test_Results} }; 991} 992 993#line 1569 994 995sub todo { 996 my($self, $pack) = @_; 997 998 $pack = $pack || $self->exported_to || $self->caller($Level); 999 return 0 unless $pack; 1000 1001 no strict 'refs'; 1002 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} 1003 : 0; 1004} 1005 1006#line 1590 1007 1008sub caller { 1009 my($self, $height) = @_; 1010 $height ||= 0; 1011 1012 my @caller = CORE::caller($self->level + $height + 1); 1013 return wantarray ? @caller : $caller[0]; 1014} 1015 1016#line 1602 1017 1018#line 1616 1019 1020#'# 1021sub _sanity_check { 1022 my $self = shift; 1023 1024 $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!'); 1025 $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test}, 1026 'Somehow your tests ran without a plan!'); 1027 $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} }, 1028 'Somehow you got a different number of results than tests ran!'); 1029} 1030 1031#line 1637 1032 1033sub _whoa { 1034 my($self, $check, $desc) = @_; 1035 if( $check ) { 1036 local $Level = $Level + 1; 1037 $self->croak(<<"WHOA"); 1038WHOA! $desc 1039This should never happen! Please contact the author immediately! 1040WHOA 1041 } 1042} 1043 1044#line 1659 1045 1046sub _my_exit { 1047 $? = $_[0]; 1048 1049 return 1; 1050} 1051 1052 1053#line 1672 1054 1055$SIG{__DIE__} = sub { 1056 # We don't want to muck with death in an eval, but $^S isn't 1057 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing 1058 # with it. Instead, we use caller. This also means it runs under 1059 # 5.004! 1060 my $in_eval = 0; 1061 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { 1062 $in_eval = 1 if $sub =~ /^\(eval\)/; 1063 } 1064 $Test->{Test_Died} = 1 unless $in_eval; 1065}; 1066 1067sub _ending { 1068 my $self = shift; 1069 1070 $self->_sanity_check(); 1071 1072 # Don't bother with an ending if this is a forked copy. Only the parent 1073 # should do the ending. 1074 # Exit if plan() was never called. This is so "require Test::Simple" 1075 # doesn't puke. 1076 # Don't do an ending if we bailed out. 1077 if( ($self->{Original_Pid} != $$) or 1078 (!$self->{Have_Plan} && !$self->{Test_Died}) or 1079 $self->{Bailed_Out} 1080 ) 1081 { 1082 _my_exit($?); 1083 return; 1084 } 1085 1086 # Figure out if we passed or failed and print helpful messages. 1087 my $test_results = $self->{Test_Results}; 1088 if( @$test_results ) { 1089 # The plan? We have no plan. 1090 if( $self->{No_Plan} ) { 1091 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; 1092 $self->{Expected_Tests} = $self->{Curr_Test}; 1093 } 1094 1095 # Auto-extended arrays and elements which aren't explicitly 1096 # filled in with a shared reference will puke under 5.8.0 1097 # ithreads. So we have to fill them in by hand. :( 1098 my $empty_result = &share({}); 1099 for my $idx ( 0..$self->{Expected_Tests}-1 ) { 1100 $test_results->[$idx] = $empty_result 1101 unless defined $test_results->[$idx]; 1102 } 1103 1104 my $num_failed = grep !$_->{'ok'}, 1105 @{$test_results}[0..$self->{Curr_Test}-1]; 1106 1107 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; 1108 1109 if( $num_extra < 0 ) { 1110 my $s = $self->{Expected_Tests} == 1 ? '' : 's'; 1111 $self->diag(<<"FAIL"); 1112Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. 1113FAIL 1114 } 1115 elsif( $num_extra > 0 ) { 1116 my $s = $self->{Expected_Tests} == 1 ? '' : 's'; 1117 $self->diag(<<"FAIL"); 1118Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. 1119FAIL 1120 } 1121 1122 if ( $num_failed ) { 1123 my $num_tests = $self->{Curr_Test}; 1124 my $s = $num_failed == 1 ? '' : 's'; 1125 1126 my $qualifier = $num_extra == 0 ? '' : ' run'; 1127 1128 $self->diag(<<"FAIL"); 1129Looks like you failed $num_failed test$s of $num_tests$qualifier. 1130FAIL 1131 } 1132 1133 if( $self->{Test_Died} ) { 1134 $self->diag(<<"FAIL"); 1135Looks like your test died just after $self->{Curr_Test}. 1136FAIL 1137 1138 _my_exit( 255 ) && return; 1139 } 1140 1141 my $exit_code; 1142 if( $num_failed ) { 1143 $exit_code = $num_failed <= 254 ? $num_failed : 254; 1144 } 1145 elsif( $num_extra != 0 ) { 1146 $exit_code = 255; 1147 } 1148 else { 1149 $exit_code = 0; 1150 } 1151 1152 _my_exit( $exit_code ) && return; 1153 } 1154 elsif ( $self->{Skip_All} ) { 1155 _my_exit( 0 ) && return; 1156 } 1157 elsif ( $self->{Test_Died} ) { 1158 $self->diag(<<'FAIL'); 1159Looks like your test died before it could output anything. 1160FAIL 1161 _my_exit( 255 ) && return; 1162 } 1163 else { 1164 $self->diag("No tests run!\n"); 1165 _my_exit( 255 ) && return; 1166 } 1167} 1168 1169END { 1170 $Test->_ending if defined $Test and !$Test->no_ending; 1171} 1172 1173#line 1847 1174 11751; 1176