1#line 1 2package Test::Builder; 3 4use 5.006; 5use strict; 6use warnings; 7 8our $VERSION = '0.94'; 9$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) 10 11BEGIN { 12 if( $] < 5.008 ) { 13 require Test::Builder::IO::Scalar; 14 } 15} 16 17 18# Make Test::Builder thread-safe for ithreads. 19BEGIN { 20 use Config; 21 # Load threads::shared when threads are turned on. 22 # 5.8.0's threads are so busted we no longer support them. 23 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { 24 require threads::shared; 25 26 # Hack around YET ANOTHER threads::shared bug. It would 27 # occassionally forget the contents of the variable when sharing it. 28 # So we first copy the data, then share, then put our copy back. 29 *share = sub (\[$@%]) { 30 my $type = ref $_[0]; 31 my $data; 32 33 if( $type eq 'HASH' ) { 34 %$data = %{ $_[0] }; 35 } 36 elsif( $type eq 'ARRAY' ) { 37 @$data = @{ $_[0] }; 38 } 39 elsif( $type eq 'SCALAR' ) { 40 $$data = ${ $_[0] }; 41 } 42 else { 43 die( "Unknown type: " . $type ); 44 } 45 46 $_[0] = &threads::shared::share( $_[0] ); 47 48 if( $type eq 'HASH' ) { 49 %{ $_[0] } = %$data; 50 } 51 elsif( $type eq 'ARRAY' ) { 52 @{ $_[0] } = @$data; 53 } 54 elsif( $type eq 'SCALAR' ) { 55 ${ $_[0] } = $$data; 56 } 57 else { 58 die( "Unknown type: " . $type ); 59 } 60 61 return $_[0]; 62 }; 63 } 64 # 5.8.0's threads::shared is busted when threads are off 65 # and earlier Perls just don't have that module at all. 66 else { 67 *share = sub { return $_[0] }; 68 *lock = sub { 0 }; 69 } 70} 71 72#line 117 73 74our $Test = Test::Builder->new; 75 76sub new { 77 my($class) = shift; 78 $Test ||= $class->create; 79 return $Test; 80} 81 82#line 139 83 84sub create { 85 my $class = shift; 86 87 my $self = bless {}, $class; 88 $self->reset; 89 90 return $self; 91} 92 93#line 168 94 95sub child { 96 my( $self, $name ) = @_; 97 98 if( $self->{Child_Name} ) { 99 $self->croak("You already have a child named ($self->{Child_Name}) running"); 100 } 101 102 my $child = bless {}, ref $self; 103 $child->reset; 104 105 # Add to our indentation 106 $child->_indent( $self->_indent . ' ' ); 107 $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH}; 108 109 # This will be reset in finalize. We do this here lest one child failure 110 # cause all children to fail. 111 $child->{Child_Error} = $?; 112 $? = 0; 113 $child->{Parent} = $self; 114 $child->{Name} = $name || "Child of " . $self->name; 115 $self->{Child_Name} = $child->name; 116 return $child; 117} 118 119 120#line 201 121 122sub subtest { 123 my $self = shift; 124 my($name, $subtests) = @_; 125 126 if ('CODE' ne ref $subtests) { 127 $self->croak("subtest()'s second argument must be a code ref"); 128 } 129 130 # Turn the child into the parent so anyone who has stored a copy of 131 # the Test::Builder singleton will get the child. 132 my $child = $self->child($name); 133 my %parent = %$self; 134 %$self = %$child; 135 136 my $error; 137 if( !eval { $subtests->(); 1 } ) { 138 $error = $@; 139 } 140 141 # Restore the parent and the copied child. 142 %$child = %$self; 143 %$self = %parent; 144 145 # Die *after* we restore the parent. 146 die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; 147 148 return $child->finalize; 149} 150 151 152#line 250 153 154sub finalize { 155 my $self = shift; 156 157 return unless $self->parent; 158 if( $self->{Child_Name} ) { 159 $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); 160 } 161 $self->_ending; 162 163 # XXX This will only be necessary for TAP envelopes (we think) 164 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); 165 166 my $ok = 1; 167 $self->parent->{Child_Name} = undef; 168 if ( $self->{Skip_All} ) { 169 $self->parent->skip($self->{Skip_All}); 170 } 171 elsif ( not @{ $self->{Test_Results} } ) { 172 $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); 173 } 174 else { 175 $self->parent->ok( $self->is_passing, $self->name ); 176 } 177 $? = $self->{Child_Error}; 178 delete $self->{Parent}; 179 180 return $self->is_passing; 181} 182 183sub _indent { 184 my $self = shift; 185 186 if( @_ ) { 187 $self->{Indent} = shift; 188 } 189 190 return $self->{Indent}; 191} 192 193#line 300 194 195sub parent { shift->{Parent} } 196 197#line 312 198 199sub name { shift->{Name} } 200 201sub DESTROY { 202 my $self = shift; 203 if ( $self->parent ) { 204 my $name = $self->name; 205 $self->diag(<<"FAIL"); 206Child ($name) exited without calling finalize() 207FAIL 208 $self->parent->{In_Destroy} = 1; 209 $self->parent->ok(0, $name); 210 } 211} 212 213#line 336 214 215our $Level; 216 217sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) 218 my($self) = @_; 219 220 # We leave this a global because it has to be localized and localizing 221 # hash keys is just asking for pain. Also, it was documented. 222 $Level = 1; 223 224 $self->{Name} = $0; 225 $self->is_passing(1); 226 $self->{Ending} = 0; 227 $self->{Have_Plan} = 0; 228 $self->{No_Plan} = 0; 229 $self->{Have_Output_Plan} = 0; 230 231 $self->{Original_Pid} = $$; 232 $self->{Child_Name} = undef; 233 $self->{Indent} ||= ''; 234 235 share( $self->{Curr_Test} ); 236 $self->{Curr_Test} = 0; 237 $self->{Test_Results} = &share( [] ); 238 239 $self->{Exported_To} = undef; 240 $self->{Expected_Tests} = 0; 241 242 $self->{Skip_All} = 0; 243 244 $self->{Use_Nums} = 1; 245 246 $self->{No_Header} = 0; 247 $self->{No_Ending} = 0; 248 249 $self->{Todo} = undef; 250 $self->{Todo_Stack} = []; 251 $self->{Start_Todo} = 0; 252 $self->{Opened_Testhandles} = 0; 253 254 $self->_dup_stdhandles; 255 256 return; 257} 258 259#line 414 260 261my %plan_cmds = ( 262 no_plan => \&no_plan, 263 skip_all => \&skip_all, 264 tests => \&_plan_tests, 265); 266 267sub plan { 268 my( $self, $cmd, $arg ) = @_; 269 270 return unless $cmd; 271 272 local $Level = $Level + 1; 273 274 $self->croak("You tried to plan twice") if $self->{Have_Plan}; 275 276 if( my $method = $plan_cmds{$cmd} ) { 277 local $Level = $Level + 1; 278 $self->$method($arg); 279 } 280 else { 281 my @args = grep { defined } ( $cmd, $arg ); 282 $self->croak("plan() doesn't understand @args"); 283 } 284 285 return 1; 286} 287 288 289sub _plan_tests { 290 my($self, $arg) = @_; 291 292 if($arg) { 293 local $Level = $Level + 1; 294 return $self->expected_tests($arg); 295 } 296 elsif( !defined $arg ) { 297 $self->croak("Got an undefined number of tests"); 298 } 299 else { 300 $self->croak("You said to run 0 tests"); 301 } 302 303 return; 304} 305 306 307#line 470 308 309sub expected_tests { 310 my $self = shift; 311 my($max) = @_; 312 313 if(@_) { 314 $self->croak("Number of tests must be a positive integer. You gave it '$max'") 315 unless $max =~ /^\+?\d+$/; 316 317 $self->{Expected_Tests} = $max; 318 $self->{Have_Plan} = 1; 319 320 $self->_output_plan($max) unless $self->no_header; 321 } 322 return $self->{Expected_Tests}; 323} 324 325#line 494 326 327sub no_plan { 328 my($self, $arg) = @_; 329 330 $self->carp("no_plan takes no arguments") if $arg; 331 332 $self->{No_Plan} = 1; 333 $self->{Have_Plan} = 1; 334 335 return 1; 336} 337 338 339#line 528 340 341sub _output_plan { 342 my($self, $max, $directive, $reason) = @_; 343 344 $self->carp("The plan was already output") if $self->{Have_Output_Plan}; 345 346 my $plan = "1..$max"; 347 $plan .= " # $directive" if defined $directive; 348 $plan .= " $reason" if defined $reason; 349 350 $self->_print("$plan\n"); 351 352 $self->{Have_Output_Plan} = 1; 353 354 return; 355} 356 357#line 579 358 359sub done_testing { 360 my($self, $num_tests) = @_; 361 362 # If done_testing() specified the number of tests, shut off no_plan. 363 if( defined $num_tests ) { 364 $self->{No_Plan} = 0; 365 } 366 else { 367 $num_tests = $self->current_test; 368 } 369 370 if( $self->{Done_Testing} ) { 371 my($file, $line) = @{$self->{Done_Testing}}[1,2]; 372 $self->ok(0, "done_testing() was already called at $file line $line"); 373 return; 374 } 375 376 $self->{Done_Testing} = [caller]; 377 378 if( $self->expected_tests && $num_tests != $self->expected_tests ) { 379 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". 380 "but done_testing() expects $num_tests"); 381 } 382 else { 383 $self->{Expected_Tests} = $num_tests; 384 } 385 386 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; 387 388 $self->{Have_Plan} = 1; 389 390 # The wrong number of tests were run 391 $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test}; 392 393 # No tests were run 394 $self->is_passing(0) if $self->{Curr_Test} == 0; 395 396 return 1; 397} 398 399 400#line 630 401 402sub has_plan { 403 my $self = shift; 404 405 return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; 406 return('no_plan') if $self->{No_Plan}; 407 return(undef); 408} 409 410#line 647 411 412sub skip_all { 413 my( $self, $reason ) = @_; 414 415 $self->{Skip_All} = $self->parent ? $reason : 1; 416 417 $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; 418 if ( $self->parent ) { 419 die bless {} => 'Test::Builder::Exception'; 420 } 421 exit(0); 422} 423 424#line 672 425 426sub exported_to { 427 my( $self, $pack ) = @_; 428 429 if( defined $pack ) { 430 $self->{Exported_To} = $pack; 431 } 432 return $self->{Exported_To}; 433} 434 435#line 702 436 437sub ok { 438 my( $self, $test, $name ) = @_; 439 440 if ( $self->{Child_Name} and not $self->{In_Destroy} ) { 441 $name = 'unnamed test' unless defined $name; 442 $self->is_passing(0); 443 $self->croak("Cannot run test ($name) with active children"); 444 } 445 # $test might contain an object which we don't want to accidentally 446 # store, so we turn it into a boolean. 447 $test = $test ? 1 : 0; 448 449 lock $self->{Curr_Test}; 450 $self->{Curr_Test}++; 451 452 # In case $name is a string overloaded object, force it to stringify. 453 $self->_unoverload_str( \$name ); 454 455 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; 456 You named your test '$name'. You shouldn't use numbers for your test names. 457 Very confusing. 458ERR 459 460 # Capture the value of $TODO for the rest of this ok() call 461 # so it can more easily be found by other routines. 462 my $todo = $self->todo(); 463 my $in_todo = $self->in_todo; 464 local $self->{Todo} = $todo if $in_todo; 465 466 $self->_unoverload_str( \$todo ); 467 468 my $out; 469 my $result = &share( {} ); 470 471 unless($test) { 472 $out .= "not "; 473 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); 474 } 475 else { 476 @$result{ 'ok', 'actual_ok' } = ( 1, $test ); 477 } 478 479 $out .= "ok"; 480 $out .= " $self->{Curr_Test}" if $self->use_numbers; 481 482 if( defined $name ) { 483 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. 484 $out .= " - $name"; 485 $result->{name} = $name; 486 } 487 else { 488 $result->{name} = ''; 489 } 490 491 if( $self->in_todo ) { 492 $out .= " # TODO $todo"; 493 $result->{reason} = $todo; 494 $result->{type} = 'todo'; 495 } 496 else { 497 $result->{reason} = ''; 498 $result->{type} = ''; 499 } 500 501 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; 502 $out .= "\n"; 503 504 $self->_print($out); 505 506 unless($test) { 507 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; 508 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; 509 510 my( undef, $file, $line ) = $self->caller; 511 if( defined $name ) { 512 $self->diag(qq[ $msg test '$name'\n]); 513 $self->diag(qq[ at $file line $line.\n]); 514 } 515 else { 516 $self->diag(qq[ $msg test at $file line $line.\n]); 517 } 518 } 519 520 $self->is_passing(0) unless $test || $self->in_todo; 521 522 # Check that we haven't violated the plan 523 $self->_check_is_passing_plan(); 524 525 return $test ? 1 : 0; 526} 527 528 529# Check that we haven't yet violated the plan and set 530# is_passing() accordingly 531sub _check_is_passing_plan { 532 my $self = shift; 533 534 my $plan = $self->has_plan; 535 return unless defined $plan; # no plan yet defined 536 return unless $plan !~ /\D/; # no numeric plan 537 $self->is_passing(0) if $plan < $self->{Curr_Test}; 538} 539 540 541sub _unoverload { 542 my $self = shift; 543 my $type = shift; 544 545 $self->_try(sub { require overload; }, die_on_fail => 1); 546 547 foreach my $thing (@_) { 548 if( $self->_is_object($$thing) ) { 549 if( my $string_meth = overload::Method( $$thing, $type ) ) { 550 $$thing = $$thing->$string_meth(); 551 } 552 } 553 } 554 555 return; 556} 557 558sub _is_object { 559 my( $self, $thing ) = @_; 560 561 return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; 562} 563 564sub _unoverload_str { 565 my $self = shift; 566 567 return $self->_unoverload( q[""], @_ ); 568} 569 570sub _unoverload_num { 571 my $self = shift; 572 573 $self->_unoverload( '0+', @_ ); 574 575 for my $val (@_) { 576 next unless $self->_is_dualvar($$val); 577 $$val = $$val + 0; 578 } 579 580 return; 581} 582 583# This is a hack to detect a dualvar such as $! 584sub _is_dualvar { 585 my( $self, $val ) = @_; 586 587 # Objects are not dualvars. 588 return 0 if ref $val; 589 590 no warnings 'numeric'; 591 my $numval = $val + 0; 592 return $numval != 0 and $numval ne $val ? 1 : 0; 593} 594 595#line 876 596 597sub is_eq { 598 my( $self, $got, $expect, $name ) = @_; 599 local $Level = $Level + 1; 600 601 $self->_unoverload_str( \$got, \$expect ); 602 603 if( !defined $got || !defined $expect ) { 604 # undef only matches undef and nothing else 605 my $test = !defined $got && !defined $expect; 606 607 $self->ok( $test, $name ); 608 $self->_is_diag( $got, 'eq', $expect ) unless $test; 609 return $test; 610 } 611 612 return $self->cmp_ok( $got, 'eq', $expect, $name ); 613} 614 615sub is_num { 616 my( $self, $got, $expect, $name ) = @_; 617 local $Level = $Level + 1; 618 619 $self->_unoverload_num( \$got, \$expect ); 620 621 if( !defined $got || !defined $expect ) { 622 # undef only matches undef and nothing else 623 my $test = !defined $got && !defined $expect; 624 625 $self->ok( $test, $name ); 626 $self->_is_diag( $got, '==', $expect ) unless $test; 627 return $test; 628 } 629 630 return $self->cmp_ok( $got, '==', $expect, $name ); 631} 632 633sub _diag_fmt { 634 my( $self, $type, $val ) = @_; 635 636 if( defined $$val ) { 637 if( $type eq 'eq' or $type eq 'ne' ) { 638 # quote and force string context 639 $$val = "'$$val'"; 640 } 641 else { 642 # force numeric context 643 $self->_unoverload_num($val); 644 } 645 } 646 else { 647 $$val = 'undef'; 648 } 649 650 return; 651} 652 653sub _is_diag { 654 my( $self, $got, $type, $expect ) = @_; 655 656 $self->_diag_fmt( $type, $_ ) for \$got, \$expect; 657 658 local $Level = $Level + 1; 659 return $self->diag(<<"DIAGNOSTIC"); 660 got: $got 661 expected: $expect 662DIAGNOSTIC 663 664} 665 666sub _isnt_diag { 667 my( $self, $got, $type ) = @_; 668 669 $self->_diag_fmt( $type, \$got ); 670 671 local $Level = $Level + 1; 672 return $self->diag(<<"DIAGNOSTIC"); 673 got: $got 674 expected: anything else 675DIAGNOSTIC 676} 677 678#line 973 679 680sub isnt_eq { 681 my( $self, $got, $dont_expect, $name ) = @_; 682 local $Level = $Level + 1; 683 684 if( !defined $got || !defined $dont_expect ) { 685 # undef only matches undef and nothing else 686 my $test = defined $got || defined $dont_expect; 687 688 $self->ok( $test, $name ); 689 $self->_isnt_diag( $got, 'ne' ) unless $test; 690 return $test; 691 } 692 693 return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); 694} 695 696sub isnt_num { 697 my( $self, $got, $dont_expect, $name ) = @_; 698 local $Level = $Level + 1; 699 700 if( !defined $got || !defined $dont_expect ) { 701 # undef only matches undef and nothing else 702 my $test = defined $got || defined $dont_expect; 703 704 $self->ok( $test, $name ); 705 $self->_isnt_diag( $got, '!=' ) unless $test; 706 return $test; 707 } 708 709 return $self->cmp_ok( $got, '!=', $dont_expect, $name ); 710} 711 712#line 1022 713 714sub like { 715 my( $self, $this, $regex, $name ) = @_; 716 717 local $Level = $Level + 1; 718 return $self->_regex_ok( $this, $regex, '=~', $name ); 719} 720 721sub unlike { 722 my( $self, $this, $regex, $name ) = @_; 723 724 local $Level = $Level + 1; 725 return $self->_regex_ok( $this, $regex, '!~', $name ); 726} 727 728#line 1046 729 730my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); 731 732sub cmp_ok { 733 my( $self, $got, $type, $expect, $name ) = @_; 734 735 my $test; 736 my $error; 737 { 738 ## no critic (BuiltinFunctions::ProhibitStringyEval) 739 740 local( $@, $!, $SIG{__DIE__} ); # isolate eval 741 742 my($pack, $file, $line) = $self->caller(); 743 744 $test = eval qq[ 745#line 1 "cmp_ok [from $file line $line]" 746\$got $type \$expect; 747]; 748 $error = $@; 749 } 750 local $Level = $Level + 1; 751 my $ok = $self->ok( $test, $name ); 752 753 # Treat overloaded objects as numbers if we're asked to do a 754 # numeric comparison. 755 my $unoverload 756 = $numeric_cmps{$type} 757 ? '_unoverload_num' 758 : '_unoverload_str'; 759 760 $self->diag(<<"END") if $error; 761An error occurred while using $type: 762------------------------------------ 763$error 764------------------------------------ 765END 766 767 unless($ok) { 768 $self->$unoverload( \$got, \$expect ); 769 770 if( $type =~ /^(eq|==)$/ ) { 771 $self->_is_diag( $got, $type, $expect ); 772 } 773 elsif( $type =~ /^(ne|!=)$/ ) { 774 $self->_isnt_diag( $got, $type ); 775 } 776 else { 777 $self->_cmp_diag( $got, $type, $expect ); 778 } 779 } 780 return $ok; 781} 782 783sub _cmp_diag { 784 my( $self, $got, $type, $expect ) = @_; 785 786 $got = defined $got ? "'$got'" : 'undef'; 787 $expect = defined $expect ? "'$expect'" : 'undef'; 788 789 local $Level = $Level + 1; 790 return $self->diag(<<"DIAGNOSTIC"); 791 $got 792 $type 793 $expect 794DIAGNOSTIC 795} 796 797sub _caller_context { 798 my $self = shift; 799 800 my( $pack, $file, $line ) = $self->caller(1); 801 802 my $code = ''; 803 $code .= "#line $line $file\n" if defined $file and defined $line; 804 805 return $code; 806} 807 808#line 1145 809 810sub BAIL_OUT { 811 my( $self, $reason ) = @_; 812 813 $self->{Bailed_Out} = 1; 814 $self->_print("Bail out! $reason"); 815 exit 255; 816} 817 818#line 1158 819 820{ 821 no warnings 'once'; 822 *BAILOUT = \&BAIL_OUT; 823} 824 825#line 1172 826 827sub skip { 828 my( $self, $why ) = @_; 829 $why ||= ''; 830 $self->_unoverload_str( \$why ); 831 832 lock( $self->{Curr_Test} ); 833 $self->{Curr_Test}++; 834 835 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( 836 { 837 'ok' => 1, 838 actual_ok => 1, 839 name => '', 840 type => 'skip', 841 reason => $why, 842 } 843 ); 844 845 my $out = "ok"; 846 $out .= " $self->{Curr_Test}" if $self->use_numbers; 847 $out .= " # skip"; 848 $out .= " $why" if length $why; 849 $out .= "\n"; 850 851 $self->_print($out); 852 853 return 1; 854} 855 856#line 1213 857 858sub todo_skip { 859 my( $self, $why ) = @_; 860 $why ||= ''; 861 862 lock( $self->{Curr_Test} ); 863 $self->{Curr_Test}++; 864 865 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( 866 { 867 'ok' => 1, 868 actual_ok => 0, 869 name => '', 870 type => 'todo_skip', 871 reason => $why, 872 } 873 ); 874 875 my $out = "not ok"; 876 $out .= " $self->{Curr_Test}" if $self->use_numbers; 877 $out .= " # TODO & SKIP $why\n"; 878 879 $self->_print($out); 880 881 return 1; 882} 883 884#line 1293 885 886sub maybe_regex { 887 my( $self, $regex ) = @_; 888 my $usable_regex = undef; 889 890 return $usable_regex unless defined $regex; 891 892 my( $re, $opts ); 893 894 # Check for qr/foo/ 895 if( _is_qr($regex) ) { 896 $usable_regex = $regex; 897 } 898 # Check for '/foo/' or 'm,foo,' 899 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or 900 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx 901 ) 902 { 903 $usable_regex = length $opts ? "(?$opts)$re" : $re; 904 } 905 906 return $usable_regex; 907} 908 909sub _is_qr { 910 my $regex = shift; 911 912 # is_regexp() checks for regexes in a robust manner, say if they're 913 # blessed. 914 return re::is_regexp($regex) if defined &re::is_regexp; 915 return ref $regex eq 'Regexp'; 916} 917 918sub _regex_ok { 919 my( $self, $this, $regex, $cmp, $name ) = @_; 920 921 my $ok = 0; 922 my $usable_regex = $self->maybe_regex($regex); 923 unless( defined $usable_regex ) { 924 local $Level = $Level + 1; 925 $ok = $self->ok( 0, $name ); 926 $self->diag(" '$regex' doesn't look much like a regex to me."); 927 return $ok; 928 } 929 930 { 931 ## no critic (BuiltinFunctions::ProhibitStringyEval) 932 933 my $test; 934 my $context = $self->_caller_context; 935 936 local( $@, $!, $SIG{__DIE__} ); # isolate eval 937 938 $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; 939 940 $test = !$test if $cmp eq '!~'; 941 942 local $Level = $Level + 1; 943 $ok = $self->ok( $test, $name ); 944 } 945 946 unless($ok) { 947 $this = defined $this ? "'$this'" : 'undef'; 948 my $match = $cmp eq '=~' ? "doesn't match" : "matches"; 949 950 local $Level = $Level + 1; 951 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); 952 %s 953 %13s '%s' 954DIAGNOSTIC 955 956 } 957 958 return $ok; 959} 960 961# I'm not ready to publish this. It doesn't deal with array return 962# values from the code or context. 963 964#line 1389 965 966sub _try { 967 my( $self, $code, %opts ) = @_; 968 969 my $error; 970 my $return; 971 { 972 local $!; # eval can mess up $! 973 local $@; # don't set $@ in the test 974 local $SIG{__DIE__}; # don't trip an outside DIE handler. 975 $return = eval { $code->() }; 976 $error = $@; 977 } 978 979 die $error if $error and $opts{die_on_fail}; 980 981 return wantarray ? ( $return, $error ) : $return; 982} 983 984#line 1418 985 986sub is_fh { 987 my $self = shift; 988 my $maybe_fh = shift; 989 return 0 unless defined $maybe_fh; 990 991 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref 992 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob 993 994 return eval { $maybe_fh->isa("IO::Handle") } || 995 eval { tied($maybe_fh)->can('TIEHANDLE') }; 996} 997 998#line 1461 999 1000sub level { 1001 my( $self, $level ) = @_; 1002 1003 if( defined $level ) { 1004 $Level = $level; 1005 } 1006 return $Level; 1007} 1008 1009#line 1493 1010 1011sub use_numbers { 1012 my( $self, $use_nums ) = @_; 1013 1014 if( defined $use_nums ) { 1015 $self->{Use_Nums} = $use_nums; 1016 } 1017 return $self->{Use_Nums}; 1018} 1019 1020#line 1526 1021 1022foreach my $attribute (qw(No_Header No_Ending No_Diag)) { 1023 my $method = lc $attribute; 1024 1025 my $code = sub { 1026 my( $self, $no ) = @_; 1027 1028 if( defined $no ) { 1029 $self->{$attribute} = $no; 1030 } 1031 return $self->{$attribute}; 1032 }; 1033 1034 no strict 'refs'; ## no critic 1035 *{ __PACKAGE__ . '::' . $method } = $code; 1036} 1037 1038#line 1579 1039 1040sub diag { 1041 my $self = shift; 1042 1043 $self->_print_comment( $self->_diag_fh, @_ ); 1044} 1045 1046#line 1594 1047 1048sub note { 1049 my $self = shift; 1050 1051 $self->_print_comment( $self->output, @_ ); 1052} 1053 1054sub _diag_fh { 1055 my $self = shift; 1056 1057 local $Level = $Level + 1; 1058 return $self->in_todo ? $self->todo_output : $self->failure_output; 1059} 1060 1061sub _print_comment { 1062 my( $self, $fh, @msgs ) = @_; 1063 1064 return if $self->no_diag; 1065 return unless @msgs; 1066 1067 # Prevent printing headers when compiling (i.e. -c) 1068 return if $^C; 1069 1070 # Smash args together like print does. 1071 # Convert undef to 'undef' so its readable. 1072 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; 1073 1074 # Escape the beginning, _print will take care of the rest. 1075 $msg =~ s/^/# /; 1076 1077 local $Level = $Level + 1; 1078 $self->_print_to_fh( $fh, $msg ); 1079 1080 return 0; 1081} 1082 1083#line 1644 1084 1085sub explain { 1086 my $self = shift; 1087 1088 return map { 1089 ref $_ 1090 ? do { 1091 $self->_try(sub { require Data::Dumper }, die_on_fail => 1); 1092 1093 my $dumper = Data::Dumper->new( [$_] ); 1094 $dumper->Indent(1)->Terse(1); 1095 $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); 1096 $dumper->Dump; 1097 } 1098 : $_ 1099 } @_; 1100} 1101 1102#line 1673 1103 1104sub _print { 1105 my $self = shift; 1106 return $self->_print_to_fh( $self->output, @_ ); 1107} 1108 1109sub _print_to_fh { 1110 my( $self, $fh, @msgs ) = @_; 1111 1112 # Prevent printing headers when only compiling. Mostly for when 1113 # tests are deparsed with B::Deparse 1114 return if $^C; 1115 1116 my $msg = join '', @msgs; 1117 1118 local( $\, $", $, ) = ( undef, ' ', '' ); 1119 1120 # Escape each line after the first with a # so we don't 1121 # confuse Test::Harness. 1122 $msg =~ s{\n(?!\z)}{\n# }sg; 1123 1124 # Stick a newline on the end if it needs it. 1125 $msg .= "\n" unless $msg =~ /\n\z/; 1126 1127 return print $fh $self->_indent, $msg; 1128} 1129 1130#line 1732 1131 1132sub output { 1133 my( $self, $fh ) = @_; 1134 1135 if( defined $fh ) { 1136 $self->{Out_FH} = $self->_new_fh($fh); 1137 } 1138 return $self->{Out_FH}; 1139} 1140 1141sub failure_output { 1142 my( $self, $fh ) = @_; 1143 1144 if( defined $fh ) { 1145 $self->{Fail_FH} = $self->_new_fh($fh); 1146 } 1147 return $self->{Fail_FH}; 1148} 1149 1150sub todo_output { 1151 my( $self, $fh ) = @_; 1152 1153 if( defined $fh ) { 1154 $self->{Todo_FH} = $self->_new_fh($fh); 1155 } 1156 return $self->{Todo_FH}; 1157} 1158 1159sub _new_fh { 1160 my $self = shift; 1161 my($file_or_fh) = shift; 1162 1163 my $fh; 1164 if( $self->is_fh($file_or_fh) ) { 1165 $fh = $file_or_fh; 1166 } 1167 elsif( ref $file_or_fh eq 'SCALAR' ) { 1168 # Scalar refs as filehandles was added in 5.8. 1169 if( $] >= 5.008 ) { 1170 open $fh, ">>", $file_or_fh 1171 or $self->croak("Can't open scalar ref $file_or_fh: $!"); 1172 } 1173 # Emulate scalar ref filehandles with a tie. 1174 else { 1175 $fh = Test::Builder::IO::Scalar->new($file_or_fh) 1176 or $self->croak("Can't tie scalar ref $file_or_fh"); 1177 } 1178 } 1179 else { 1180 open $fh, ">", $file_or_fh 1181 or $self->croak("Can't open test output log $file_or_fh: $!"); 1182 _autoflush($fh); 1183 } 1184 1185 return $fh; 1186} 1187 1188sub _autoflush { 1189 my($fh) = shift; 1190 my $old_fh = select $fh; 1191 $| = 1; 1192 select $old_fh; 1193 1194 return; 1195} 1196 1197my( $Testout, $Testerr ); 1198 1199sub _dup_stdhandles { 1200 my $self = shift; 1201 1202 $self->_open_testhandles; 1203 1204 # Set everything to unbuffered else plain prints to STDOUT will 1205 # come out in the wrong order from our own prints. 1206 _autoflush($Testout); 1207 _autoflush( \*STDOUT ); 1208 _autoflush($Testerr); 1209 _autoflush( \*STDERR ); 1210 1211 $self->reset_outputs; 1212 1213 return; 1214} 1215 1216sub _open_testhandles { 1217 my $self = shift; 1218 1219 return if $self->{Opened_Testhandles}; 1220 1221 # We dup STDOUT and STDERR so people can change them in their 1222 # test suites while still getting normal test output. 1223 open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; 1224 open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; 1225 1226 # $self->_copy_io_layers( \*STDOUT, $Testout ); 1227 # $self->_copy_io_layers( \*STDERR, $Testerr ); 1228 1229 $self->{Opened_Testhandles} = 1; 1230 1231 return; 1232} 1233 1234sub _copy_io_layers { 1235 my( $self, $src, $dst ) = @_; 1236 1237 $self->_try( 1238 sub { 1239 require PerlIO; 1240 my @src_layers = PerlIO::get_layers($src); 1241 1242 binmode $dst, join " ", map ":$_", @src_layers if @src_layers; 1243 } 1244 ); 1245 1246 return; 1247} 1248 1249#line 1857 1250 1251sub reset_outputs { 1252 my $self = shift; 1253 1254 $self->output ($Testout); 1255 $self->failure_output($Testerr); 1256 $self->todo_output ($Testout); 1257 1258 return; 1259} 1260 1261#line 1883 1262 1263sub _message_at_caller { 1264 my $self = shift; 1265 1266 local $Level = $Level + 1; 1267 my( $pack, $file, $line ) = $self->caller; 1268 return join( "", @_ ) . " at $file line $line.\n"; 1269} 1270 1271sub carp { 1272 my $self = shift; 1273 return warn $self->_message_at_caller(@_); 1274} 1275 1276sub croak { 1277 my $self = shift; 1278 return die $self->_message_at_caller(@_); 1279} 1280 1281 1282#line 1923 1283 1284sub current_test { 1285 my( $self, $num ) = @_; 1286 1287 lock( $self->{Curr_Test} ); 1288 if( defined $num ) { 1289 $self->{Curr_Test} = $num; 1290 1291 # If the test counter is being pushed forward fill in the details. 1292 my $test_results = $self->{Test_Results}; 1293 if( $num > @$test_results ) { 1294 my $start = @$test_results ? @$test_results : 0; 1295 for( $start .. $num - 1 ) { 1296 $test_results->[$_] = &share( 1297 { 1298 'ok' => 1, 1299 actual_ok => undef, 1300 reason => 'incrementing test number', 1301 type => 'unknown', 1302 name => undef 1303 } 1304 ); 1305 } 1306 } 1307 # If backward, wipe history. Its their funeral. 1308 elsif( $num < @$test_results ) { 1309 $#{$test_results} = $num - 1; 1310 } 1311 } 1312 return $self->{Curr_Test}; 1313} 1314 1315#line 1971 1316 1317sub is_passing { 1318 my $self = shift; 1319 1320 if( @_ ) { 1321 $self->{Is_Passing} = shift; 1322 } 1323 1324 return $self->{Is_Passing}; 1325} 1326 1327 1328#line 1993 1329 1330sub summary { 1331 my($self) = shift; 1332 1333 return map { $_->{'ok'} } @{ $self->{Test_Results} }; 1334} 1335 1336#line 2048 1337 1338sub details { 1339 my $self = shift; 1340 return @{ $self->{Test_Results} }; 1341} 1342 1343#line 2077 1344 1345sub todo { 1346 my( $self, $pack ) = @_; 1347 1348 return $self->{Todo} if defined $self->{Todo}; 1349 1350 local $Level = $Level + 1; 1351 my $todo = $self->find_TODO($pack); 1352 return $todo if defined $todo; 1353 1354 return ''; 1355} 1356 1357#line 2099 1358 1359sub find_TODO { 1360 my( $self, $pack ) = @_; 1361 1362 $pack = $pack || $self->caller(1) || $self->exported_to; 1363 return unless $pack; 1364 1365 no strict 'refs'; ## no critic 1366 return ${ $pack . '::TODO' }; 1367} 1368 1369#line 2117 1370 1371sub in_todo { 1372 my $self = shift; 1373 1374 local $Level = $Level + 1; 1375 return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; 1376} 1377 1378#line 2167 1379 1380sub todo_start { 1381 my $self = shift; 1382 my $message = @_ ? shift : ''; 1383 1384 $self->{Start_Todo}++; 1385 if( $self->in_todo ) { 1386 push @{ $self->{Todo_Stack} } => $self->todo; 1387 } 1388 $self->{Todo} = $message; 1389 1390 return; 1391} 1392 1393#line 2189 1394 1395sub todo_end { 1396 my $self = shift; 1397 1398 if( !$self->{Start_Todo} ) { 1399 $self->croak('todo_end() called without todo_start()'); 1400 } 1401 1402 $self->{Start_Todo}--; 1403 1404 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { 1405 $self->{Todo} = pop @{ $self->{Todo_Stack} }; 1406 } 1407 else { 1408 delete $self->{Todo}; 1409 } 1410 1411 return; 1412} 1413 1414#line 2222 1415 1416sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) 1417 my( $self, $height ) = @_; 1418 $height ||= 0; 1419 1420 my $level = $self->level + $height + 1; 1421 my @caller; 1422 do { 1423 @caller = CORE::caller( $level ); 1424 $level--; 1425 } until @caller; 1426 return wantarray ? @caller : $caller[0]; 1427} 1428 1429#line 2239 1430 1431#line 2253 1432 1433#'# 1434sub _sanity_check { 1435 my $self = shift; 1436 1437 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); 1438 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, 1439 'Somehow you got a different number of results than tests ran!' ); 1440 1441 return; 1442} 1443 1444#line 2274 1445 1446sub _whoa { 1447 my( $self, $check, $desc ) = @_; 1448 if($check) { 1449 local $Level = $Level + 1; 1450 $self->croak(<<"WHOA"); 1451WHOA! $desc 1452This should never happen! Please contact the author immediately! 1453WHOA 1454 } 1455 1456 return; 1457} 1458 1459#line 2298 1460 1461sub _my_exit { 1462 $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) 1463 1464 return 1; 1465} 1466 1467#line 2310 1468 1469sub _ending { 1470 my $self = shift; 1471 return if $self->no_ending; 1472 return if $self->{Ending}++; 1473 1474 my $real_exit_code = $?; 1475 1476 # Don't bother with an ending if this is a forked copy. Only the parent 1477 # should do the ending. 1478 if( $self->{Original_Pid} != $$ ) { 1479 return; 1480 } 1481 1482 # Ran tests but never declared a plan or hit done_testing 1483 if( !$self->{Have_Plan} and $self->{Curr_Test} ) { 1484 $self->is_passing(0); 1485 $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); 1486 } 1487 1488 # Exit if plan() was never called. This is so "require Test::Simple" 1489 # doesn't puke. 1490 if( !$self->{Have_Plan} ) { 1491 return; 1492 } 1493 1494 # Don't do an ending if we bailed out. 1495 if( $self->{Bailed_Out} ) { 1496 $self->is_passing(0); 1497 return; 1498 } 1499 # Figure out if we passed or failed and print helpful messages. 1500 my $test_results = $self->{Test_Results}; 1501 if(@$test_results) { 1502 # The plan? We have no plan. 1503 if( $self->{No_Plan} ) { 1504 $self->_output_plan($self->{Curr_Test}) unless $self->no_header; 1505 $self->{Expected_Tests} = $self->{Curr_Test}; 1506 } 1507 1508 # Auto-extended arrays and elements which aren't explicitly 1509 # filled in with a shared reference will puke under 5.8.0 1510 # ithreads. So we have to fill them in by hand. :( 1511 my $empty_result = &share( {} ); 1512 for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { 1513 $test_results->[$idx] = $empty_result 1514 unless defined $test_results->[$idx]; 1515 } 1516 1517 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; 1518 1519 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; 1520 1521 if( $num_extra != 0 ) { 1522 my $s = $self->{Expected_Tests} == 1 ? '' : 's'; 1523 $self->diag(<<"FAIL"); 1524Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. 1525FAIL 1526 $self->is_passing(0); 1527 } 1528 1529 if($num_failed) { 1530 my $num_tests = $self->{Curr_Test}; 1531 my $s = $num_failed == 1 ? '' : 's'; 1532 1533 my $qualifier = $num_extra == 0 ? '' : ' run'; 1534 1535 $self->diag(<<"FAIL"); 1536Looks like you failed $num_failed test$s of $num_tests$qualifier. 1537FAIL 1538 $self->is_passing(0); 1539 } 1540 1541 if($real_exit_code) { 1542 $self->diag(<<"FAIL"); 1543Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. 1544FAIL 1545 $self->is_passing(0); 1546 _my_exit($real_exit_code) && return; 1547 } 1548 1549 my $exit_code; 1550 if($num_failed) { 1551 $exit_code = $num_failed <= 254 ? $num_failed : 254; 1552 } 1553 elsif( $num_extra != 0 ) { 1554 $exit_code = 255; 1555 } 1556 else { 1557 $exit_code = 0; 1558 } 1559 1560 _my_exit($exit_code) && return; 1561 } 1562 elsif( $self->{Skip_All} ) { 1563 _my_exit(0) && return; 1564 } 1565 elsif($real_exit_code) { 1566 $self->diag(<<"FAIL"); 1567Looks like your test exited with $real_exit_code before it could output anything. 1568FAIL 1569 $self->is_passing(0); 1570 _my_exit($real_exit_code) && return; 1571 } 1572 else { 1573 $self->diag("No tests run!\n"); 1574 $self->is_passing(0); 1575 _my_exit(255) && return; 1576 } 1577 1578 $self->is_passing(0); 1579 $self->_whoa( 1, "We fell off the end of _ending()" ); 1580} 1581 1582END { 1583 $Test->_ending if defined $Test; 1584} 1585 1586#line 2498 1587 15881; 1589 1590