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