git.maemo.org Git - dh-make-perl/blob - dev/i386/libmodule-build-perl/libmodule-build-perl-0.2808.01/t/bundled/Test/Builder.pm

   1 package Test::Builder;
   2
   3 use 5.004;
   4
   5 # $^C was only introduced in 5.005-ish.  We do this to prevent
   6 # use of uninitialized value warnings in older perls.
   7 $^C ||= 0;
   8
   9 use strict;
  10 use vars qw($VERSION);
  11 $VERSION = '0.19';
  12
  13 my $IsVMS = $^O eq 'VMS';
  14
  15 # Make Test::Builder thread-safe for ithreads.
  16 BEGIN {
  17     use Config;
  18     # Load threads::shared when threads are turned on
  19     if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) {
  20         require threads::shared;
  21         threads::shared->import;
  22     }
  23     # 5.8.0's threads::shared is busted when threads are off.
  24     # We emulate it here.
  25     else {
  26         *share = sub { return $_[0] };
  27         *lock  = sub { 0 };
  28     }
  29 }
  30
  31
  32 =head1 NAME
  33
  34 Test::Builder - Backend for building test libraries
  35
  36 =head1 SYNOPSIS
  37
  38   package My::Test::Module;
  39   use Test::Builder;
  40   require Exporter;
  41   @ISA = qw(Exporter);
  42   @EXPORT = qw(ok);
  43
  44   my $Test = Test::Builder->new;
  45   $Test->output('my_logfile');
  46
  47   sub import {
  48       my($self) = shift;
  49       my $pack = caller;
  50
  51       $Test->exported_to($pack);
  52       $Test->plan(@_);
  53
  54       $self->export_to_level(1, $self, 'ok');
  55   }
  56
  57   sub ok {
  58       my($test, $name) = @_;
  59
  60       $Test->ok($test, $name);
  61   }
  62
  63
  64 =head1 DESCRIPTION
  65
  66 Test::Simple and Test::More have proven to be popular testing modules,
  67 but they're not always flexible enough.  Test::Builder provides the a
  68 building block upon which to write your own test libraries I<which can
  69 work together>.
  70
  71 =head2 Construction
  72
  73 =over 4
  74
  75 =item B<new>
  76
  77   my $Test = Test::Builder->new;
  78
  79 Returns a Test::Builder object representing the current state of the
  80 test.
  81
  82 Since you only run one test per program, there is B<one and only one>
  83 Test::Builder object.  No matter how many times you call new(), you're
  84 getting the same object.  (This is called a singleton).
  85
  86 =cut
  87
  88 my $Test = Test::Builder->new;
  89 sub new {
  90     my($class) = shift;
  91     $Test ||= bless ['Move along, nothing to see here'], $class;
  92     return $Test;
  93 }
  94
  95 =item B<reset>
  96
  97   $Test->reset;
  98
  99 Reinitializes the Test::Builder singleton to its original state.
 100 Mostly useful for tests run in persistent environments where the same
 101 test might be run multiple times in the same process.
 102
 103 =cut
 104
 105 my $Test_Died;
 106 my $Have_Plan;
 107 my $No_Plan;
 108 my $Curr_Test;     share($Curr_Test);
 109 use vars qw($Level);
 110 my $Original_Pid;
 111 my @Test_Results;  share(@Test_Results);
 112 my @Test_Details;  share(@Test_Details);
 113
 114 my $Exported_To;
 115 my $Expected_Tests;
 116
 117 my $Skip_All;
 118
 119 my $Use_Nums;
 120
 121 my($No_Header, $No_Ending);
 122
 123 $Test->reset;
 124
 125 sub reset {
 126     my ($self) = @_;
 127
 128     $Test_Died = 0;
 129     $Have_Plan = 0;
 130     $No_Plan   = 0;
 131     $Curr_Test = 0;
 132     $Level     = 1;
 133     $Original_Pid = $$;
 134     @Test_Results = ();
 135     @Test_Details = ();
 136
 137     $Exported_To    = undef;
 138     $Expected_Tests = 0;
 139
 140     $Skip_All = 0;
 141
 142     $Use_Nums = 1;
 143
 144     ($No_Header, $No_Ending) = (0,0);
 145
 146     $self->_dup_stdhandles unless $^C;
 147
 148     return undef;
 149 }
 150
 151 =back
 152
 153 =head2 Setting up tests
 154
 155 These methods are for setting up tests and declaring how many there
 156 are.  You usually only want to call one of these methods.
 157
 158 =over 4
 159
 160 =item B<exported_to>
 161
 162   my $pack = $Test->exported_to;
 163   $Test->exported_to($pack);
 164
 165 Tells Test::Builder what package you exported your functions to.
 166 This is important for getting TODO tests right.
 167
 168 =cut
 169
 170 sub exported_to {
 171     my($self, $pack) = @_;
 172
 173     if( defined $pack ) {
 174         $Exported_To = $pack;
 175     }
 176     return $Exported_To;
 177 }
 178
 179 =item B<plan>
 180
 181   $Test->plan('no_plan');
 182   $Test->plan( skip_all => $reason );
 183   $Test->plan( tests => $num_tests );
 184
 185 A convenient way to set up your tests.  Call this and Test::Builder
 186 will print the appropriate headers and take the appropriate actions.
 187
 188 If you call plan(), don't call any of the other methods below.
 189
 190 =cut
 191
 192 sub plan {
 193     my($self, $cmd, $arg) = @_;
 194
 195     return unless $cmd;
 196
 197     if( $Have_Plan ) {
 198         die sprintf "You tried to plan twice!  Second plan at %s line %d\n",
 199           ($self->caller)[1,2];
 200     }
 201
 202     if( $cmd eq 'no_plan' ) {
 203         $self->no_plan;
 204     }
 205     elsif( $cmd eq 'skip_all' ) {
 206         return $self->skip_all($arg);
 207     }
 208     elsif( $cmd eq 'tests' ) {
 209         if( $arg ) {
 210             return $self->expected_tests($arg);
 211         }
 212         elsif( !defined $arg ) {
 213             die "Got an undefined number of tests.  Looks like you tried to ".
 214                 "say how many tests you plan to run but made a mistake.\n";
 215         }
 216         elsif( !$arg ) {
 217             die "You said to run 0 tests!  You've got to run something.\n";
 218         }
 219     }
 220     else {
 221         require Carp;
 222         my @args = grep { defined } ($cmd, $arg);
 223         Carp::croak("plan() doesn't understand @args");
 224     }
 225
 226     return 1;
 227 }
 228
 229 =item B<expected_tests>
 230
 231     my $max = $Test->expected_tests;
 232     $Test->expected_tests($max);
 233
 234 Gets/sets the # of tests we expect this test to run and prints out
 235 the appropriate headers.
 236
 237 =cut
 238
 239 sub expected_tests {
 240     my($self, $max) = @_;
 241
 242     if( defined $max ) {
 243         $Expected_Tests = $max;
 244         $Have_Plan      = 1;
 245
 246         $self->_print("1..$max\n") unless $self->no_header;
 247     }
 248     return $Expected_Tests;
 249 }
 250
 251
 252 =item B<no_plan>
 253
 254   $Test->no_plan;
 255
 256 Declares that this test will run an indeterminate # of tests.
 257
 258 =cut
 259
 260 sub no_plan {
 261     $No_Plan    = 1;
 262     $Have_Plan  = 1;
 263 }
 264
 265 =item B<has_plan>
 266
 267   $plan = $Test->has_plan
 268
 269 Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
 270
 271 =cut
 272
 273 sub has_plan {
 274         return($Expected_Tests) if $Expected_Tests;
 275         return('no_plan') if $No_Plan;
 276         return(undef);
 277 };
 278
 279
 280 =item B<skip_all>
 281
 282   $Test->skip_all;
 283   $Test->skip_all($reason);
 284
 285 Skips all the tests, using the given $reason.  Exits immediately with 0.
 286
 287 =cut
 288
 289 sub skip_all {
 290     my($self, $reason) = @_;
 291
 292     my $out = "1..0";
 293     $out .= " # Skip $reason" if $reason;
 294     $out .= "\n";
 295
 296     $Skip_All = 1;
 297
 298     $self->_print($out) unless $self->no_header;
 299     exit(0);
 300 }
 301
 302 =back
 303
 304 =head2 Running tests
 305
 306 These actually run the tests, analogous to the functions in
 307 Test::More.
 308
 309 $name is always optional.
 310
 311 =over 4
 312
 313 =item B<ok>
 314
 315   $Test->ok($test, $name);
 316
 317 Your basic test.  Pass if $test is true, fail if $test is false.  Just
 318 like Test::Simple's ok().
 319
 320 =cut
 321
 322 sub ok {
 323     my($self, $test, $name) = @_;
 324
 325     # $test might contain an object which we don't want to accidentally
 326     # store, so we turn it into a boolean.
 327     $test = $test ? 1 : 0;
 328
 329     unless( $Have_Plan ) {
 330         require Carp;
 331         Carp::croak("You tried to run a test without a plan!  Gotta have a plan.");
 332     }
 333
 334     lock $Curr_Test;
 335     $Curr_Test++;
 336
 337     # In case $name is a string overloaded object, force it to stringify.
 338     local($@,$!);
 339     eval {
 340         if( defined $name ) {
 341             require overload;
 342             if( my $string_meth = overload::Method($name, '""') ) {
 343                 $name = $name->$string_meth();
 344             }
 345         }
 346     };
 347
 348     $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
 349     You named your test '$name'.  You shouldn't use numbers for your test names.
 350     Very confusing.
 351 ERR
 352
 353     my($pack, $file, $line) = $self->caller;
 354
 355     my $todo = $self->todo($pack);
 356
 357     my $out;
 358     my $result = &share({});
 359
 360     unless( $test ) {
 361         $out .= "not ";
 362         @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
 363     }
 364     else {
 365         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
 366     }
 367
 368     $out .= "ok";
 369     $out .= " $Curr_Test" if $self->use_numbers;
 370
 371     if( defined $name ) {
 372         $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
 373         $out   .= " - $name";
 374         $result->{name} = $name;
 375     }
 376     else {
 377         $result->{name} = '';
 378     }
 379
 380     if( $todo ) {
 381         my $what_todo = $todo;
 382         $out   .= " # TODO $what_todo";
 383         $result->{reason} = $what_todo;
 384         $result->{type}   = 'todo';
 385     }
 386     else {
 387         $result->{reason} = '';
 388         $result->{type}   = '';
 389     }
 390
 391     $Test_Results[$Curr_Test-1] = $result;
 392     $out .= "\n";
 393
 394     $self->_print($out);
 395
 396     unless( $test ) {
 397         my $msg = $todo ? "Failed (TODO)" : "Failed";
 398         $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
 399         $self->diag("    $msg test ($file at line $line)\n");
 400     }
 401
 402     return $test ? 1 : 0;
 403 }
 404
 405 =item B<is_eq>
 406
 407   $Test->is_eq($got, $expected, $name);
 408
 409 Like Test::More's is().  Checks if $got eq $expected.  This is the
 410 string version.
 411
 412 =item B<is_num>
 413
 414   $Test->is_num($got, $expected, $name);
 415
 416 Like Test::More's is().  Checks if $got == $expected.  This is the
 417 numeric version.
 418
 419 =cut
 420
 421 sub is_eq {
 422     my($self, $got, $expect, $name) = @_;
 423     local $Level = $Level + 1;
 424
 425     if( !defined $got || !defined $expect ) {
 426         # undef only matches undef and nothing else
 427         my $test = !defined $got && !defined $expect;
 428
 429         $self->ok($test, $name);
 430         $self->_is_diag($got, 'eq', $expect) unless $test;
 431         return $test;
 432     }
 433
 434     return $self->cmp_ok($got, 'eq', $expect, $name);
 435 }
 436
 437 sub is_num {
 438     my($self, $got, $expect, $name) = @_;
 439     local $Level = $Level + 1;
 440
 441     if( !defined $got || !defined $expect ) {
 442         # undef only matches undef and nothing else
 443         my $test = !defined $got && !defined $expect;
 444
 445         $self->ok($test, $name);
 446         $self->_is_diag($got, '==', $expect) unless $test;
 447         return $test;
 448     }
 449
 450     return $self->cmp_ok($got, '==', $expect, $name);
 451 }
 452
 453 sub _is_diag {
 454     my($self, $got, $type, $expect) = @_;
 455
 456     foreach my $val (\$got, \$expect) {
 457         if( defined $$val ) {
 458             if( $type eq 'eq' ) {
 459                 # quote and force string context
 460                 $$val = "'$$val'"
 461             }
 462             else {
 463                 # force numeric context
 464                 $$val = $$val+0;
 465             }
 466         }
 467         else {
 468             $$val = 'undef';
 469         }
 470     }
 471
 472     return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
 473          got: %s
 474     expected: %s
 475 DIAGNOSTIC
 476
 477 }
 478
 479 =item B<isnt_eq>
 480
 481   $Test->isnt_eq($got, $dont_expect, $name);
 482
 483 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
 484 the string version.
 485
 486 =item B<isnt_num>
 487
 488   $Test->is_num($got, $dont_expect, $name);
 489
 490 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
 491 the numeric version.
 492
 493 =cut
 494
 495 sub isnt_eq {
 496     my($self, $got, $dont_expect, $name) = @_;
 497     local $Level = $Level + 1;
 498
 499     if( !defined $got || !defined $dont_expect ) {
 500         # undef only matches undef and nothing else
 501         my $test = defined $got || defined $dont_expect;
 502
 503         $self->ok($test, $name);
 504         $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
 505         return $test;
 506     }
 507
 508     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
 509 }
 510
 511 sub isnt_num {
 512     my($self, $got, $dont_expect, $name) = @_;
 513     local $Level = $Level + 1;
 514
 515     if( !defined $got || !defined $dont_expect ) {
 516         # undef only matches undef and nothing else
 517         my $test = defined $got || defined $dont_expect;
 518
 519         $self->ok($test, $name);
 520         $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
 521         return $test;
 522     }
 523
 524     return $self->cmp_ok($got, '!=', $dont_expect, $name);
 525 }
 526
 527
 528 =item B<like>
 529
 530   $Test->like($this, qr/$regex/, $name);
 531   $Test->like($this, '/$regex/', $name);
 532
 533 Like Test::More's like().  Checks if $this matches the given $regex.
 534
 535 You'll want to avoid qr// if you want your tests to work before 5.005.
 536
 537 =item B<unlike>
 538
 539   $Test->unlike($this, qr/$regex/, $name);
 540   $Test->unlike($this, '/$regex/', $name);
 541
 542 Like Test::More's unlike().  Checks if $this B<does not match> the
 543 given $regex.
 544
 545 =cut
 546
 547 sub like {
 548     my($self, $this, $regex, $name) = @_;
 549
 550     local $Level = $Level + 1;
 551     $self->_regex_ok($this, $regex, '=~', $name);
 552 }
 553
 554 sub unlike {
 555     my($self, $this, $regex, $name) = @_;
 556
 557     local $Level = $Level + 1;
 558     $self->_regex_ok($this, $regex, '!~', $name);
 559 }
 560
 561 =item B<maybe_regex>
 562
 563   $Test->maybe_regex(qr/$regex/);
 564   $Test->maybe_regex('/$regex/');
 565
 566 Convenience method for building testing functions that take regular
 567 expressions as arguments, but need to work before perl 5.005.
 568
 569 Takes a quoted regular expression produced by qr//, or a string
 570 representing a regular expression.
 571
 572 Returns a Perl value which may be used instead of the corresponding
 573 regular expression, or undef if it's argument is not recognised.
 574
 575 For example, a version of like(), sans the useful diagnostic messages,
 576 could be written as:
 577
 578   sub laconic_like {
 579       my ($self, $this, $regex, $name) = @_;
 580       my $usable_regex = $self->maybe_regex($regex);
 581       die "expecting regex, found '$regex'\n"
 582           unless $usable_regex;
 583       $self->ok($this =~ m/$usable_regex/, $name);
 584   }
 585
 586 =cut
 587
 588
 589 sub maybe_regex {
 590         my ($self, $regex) = @_;
 591     my $usable_regex = undef;
 592     if( ref $regex eq 'Regexp' ) {
 593         $usable_regex = $regex;
 594     }
 595     # Check if it looks like '/foo/'
 596     elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
 597         $usable_regex = length $opts ? "(?$opts)$re" : $re;
 598     };
 599     return($usable_regex)
 600 };
 601
 602 sub _regex_ok {
 603     my($self, $this, $regex, $cmp, $name) = @_;
 604
 605     local $Level = $Level + 1;
 606
 607     my $ok = 0;
 608     my $usable_regex = $self->maybe_regex($regex);
 609     unless (defined $usable_regex) {
 610         $ok = $self->ok( 0, $name );
 611         $self->diag("    '$regex' doesn't look much like a regex to me.");
 612         return $ok;
 613     }
 614
 615     {
 616         local $^W = 0;
 617         my $test = $this =~ /$usable_regex/ ? 1 : 0;
 618         $test = !$test if $cmp eq '!~';
 619         $ok = $self->ok( $test, $name );
 620     }
 621
 622     unless( $ok ) {
 623         $this = defined $this ? "'$this'" : 'undef';
 624         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
 625         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
 626                   %s
 627     %13s '%s'
 628 DIAGNOSTIC
 629
 630     }
 631
 632     return $ok;
 633 }
 634
 635 =item B<cmp_ok>
 636
 637   $Test->cmp_ok($this, $type, $that, $name);
 638
 639 Works just like Test::More's cmp_ok().
 640
 641     $Test->cmp_ok($big_num, '!=', $other_big_num);
 642
 643 =cut
 644
 645 sub cmp_ok {
 646     my($self, $got, $type, $expect, $name) = @_;
 647
 648     my $test;
 649     {
 650         local $^W = 0;
 651         local($@,$!);   # don't interfere with $@
 652                         # eval() sometimes resets $!
 653         $test = eval "\$got $type \$expect";
 654     }
 655     local $Level = $Level + 1;
 656     my $ok = $self->ok($test, $name);
 657
 658     unless( $ok ) {
 659         if( $type =~ /^(eq|==)$/ ) {
 660             $self->_is_diag($got, $type, $expect);
 661         }
 662         else {
 663             $self->_cmp_diag($got, $type, $expect);
 664         }
 665     }
 666     return $ok;
 667 }
 668
 669 sub _cmp_diag {
 670     my($self, $got, $type, $expect) = @_;
 671
 672     $got    = defined $got    ? "'$got'"    : 'undef';
 673     $expect = defined $expect ? "'$expect'" : 'undef';
 674     return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
 675     %s
 676         %s
 677     %s
 678 DIAGNOSTIC
 679 }
 680
 681 =item B<BAILOUT>
 682
 683     $Test->BAILOUT($reason);
 684
 685 Indicates to the Test::Harness that things are going so badly all
 686 testing should terminate.  This includes running any additional test
 687 scripts.
 688
 689 It will exit with 255.
 690
 691 =cut
 692
 693 sub BAILOUT {
 694     my($self, $reason) = @_;
 695
 696     $self->_print("Bail out!  $reason");
 697     exit 255;
 698 }
 699
 700 =item B<skip>
 701
 702     $Test->skip;
 703     $Test->skip($why);
 704
 705 Skips the current test, reporting $why.
 706
 707 =cut
 708
 709 sub skip {
 710     my($self, $why) = @_;
 711     $why ||= '';
 712
 713     unless( $Have_Plan ) {
 714         require Carp;
 715         Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");
 716     }
 717
 718     lock($Curr_Test);
 719     $Curr_Test++;
 720
 721     $Test_Results[$Curr_Test-1] = &share({
 722         'ok'      => 1,
 723         actual_ok => 1,
 724         name      => '',
 725         type      => 'skip',
 726         reason    => $why,
 727     });
 728
 729     my $out = "ok";
 730     $out   .= " $Curr_Test" if $self->use_numbers;
 731     $out   .= " # skip $why\n";
 732
 733     $Test->_print($out);
 734
 735     return 1;
 736 }
 737
 738
 739 =item B<todo_skip>
 740
 741   $Test->todo_skip;
 742   $Test->todo_skip($why);
 743
 744 Like skip(), only it will declare the test as failing and TODO.  Similar
 745 to
 746
 747     print "not ok $tnum # TODO $why\n";
 748
 749 =cut
 750
 751 sub todo_skip {
 752     my($self, $why) = @_;
 753     $why ||= '';
 754
 755     unless( $Have_Plan ) {
 756         require Carp;
 757         Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");
 758     }
 759
 760     lock($Curr_Test);
 761     $Curr_Test++;
 762
 763     $Test_Results[$Curr_Test-1] = &share({
 764         'ok'      => 1,
 765         actual_ok => 0,
 766         name      => '',
 767         type      => 'todo_skip',
 768         reason    => $why,
 769     });
 770
 771     my $out = "not ok";
 772     $out   .= " $Curr_Test" if $self->use_numbers;
 773     $out   .= " # TODO & SKIP $why\n";
 774
 775     $Test->_print($out);
 776
 777     return 1;
 778 }
 779
 780
 781 =begin _unimplemented
 782
 783 =item B<skip_rest>
 784
 785   $Test->skip_rest;
 786   $Test->skip_rest($reason);
 787
 788 Like skip(), only it skips all the rest of the tests you plan to run
 789 and terminates the test.
 790
 791 If you're running under no_plan, it skips once and terminates the
 792 test.
 793
 794 =end _unimplemented
 795
 796 =back
 797
 798
 799 =head2 Test style
 800
 801 =over 4
 802
 803 =item B<level>
 804
 805     $Test->level($how_high);
 806
 807 How far up the call stack should $Test look when reporting where the
 808 test failed.
 809
 810 Defaults to 1.
 811
 812 Setting $Test::Builder::Level overrides.  This is typically useful
 813 localized:
 814
 815     {
 816         local $Test::Builder::Level = 2;
 817         $Test->ok($test);
 818     }
 819
 820 =cut
 821
 822 sub level {
 823     my($self, $level) = @_;
 824
 825     if( defined $level ) {
 826         $Level = $level;
 827     }
 828     return $Level;
 829 }
 830
 831
 832 =item B<use_numbers>
 833
 834     $Test->use_numbers($on_or_off);
 835
 836 Whether or not the test should output numbers.  That is, this if true:
 837
 838   ok 1
 839   ok 2
 840   ok 3
 841
 842 or this if false
 843
 844   ok
 845   ok
 846   ok
 847
 848 Most useful when you can't depend on the test output order, such as
 849 when threads or forking is involved.
 850
 851 Test::Harness will accept either, but avoid mixing the two styles.
 852
 853 Defaults to on.
 854
 855 =cut
 856
 857 sub use_numbers {
 858     my($self, $use_nums) = @_;
 859
 860     if( defined $use_nums ) {
 861         $Use_Nums = $use_nums;
 862     }
 863     return $Use_Nums;
 864 }
 865
 866 =item B<no_header>
 867
 868     $Test->no_header($no_header);
 869
 870 If set to true, no "1..N" header will be printed.
 871
 872 =item B<no_ending>
 873
 874     $Test->no_ending($no_ending);
 875
 876 Normally, Test::Builder does some extra diagnostics when the test
 877 ends.  It also changes the exit code as described below.
 878
 879 If this is true, none of that will be done.
 880
 881 =cut
 882
 883 sub no_header {
 884     my($self, $no_header) = @_;
 885
 886     if( defined $no_header ) {
 887         $No_Header = $no_header;
 888     }
 889     return $No_Header;
 890 }
 891
 892 sub no_ending {
 893     my($self, $no_ending) = @_;
 894
 895     if( defined $no_ending ) {
 896         $No_Ending = $no_ending;
 897     }
 898     return $No_Ending;
 899 }
 900
 901
 902 =back
 903
 904 =head2 Output
 905
 906 Controlling where the test output goes.
 907
 908 It's ok for your test to change where STDOUT and STDERR point to,
 909 Test::Builder's default output settings will not be affected.
 910
 911 =over 4
 912
 913 =item B<diag>
 914
 915     $Test->diag(@msgs);
 916
 917 Prints out the given $message.  Normally, it uses the failure_output()
 918 handle, but if this is for a TODO test, the todo_output() handle is
 919 used.
 920
 921 Output will be indented and marked with a # so as not to interfere
 922 with test output.  A newline will be put on the end if there isn't one
 923 already.
 924
 925 We encourage using this rather than calling print directly.
 926
 927 Returns false.  Why?  Because diag() is often used in conjunction with
 928 a failing test (C<ok() || diag()>) it "passes through" the failure.
 929
 930     return ok(...) || diag(...);
 931
 932 =for blame transfer
 933 Mark Fowler <mark@twoshortplanks.com>
 934
 935 =cut
 936
 937 sub diag {
 938     my($self, @msgs) = @_;
 939     return unless @msgs;
 940
 941     # Prevent printing headers when compiling (i.e. -c)
 942     return if $^C;
 943
 944     # Escape each line with a #.
 945     foreach (@msgs) {
 946         $_ = 'undef' unless defined;
 947         s/^/# /gms;
 948     }
 949
 950     push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
 951
 952     local $Level = $Level + 1;
 953     $self->_print_diag(@msgs);
 954
 955     return 0;
 956 }
 957
 958 =begin _private
 959
 960 =item B<_print>
 961
 962     $Test->_print(@msgs);
 963
 964 Prints to the output() filehandle.
 965
 966 =end _private
 967
 968 =cut
 969
 970 sub _print {
 971     my($self, @msgs) = @_;
 972
 973     # Prevent printing headers when only compiling.  Mostly for when
 974     # tests are deparsed with B::Deparse
 975     return if $^C;
 976
 977     local($\, $", $,) = (undef, ' ', '');
 978     my $fh = $self->output;
 979
 980     # Escape each line after the first with a # so we don't
 981     # confuse Test::Harness.
 982     foreach (@msgs) {
 983         s/\n(.)/\n# $1/sg;
 984     }
 985
 986     push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
 987
 988     print $fh @msgs;
 989 }
 990
 991
 992 =item B<_print_diag>
 993
 994     $Test->_print_diag(@msg);
 995
 996 Like _print, but prints to the current diagnostic filehandle.
 997
 998 =cut
 999
1000 sub _print_diag {
1001     my $self = shift;
1002
1003     local($\, $", $,) = (undef, ' ', '');
1004     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1005     print $fh @_;
1006 }
1007
1008 =item B<output>
1009
1010     $Test->output($fh);
1011     $Test->output($file);
1012
1013 Where normal "ok/not ok" test output should go.
1014
1015 Defaults to STDOUT.
1016
1017 =item B<failure_output>
1018
1019     $Test->failure_output($fh);
1020     $Test->failure_output($file);
1021
1022 Where diagnostic output on test failures and diag() should go.
1023
1024 Defaults to STDERR.
1025
1026 =item B<todo_output>
1027
1028     $Test->todo_output($fh);
1029     $Test->todo_output($file);
1030
1031 Where diagnostics about todo test failures and diag() should go.
1032
1033 Defaults to STDOUT.
1034
1035 =cut
1036
1037 my($Out_FH, $Fail_FH, $Todo_FH);
1038 sub output {
1039     my($self, $fh) = @_;
1040
1041     if( defined $fh ) {
1042         $Out_FH = _new_fh($fh);
1043     }
1044     return $Out_FH;
1045 }
1046
1047 sub failure_output {
1048     my($self, $fh) = @_;
1049
1050     if( defined $fh ) {
1051         $Fail_FH = _new_fh($fh);
1052     }
1053     return $Fail_FH;
1054 }
1055
1056 sub todo_output {
1057     my($self, $fh) = @_;
1058
1059     if( defined $fh ) {
1060         $Todo_FH = _new_fh($fh);
1061     }
1062     return $Todo_FH;
1063 }
1064
1065 sub _new_fh {
1066     my($file_or_fh) = shift;
1067
1068     my $fh;
1069     unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
1070         $fh = do { local *FH };
1071         open $fh, ">$file_or_fh" or
1072             die "Can't open test output log $file_or_fh: $!";
1073     }
1074     else {
1075         $fh = $file_or_fh;
1076     }
1077
1078     return $fh;
1079 }
1080
1081 sub _autoflush {
1082     my($fh) = shift;
1083     my $old_fh = select $fh;
1084     $| = 1;
1085     select $old_fh;
1086 }
1087
1088
1089 my $Opened_Testhandles = 0;
1090 sub _dup_stdhandles {
1091     my $self = shift;
1092
1093     $self->_open_testhandles unless $Opened_Testhandles;
1094
1095     # Set everything to unbuffered else plain prints to STDOUT will
1096     # come out in the wrong order from our own prints.
1097     _autoflush(\*TESTOUT);
1098     _autoflush(\*STDOUT);
1099     _autoflush(\*TESTERR);
1100     _autoflush(\*STDERR);
1101
1102     $Test->output(\*TESTOUT);
1103     $Test->failure_output(\*TESTERR);
1104     $Test->todo_output(\*TESTOUT);
1105 }
1106
1107 sub _open_testhandles {
1108     # We dup STDOUT and STDERR so people can change them in their
1109     # test suites while still getting normal test output.
1110     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
1111     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
1112     $Opened_Testhandles = 1;
1113 }
1114
1115
1116 =back
1117
1118
1119 =head2 Test Status and Info
1120
1121 =over 4
1122
1123 =item B<current_test>
1124
1125     my $curr_test = $Test->current_test;
1126     $Test->current_test($num);
1127
1128 Gets/sets the current test # we're on.
1129
1130 You usually shouldn't have to set this.
1131
1132 =cut
1133
1134 sub current_test {
1135     my($self, $num) = @_;
1136
1137     lock($Curr_Test);
1138     if( defined $num ) {
1139         unless( $Have_Plan ) {
1140             require Carp;
1141             Carp::croak("Can't change the current test number without a plan!");
1142         }
1143
1144         $Curr_Test = $num;
1145         if( $num > @Test_Results ) {
1146             my $start = @Test_Results ? $#Test_Results + 1 : 0;
1147             for ($start..$num-1) {
1148                 $Test_Results[$_] = &share({
1149                     'ok'      => 1,
1150                     actual_ok => undef,
1151                     reason    => 'incrementing test number',
1152                     type      => 'unknown',
1153                     name      => undef
1154                 });
1155             }
1156         }
1157     }
1158     return $Curr_Test;
1159 }
1160
1161
1162 =item B<summary>
1163
1164     my @tests = $Test->summary;
1165
1166 A simple summary of the tests so far.  True for pass, false for fail.
1167 This is a logical pass/fail, so todos are passes.
1168
1169 Of course, test #1 is $tests[0], etc...
1170
1171 =cut
1172
1173 sub summary {
1174     my($self) = shift;
1175
1176     return map { $_->{'ok'} } @Test_Results;
1177 }
1178
1179 =item B<details>
1180
1181     my @tests = $Test->details;
1182
1183 Like summary(), but with a lot more detail.
1184
1185     $tests[$test_num - 1] =
1186             { 'ok'       => is the test considered a pass?
1187               actual_ok  => did it literally say 'ok'?
1188               name       => name of the test (if any)
1189               type       => type of test (if any, see below).
1190               reason     => reason for the above (if any)
1191             };
1192
1193 'ok' is true if Test::Harness will consider the test to be a pass.
1194
1195 'actual_ok' is a reflection of whether or not the test literally
1196 printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
1197 tests.
1198
1199 'name' is the name of the test.
1200
1201 'type' indicates if it was a special test.  Normal tests have a type
1202 of ''.  Type can be one of the following:
1203
1204     skip        see skip()
1205     todo        see todo()
1206     todo_skip   see todo_skip()
1207     unknown     see below
1208
1209 Sometimes the Test::Builder test counter is incremented without it
1210 printing any test output, for example, when current_test() is changed.
1211 In these cases, Test::Builder doesn't know the result of the test, so
1212 it's type is 'unkown'.  These details for these tests are filled in.
1213 They are considered ok, but the name and actual_ok is left undef.
1214
1215 For example "not ok 23 - hole count # TODO insufficient donuts" would
1216 result in this structure:
1217
1218     $tests[22] =    # 23 - 1, since arrays start from 0.
1219       { ok        => 1,   # logically, the test passed since it's todo
1220         actual_ok => 0,   # in absolute terms, it failed
1221         name      => 'hole count',
1222         type      => 'todo',
1223         reason    => 'insufficient donuts'
1224       };
1225
1226 =cut
1227
1228 sub details {
1229     return @Test_Results;
1230 }
1231
1232 =item B<todo>
1233
1234     my $todo_reason = $Test->todo;
1235     my $todo_reason = $Test->todo($pack);
1236
1237 todo() looks for a $TODO variable in your tests.  If set, all tests
1238 will be considered 'todo' (see Test::More and Test::Harness for
1239 details).  Returns the reason (ie. the value of $TODO) if running as
1240 todo tests, false otherwise.
1241
1242 todo() is pretty part about finding the right package to look for
1243 $TODO in.  It uses the exported_to() package to find it.  If that's
1244 not set, it's pretty good at guessing the right package to look at.
1245
1246 Sometimes there is some confusion about where todo() should be looking
1247 for the $TODO variable.  If you want to be sure, tell it explicitly
1248 what $pack to use.
1249
1250 =cut
1251
1252 sub todo {
1253     my($self, $pack) = @_;
1254
1255     $pack = $pack || $self->exported_to || $self->caller(1);
1256
1257     no strict 'refs';
1258     return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1259                                      : 0;
1260 }
1261
1262 =item B<caller>
1263
1264     my $package = $Test->caller;
1265     my($pack, $file, $line) = $Test->caller;
1266     my($pack, $file, $line) = $Test->caller($height);
1267
1268 Like the normal caller(), except it reports according to your level().
1269
1270 =cut
1271
1272 sub caller {
1273     my($self, $height) = @_;
1274     $height ||= 0;
1275
1276     my @caller = CORE::caller($self->level + $height + 1);
1277     return wantarray ? @caller : $caller[0];
1278 }
1279
1280 =back
1281
1282 =cut
1283
1284 =begin _private
1285
1286 =over 4
1287
1288 =item B<_sanity_check>
1289
1290   _sanity_check();
1291
1292 Runs a bunch of end of test sanity checks to make sure reality came
1293 through ok.  If anything is wrong it will die with a fairly friendly
1294 error message.
1295
1296 =cut
1297
1298 #'#
1299 sub _sanity_check {
1300     _whoa($Curr_Test < 0,  'Says here you ran a negative number of tests!');
1301     _whoa(!$Have_Plan and $Curr_Test,
1302           'Somehow your tests ran without a plan!');
1303     _whoa($Curr_Test != @Test_Results,
1304           'Somehow you got a different number of results than tests ran!');
1305 }
1306
1307 =item B<_whoa>
1308
1309   _whoa($check, $description);
1310
1311 A sanity check, similar to assert().  If the $check is true, something
1312 has gone horribly wrong.  It will die with the given $description and
1313 a note to contact the author.
1314
1315 =cut
1316
1317 sub _whoa {
1318     my($check, $desc) = @_;
1319     if( $check ) {
1320         die <<WHOA;
1321 WHOA!  $desc
1322 This should never happen!  Please contact the author immediately!
1323 WHOA
1324     }
1325 }
1326
1327 =item B<_my_exit>
1328
1329   _my_exit($exit_num);
1330
1331 Perl seems to have some trouble with exiting inside an END block.  5.005_03
1332 and 5.6.1 both seem to do odd things.  Instead, this function edits $?
1333 directly.  It should ONLY be called from inside an END block.  It
1334 doesn't actually exit, that's your job.
1335
1336 =cut
1337
1338 sub _my_exit {
1339     $? = $_[0];
1340
1341     return 1;
1342 }
1343
1344
1345 =back
1346
1347 =end _private
1348
1349 =cut
1350
1351 $SIG{__DIE__} = sub {
1352     # We don't want to muck with death in an eval, but $^S isn't
1353     # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
1354     # with it.  Instead, we use caller.  This also means it runs under
1355     # 5.004!
1356     my $in_eval = 0;
1357     for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
1358         $in_eval = 1 if $sub =~ /^\(eval\)/;
1359     }
1360     $Test_Died = 1 unless $in_eval;
1361 };
1362
1363 sub _ending {
1364     my $self = shift;
1365
1366     _sanity_check();
1367
1368     # Don't bother with an ending if this is a forked copy.  Only the parent
1369     # should do the ending.
1370     do{ _my_exit($?) && return } if $Original_Pid != $$;
1371
1372     # Bailout if plan() was never called.  This is so
1373     # "require Test::Simple" doesn't puke.
1374     do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
1375
1376     # Figure out if we passed or failed and print helpful messages.
1377     if( @Test_Results ) {
1378         # The plan?  We have no plan.
1379         if( $No_Plan ) {
1380             $self->_print("1..$Curr_Test\n") unless $self->no_header;
1381             $Expected_Tests = $Curr_Test;
1382         }
1383
1384         # Auto-extended arrays and elements which aren't explicitly
1385         # filled in with a shared reference will puke under 5.8.0
1386         # ithreads.  So we have to fill them in by hand. :(
1387         my $empty_result = &share({});
1388         for my $idx ( 0..$Expected_Tests-1 ) {
1389             $Test_Results[$idx] = $empty_result
1390               unless defined $Test_Results[$idx];
1391         }
1392
1393         my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
1394         $num_failed += abs($Expected_Tests - @Test_Results);
1395
1396         if( $Curr_Test < $Expected_Tests ) {
1397             my $s = $Expected_Tests == 1 ? '' : 's';
1398             $self->diag(<<"FAIL");
1399 Looks like you planned $Expected_Tests test$s but only ran $Curr_Test.
1400 FAIL
1401         }
1402         elsif( $Curr_Test > $Expected_Tests ) {
1403             my $num_extra = $Curr_Test - $Expected_Tests;
1404             my $s = $Expected_Tests == 1 ? '' : 's';
1405             $self->diag(<<"FAIL");
1406 Looks like you planned $Expected_Tests test$s but ran $num_extra extra.
1407 FAIL
1408         }
1409         elsif ( $num_failed ) {
1410             my $s = $num_failed == 1 ? '' : 's';
1411             $self->diag(<<"FAIL");
1412 Looks like you failed $num_failed test$s of $Expected_Tests.
1413 FAIL
1414         }
1415
1416         if( $Test_Died ) {
1417             $self->diag(<<"FAIL");
1418 Looks like your test died just after $Curr_Test.
1419 FAIL
1420
1421             _my_exit( 255 ) && return;
1422         }
1423
1424         _my_exit( $num_failed <= 254 ? $num_failed : 254  ) && return;
1425     }
1426     elsif ( $Skip_All ) {
1427         _my_exit( 0 ) && return;
1428     }
1429     elsif ( $Test_Died ) {
1430         $self->diag(<<'FAIL');
1431 Looks like your test died before it could output anything.
1432 FAIL
1433         _my_exit( 255 ) && return;
1434     }
1435     else {
1436         $self->diag("No tests run!\n");
1437         _my_exit( 255 ) && return;
1438     }
1439 }
1440
1441 END {
1442     $Test->_ending if defined $Test and !$Test->no_ending;
1443 }
1444
1445 =head1 EXIT CODES
1446
1447 If all your tests passed, Test::Builder will exit with zero (which is
1448 normal).  If anything failed it will exit with how many failed.  If
1449 you run less (or more) tests than you planned, the missing (or extras)
1450 will be considered failures.  If no tests were ever run Test::Builder
1451 will throw a warning and exit with 255.  If the test died, even after
1452 having successfully completed all its tests, it will still be
1453 considered a failure and will exit with 255.
1454
1455 So the exit codes are...
1456
1457     0                   all tests successful
1458     255                 test died
1459     any other number    how many failed (including missing or extras)
1460
1461 If you fail more than 254 tests, it will be reported as 254.
1462
1463
1464 =head1 THREADS
1465
1466 In perl 5.8.0 and later, Test::Builder is thread-safe.  The test
1467 number is shared amongst all threads.  This means if one thread sets
1468 the test number using current_test() they will all be effected.
1469
1470 Test::Builder is only thread-aware if threads.pm is loaded I<before>
1471 Test::Builder.
1472
1473 =head1 EXAMPLES
1474
1475 CPAN can provide the best examples.  Test::Simple, Test::More,
1476 Test::Exception and Test::Differences all use Test::Builder.
1477
1478 =head1 SEE ALSO
1479
1480 Test::Simple, Test::More, Test::Harness
1481
1482 =head1 AUTHORS
1483
1484 Original code by chromatic, maintained by Michael G Schwern
1485 E<lt>schwern@pobox.comE<gt>
1486
1487 =head1 COPYRIGHT
1488
1489 Copyright 2002 by chromatic E<lt>chromatic@wgz.orgE<gt>,
1490                   Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1491
1492 This program is free software; you can redistribute it and/or
1493 modify it under the same terms as Perl itself.
1494
1495 See F<http://www.perl.com/perl/misc/Artistic.html>
1496
1497 =cut
1498
1499 1;