1package Test::Builder; 2 3use 5.006; 4use strict; 5use warnings; 6 7our $VERSION = '0.94'; 8$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) 9 10BEGIN { 11 if( $] < 5.008 ) { 12 require Test::Builder::IO::Scalar; 13 } 14} 15 16 17# Make Test::Builder thread-safe for ithreads. 18BEGIN { 19 use Config; 20 # Load threads::shared when threads are turned on. 21 # 5.8.0's threads are so busted we no longer support them. 22 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { 23 require threads::shared; 24 25 # Hack around YET ANOTHER threads::shared bug. It would 26 # occassionally forget the contents of the variable when sharing it. 27 # So we first copy the data, then share, then put our copy back. 28 *share = sub (\[$@%]) { 29 my $type = ref $_[0]; 30 my $data; 31 32 if( $type eq 'HASH' ) { 33 %$data = %{ $_[0] }; 34 } 35 elsif( $type eq 'ARRAY' ) { 36 @$data = @{ $_[0] }; 37 } 38 elsif( $type eq 'SCALAR' ) { 39 $$data = ${ $_[0] }; 40 } 41 else { 42 die( "Unknown type: " . $type ); 43 } 44 45 $_[0] = &threads::shared::share( $_[0] ); 46 47 if( $type eq 'HASH' ) { 48 %{ $_[0] } = %$data; 49 } 50 elsif( $type eq 'ARRAY' ) { 51 @{ $_[0] } = @$data; 52 } 53 elsif( $type eq 'SCALAR' ) { 54 ${ $_[0] } = $$data; 55 } 56 else { 57 die( "Unknown type: " . $type ); 58 } 59 60 return $_[0]; 61 }; 62 } 63 # 5.8.0's threads::shared is busted when threads are off 64 # and earlier Perls just don't have that module at all. 65 else { 66 *share = sub { return $_[0] }; 67 *lock = sub { 0 }; 68 } 69} 70 71=head1 NAME 72 73Test::Builder - Backend for building test libraries 74 75=head1 SYNOPSIS 76 77 package My::Test::Module; 78 use base 'Test::Builder::Module'; 79 80 my $CLASS = __PACKAGE__; 81 82 sub ok { 83 my($test, $name) = @_; 84 my $tb = $CLASS->builder; 85 86 $tb->ok($test, $name); 87 } 88 89 90=head1 DESCRIPTION 91 92Test::Simple and Test::More have proven to be popular testing modules, 93but they're not always flexible enough. Test::Builder provides the a 94building block upon which to write your own test libraries I<which can 95work together>. 96 97=head2 Construction 98 99=over 4 100 101=item B<new> 102 103 my $Test = Test::Builder->new; 104 105Returns a Test::Builder object representing the current state of the 106test. 107 108Since you only run one test per program C<new> always returns the same 109Test::Builder object. No matter how many times you call C<new()>, you're 110getting the same object. This is called a singleton. This is done so that 111multiple modules share such global information as the test counter and 112where test output is going. 113 114If you want a completely new Test::Builder object different from the 115singleton, use C<create>. 116 117=cut 118 119our $Test = Test::Builder->new; 120 121sub new { 122 my($class) = shift; 123 $Test ||= $class->create; 124 return $Test; 125} 126 127=item B<create> 128 129 my $Test = Test::Builder->create; 130 131Ok, so there can be more than one Test::Builder object and this is how 132you get it. You might use this instead of C<new()> if you're testing 133a Test::Builder based module, but otherwise you probably want C<new>. 134 135B<NOTE>: the implementation is not complete. C<level>, for example, is 136still shared amongst B<all> Test::Builder objects, even ones created using 137this method. Also, the method name may change in the future. 138 139=cut 140 141sub create { 142 my $class = shift; 143 144 my $self = bless {}, $class; 145 $self->reset; 146 147 return $self; 148} 149 150=item B<child> 151 152 my $child = $builder->child($name_of_child); 153 $child->plan( tests => 4 ); 154 $child->ok(some_code()); 155 ... 156 $child->finalize; 157 158Returns a new instance of C<Test::Builder>. Any output from this child will 159indented four spaces more than the parent's indentation. When done, the 160C<finalize> method I<must> be called explicitly. 161 162Trying to create a new child with a previous child still active (i.e., 163C<finalize> not called) will C<croak>. 164 165Trying to run a test when you have an open child will also C<croak> and cause 166the test suite to fail. 167 168=cut 169 170sub child { 171 my( $self, $name ) = @_; 172 173 if( $self->{Child_Name} ) { 174 $self->croak("You already have a child named ($self->{Child_Name}) running"); 175 } 176 177 my $child = bless {}, ref $self; 178 $child->reset; 179 180 # Add to our indentation 181 $child->_indent( $self->_indent . ' ' ); 182 $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH}; 183 184 # This will be reset in finalize. We do this here lest one child failure 185 # cause all children to fail. 186 $child->{Child_Error} = $?; 187 $? = 0; 188 $child->{Parent} = $self; 189 $child->{Name} = $name || "Child of " . $self->name; 190 $self->{Child_Name} = $child->name; 191 return $child; 192} 193 194 195=item B<subtest> 196 197 $builder->subtest($name, \&subtests); 198 199See documentation of C<subtest> in Test::More. 200 201=cut 202 203sub subtest { 204 my $self = shift; 205 my($name, $subtests) = @_; 206 207 if ('CODE' ne ref $subtests) { 208 $self->croak("subtest()'s second argument must be a code ref"); 209 } 210 211 # Turn the child into the parent so anyone who has stored a copy of 212 # the Test::Builder singleton will get the child. 213 my $child = $self->child($name); 214 my %parent = %$self; 215 %$self = %$child; 216 217 my $error; 218 if( !eval { $subtests->(); 1 } ) { 219 $error = $@; 220 } 221 222 # Restore the parent and the copied child. 223 %$child = %$self; 224 %$self = %parent; 225 226 # Die *after* we restore the parent. 227 die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; 228 229 return $child->finalize; 230} 231 232 233=item B<finalize> 234 235 my $ok = $child->finalize; 236 237When your child is done running tests, you must call C<finalize> to clean up 238and tell the parent your pass/fail status. 239 240Calling finalize on a child with open children will C<croak>. 241 242If the child falls out of scope before C<finalize> is called, a failure 243diagnostic will be issued and the child is considered to have failed. 244 245No attempt to call methods on a child after C<finalize> is called is 246guaranteed to succeed. 247 248Calling this on the root builder is a no-op. 249 250=cut 251 252sub finalize { 253 my $self = shift; 254 255 return unless $self->parent; 256 if( $self->{Child_Name} ) { 257 $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); 258 } 259 $self->_ending; 260 261 # XXX This will only be necessary for TAP envelopes (we think) 262 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); 263 264 my $ok = 1; 265 $self->parent->{Child_Name} = undef; 266 if ( $self->{Skip_All} ) { 267 $self->parent->skip($self->{Skip_All}); 268 } 269 elsif ( not @{ $self->{Test_Results} } ) { 270 $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); 271 } 272 else { 273 $self->parent->ok( $self->is_passing, $self->name ); 274 } 275 $? = $self->{Child_Error}; 276 delete $self->{Parent}; 277 278 return $self->is_passing; 279} 280 281sub _indent { 282 my $self = shift; 283 284 if( @_ ) { 285 $self->{Indent} = shift; 286 } 287 288 return $self->{Indent}; 289} 290 291=item B<parent> 292 293 if ( my $parent = $builder->parent ) { 294 ... 295 } 296 297Returns the parent C<Test::Builder> instance, if any. Only used with child 298builders for nested TAP. 299 300=cut 301 302sub parent { shift->{Parent} } 303 304=item B<name> 305 306 diag $builder->name; 307 308Returns the name of the current builder. Top level builders default to C<$0> 309(the name of the executable). Child builders are named via the C<child> 310method. If no name is supplied, will be named "Child of $parent->name". 311 312=cut 313 314sub name { shift->{Name} } 315 316sub DESTROY { 317 my $self = shift; 318 if ( $self->parent ) { 319 my $name = $self->name; 320 $self->diag(<<"FAIL"); 321Child ($name) exited without calling finalize() 322FAIL 323 $self->parent->{In_Destroy} = 1; 324 $self->parent->ok(0, $name); 325 } 326} 327 328=item B<reset> 329 330 $Test->reset; 331 332Reinitializes the Test::Builder singleton to its original state. 333Mostly useful for tests run in persistent environments where the same 334test might be run multiple times in the same process. 335 336=cut 337 338our $Level; 339 340sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) 341 my($self) = @_; 342 343 # We leave this a global because it has to be localized and localizing 344 # hash keys is just asking for pain. Also, it was documented. 345 $Level = 1; 346 347 $self->{Name} = $0; 348 $self->is_passing(1); 349 $self->{Ending} = 0; 350 $self->{Have_Plan} = 0; 351 $self->{No_Plan} = 0; 352 $self->{Have_Output_Plan} = 0; 353 354 $self->{Original_Pid} = $$; 355 $self->{Child_Name} = undef; 356 $self->{Indent} ||= ''; 357 358 share( $self->{Curr_Test} ); 359 $self->{Curr_Test} = 0; 360 $self->{Test_Results} = &share( [] ); 361 362 $self->{Exported_To} = undef; 363 $self->{Expected_Tests} = 0; 364 365 $self->{Skip_All} = 0; 366 367 $self->{Use_Nums} = 1; 368 369 $self->{No_Header} = 0; 370 $self->{No_Ending} = 0; 371 372 $self->{Todo} = undef; 373 $self->{Todo_Stack} = []; 374 $self->{Start_Todo} = 0; 375 $self->{Opened_Testhandles} = 0; 376 377 $self->_dup_stdhandles; 378 379 return; 380} 381 382=back 383 384=head2 Setting up tests 385 386These methods are for setting up tests and declaring how many there 387are. You usually only want to call one of these methods. 388 389=over 4 390 391=item B<plan> 392 393 $Test->plan('no_plan'); 394 $Test->plan( skip_all => $reason ); 395 $Test->plan( tests => $num_tests ); 396 397A convenient way to set up your tests. Call this and Test::Builder 398will print the appropriate headers and take the appropriate actions. 399 400If you call C<plan()>, don't call any of the other methods below. 401 402If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is 403thrown. Trap this error, call C<finalize()> and don't run any more tests on 404the child. 405 406 my $child = $Test->child('some child'); 407 eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) }; 408 if ( eval { $@->isa('Test::Builder::Exception') } ) { 409 $child->finalize; 410 return; 411 } 412 # run your tests 413 414=cut 415 416my %plan_cmds = ( 417 no_plan => \&no_plan, 418 skip_all => \&skip_all, 419 tests => \&_plan_tests, 420); 421 422sub plan { 423 my( $self, $cmd, $arg ) = @_; 424 425 return unless $cmd; 426 427 local $Level = $Level + 1; 428 429 $self->croak("You tried to plan twice") if $self->{Have_Plan}; 430 431 if( my $method = $plan_cmds{$cmd} ) { 432 local $Level = $Level + 1; 433 $self->$method($arg); 434 } 435 else { 436 my @args = grep { defined } ( $cmd, $arg ); 437 $self->croak("plan() doesn't understand @args"); 438 } 439 440 return 1; 441} 442 443 444sub _plan_tests { 445 my($self, $arg) = @_; 446 447 if($arg) { 448 local $Level = $Level + 1; 449 return $self->expected_tests($arg); 450 } 451 elsif( !defined $arg ) { 452 $self->croak("Got an undefined number of tests"); 453 } 454 else { 455 $self->croak("You said to run 0 tests"); 456 } 457 458 return; 459} 460 461 462=item B<expected_tests> 463 464 my $max = $Test->expected_tests; 465 $Test->expected_tests($max); 466 467Gets/sets the number of tests we expect this test to run and prints out 468the appropriate headers. 469 470=cut 471 472sub expected_tests { 473 my $self = shift; 474 my($max) = @_; 475 476 if(@_) { 477 $self->croak("Number of tests must be a positive integer. You gave it '$max'") 478 unless $max =~ /^\+?\d+$/; 479 480 $self->{Expected_Tests} = $max; 481 $self->{Have_Plan} = 1; 482 483 $self->_output_plan($max) unless $self->no_header; 484 } 485 return $self->{Expected_Tests}; 486} 487 488=item B<no_plan> 489 490 $Test->no_plan; 491 492Declares that this test will run an indeterminate number of tests. 493 494=cut 495 496sub no_plan { 497 my($self, $arg) = @_; 498 499 $self->carp("no_plan takes no arguments") if $arg; 500 501 $self->{No_Plan} = 1; 502 $self->{Have_Plan} = 1; 503 504 return 1; 505} 506 507 508=begin private 509 510=item B<_output_plan> 511 512 $tb->_output_plan($max); 513 $tb->_output_plan($max, $directive); 514 $tb->_output_plan($max, $directive => $reason); 515 516Handles displaying the test plan. 517 518If a C<$directive> and/or C<$reason> are given they will be output with the 519plan. So here's what skipping all tests looks like: 520 521 $tb->_output_plan(0, "SKIP", "Because I said so"); 522 523It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already 524output. 525 526=end private 527 528=cut 529 530sub _output_plan { 531 my($self, $max, $directive, $reason) = @_; 532 533 $self->carp("The plan was already output") if $self->{Have_Output_Plan}; 534 535 my $plan = "1..$max"; 536 $plan .= " # $directive" if defined $directive; 537 $plan .= " $reason" if defined $reason; 538 539 $self->_print("$plan\n"); 540 541 $self->{Have_Output_Plan} = 1; 542 543 return; 544} 545 546=item B<done_testing> 547 548 $Test->done_testing(); 549 $Test->done_testing($num_tests); 550 551Declares that you are done testing, no more tests will be run after this point. 552 553If a plan has not yet been output, it will do so. 554 555$num_tests is the number of tests you planned to run. If a numbered 556plan was already declared, and if this contradicts, a failing test 557will be run to reflect the planning mistake. If C<no_plan> was declared, 558this will override. 559 560If C<done_testing()> is called twice, the second call will issue a 561failing test. 562 563If C<$num_tests> is omitted, the number of tests run will be used, like 564no_plan. 565 566C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but 567safer. You'd use it like so: 568 569 $Test->ok($a == $b); 570 $Test->done_testing(); 571 572Or to plan a variable number of tests: 573 574 for my $test (@tests) { 575 $Test->ok($test); 576 } 577 $Test->done_testing(@tests); 578 579=cut 580 581sub done_testing { 582 my($self, $num_tests) = @_; 583 584 # If done_testing() specified the number of tests, shut off no_plan. 585 if( defined $num_tests ) { 586 $self->{No_Plan} = 0; 587 } 588 else { 589 $num_tests = $self->current_test; 590 } 591 592 if( $self->{Done_Testing} ) { 593 my($file, $line) = @{$self->{Done_Testing}}[1,2]; 594 $self->ok(0, "done_testing() was already called at $file line $line"); 595 return; 596 } 597 598 $self->{Done_Testing} = [caller]; 599 600 if( $self->expected_tests && $num_tests != $self->expected_tests ) { 601 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". 602 "but done_testing() expects $num_tests"); 603 } 604 else { 605 $self->{Expected_Tests} = $num_tests; 606 } 607 608 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; 609 610 $self->{Have_Plan} = 1; 611 612 # The wrong number of tests were run 613 $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test}; 614 615 # No tests were run 616 $self->is_passing(0) if $self->{Curr_Test} == 0; 617 618 return 1; 619} 620 621 622=item B<has_plan> 623 624 $plan = $Test->has_plan 625 626Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan 627has been set), C<no_plan> (indeterminate # of tests) or an integer (the number 628of expected tests). 629 630=cut 631 632sub has_plan { 633 my $self = shift; 634 635 return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; 636 return('no_plan') if $self->{No_Plan}; 637 return(undef); 638} 639 640=item B<skip_all> 641 642 $Test->skip_all; 643 $Test->skip_all($reason); 644 645Skips all the tests, using the given C<$reason>. Exits immediately with 0. 646 647=cut 648 649sub skip_all { 650 my( $self, $reason ) = @_; 651 652 $self->{Skip_All} = $self->parent ? $reason : 1; 653 654 $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; 655 if ( $self->parent ) { 656 die bless {} => 'Test::Builder::Exception'; 657 } 658 exit(0); 659} 660 661=item B<exported_to> 662 663 my $pack = $Test->exported_to; 664 $Test->exported_to($pack); 665 666Tells Test::Builder what package you exported your functions to. 667 668This method isn't terribly useful since modules which share the same 669Test::Builder object might get exported to different packages and only 670the last one will be honored. 671 672=cut 673 674sub exported_to { 675 my( $self, $pack ) = @_; 676 677 if( defined $pack ) { 678 $self->{Exported_To} = $pack; 679 } 680 return $self->{Exported_To}; 681} 682 683=back 684 685=head2 Running tests 686 687These actually run the tests, analogous to the functions in Test::More. 688 689They all return true if the test passed, false if the test failed. 690 691C<$name> is always optional. 692 693=over 4 694 695=item B<ok> 696 697 $Test->ok($test, $name); 698 699Your basic test. Pass if C<$test> is true, fail if $test is false. Just 700like Test::Simple's C<ok()>. 701 702=cut 703 704sub ok { 705 my( $self, $test, $name ) = @_; 706 707 if ( $self->{Child_Name} and not $self->{In_Destroy} ) { 708 $name = 'unnamed test' unless defined $name; 709 $self->is_passing(0); 710 $self->croak("Cannot run test ($name) with active children"); 711 } 712 # $test might contain an object which we don't want to accidentally 713 # store, so we turn it into a boolean. 714 $test = $test ? 1 : 0; 715 716 lock $self->{Curr_Test}; 717 $self->{Curr_Test}++; 718 719 # In case $name is a string overloaded object, force it to stringify. 720 $self->_unoverload_str( \$name ); 721 722 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; 723 You named your test '$name'. You shouldn't use numbers for your test names. 724 Very confusing. 725ERR 726 727 # Capture the value of $TODO for the rest of this ok() call 728 # so it can more easily be found by other routines. 729 my $todo = $self->todo(); 730 my $in_todo = $self->in_todo; 731 local $self->{Todo} = $todo if $in_todo; 732 733 $self->_unoverload_str( \$todo ); 734 735 my $out; 736 my $result = &share( {} ); 737 738 unless($test) { 739 $out .= "not "; 740 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); 741 } 742 else { 743 @$result{ 'ok', 'actual_ok' } = ( 1, $test ); 744 } 745 746 $out .= "ok"; 747 $out .= " $self->{Curr_Test}" if $self->use_numbers; 748 749 if( defined $name ) { 750 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. 751 $out .= " - $name"; 752 $result->{name} = $name; 753 } 754 else { 755 $result->{name} = ''; 756 } 757 758 if( $self->in_todo ) { 759 $out .= " # TODO $todo"; 760 $result->{reason} = $todo; 761 $result->{type} = 'todo'; 762 } 763 else { 764 $result->{reason} = ''; 765 $result->{type} = ''; 766 } 767 768 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; 769 $out .= "\n"; 770 771 $self->_print($out); 772 773 unless($test) { 774 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; 775 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; 776 777 my( undef, $file, $line ) = $self->caller; 778 if( defined $name ) { 779 $self->diag(qq[ $msg test '$name'\n]); 780 $self->diag(qq[ at $file line $line.\n]); 781 } 782 else { 783 $self->diag(qq[ $msg test at $file line $line.\n]); 784 } 785 } 786 787 $self->is_passing(0) unless $test || $self->in_todo; 788 789 # Check that we haven't violated the plan 790 $self->_check_is_passing_plan(); 791 792 return $test ? 1 : 0; 793} 794 795 796# Check that we haven't yet violated the plan and set 797# is_passing() accordingly 798sub _check_is_passing_plan { 799 my $self = shift; 800 801 my $plan = $self->has_plan; 802 return unless defined $plan; # no plan yet defined 803 return unless $plan !~ /\D/; # no numeric plan 804 $self->is_passing(0) if $plan < $self->{Curr_Test}; 805} 806 807 808sub _unoverload { 809 my $self = shift; 810 my $type = shift; 811 812 $self->_try(sub { require overload; }, die_on_fail => 1); 813 814 foreach my $thing (@_) { 815 if( $self->_is_object($$thing) ) { 816 if( my $string_meth = overload::Method( $$thing, $type ) ) { 817 $$thing = $$thing->$string_meth(); 818 } 819 } 820 } 821 822 return; 823} 824 825sub _is_object { 826 my( $self, $thing ) = @_; 827 828 return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; 829} 830 831sub _unoverload_str { 832 my $self = shift; 833 834 return $self->_unoverload( q[""], @_ ); 835} 836 837sub _unoverload_num { 838 my $self = shift; 839 840 $self->_unoverload( '0+', @_ ); 841 842 for my $val (@_) { 843 next unless $self->_is_dualvar($$val); 844 $$val = $$val + 0; 845 } 846 847 return; 848} 849 850# This is a hack to detect a dualvar such as $! 851sub _is_dualvar { 852 my( $self, $val ) = @_; 853 854 # Objects are not dualvars. 855 return 0 if ref $val; 856 857 no warnings 'numeric'; 858 my $numval = $val + 0; 859 return $numval != 0 and $numval ne $val ? 1 : 0; 860} 861 862=item B<is_eq> 863 864 $Test->is_eq($got, $expected, $name); 865 866Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the 867string version. 868 869=item B<is_num> 870 871 $Test->is_num($got, $expected, $name); 872 873Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the 874numeric version. 875 876=cut 877 878sub is_eq { 879 my( $self, $got, $expect, $name ) = @_; 880 local $Level = $Level + 1; 881 882 $self->_unoverload_str( \$got, \$expect ); 883 884 if( !defined $got || !defined $expect ) { 885 # undef only matches undef and nothing else 886 my $test = !defined $got && !defined $expect; 887 888 $self->ok( $test, $name ); 889 $self->_is_diag( $got, 'eq', $expect ) unless $test; 890 return $test; 891 } 892 893 return $self->cmp_ok( $got, 'eq', $expect, $name ); 894} 895 896sub is_num { 897 my( $self, $got, $expect, $name ) = @_; 898 local $Level = $Level + 1; 899 900 $self->_unoverload_num( \$got, \$expect ); 901 902 if( !defined $got || !defined $expect ) { 903 # undef only matches undef and nothing else 904 my $test = !defined $got && !defined $expect; 905 906 $self->ok( $test, $name ); 907 $self->_is_diag( $got, '==', $expect ) unless $test; 908 return $test; 909 } 910 911 return $self->cmp_ok( $got, '==', $expect, $name ); 912} 913 914sub _diag_fmt { 915 my( $self, $type, $val ) = @_; 916 917 if( defined $$val ) { 918 if( $type eq 'eq' or $type eq 'ne' ) { 919 # quote and force string context 920 $$val = "'$$val'"; 921 } 922 else { 923 # force numeric context 924 $self->_unoverload_num($val); 925 } 926 } 927 else { 928 $$val = 'undef'; 929 } 930 931 return; 932} 933 934sub _is_diag { 935 my( $self, $got, $type, $expect ) = @_; 936 937 $self->_diag_fmt( $type, $_ ) for \$got, \$expect; 938 939 local $Level = $Level + 1; 940 return $self->diag(<<"DIAGNOSTIC"); 941 got: $got 942 expected: $expect 943DIAGNOSTIC 944 945} 946 947sub _isnt_diag { 948 my( $self, $got, $type ) = @_; 949 950 $self->_diag_fmt( $type, \$got ); 951 952 local $Level = $Level + 1; 953 return $self->diag(<<"DIAGNOSTIC"); 954 got: $got 955 expected: anything else 956DIAGNOSTIC 957} 958 959=item B<isnt_eq> 960 961 $Test->isnt_eq($got, $dont_expect, $name); 962 963Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is 964the string version. 965 966=item B<isnt_num> 967 968 $Test->isnt_num($got, $dont_expect, $name); 969 970Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is 971the numeric version. 972 973=cut 974 975sub isnt_eq { 976 my( $self, $got, $dont_expect, $name ) = @_; 977 local $Level = $Level + 1; 978 979 if( !defined $got || !defined $dont_expect ) { 980 # undef only matches undef and nothing else 981 my $test = defined $got || defined $dont_expect; 982 983 $self->ok( $test, $name ); 984 $self->_isnt_diag( $got, 'ne' ) unless $test; 985 return $test; 986 } 987 988 return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); 989} 990 991sub isnt_num { 992 my( $self, $got, $dont_expect, $name ) = @_; 993 local $Level = $Level + 1; 994 995 if( !defined $got || !defined $dont_expect ) { 996 # undef only matches undef and nothing else 997 my $test = defined $got || defined $dont_expect; 998 999 $self->ok( $test, $name ); 1000 $self->_isnt_diag( $got, '!=' ) unless $test; 1001 return $test; 1002 } 1003 1004 return $self->cmp_ok( $got, '!=', $dont_expect, $name ); 1005} 1006 1007=item B<like> 1008 1009 $Test->like($this, qr/$regex/, $name); 1010 $Test->like($this, '/$regex/', $name); 1011 1012Like Test::More's C<like()>. Checks if $this matches the given C<$regex>. 1013 1014=item B<unlike> 1015 1016 $Test->unlike($this, qr/$regex/, $name); 1017 $Test->unlike($this, '/$regex/', $name); 1018 1019Like Test::More's C<unlike()>. Checks if $this B<does not match> the 1020given C<$regex>. 1021 1022=cut 1023 1024sub like { 1025 my( $self, $this, $regex, $name ) = @_; 1026 1027 local $Level = $Level + 1; 1028 return $self->_regex_ok( $this, $regex, '=~', $name ); 1029} 1030 1031sub unlike { 1032 my( $self, $this, $regex, $name ) = @_; 1033 1034 local $Level = $Level + 1; 1035 return $self->_regex_ok( $this, $regex, '!~', $name ); 1036} 1037 1038=item B<cmp_ok> 1039 1040 $Test->cmp_ok($this, $type, $that, $name); 1041 1042Works just like Test::More's C<cmp_ok()>. 1043 1044 $Test->cmp_ok($big_num, '!=', $other_big_num); 1045 1046=cut 1047 1048my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); 1049 1050sub cmp_ok { 1051 my( $self, $got, $type, $expect, $name ) = @_; 1052 1053 my $test; 1054 my $error; 1055 { 1056 ## no critic (BuiltinFunctions::ProhibitStringyEval) 1057 1058 local( $@, $!, $SIG{__DIE__} ); # isolate eval 1059 1060 my($pack, $file, $line) = $self->caller(); 1061 1062 $test = eval qq[ 1063#line 1 "cmp_ok [from $file line $line]" 1064\$got $type \$expect; 1065]; 1066 $error = $@; 1067 } 1068 local $Level = $Level + 1; 1069 my $ok = $self->ok( $test, $name ); 1070 1071 # Treat overloaded objects as numbers if we're asked to do a 1072 # numeric comparison. 1073 my $unoverload 1074 = $numeric_cmps{$type} 1075 ? '_unoverload_num' 1076 : '_unoverload_str'; 1077 1078 $self->diag(<<"END") if $error; 1079An error occurred while using $type: 1080------------------------------------ 1081$error 1082------------------------------------ 1083END 1084 1085 unless($ok) { 1086 $self->$unoverload( \$got, \$expect ); 1087 1088 if( $type =~ /^(eq|==)$/ ) { 1089 $self->_is_diag( $got, $type, $expect ); 1090 } 1091 elsif( $type =~ /^(ne|!=)$/ ) { 1092 $self->_isnt_diag( $got, $type ); 1093 } 1094 else { 1095 $self->_cmp_diag( $got, $type, $expect ); 1096 } 1097 } 1098 return $ok; 1099} 1100 1101sub _cmp_diag { 1102 my( $self, $got, $type, $expect ) = @_; 1103 1104 $got = defined $got ? "'$got'" : 'undef'; 1105 $expect = defined $expect ? "'$expect'" : 'undef'; 1106 1107 local $Level = $Level + 1; 1108 return $self->diag(<<"DIAGNOSTIC"); 1109 $got 1110 $type 1111 $expect 1112DIAGNOSTIC 1113} 1114 1115sub _caller_context { 1116 my $self = shift; 1117 1118 my( $pack, $file, $line ) = $self->caller(1); 1119 1120 my $code = ''; 1121 $code .= "#line $line $file\n" if defined $file and defined $line; 1122 1123 return $code; 1124} 1125 1126=back 1127 1128 1129=head2 Other Testing Methods 1130 1131These are methods which are used in the course of writing a test but are not themselves tests. 1132 1133=over 4 1134 1135=item B<BAIL_OUT> 1136 1137 $Test->BAIL_OUT($reason); 1138 1139Indicates to the Test::Harness that things are going so badly all 1140testing should terminate. This includes running any additional test 1141scripts. 1142 1143It will exit with 255. 1144 1145=cut 1146 1147sub BAIL_OUT { 1148 my( $self, $reason ) = @_; 1149 1150 $self->{Bailed_Out} = 1; 1151 $self->_print("Bail out! $reason"); 1152 exit 255; 1153} 1154 1155=for deprecated 1156BAIL_OUT() used to be BAILOUT() 1157 1158=cut 1159 1160{ 1161 no warnings 'once'; 1162 *BAILOUT = \&BAIL_OUT; 1163} 1164 1165=item B<skip> 1166 1167 $Test->skip; 1168 $Test->skip($why); 1169 1170Skips the current test, reporting C<$why>. 1171 1172=cut 1173 1174sub skip { 1175 my( $self, $why ) = @_; 1176 $why ||= ''; 1177 $self->_unoverload_str( \$why ); 1178 1179 lock( $self->{Curr_Test} ); 1180 $self->{Curr_Test}++; 1181 1182 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( 1183 { 1184 'ok' => 1, 1185 actual_ok => 1, 1186 name => '', 1187 type => 'skip', 1188 reason => $why, 1189 } 1190 ); 1191 1192 my $out = "ok"; 1193 $out .= " $self->{Curr_Test}" if $self->use_numbers; 1194 $out .= " # skip"; 1195 $out .= " $why" if length $why; 1196 $out .= "\n"; 1197 1198 $self->_print($out); 1199 1200 return 1; 1201} 1202 1203=item B<todo_skip> 1204 1205 $Test->todo_skip; 1206 $Test->todo_skip($why); 1207 1208Like C<skip()>, only it will declare the test as failing and TODO. Similar 1209to 1210 1211 print "not ok $tnum # TODO $why\n"; 1212 1213=cut 1214 1215sub todo_skip { 1216 my( $self, $why ) = @_; 1217 $why ||= ''; 1218 1219 lock( $self->{Curr_Test} ); 1220 $self->{Curr_Test}++; 1221 1222 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( 1223 { 1224 'ok' => 1, 1225 actual_ok => 0, 1226 name => '', 1227 type => 'todo_skip', 1228 reason => $why, 1229 } 1230 ); 1231 1232 my $out = "not ok"; 1233 $out .= " $self->{Curr_Test}" if $self->use_numbers; 1234 $out .= " # TODO & SKIP $why\n"; 1235 1236 $self->_print($out); 1237 1238 return 1; 1239} 1240 1241=begin _unimplemented 1242 1243=item B<skip_rest> 1244 1245 $Test->skip_rest; 1246 $Test->skip_rest($reason); 1247 1248Like C<skip()>, only it skips all the rest of the tests you plan to run 1249and terminates the test. 1250 1251If you're running under C<no_plan>, it skips once and terminates the 1252test. 1253 1254=end _unimplemented 1255 1256=back 1257 1258 1259=head2 Test building utility methods 1260 1261These methods are useful when writing your own test methods. 1262 1263=over 4 1264 1265=item B<maybe_regex> 1266 1267 $Test->maybe_regex(qr/$regex/); 1268 $Test->maybe_regex('/$regex/'); 1269 1270This method used to be useful back when Test::Builder worked on Perls 1271before 5.6 which didn't have qr//. Now its pretty useless. 1272 1273Convenience method for building testing functions that take regular 1274expressions as arguments. 1275 1276Takes a quoted regular expression produced by C<qr//>, or a string 1277representing a regular expression. 1278 1279Returns a Perl value which may be used instead of the corresponding 1280regular expression, or C<undef> if its argument is not recognised. 1281 1282For example, a version of C<like()>, sans the useful diagnostic messages, 1283could be written as: 1284 1285 sub laconic_like { 1286 my ($self, $this, $regex, $name) = @_; 1287 my $usable_regex = $self->maybe_regex($regex); 1288 die "expecting regex, found '$regex'\n" 1289 unless $usable_regex; 1290 $self->ok($this =~ m/$usable_regex/, $name); 1291 } 1292 1293=cut 1294 1295sub maybe_regex { 1296 my( $self, $regex ) = @_; 1297 my $usable_regex = undef; 1298 1299 return $usable_regex unless defined $regex; 1300 1301 my( $re, $opts ); 1302 1303 # Check for qr/foo/ 1304 if( _is_qr($regex) ) { 1305 $usable_regex = $regex; 1306 } 1307 # Check for '/foo/' or 'm,foo,' 1308 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or 1309 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx 1310 ) 1311 { 1312 $usable_regex = length $opts ? "(?$opts)$re" : $re; 1313 } 1314 1315 return $usable_regex; 1316} 1317 1318sub _is_qr { 1319 my $regex = shift; 1320 1321 # is_regexp() checks for regexes in a robust manner, say if they're 1322 # blessed. 1323 return re::is_regexp($regex) if defined &re::is_regexp; 1324 return ref $regex eq 'Regexp'; 1325} 1326 1327sub _regex_ok { 1328 my( $self, $this, $regex, $cmp, $name ) = @_; 1329 1330 my $ok = 0; 1331 my $usable_regex = $self->maybe_regex($regex); 1332 unless( defined $usable_regex ) { 1333 local $Level = $Level + 1; 1334 $ok = $self->ok( 0, $name ); 1335 $self->diag(" '$regex' doesn't look much like a regex to me."); 1336 return $ok; 1337 } 1338 1339 { 1340 ## no critic (BuiltinFunctions::ProhibitStringyEval) 1341 1342 my $test; 1343 my $context = $self->_caller_context; 1344 1345 local( $@, $!, $SIG{__DIE__} ); # isolate eval 1346 1347 $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; 1348 1349 $test = !$test if $cmp eq '!~'; 1350 1351 local $Level = $Level + 1; 1352 $ok = $self->ok( $test, $name ); 1353 } 1354 1355 unless($ok) { 1356 $this = defined $this ? "'$this'" : 'undef'; 1357 my $match = $cmp eq '=~' ? "doesn't match" : "matches"; 1358 1359 local $Level = $Level + 1; 1360 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); 1361 %s 1362 %13s '%s' 1363DIAGNOSTIC 1364 1365 } 1366 1367 return $ok; 1368} 1369 1370# I'm not ready to publish this. It doesn't deal with array return 1371# values from the code or context. 1372 1373=begin private 1374 1375=item B<_try> 1376 1377 my $return_from_code = $Test->try(sub { code }); 1378 my($return_from_code, $error) = $Test->try(sub { code }); 1379 1380Works like eval BLOCK except it ensures it has no effect on the rest 1381of the test (ie. C<$@> is not set) nor is effected by outside 1382interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older 1383Perls. 1384 1385C<$error> is what would normally be in C<$@>. 1386 1387It is suggested you use this in place of eval BLOCK. 1388 1389=cut 1390 1391sub _try { 1392 my( $self, $code, %opts ) = @_; 1393 1394 my $error; 1395 my $return; 1396 { 1397 local $!; # eval can mess up $! 1398 local $@; # don't set $@ in the test 1399 local $SIG{__DIE__}; # don't trip an outside DIE handler. 1400 $return = eval { $code->() }; 1401 $error = $@; 1402 } 1403 1404 die $error if $error and $opts{die_on_fail}; 1405 1406 return wantarray ? ( $return, $error ) : $return; 1407} 1408 1409=end private 1410 1411 1412=item B<is_fh> 1413 1414 my $is_fh = $Test->is_fh($thing); 1415 1416Determines if the given C<$thing> can be used as a filehandle. 1417 1418=cut 1419 1420sub is_fh { 1421 my $self = shift; 1422 my $maybe_fh = shift; 1423 return 0 unless defined $maybe_fh; 1424 1425 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref 1426 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob 1427 1428 return eval { $maybe_fh->isa("IO::Handle") } || 1429 eval { tied($maybe_fh)->can('TIEHANDLE') }; 1430} 1431 1432=back 1433 1434 1435=head2 Test style 1436 1437 1438=over 4 1439 1440=item B<level> 1441 1442 $Test->level($how_high); 1443 1444How far up the call stack should C<$Test> look when reporting where the 1445test failed. 1446 1447Defaults to 1. 1448 1449Setting L<$Test::Builder::Level> overrides. This is typically useful 1450localized: 1451 1452 sub my_ok { 1453 my $test = shift; 1454 1455 local $Test::Builder::Level = $Test::Builder::Level + 1; 1456 $TB->ok($test); 1457 } 1458 1459To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. 1460 1461=cut 1462 1463sub level { 1464 my( $self, $level ) = @_; 1465 1466 if( defined $level ) { 1467 $Level = $level; 1468 } 1469 return $Level; 1470} 1471 1472=item B<use_numbers> 1473 1474 $Test->use_numbers($on_or_off); 1475 1476Whether or not the test should output numbers. That is, this if true: 1477 1478 ok 1 1479 ok 2 1480 ok 3 1481 1482or this if false 1483 1484 ok 1485 ok 1486 ok 1487 1488Most useful when you can't depend on the test output order, such as 1489when threads or forking is involved. 1490 1491Defaults to on. 1492 1493=cut 1494 1495sub use_numbers { 1496 my( $self, $use_nums ) = @_; 1497 1498 if( defined $use_nums ) { 1499 $self->{Use_Nums} = $use_nums; 1500 } 1501 return $self->{Use_Nums}; 1502} 1503 1504=item B<no_diag> 1505 1506 $Test->no_diag($no_diag); 1507 1508If set true no diagnostics will be printed. This includes calls to 1509C<diag()>. 1510 1511=item B<no_ending> 1512 1513 $Test->no_ending($no_ending); 1514 1515Normally, Test::Builder does some extra diagnostics when the test 1516ends. It also changes the exit code as described below. 1517 1518If this is true, none of that will be done. 1519 1520=item B<no_header> 1521 1522 $Test->no_header($no_header); 1523 1524If set to true, no "1..N" header will be printed. 1525 1526=cut 1527 1528foreach my $attribute (qw(No_Header No_Ending No_Diag)) { 1529 my $method = lc $attribute; 1530 1531 my $code = sub { 1532 my( $self, $no ) = @_; 1533 1534 if( defined $no ) { 1535 $self->{$attribute} = $no; 1536 } 1537 return $self->{$attribute}; 1538 }; 1539 1540 no strict 'refs'; ## no critic 1541 *{ __PACKAGE__ . '::' . $method } = $code; 1542} 1543 1544=back 1545 1546=head2 Output 1547 1548Controlling where the test output goes. 1549 1550It's ok for your test to change where STDOUT and STDERR point to, 1551Test::Builder's default output settings will not be affected. 1552 1553=over 4 1554 1555=item B<diag> 1556 1557 $Test->diag(@msgs); 1558 1559Prints out the given C<@msgs>. Like C<print>, arguments are simply 1560appended together. 1561 1562Normally, it uses the C<failure_output()> handle, but if this is for a 1563TODO test, the C<todo_output()> handle is used. 1564 1565Output will be indented and marked with a # so as not to interfere 1566with test output. A newline will be put on the end if there isn't one 1567already. 1568 1569We encourage using this rather than calling print directly. 1570 1571Returns false. Why? Because C<diag()> is often used in conjunction with 1572a failing test (C<ok() || diag()>) it "passes through" the failure. 1573 1574 return ok(...) || diag(...); 1575 1576=for blame transfer 1577Mark Fowler <mark@twoshortplanks.com> 1578 1579=cut 1580 1581sub diag { 1582 my $self = shift; 1583 1584 $self->_print_comment( $self->_diag_fh, @_ ); 1585} 1586 1587=item B<note> 1588 1589 $Test->note(@msgs); 1590 1591Like C<diag()>, but it prints to the C<output()> handle so it will not 1592normally be seen by the user except in verbose mode. 1593 1594=cut 1595 1596sub note { 1597 my $self = shift; 1598 1599 $self->_print_comment( $self->output, @_ ); 1600} 1601 1602sub _diag_fh { 1603 my $self = shift; 1604 1605 local $Level = $Level + 1; 1606 return $self->in_todo ? $self->todo_output : $self->failure_output; 1607} 1608 1609sub _print_comment { 1610 my( $self, $fh, @msgs ) = @_; 1611 1612 return if $self->no_diag; 1613 return unless @msgs; 1614 1615 # Prevent printing headers when compiling (i.e. -c) 1616 return if $^C; 1617 1618 # Smash args together like print does. 1619 # Convert undef to 'undef' so its readable. 1620 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; 1621 1622 # Escape the beginning, _print will take care of the rest. 1623 $msg =~ s/^/# /; 1624 1625 local $Level = $Level + 1; 1626 $self->_print_to_fh( $fh, $msg ); 1627 1628 return 0; 1629} 1630 1631=item B<explain> 1632 1633 my @dump = $Test->explain(@msgs); 1634 1635Will dump the contents of any references in a human readable format. 1636Handy for things like... 1637 1638 is_deeply($have, $want) || diag explain $have; 1639 1640or 1641 1642 is_deeply($have, $want) || note explain $have; 1643 1644=cut 1645 1646sub explain { 1647 my $self = shift; 1648 1649 return map { 1650 ref $_ 1651 ? do { 1652 $self->_try(sub { require Data::Dumper }, die_on_fail => 1); 1653 1654 my $dumper = Data::Dumper->new( [$_] ); 1655 $dumper->Indent(1)->Terse(1); 1656 $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); 1657 $dumper->Dump; 1658 } 1659 : $_ 1660 } @_; 1661} 1662 1663=begin _private 1664 1665=item B<_print> 1666 1667 $Test->_print(@msgs); 1668 1669Prints to the C<output()> filehandle. 1670 1671=end _private 1672 1673=cut 1674 1675sub _print { 1676 my $self = shift; 1677 return $self->_print_to_fh( $self->output, @_ ); 1678} 1679 1680sub _print_to_fh { 1681 my( $self, $fh, @msgs ) = @_; 1682 1683 # Prevent printing headers when only compiling. Mostly for when 1684 # tests are deparsed with B::Deparse 1685 return if $^C; 1686 1687 my $msg = join '', @msgs; 1688 1689 local( $\, $", $, ) = ( undef, ' ', '' ); 1690 1691 # Escape each line after the first with a # so we don't 1692 # confuse Test::Harness. 1693 $msg =~ s{\n(?!\z)}{\n# }sg; 1694 1695 # Stick a newline on the end if it needs it. 1696 $msg .= "\n" unless $msg =~ /\n\z/; 1697 1698 return print $fh $self->_indent, $msg; 1699} 1700 1701=item B<output> 1702 1703=item B<failure_output> 1704 1705=item B<todo_output> 1706 1707 my $filehandle = $Test->output; 1708 $Test->output($filehandle); 1709 $Test->output($filename); 1710 $Test->output(\$scalar); 1711 1712These methods control where Test::Builder will print its output. 1713They take either an open C<$filehandle>, a C<$filename> to open and write to 1714or a C<$scalar> reference to append to. It will always return a C<$filehandle>. 1715 1716B<output> is where normal "ok/not ok" test output goes. 1717 1718Defaults to STDOUT. 1719 1720B<failure_output> is where diagnostic output on test failures and 1721C<diag()> goes. It is normally not read by Test::Harness and instead is 1722displayed to the user. 1723 1724Defaults to STDERR. 1725 1726C<todo_output> is used instead of C<failure_output()> for the 1727diagnostics of a failing TODO test. These will not be seen by the 1728user. 1729 1730Defaults to STDOUT. 1731 1732=cut 1733 1734sub output { 1735 my( $self, $fh ) = @_; 1736 1737 if( defined $fh ) { 1738 $self->{Out_FH} = $self->_new_fh($fh); 1739 } 1740 return $self->{Out_FH}; 1741} 1742 1743sub failure_output { 1744 my( $self, $fh ) = @_; 1745 1746 if( defined $fh ) { 1747 $self->{Fail_FH} = $self->_new_fh($fh); 1748 } 1749 return $self->{Fail_FH}; 1750} 1751 1752sub todo_output { 1753 my( $self, $fh ) = @_; 1754 1755 if( defined $fh ) { 1756 $self->{Todo_FH} = $self->_new_fh($fh); 1757 } 1758 return $self->{Todo_FH}; 1759} 1760 1761sub _new_fh { 1762 my $self = shift; 1763 my($file_or_fh) = shift; 1764 1765 my $fh; 1766 if( $self->is_fh($file_or_fh) ) { 1767 $fh = $file_or_fh; 1768 } 1769 elsif( ref $file_or_fh eq 'SCALAR' ) { 1770 # Scalar refs as filehandles was added in 5.8. 1771 if( $] >= 5.008 ) { 1772 open $fh, ">>", $file_or_fh 1773 or $self->croak("Can't open scalar ref $file_or_fh: $!"); 1774 } 1775 # Emulate scalar ref filehandles with a tie. 1776 else { 1777 $fh = Test::Builder::IO::Scalar->new($file_or_fh) 1778 or $self->croak("Can't tie scalar ref $file_or_fh"); 1779 } 1780 } 1781 else { 1782 open $fh, ">", $file_or_fh 1783 or $self->croak("Can't open test output log $file_or_fh: $!"); 1784 _autoflush($fh); 1785 } 1786 1787 return $fh; 1788} 1789 1790sub _autoflush { 1791 my($fh) = shift; 1792 my $old_fh = select $fh; 1793 $| = 1; 1794 select $old_fh; 1795 1796 return; 1797} 1798 1799my( $Testout, $Testerr ); 1800 1801sub _dup_stdhandles { 1802 my $self = shift; 1803 1804 $self->_open_testhandles; 1805 1806 # Set everything to unbuffered else plain prints to STDOUT will 1807 # come out in the wrong order from our own prints. 1808 _autoflush($Testout); 1809 _autoflush( \*STDOUT ); 1810 _autoflush($Testerr); 1811 _autoflush( \*STDERR ); 1812 1813 $self->reset_outputs; 1814 1815 return; 1816} 1817 1818sub _open_testhandles { 1819 my $self = shift; 1820 1821 return if $self->{Opened_Testhandles}; 1822 1823 # We dup STDOUT and STDERR so people can change them in their 1824 # test suites while still getting normal test output. 1825 open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; 1826 open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; 1827 1828 # $self->_copy_io_layers( \*STDOUT, $Testout ); 1829 # $self->_copy_io_layers( \*STDERR, $Testerr ); 1830 1831 $self->{Opened_Testhandles} = 1; 1832 1833 return; 1834} 1835 1836sub _copy_io_layers { 1837 my( $self, $src, $dst ) = @_; 1838 1839 $self->_try( 1840 sub { 1841 require PerlIO; 1842 my @src_layers = PerlIO::get_layers($src); 1843 1844 binmode $dst, join " ", map ":$_", @src_layers if @src_layers; 1845 } 1846 ); 1847 1848 return; 1849} 1850 1851=item reset_outputs 1852 1853 $tb->reset_outputs; 1854 1855Resets all the output filehandles back to their defaults. 1856 1857=cut 1858 1859sub reset_outputs { 1860 my $self = shift; 1861 1862 $self->output ($Testout); 1863 $self->failure_output($Testerr); 1864 $self->todo_output ($Testout); 1865 1866 return; 1867} 1868 1869=item carp 1870 1871 $tb->carp(@message); 1872 1873Warns with C<@message> but the message will appear to come from the 1874point where the original test function was called (C<< $tb->caller >>). 1875 1876=item croak 1877 1878 $tb->croak(@message); 1879 1880Dies with C<@message> but the message will appear to come from the 1881point where the original test function was called (C<< $tb->caller >>). 1882 1883=cut 1884 1885sub _message_at_caller { 1886 my $self = shift; 1887 1888 local $Level = $Level + 1; 1889 my( $pack, $file, $line ) = $self->caller; 1890 return join( "", @_ ) . " at $file line $line.\n"; 1891} 1892 1893sub carp { 1894 my $self = shift; 1895 return warn $self->_message_at_caller(@_); 1896} 1897 1898sub croak { 1899 my $self = shift; 1900 return die $self->_message_at_caller(@_); 1901} 1902 1903 1904=back 1905 1906 1907=head2 Test Status and Info 1908 1909=over 4 1910 1911=item B<current_test> 1912 1913 my $curr_test = $Test->current_test; 1914 $Test->current_test($num); 1915 1916Gets/sets the current test number we're on. You usually shouldn't 1917have to set this. 1918 1919If set forward, the details of the missing tests are filled in as 'unknown'. 1920if set backward, the details of the intervening tests are deleted. You 1921can erase history if you really want to. 1922 1923=cut 1924 1925sub current_test { 1926 my( $self, $num ) = @_; 1927 1928 lock( $self->{Curr_Test} ); 1929 if( defined $num ) { 1930 $self->{Curr_Test} = $num; 1931 1932 # If the test counter is being pushed forward fill in the details. 1933 my $test_results = $self->{Test_Results}; 1934 if( $num > @$test_results ) { 1935 my $start = @$test_results ? @$test_results : 0; 1936 for( $start .. $num - 1 ) { 1937 $test_results->[$_] = &share( 1938 { 1939 'ok' => 1, 1940 actual_ok => undef, 1941 reason => 'incrementing test number', 1942 type => 'unknown', 1943 name => undef 1944 } 1945 ); 1946 } 1947 } 1948 # If backward, wipe history. Its their funeral. 1949 elsif( $num < @$test_results ) { 1950 $#{$test_results} = $num - 1; 1951 } 1952 } 1953 return $self->{Curr_Test}; 1954} 1955 1956=item B<is_passing> 1957 1958 my $ok = $builder->is_passing; 1959 1960Indicates if the test suite is currently passing. 1961 1962More formally, it will be false if anything has happened which makes 1963it impossible for the test suite to pass. True otherwise. 1964 1965For example, if no tests have run C<is_passing()> will be true because 1966even though a suite with no tests is a failure you can add a passing 1967test to it and start passing. 1968 1969Don't think about it too much. 1970 1971=cut 1972 1973sub is_passing { 1974 my $self = shift; 1975 1976 if( @_ ) { 1977 $self->{Is_Passing} = shift; 1978 } 1979 1980 return $self->{Is_Passing}; 1981} 1982 1983 1984=item B<summary> 1985 1986 my @tests = $Test->summary; 1987 1988A simple summary of the tests so far. True for pass, false for fail. 1989This is a logical pass/fail, so todos are passes. 1990 1991Of course, test #1 is $tests[0], etc... 1992 1993=cut 1994 1995sub summary { 1996 my($self) = shift; 1997 1998 return map { $_->{'ok'} } @{ $self->{Test_Results} }; 1999} 2000 2001=item B<details> 2002 2003 my @tests = $Test->details; 2004 2005Like C<summary()>, but with a lot more detail. 2006 2007 $tests[$test_num - 1] = 2008 { 'ok' => is the test considered a pass? 2009 actual_ok => did it literally say 'ok'? 2010 name => name of the test (if any) 2011 type => type of test (if any, see below). 2012 reason => reason for the above (if any) 2013 }; 2014 2015'ok' is true if Test::Harness will consider the test to be a pass. 2016 2017'actual_ok' is a reflection of whether or not the test literally 2018printed 'ok' or 'not ok'. This is for examining the result of 'todo' 2019tests. 2020 2021'name' is the name of the test. 2022 2023'type' indicates if it was a special test. Normal tests have a type 2024of ''. Type can be one of the following: 2025 2026 skip see skip() 2027 todo see todo() 2028 todo_skip see todo_skip() 2029 unknown see below 2030 2031Sometimes the Test::Builder test counter is incremented without it 2032printing any test output, for example, when C<current_test()> is changed. 2033In these cases, Test::Builder doesn't know the result of the test, so 2034its type is 'unknown'. These details for these tests are filled in. 2035They are considered ok, but the name and actual_ok is left C<undef>. 2036 2037For example "not ok 23 - hole count # TODO insufficient donuts" would 2038result in this structure: 2039 2040 $tests[22] = # 23 - 1, since arrays start from 0. 2041 { ok => 1, # logically, the test passed since its todo 2042 actual_ok => 0, # in absolute terms, it failed 2043 name => 'hole count', 2044 type => 'todo', 2045 reason => 'insufficient donuts' 2046 }; 2047 2048=cut 2049 2050sub details { 2051 my $self = shift; 2052 return @{ $self->{Test_Results} }; 2053} 2054 2055=item B<todo> 2056 2057 my $todo_reason = $Test->todo; 2058 my $todo_reason = $Test->todo($pack); 2059 2060If the current tests are considered "TODO" it will return the reason, 2061if any. This reason can come from a C<$TODO> variable or the last call 2062to C<todo_start()>. 2063 2064Since a TODO test does not need a reason, this function can return an 2065empty string even when inside a TODO block. Use C<< $Test->in_todo >> 2066to determine if you are currently inside a TODO block. 2067 2068C<todo()> is about finding the right package to look for C<$TODO> in. It's 2069pretty good at guessing the right package to look at. It first looks for 2070the caller based on C<$Level + 1>, since C<todo()> is usually called inside 2071a test function. As a last resort it will use C<exported_to()>. 2072 2073Sometimes there is some confusion about where todo() should be looking 2074for the C<$TODO> variable. If you want to be sure, tell it explicitly 2075what $pack to use. 2076 2077=cut 2078 2079sub todo { 2080 my( $self, $pack ) = @_; 2081 2082 return $self->{Todo} if defined $self->{Todo}; 2083 2084 local $Level = $Level + 1; 2085 my $todo = $self->find_TODO($pack); 2086 return $todo if defined $todo; 2087 2088 return ''; 2089} 2090 2091=item B<find_TODO> 2092 2093 my $todo_reason = $Test->find_TODO(); 2094 my $todo_reason = $Test->find_TODO($pack): 2095 2096Like C<todo()> but only returns the value of C<$TODO> ignoring 2097C<todo_start()>. 2098 2099=cut 2100 2101sub find_TODO { 2102 my( $self, $pack ) = @_; 2103 2104 $pack = $pack || $self->caller(1) || $self->exported_to; 2105 return unless $pack; 2106 2107 no strict 'refs'; ## no critic 2108 return ${ $pack . '::TODO' }; 2109} 2110 2111=item B<in_todo> 2112 2113 my $in_todo = $Test->in_todo; 2114 2115Returns true if the test is currently inside a TODO block. 2116 2117=cut 2118 2119sub in_todo { 2120 my $self = shift; 2121 2122 local $Level = $Level + 1; 2123 return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; 2124} 2125 2126=item B<todo_start> 2127 2128 $Test->todo_start(); 2129 $Test->todo_start($message); 2130 2131This method allows you declare all subsequent tests as TODO tests, up until 2132the C<todo_end> method has been called. 2133 2134The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out 2135whether or not we're in a TODO test. However, often we find that this is not 2136possible to determine (such as when we want to use C<$TODO> but 2137the tests are being executed in other packages which can't be inferred 2138beforehand). 2139 2140Note that you can use this to nest "todo" tests 2141 2142 $Test->todo_start('working on this'); 2143 # lots of code 2144 $Test->todo_start('working on that'); 2145 # more code 2146 $Test->todo_end; 2147 $Test->todo_end; 2148 2149This is generally not recommended, but large testing systems often have weird 2150internal needs. 2151 2152We've tried to make this also work with the TODO: syntax, but it's not 2153guaranteed and its use is also discouraged: 2154 2155 TODO: { 2156 local $TODO = 'We have work to do!'; 2157 $Test->todo_start('working on this'); 2158 # lots of code 2159 $Test->todo_start('working on that'); 2160 # more code 2161 $Test->todo_end; 2162 $Test->todo_end; 2163 } 2164 2165Pick one style or another of "TODO" to be on the safe side. 2166 2167=cut 2168 2169sub todo_start { 2170 my $self = shift; 2171 my $message = @_ ? shift : ''; 2172 2173 $self->{Start_Todo}++; 2174 if( $self->in_todo ) { 2175 push @{ $self->{Todo_Stack} } => $self->todo; 2176 } 2177 $self->{Todo} = $message; 2178 2179 return; 2180} 2181 2182=item C<todo_end> 2183 2184 $Test->todo_end; 2185 2186Stops running tests as "TODO" tests. This method is fatal if called without a 2187preceding C<todo_start> method call. 2188 2189=cut 2190 2191sub todo_end { 2192 my $self = shift; 2193 2194 if( !$self->{Start_Todo} ) { 2195 $self->croak('todo_end() called without todo_start()'); 2196 } 2197 2198 $self->{Start_Todo}--; 2199 2200 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { 2201 $self->{Todo} = pop @{ $self->{Todo_Stack} }; 2202 } 2203 else { 2204 delete $self->{Todo}; 2205 } 2206 2207 return; 2208} 2209 2210=item B<caller> 2211 2212 my $package = $Test->caller; 2213 my($pack, $file, $line) = $Test->caller; 2214 my($pack, $file, $line) = $Test->caller($height); 2215 2216Like the normal C<caller()>, except it reports according to your C<level()>. 2217 2218C<$height> will be added to the C<level()>. 2219 2220If C<caller()> winds up off the top of the stack it report the highest context. 2221 2222=cut 2223 2224sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) 2225 my( $self, $height ) = @_; 2226 $height ||= 0; 2227 2228 my $level = $self->level + $height + 1; 2229 my @caller; 2230 do { 2231 @caller = CORE::caller( $level ); 2232 $level--; 2233 } until @caller; 2234 return wantarray ? @caller : $caller[0]; 2235} 2236 2237=back 2238 2239=cut 2240 2241=begin _private 2242 2243=over 4 2244 2245=item B<_sanity_check> 2246 2247 $self->_sanity_check(); 2248 2249Runs a bunch of end of test sanity checks to make sure reality came 2250through ok. If anything is wrong it will die with a fairly friendly 2251error message. 2252 2253=cut 2254 2255#'# 2256sub _sanity_check { 2257 my $self = shift; 2258 2259 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); 2260 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, 2261 'Somehow you got a different number of results than tests ran!' ); 2262 2263 return; 2264} 2265 2266=item B<_whoa> 2267 2268 $self->_whoa($check, $description); 2269 2270A sanity check, similar to C<assert()>. If the C<$check> is true, something 2271has gone horribly wrong. It will die with the given C<$description> and 2272a note to contact the author. 2273 2274=cut 2275 2276sub _whoa { 2277 my( $self, $check, $desc ) = @_; 2278 if($check) { 2279 local $Level = $Level + 1; 2280 $self->croak(<<"WHOA"); 2281WHOA! $desc 2282This should never happen! Please contact the author immediately! 2283WHOA 2284 } 2285 2286 return; 2287} 2288 2289=item B<_my_exit> 2290 2291 _my_exit($exit_num); 2292 2293Perl seems to have some trouble with exiting inside an C<END> block. 22945.6.1 does some odd things. Instead, this function edits C<$?> 2295directly. It should B<only> be called from inside an C<END> block. 2296It doesn't actually exit, that's your job. 2297 2298=cut 2299 2300sub _my_exit { 2301 $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) 2302 2303 return 1; 2304} 2305 2306=back 2307 2308=end _private 2309 2310=cut 2311 2312sub _ending { 2313 my $self = shift; 2314 return if $self->no_ending; 2315 return if $self->{Ending}++; 2316 2317 my $real_exit_code = $?; 2318 2319 # Don't bother with an ending if this is a forked copy. Only the parent 2320 # should do the ending. 2321 if( $self->{Original_Pid} != $$ ) { 2322 return; 2323 } 2324 2325 # Ran tests but never declared a plan or hit done_testing 2326 if( !$self->{Have_Plan} and $self->{Curr_Test} ) { 2327 $self->is_passing(0); 2328 $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); 2329 } 2330 2331 # Exit if plan() was never called. This is so "require Test::Simple" 2332 # doesn't puke. 2333 if( !$self->{Have_Plan} ) { 2334 return; 2335 } 2336 2337 # Don't do an ending if we bailed out. 2338 if( $self->{Bailed_Out} ) { 2339 $self->is_passing(0); 2340 return; 2341 } 2342 # Figure out if we passed or failed and print helpful messages. 2343 my $test_results = $self->{Test_Results}; 2344 if(@$test_results) { 2345 # The plan? We have no plan. 2346 if( $self->{No_Plan} ) { 2347 $self->_output_plan($self->{Curr_Test}) unless $self->no_header; 2348 $self->{Expected_Tests} = $self->{Curr_Test}; 2349 } 2350 2351 # Auto-extended arrays and elements which aren't explicitly 2352 # filled in with a shared reference will puke under 5.8.0 2353 # ithreads. So we have to fill them in by hand. :( 2354 my $empty_result = &share( {} ); 2355 for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { 2356 $test_results->[$idx] = $empty_result 2357 unless defined $test_results->[$idx]; 2358 } 2359 2360 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; 2361 2362 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; 2363 2364 if( $num_extra != 0 ) { 2365 my $s = $self->{Expected_Tests} == 1 ? '' : 's'; 2366 $self->diag(<<"FAIL"); 2367Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. 2368FAIL 2369 $self->is_passing(0); 2370 } 2371 2372 if($num_failed) { 2373 my $num_tests = $self->{Curr_Test}; 2374 my $s = $num_failed == 1 ? '' : 's'; 2375 2376 my $qualifier = $num_extra == 0 ? '' : ' run'; 2377 2378 $self->diag(<<"FAIL"); 2379Looks like you failed $num_failed test$s of $num_tests$qualifier. 2380FAIL 2381 $self->is_passing(0); 2382 } 2383 2384 if($real_exit_code) { 2385 $self->diag(<<"FAIL"); 2386Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. 2387FAIL 2388 $self->is_passing(0); 2389 _my_exit($real_exit_code) && return; 2390 } 2391 2392 my $exit_code; 2393 if($num_failed) { 2394 $exit_code = $num_failed <= 254 ? $num_failed : 254; 2395 } 2396 elsif( $num_extra != 0 ) { 2397 $exit_code = 255; 2398 } 2399 else { 2400 $exit_code = 0; 2401 } 2402 2403 _my_exit($exit_code) && return; 2404 } 2405 elsif( $self->{Skip_All} ) { 2406 _my_exit(0) && return; 2407 } 2408 elsif($real_exit_code) { 2409 $self->diag(<<"FAIL"); 2410Looks like your test exited with $real_exit_code before it could output anything. 2411FAIL 2412 $self->is_passing(0); 2413 _my_exit($real_exit_code) && return; 2414 } 2415 else { 2416 $self->diag("No tests run!\n"); 2417 $self->is_passing(0); 2418 _my_exit(255) && return; 2419 } 2420 2421 $self->is_passing(0); 2422 $self->_whoa( 1, "We fell off the end of _ending()" ); 2423} 2424 2425END { 2426 $Test->_ending if defined $Test; 2427} 2428 2429=head1 EXIT CODES 2430 2431If all your tests passed, Test::Builder will exit with zero (which is 2432normal). If anything failed it will exit with how many failed. If 2433you run less (or more) tests than you planned, the missing (or extras) 2434will be considered failures. If no tests were ever run Test::Builder 2435will throw a warning and exit with 255. If the test died, even after 2436having successfully completed all its tests, it will still be 2437considered a failure and will exit with 255. 2438 2439So the exit codes are... 2440 2441 0 all tests successful 2442 255 test died or all passed but wrong # of tests run 2443 any other number how many failed (including missing or extras) 2444 2445If you fail more than 254 tests, it will be reported as 254. 2446 2447=head1 THREADS 2448 2449In perl 5.8.1 and later, Test::Builder is thread-safe. The test 2450number is shared amongst all threads. This means if one thread sets 2451the test number using C<current_test()> they will all be effected. 2452 2453While versions earlier than 5.8.1 had threads they contain too many 2454bugs to support. 2455 2456Test::Builder is only thread-aware if threads.pm is loaded I<before> 2457Test::Builder. 2458 2459=head1 MEMORY 2460 2461An informative hash, accessable via C<<details()>>, is stored for each 2462test you perform. So memory usage will scale linearly with each test 2463run. Although this is not a problem for most test suites, it can 2464become an issue if you do large (hundred thousands to million) 2465combinatorics tests in the same run. 2466 2467In such cases, you are advised to either split the test file into smaller 2468ones, or use a reverse approach, doing "normal" (code) compares and 2469triggering fail() should anything go unexpected. 2470 2471Future versions of Test::Builder will have a way to turn history off. 2472 2473 2474=head1 EXAMPLES 2475 2476CPAN can provide the best examples. Test::Simple, Test::More, 2477Test::Exception and Test::Differences all use Test::Builder. 2478 2479=head1 SEE ALSO 2480 2481Test::Simple, Test::More, Test::Harness 2482 2483=head1 AUTHORS 2484 2485Original code by chromatic, maintained by Michael G Schwern 2486E<lt>schwern@pobox.comE<gt> 2487 2488=head1 COPYRIGHT 2489 2490Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and 2491 Michael G Schwern E<lt>schwern@pobox.comE<gt>. 2492 2493This program is free software; you can redistribute it and/or 2494modify it under the same terms as Perl itself. 2495 2496See F<http://www.perl.com/perl/misc/Artistic.html> 2497 2498=cut 2499 25001; 2501 2502