cpan/Test-Simple/lib/Test/Builder.pm

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