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