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