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.70'; 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#line 999 694 695sub _try { 696 my($self, $code) = @_; 697 698 local $!; # eval can mess up $! 699 local $@; # don't set $@ in the test 700 local $SIG{__DIE__}; # don't trip an outside DIE handler. 701 my $return = eval { $code->() }; 702 703 return wantarray ? ($return, $@) : $return; 704} 705 706#line 1021 707 708sub is_fh { 709 my $self = shift; 710 my $maybe_fh = shift; 711 return 0 unless defined $maybe_fh; 712 713 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob 714 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob ref 715 716 return eval { $maybe_fh->isa("IO::Handle") } || 717 # 5.5.4's tied() and can() doesn't like getting undef 718 eval { (tied($maybe_fh) || '')->can('TIEHANDLE') }; 719} 720 721 722#line 1066 723 724sub level { 725 my($self, $level) = @_; 726 727 if( defined $level ) { 728 $Level = $level; 729 } 730 return $Level; 731} 732 733 734#line 1099 735 736sub use_numbers { 737 my($self, $use_nums) = @_; 738 739 if( defined $use_nums ) { 740 $self->{Use_Nums} = $use_nums; 741 } 742 return $self->{Use_Nums}; 743} 744 745 746#line 1133 747 748foreach my $attribute (qw(No_Header No_Ending No_Diag)) { 749 my $method = lc $attribute; 750 751 my $code = sub { 752 my($self, $no) = @_; 753 754 if( defined $no ) { 755 $self->{$attribute} = $no; 756 } 757 return $self->{$attribute}; 758 }; 759 760 no strict 'refs'; 761 *{__PACKAGE__.'::'.$method} = $code; 762} 763 764 765#line 1187 766 767sub diag { 768 my($self, @msgs) = @_; 769 770 return if $self->no_diag; 771 return unless @msgs; 772 773 # Prevent printing headers when compiling (i.e. -c) 774 return if $^C; 775 776 # Smash args together like print does. 777 # Convert undef to 'undef' so its readable. 778 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; 779 780 # Escape each line with a #. 781 $msg =~ s/^/# /gm; 782 783 # Stick a newline on the end if it needs it. 784 $msg .= "\n" unless $msg =~ /\n\Z/; 785 786 local $Level = $Level + 1; 787 $self->_print_diag($msg); 788 789 return 0; 790} 791 792#line 1224 793 794sub _print { 795 my($self, @msgs) = @_; 796 797 # Prevent printing headers when only compiling. Mostly for when 798 # tests are deparsed with B::Deparse 799 return if $^C; 800 801 my $msg = join '', @msgs; 802 803 local($\, $", $,) = (undef, ' ', ''); 804 my $fh = $self->output; 805 806 # Escape each line after the first with a # so we don't 807 # confuse Test::Harness. 808 $msg =~ s/\n(.)/\n# $1/sg; 809 810 # Stick a newline on the end if it needs it. 811 $msg .= "\n" unless $msg =~ /\n\Z/; 812 813 print $fh $msg; 814} 815 816#line 1258 817 818sub _print_diag { 819 my $self = shift; 820 821 local($\, $", $,) = (undef, ' ', ''); 822 my $fh = $self->todo ? $self->todo_output : $self->failure_output; 823 print $fh @_; 824} 825 826#line 1295 827 828sub output { 829 my($self, $fh) = @_; 830 831 if( defined $fh ) { 832 $self->{Out_FH} = $self->_new_fh($fh); 833 } 834 return $self->{Out_FH}; 835} 836 837sub failure_output { 838 my($self, $fh) = @_; 839 840 if( defined $fh ) { 841 $self->{Fail_FH} = $self->_new_fh($fh); 842 } 843 return $self->{Fail_FH}; 844} 845 846sub todo_output { 847 my($self, $fh) = @_; 848 849 if( defined $fh ) { 850 $self->{Todo_FH} = $self->_new_fh($fh); 851 } 852 return $self->{Todo_FH}; 853} 854 855 856sub _new_fh { 857 my $self = shift; 858 my($file_or_fh) = shift; 859 860 my $fh; 861 if( $self->is_fh($file_or_fh) ) { 862 $fh = $file_or_fh; 863 } 864 else { 865 $fh = do { local *FH }; 866 open $fh, ">$file_or_fh" or 867 $self->croak("Can't open test output log $file_or_fh: $!"); 868 _autoflush($fh); 869 } 870 871 return $fh; 872} 873 874 875sub _autoflush { 876 my($fh) = shift; 877 my $old_fh = select $fh; 878 $| = 1; 879 select $old_fh; 880} 881 882 883sub _dup_stdhandles { 884 my $self = shift; 885 886 $self->_open_testhandles; 887 888 # Set everything to unbuffered else plain prints to STDOUT will 889 # come out in the wrong order from our own prints. 890 _autoflush(\*TESTOUT); 891 _autoflush(\*STDOUT); 892 _autoflush(\*TESTERR); 893 _autoflush(\*STDERR); 894 895 $self->output(\*TESTOUT); 896 $self->failure_output(\*TESTERR); 897 $self->todo_output(\*TESTOUT); 898} 899 900 901my $Opened_Testhandles = 0; 902sub _open_testhandles { 903 return if $Opened_Testhandles; 904 # We dup STDOUT and STDERR so people can change them in their 905 # test suites while still getting normal test output. 906 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; 907 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; 908 $Opened_Testhandles = 1; 909} 910 911 912#line 1395 913 914sub _message_at_caller { 915 my $self = shift; 916 917 local $Level = $Level + 1; 918 my($pack, $file, $line) = $self->caller; 919 return join("", @_) . " at $file line $line.\n"; 920} 921 922sub carp { 923 my $self = shift; 924 warn $self->_message_at_caller(@_); 925} 926 927sub croak { 928 my $self = shift; 929 die $self->_message_at_caller(@_); 930} 931 932sub _plan_check { 933 my $self = shift; 934 935 unless( $self->{Have_Plan} ) { 936 local $Level = $Level + 2; 937 $self->croak("You tried to run a test without a plan"); 938 } 939} 940 941#line 1443 942 943sub current_test { 944 my($self, $num) = @_; 945 946 lock($self->{Curr_Test}); 947 if( defined $num ) { 948 unless( $self->{Have_Plan} ) { 949 $self->croak("Can't change the current test number without a plan!"); 950 } 951 952 $self->{Curr_Test} = $num; 953 954 # If the test counter is being pushed forward fill in the details. 955 my $test_results = $self->{Test_Results}; 956 if( $num > @$test_results ) { 957 my $start = @$test_results ? @$test_results : 0; 958 for ($start..$num-1) { 959 $test_results->[$_] = &share({ 960 'ok' => 1, 961 actual_ok => undef, 962 reason => 'incrementing test number', 963 type => 'unknown', 964 name => undef 965 }); 966 } 967 } 968 # If backward, wipe history. Its their funeral. 969 elsif( $num < @$test_results ) { 970 $#{$test_results} = $num - 1; 971 } 972 } 973 return $self->{Curr_Test}; 974} 975 976 977#line 1488 978 979sub summary { 980 my($self) = shift; 981 982 return map { $_->{'ok'} } @{ $self->{Test_Results} }; 983} 984 985#line 1543 986 987sub details { 988 my $self = shift; 989 return @{ $self->{Test_Results} }; 990} 991 992#line 1568 993 994sub todo { 995 my($self, $pack) = @_; 996 997 $pack = $pack || $self->exported_to || $self->caller($Level); 998 return 0 unless $pack; 999 1000 no strict 'refs'; 1001 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} 1002 : 0; 1003} 1004 1005#line 1589 1006 1007sub caller { 1008 my($self, $height) = @_; 1009 $height ||= 0; 1010 1011 my @caller = CORE::caller($self->level + $height + 1); 1012 return wantarray ? @caller : $caller[0]; 1013} 1014 1015#line 1601 1016 1017#line 1615 1018 1019#'# 1020sub _sanity_check { 1021 my $self = shift; 1022 1023 $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!'); 1024 $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test}, 1025 'Somehow your tests ran without a plan!'); 1026 $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} }, 1027 'Somehow you got a different number of results than tests ran!'); 1028} 1029 1030#line 1636 1031 1032sub _whoa { 1033 my($self, $check, $desc) = @_; 1034 if( $check ) { 1035 local $Level = $Level + 1; 1036 $self->croak(<<"WHOA"); 1037WHOA! $desc 1038This should never happen! Please contact the author immediately! 1039WHOA 1040 } 1041} 1042 1043#line 1658 1044 1045sub _my_exit { 1046 $? = $_[0]; 1047 1048 return 1; 1049} 1050 1051 1052#line 1671 1053 1054$SIG{__DIE__} = sub { 1055 # We don't want to muck with death in an eval, but $^S isn't 1056 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing 1057 # with it. Instead, we use caller. This also means it runs under 1058 # 5.004! 1059 my $in_eval = 0; 1060 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { 1061 $in_eval = 1 if $sub =~ /^\(eval\)/; 1062 } 1063 $Test->{Test_Died} = 1 unless $in_eval; 1064}; 1065 1066sub _ending { 1067 my $self = shift; 1068 1069 $self->_sanity_check(); 1070 1071 # Don't bother with an ending if this is a forked copy. Only the parent 1072 # should do the ending. 1073 # Exit if plan() was never called. This is so "require Test::Simple" 1074 # doesn't puke. 1075 # Don't do an ending if we bailed out. 1076 if( ($self->{Original_Pid} != $$) or 1077 (!$self->{Have_Plan} && !$self->{Test_Died}) or 1078 $self->{Bailed_Out} 1079 ) 1080 { 1081 _my_exit($?); 1082 return; 1083 } 1084 1085 # Figure out if we passed or failed and print helpful messages. 1086 my $test_results = $self->{Test_Results}; 1087 if( @$test_results ) { 1088 # The plan? We have no plan. 1089 if( $self->{No_Plan} ) { 1090 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; 1091 $self->{Expected_Tests} = $self->{Curr_Test}; 1092 } 1093 1094 # Auto-extended arrays and elements which aren't explicitly 1095 # filled in with a shared reference will puke under 5.8.0 1096 # ithreads. So we have to fill them in by hand. :( 1097 my $empty_result = &share({}); 1098 for my $idx ( 0..$self->{Expected_Tests}-1 ) { 1099 $test_results->[$idx] = $empty_result 1100 unless defined $test_results->[$idx]; 1101 } 1102 1103 my $num_failed = grep !$_->{'ok'}, 1104 @{$test_results}[0..$self->{Curr_Test}-1]; 1105 1106 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; 1107 1108 if( $num_extra < 0 ) { 1109 my $s = $self->{Expected_Tests} == 1 ? '' : 's'; 1110 $self->diag(<<"FAIL"); 1111Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. 1112FAIL 1113 } 1114 elsif( $num_extra > 0 ) { 1115 my $s = $self->{Expected_Tests} == 1 ? '' : 's'; 1116 $self->diag(<<"FAIL"); 1117Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. 1118FAIL 1119 } 1120 1121 if ( $num_failed ) { 1122 my $num_tests = $self->{Curr_Test}; 1123 my $s = $num_failed == 1 ? '' : 's'; 1124 1125 my $qualifier = $num_extra == 0 ? '' : ' run'; 1126 1127 $self->diag(<<"FAIL"); 1128Looks like you failed $num_failed test$s of $num_tests$qualifier. 1129FAIL 1130 } 1131 1132 if( $self->{Test_Died} ) { 1133 $self->diag(<<"FAIL"); 1134Looks like your test died just after $self->{Curr_Test}. 1135FAIL 1136 1137 _my_exit( 255 ) && return; 1138 } 1139 1140 my $exit_code; 1141 if( $num_failed ) { 1142 $exit_code = $num_failed <= 254 ? $num_failed : 254; 1143 } 1144 elsif( $num_extra != 0 ) { 1145 $exit_code = 255; 1146 } 1147 else { 1148 $exit_code = 0; 1149 } 1150 1151 _my_exit( $exit_code ) && return; 1152 } 1153 elsif ( $self->{Skip_All} ) { 1154 _my_exit( 0 ) && return; 1155 } 1156 elsif ( $self->{Test_Died} ) { 1157 $self->diag(<<'FAIL'); 1158Looks like your test died before it could output anything. 1159FAIL 1160 _my_exit( 255 ) && return; 1161 } 1162 else { 1163 $self->diag("No tests run!\n"); 1164 _my_exit( 255 ) && return; 1165 } 1166} 1167 1168END { 1169 $Test->_ending if defined $Test and !$Test->no_ending; 1170} 1171 1172#line 1846 1173 11741; 1175