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

   1 package Test::Builder;
   2
   3 use 5.008001;
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '1.301001_089';
   8 $VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
   9
  10
  11 use Test::Stream 1.301001 qw/ -internal STATE_LEGACY STATE_PLAN STATE_COUNT /;
  12 use Test::Stream::Toolset;
  13 use Test::Stream::Context;
  14 use Test::Stream::Carp qw/confess/;
  15 use Test::Stream::Meta qw/MODERN/;
  16
  17 use Test::Stream::Util qw/try protect unoverload_str is_regex/;
  18 use Scalar::Util qw/blessed reftype/;
  19
  20 use Test::More::Tools;
  21
  22 BEGIN {
  23     my $meta = Test::Stream::Meta->is_tester('main');
  24     Test::Stream->shared->set_use_legacy(1)
  25         unless $meta && $meta->[MODERN];
  26 }
  27
  28 # The mostly-singleton, and other package vars.
  29 our $Test  = Test::Builder->new;
  30 our $_ORIG_Test = $Test;
  31 our $Level = 1;
  32
  33 sub ctx {
  34     my $self = shift || die "No self in context";
  35     my ($add) = @_;
  36     my $ctx = Test::Stream::Context::context(2 + ($add || 0), $self->{stream});
  37     if (defined $self->{Todo}) {
  38         $ctx->set_in_todo(1);
  39         $ctx->set_todo($self->{Todo});
  40         $ctx->set_diag_todo(1);
  41     }
  42     return $ctx;
  43 }
  44
  45 sub stream {
  46     my $self = shift;
  47     return $self->{stream} || Test::Stream->shared;
  48 }
  49
  50 sub depth { $_[0]->{depth} || 0 }
  51
  52 # This is only for unit tests at this point.
  53 sub _ending {
  54     my $self = shift;
  55     my ($ctx) = @_;
  56     require Test::Stream::ExitMagic;
  57     $self->{stream}->set_no_ending(0);
  58     Test::Stream::ExitMagic->new->do_magic($self->{stream}, $ctx);
  59 }
  60
  61 my %WARNED;
  62 our $CTX;
  63 our %ORIG = (
  64     ok   => \&ok,
  65     diag => \&diag,
  66     note => \&note,
  67     plan => \&plan,
  68     done_testing => \&done_testing,
  69 );
  70
  71 sub WARN_OF_OVERRIDE {
  72     my ($sub, $ctx) = @_;
  73
  74     return unless $ctx->modern;
  75     my $old = $ORIG{$sub};
  76     # Use package instead of self, we want replaced subs, not subclass overrides.
  77     my $new = __PACKAGE__->can($sub);
  78
  79     return if $new == $old;
  80
  81     require B;
  82     my $o    = B::svref_2object($new);
  83     my $gv   = $o->GV;
  84     my $st   = $o->START;
  85     my $name = $gv->NAME;
  86     my $pkg  = $gv->STASH->NAME;
  87     my $line = $st->line;
  88     my $file = $st->file;
  89
  90     warn <<"    EOT" unless $WARNED{"$pkg $name $file $line"}++;
  91
  92 *******************************************************************************
  93 Something monkeypatched Test::Builder::$sub()!
  94 The new sub is '$pkg\::$name' defined in $file around line $line.
  95 In the near future monkeypatching Test::Builder::ok() will no longer work
  96 as expected.
  97 *******************************************************************************
  98     EOT
  99 }
 100
 101
 102 ####################
 103 # {{{ Constructors #
 104 ####################
 105
 106 sub new {
 107     my $class  = shift;
 108     my %params = @_;
 109     $Test ||= $class->create(shared_stream => 1);
 110
 111     return $Test;
 112 }
 113
 114 sub create {
 115     my $class  = shift;
 116     my %params = @_;
 117
 118     my $self = bless {}, $class;
 119     $self->reset(%params);
 120
 121     return $self;
 122 }
 123
 124 # Copy an object, currently a shallow.
 125 # This does *not* bless the destination.  This keeps the destructor from
 126 # firing when we're just storing a copy of the object to restore later.
 127 sub _copy {
 128     my ($src, $dest) = @_;
 129     %$dest = %$src;
 130     return;
 131 }
 132
 133 ####################
 134 # }}} Constructors #
 135 ####################
 136
 137 #############################
 138 # {{{ Children and subtests #
 139 #############################
 140
 141 sub subtest {
 142     my $self = shift;
 143     my $ctx = $self->ctx();
 144     require Test::Stream::Subtest;
 145     return Test::Stream::Subtest::subtest(@_);
 146 }
 147
 148 sub child {
 149     my( $self, $name ) = @_;
 150
 151     my $ctx = $self->ctx;
 152
 153     if ($self->{child}) {
 154         my $cname = $self->{child}->{Name};
 155         $ctx->throw("You already have a child named ($cname) running");
 156     }
 157
 158     $name ||= "Child of " . $self->{Name};
 159     $ctx->child('push', $name, 1);
 160
 161     my $stream = $self->{stream} || Test::Stream->shared;
 162
 163     my $child = bless {
 164         %$self,
 165         '?' => $?,
 166         parent => $self,
 167     };
 168
 169     $? = 0;
 170     $child->{Name} = $name;
 171     $self->{child} = $child;
 172     Scalar::Util::weaken($self->{child});
 173
 174     return $child;
 175 }
 176
 177 sub finalize {
 178     my $self = shift;
 179
 180     return unless $self->{parent};
 181
 182     my $ctx = $self->ctx;
 183
 184     if ($self->{child}) {
 185         my $cname = $self->{child}->{Name};
 186         $ctx->throw("Can't call finalize() with child ($cname) active");
 187     }
 188
 189     $self->_ending($ctx);
 190     my $passing = $ctx->stream->is_passing;
 191     my $count = $ctx->stream->count;
 192     my $name = $self->{Name};
 193     $ctx = undef;
 194
 195     my $stream = $self->{stream} || Test::Stream->shared;
 196
 197     my $parent = $self->parent;
 198     $self->{parent}->{child} = undef;
 199     $self->{parent} = undef;
 200
 201     $? = $self->{'?'};
 202
 203     $ctx = $parent->ctx;
 204     $ctx->child('pop', $self->{Name});
 205 }
 206
 207 sub in_subtest {
 208     my $self = shift;
 209     my $ctx = $self->ctx;
 210     return scalar @{$ctx->stream->subtests};
 211 }
 212
 213 sub parent { $_[0]->{parent} }
 214 sub name   { $_[0]->{Name} }
 215
 216 sub DESTROY {
 217     my $self = shift;
 218     return unless $self->{parent};
 219     return if $self->{Skip_All};
 220     $self->{parent}->is_passing(0);
 221     my $name = $self->{Name};
 222     die "Child ($name) exited without calling finalize()";
 223 }
 224
 225 #############################
 226 # }}} Children and subtests #
 227 #############################
 228
 229 #####################################
 230 # {{{ stuff for TODO status #
 231 #####################################
 232
 233 sub find_TODO {
 234     my ($self, $pack, $set, $new_value) = @_;
 235
 236     unless ($pack) {
 237         if (my $ctx = Test::Stream::Context->peek) {
 238             $pack = $ctx->package;
 239             my $old = $ctx->todo;
 240             $ctx->set_todo($new_value) if $set;
 241             return $old;
 242         }
 243
 244         $pack = $self->exported_to || return;
 245     }
 246
 247     no strict 'refs';    ## no critic
 248     no warnings 'once';
 249     my $old_value = ${$pack . '::TODO'};
 250     $set and ${$pack . '::TODO'} = $new_value;
 251     return $old_value;
 252 }
 253
 254 sub todo {
 255     my ($self, $pack) = @_;
 256
 257     return $self->{Todo} if defined $self->{Todo};
 258
 259     my $ctx = $self->ctx;
 260
 261     my $todo = $self->find_TODO($pack);
 262     return $todo if defined $todo;
 263
 264     return '';
 265 }
 266
 267 sub in_todo {
 268     my $self = shift;
 269
 270     my $ctx = $self->ctx;
 271     return 1 if $ctx->in_todo;
 272
 273     return (defined $self->{Todo} || $self->find_TODO) ? 1 : 0;
 274 }
 275
 276 sub todo_start {
 277     my $self = shift;
 278     my $message = @_ ? shift : '';
 279
 280     $self->{Start_Todo}++;
 281     if ($self->in_todo) {
 282         push @{$self->{Todo_Stack}} => $self->todo;
 283     }
 284     $self->{Todo} = $message;
 285
 286     return;
 287 }
 288
 289 sub todo_end {
 290     my $self = shift;
 291
 292     if (!$self->{Start_Todo}) {
 293         $self->ctx(-1)->throw('todo_end() called without todo_start()');
 294     }
 295
 296     $self->{Start_Todo}--;
 297
 298     if ($self->{Start_Todo} && @{$self->{Todo_Stack}}) {
 299         $self->{Todo} = pop @{$self->{Todo_Stack}};
 300     }
 301     else {
 302         delete $self->{Todo};
 303     }
 304
 305     return;
 306 }
 307
 308 #####################################
 309 # }}} Finding Testers and Providers #
 310 #####################################
 311
 312 ################
 313 # {{{ Planning #
 314 ################
 315
 316 my %PLAN_CMDS = (
 317     no_plan  => 'no_plan',
 318     skip_all => 'skip_all',
 319     tests    => '_plan_tests',
 320 );
 321
 322 sub plan {
 323     my ($self, $cmd, @args) = @_;
 324
 325     my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
 326     WARN_OF_OVERRIDE(plan => $ctx);
 327
 328     return unless $cmd;
 329
 330     if (my $method = $PLAN_CMDS{$cmd}) {
 331         $self->$method(@args);
 332     }
 333     else {
 334         my @in = grep { defined } ($cmd, @args);
 335         $self->ctx->throw("plan() doesn't understand @in");
 336     }
 337
 338     return 1;
 339 }
 340
 341 sub skip_all {
 342     my ($self, $reason) = @_;
 343
 344     $self->{Skip_All} = 1;
 345
 346     my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
 347
 348     $ctx->_plan(0, 'SKIP', $reason);
 349 }
 350
 351 sub no_plan {
 352     my ($self, @args) = @_;
 353
 354     my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
 355
 356     $ctx->alert("no_plan takes no arguments") if @args;
 357     $ctx->_plan(0, 'NO PLAN');
 358
 359     return 1;
 360 }
 361
 362 sub _plan_tests {
 363     my ($self, $arg) = @_;
 364
 365     my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
 366
 367     if ($arg) {
 368         $ctx->throw("Number of tests must be a positive integer.  You gave it '$arg'")
 369             unless $arg =~ /^\+?\d+$/;
 370
 371         $ctx->_plan($arg);
 372     }
 373     elsif (!defined $arg) {
 374         $ctx->throw("Got an undefined number of tests");
 375     }
 376     else {
 377         $ctx->throw("You said to run 0 tests");
 378     }
 379
 380     return;
 381 }
 382
 383 sub done_testing {
 384     my ($self, $num_tests) = @_;
 385
 386     my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
 387     WARN_OF_OVERRIDE(done_testing => $ctx);
 388
 389     my $out = $ctx->stream->done_testing($ctx, $num_tests);
 390     return $out;
 391 }
 392
 393 ################
 394 # }}} Planning #
 395 ################
 396
 397 #############################
 398 # {{{ Base Event Producers #
 399 #############################
 400
 401 sub ok {
 402     my $self = shift;
 403     my($test, $name) = @_;
 404
 405     my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
 406     WARN_OF_OVERRIDE(ok => $ctx);
 407
 408     if ($self->{child}) {
 409         $self->is_passing(0);
 410         $ctx->throw("Cannot run test ($name) with active children");
 411     }
 412
 413     $ctx->_unwind_ok($test, $name);
 414     return $test ? 1 : 0;
 415 }
 416
 417 sub BAIL_OUT {
 418     my( $self, $reason ) = @_;
 419     $self->ctx()->bail($reason);
 420 }
 421
 422 sub skip {
 423     my( $self, $why ) = @_;
 424     $why ||= '';
 425     unoverload_str( \$why );
 426
 427     my $ctx = $self->ctx();
 428     $ctx->set_skip($why);
 429     $ctx->ok(1, '');
 430     $ctx->set_skip(undef);
 431 }
 432
 433 sub todo_skip {
 434     my( $self, $why ) = @_;
 435     $why ||= '';
 436     unoverload_str( \$why );
 437
 438     my $ctx = $self->ctx();
 439     $ctx->set_skip($why);
 440     $ctx->set_todo($why);
 441     $ctx->ok(0, '');
 442     $ctx->set_skip(undef);
 443     $ctx->set_todo(undef);
 444 }
 445
 446 sub diag {
 447     my $self = shift;
 448     my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
 449
 450     my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
 451     WARN_OF_OVERRIDE(diag => $ctx);
 452
 453     $ctx->_diag($msg);
 454     return;
 455 }
 456
 457 sub note {
 458     my $self = shift;
 459     my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
 460
 461     my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
 462     WARN_OF_OVERRIDE(note => $ctx);
 463
 464     $ctx->_note($msg);
 465 }
 466
 467 #############################
 468 # }}} Base Event Producers #
 469 #############################
 470
 471 #######################
 472 # {{{ Public helpers #
 473 #######################
 474
 475 sub explain {
 476     my $self = shift;
 477
 478     return map {
 479         ref $_
 480           ? do {
 481             protect { require Data::Dumper };
 482             my $dumper = Data::Dumper->new( [$_] );
 483             $dumper->Indent(1)->Terse(1);
 484             $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
 485             $dumper->Dump;
 486           }
 487           : $_
 488     } @_;
 489 }
 490
 491 sub carp {
 492     my $self = shift;
 493     $self->ctx->alert(join '' => @_);
 494 }
 495
 496 sub croak {
 497     my $self = shift;
 498     $self->ctx->throw(join '' => @_);
 499 }
 500
 501 sub has_plan {
 502     my $self = shift;
 503
 504     my $plan = $self->ctx->stream->plan || return undef;
 505     return 'no_plan' if $plan->directive && $plan->directive eq 'NO PLAN';
 506     return $plan->max;
 507 }
 508
 509 sub reset {
 510     my $self = shift;
 511     my %params = @_;
 512
 513     $self->{use_shared} = 1 if $params{shared_stream};
 514
 515     if ($self->{use_shared}) {
 516         Test::Stream->shared->_reset;
 517         Test::Stream->shared->state->[-1]->[STATE_LEGACY] = [];
 518     }
 519     else {
 520         $self->{stream} = Test::Stream->new();
 521         $self->{stream}->set_use_legacy(1);
 522         $self->{stream}->state->[-1]->[STATE_LEGACY] = [];
 523     }
 524
 525     # We leave this a global because it has to be localized and localizing
 526     # hash keys is just asking for pain.  Also, it was documented.
 527     $Level = 1;
 528
 529     $self->{Name} = $0;
 530
 531     $self->{Original_Pid} = $$;
 532     $self->{Child_Name}   = undef;
 533
 534     $self->{Exported_To} = undef;
 535
 536     $self->{Todo}               = undef;
 537     $self->{Todo_Stack}         = [];
 538     $self->{Start_Todo}         = 0;
 539     $self->{Opened_Testhandles} = 0;
 540
 541     return;
 542 }
 543
 544 #######################
 545 # }}} Public helpers #
 546 #######################
 547
 548 #################################
 549 # {{{ Advanced Event Producers #
 550 #################################
 551
 552 sub cmp_ok {
 553     my( $self, $got, $type, $expect, $name ) = @_;
 554     my $ctx = $self->ctx;
 555     my ($ok, @diag) = tmt->cmp_check($got, $type, $expect);
 556     $ctx->ok($ok, $name, \@diag);
 557     return $ok;
 558 }
 559
 560 sub is_eq {
 561     my( $self, $got, $expect, $name ) = @_;
 562     my $ctx = $self->ctx;
 563     my ($ok, @diag) = tmt->is_eq($got, $expect);
 564     $ctx->ok($ok, $name, \@diag);
 565     return $ok;
 566 }
 567
 568 sub is_num {
 569     my( $self, $got, $expect, $name ) = @_;
 570     my $ctx = $self->ctx;
 571     my ($ok, @diag) = tmt->is_num($got, $expect);
 572     $ctx->ok($ok, $name, \@diag);
 573     return $ok;
 574 }
 575
 576 sub isnt_eq {
 577     my( $self, $got, $dont_expect, $name ) = @_;
 578     my $ctx = $self->ctx;
 579     my ($ok, @diag) = tmt->isnt_eq($got, $dont_expect);
 580     $ctx->ok($ok, $name, \@diag);
 581     return $ok;
 582 }
 583
 584 sub isnt_num {
 585     my( $self, $got, $dont_expect, $name ) = @_;
 586     my $ctx = $self->ctx;
 587     my ($ok, @diag) = tmt->isnt_num($got, $dont_expect);
 588     $ctx->ok($ok, $name, \@diag);
 589     return $ok;
 590 }
 591
 592 sub like {
 593     my( $self, $thing, $regex, $name ) = @_;
 594     my $ctx = $self->ctx;
 595     my ($ok, @diag) = tmt->regex_check($thing, $regex, '=~');
 596     $ctx->ok($ok, $name, \@diag);
 597     return $ok;
 598 }
 599
 600 sub unlike {
 601     my( $self, $thing, $regex, $name ) = @_;
 602     my $ctx = $self->ctx;
 603     my ($ok, @diag) = tmt->regex_check($thing, $regex, '!~');
 604     $ctx->ok($ok, $name, \@diag);
 605     return $ok;
 606 }
 607
 608 #################################
 609 # }}} Advanced Event Producers #
 610 #################################
 611
 612 ################################################
 613 # {{{ Misc #
 614 ################################################
 615
 616 sub _new_fh {
 617     my $self = shift;
 618     my($file_or_fh) = shift;
 619
 620     return $file_or_fh if $self->is_fh($file_or_fh);
 621
 622     my $fh;
 623     if( ref $file_or_fh eq 'SCALAR' ) {
 624         open $fh, ">>", $file_or_fh
 625           or croak("Can't open scalar ref $file_or_fh: $!");
 626     }
 627     else {
 628         open $fh, ">", $file_or_fh
 629           or croak("Can't open test output log $file_or_fh: $!");
 630         Test::Stream::IOSets->_autoflush($fh);
 631     }
 632
 633     return $fh;
 634 }
 635
 636 sub output {
 637     my $self = shift;
 638     my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
 639     $handles->[0] = $self->_new_fh(@_) if @_;
 640     return $handles->[0];
 641 }
 642
 643 sub failure_output {
 644     my $self = shift;
 645     my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
 646     $handles->[1] = $self->_new_fh(@_) if @_;
 647     return $handles->[1];
 648 }
 649
 650 sub todo_output {
 651     my $self = shift;
 652     my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
 653     $handles->[2] = $self->_new_fh(@_) if @_;
 654     return $handles->[2] || $handles->[0];
 655 }
 656
 657 sub reset_outputs {
 658     my $self = shift;
 659     my $ctx = $self->ctx;
 660     $ctx->stream->io_sets->reset_legacy;
 661 }
 662
 663 sub use_numbers {
 664     my $self = shift;
 665     my $ctx = $self->ctx;
 666     $ctx->stream->set_use_numbers(@_) if @_;
 667     $ctx->stream->use_numbers;
 668 }
 669
 670 sub no_ending {
 671     my $self = shift;
 672     my $ctx = $self->ctx;
 673     $ctx->stream->set_no_ending(@_) if @_;
 674     $ctx->stream->no_ending || 0;
 675 }
 676
 677 sub no_header {
 678     my $self = shift;
 679     my $ctx = $self->ctx;
 680     $ctx->stream->set_no_header(@_) if @_;
 681     $ctx->stream->no_header || 0;
 682 }
 683
 684 sub no_diag {
 685     my $self = shift;
 686     my $ctx = $self->ctx;
 687     $ctx->stream->set_no_diag(@_) if @_;
 688     $ctx->stream->no_diag || 0;
 689 }
 690
 691 sub exported_to {
 692     my($self, $pack) = @_;
 693     $self->{Exported_To} = $pack if defined $pack;
 694     return $self->{Exported_To};
 695 }
 696
 697 sub is_fh {
 698     my $self     = shift;
 699     my $maybe_fh = shift;
 700     return 0 unless defined $maybe_fh;
 701
 702     return 1 if ref $maybe_fh  eq 'GLOB';    # its a glob ref
 703     return 1 if ref \$maybe_fh eq 'GLOB';    # its a glob
 704
 705     my $out;
 706     protect {
 707         $out = eval { $maybe_fh->isa("IO::Handle") }
 708             || eval { tied($maybe_fh)->can('TIEHANDLE') };
 709     };
 710
 711     return $out;
 712 }
 713
 714 sub BAILOUT { goto &BAIL_OUT }
 715
 716 sub expected_tests {
 717     my $self = shift;
 718
 719     my $ctx = $self->ctx;
 720     $ctx->plan(@_) if @_;
 721
 722     my $plan = $ctx->stream->state->[-1]->[STATE_PLAN] || return 0;
 723     return $plan->max || 0;
 724 }
 725
 726 sub caller {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
 727     my $self = shift;
 728
 729     my $ctx = $self->ctx;
 730
 731     return wantarray ? $ctx->call : $ctx->package;
 732 }
 733
 734 sub level {
 735     my( $self, $level ) = @_;
 736     $Level = $level if defined $level;
 737     return $Level;
 738 }
 739
 740 sub maybe_regex {
 741     my ($self, $regex) = @_;
 742     return is_regex($regex);
 743 }
 744
 745 sub is_passing {
 746     my $self = shift;
 747     my $ctx = $self->ctx;
 748     $ctx->stream->is_passing(@_);
 749 }
 750
 751 # Yeah, this is not efficient, but it is only legacy support, barely anything
 752 # uses it, and they really should not.
 753 sub current_test {
 754     my $self = shift;
 755
 756     my $ctx = $self->ctx;
 757
 758     if (@_) {
 759         my ($num) = @_;
 760         my $state = $ctx->stream->state->[-1];
 761         $state->[STATE_COUNT] = $num;
 762
 763         my $old = $state->[STATE_LEGACY] || [];
 764         my $new = [];
 765
 766         my $nctx = $ctx->snapshot;
 767         $nctx->set_todo('incrementing test number');
 768         $nctx->set_in_todo(1);
 769
 770         for (1 .. $num) {
 771             my $i;
 772             $i = shift @$old while @$old && (!$i || !$i->isa('Test::Stream::Event::Ok'));
 773             $i ||= Test::Stream::Event::Ok->new(
 774                 $nctx,
 775                 [CORE::caller()],
 776                 0,
 777                 undef,
 778                 undef,
 779                 undef,
 780                 1,
 781             );
 782
 783             push @$new => $i;
 784         }
 785
 786         $state->[STATE_LEGACY] = $new;
 787     }
 788
 789     $ctx->stream->count;
 790 }
 791
 792 sub details {
 793     my $self = shift;
 794     my $ctx = $self->ctx;
 795     my $state = $ctx->stream->state->[-1];
 796     my @out;
 797     return @out unless $state->[STATE_LEGACY];
 798
 799     for my $e (@{$state->[STATE_LEGACY]}) {
 800         next unless $e && $e->isa('Test::Stream::Event::Ok');
 801         push @out => $e->to_legacy;
 802     }
 803
 804     return @out;
 805 }
 806
 807 sub summary {
 808     my $self = shift;
 809     my $ctx = $self->ctx;
 810     my $state = $ctx->stream->state->[-1];
 811     return @{[]} unless $state->[STATE_LEGACY];
 812     return map { $_->isa('Test::Stream::Event::Ok') ? ($_->bool ? 1 : 0) : ()} @{$state->[STATE_LEGACY]};
 813 }
 814
 815 ###################################
 816 # }}} Misc #
 817 ###################################
 818
 819 ####################
 820 # {{{ TB1.5 stuff  #
 821 ####################
 822
 823 # This is just a list of method Test::Builder current does not have that Test::Builder 1.5 does.
 824 my %TB15_METHODS = map { $_ => 1 } qw{
 825     _file_and_line _join_message _make_default _my_exit _reset_todo_state
 826     _result_to_hash _results _todo_state formatter history in_test
 827     no_change_exit_code post_event post_result set_formatter set_plan test_end
 828     test_exit_code test_start test_state
 829 };
 830
 831 our $AUTOLOAD;
 832
 833 sub AUTOLOAD {
 834     $AUTOLOAD =~ m/^(.*)::([^:]+)$/;
 835     my ($package, $sub) = ($1, $2);
 836
 837     my @caller = CORE::caller();
 838     my $msg    = qq{Can't locate object method "$sub" via package "$package" at $caller[1] line $caller[2].\n};
 839
 840     $msg .= <<"    EOT" if $TB15_METHODS{$sub};
 841
 842     *************************************************************************
 843     '$sub' is a Test::Builder 1.5 method. Test::Builder 1.5 is a dead branch.
 844     You need to update your code so that it no longer treats Test::Builders
 845     over a specific version number as anything special.
 846
 847     See: http://blogs.perl.org/users/chad_exodist_granum/2014/03/testmore---new-maintainer-also-stop-version-checking.html
 848     *************************************************************************
 849     EOT
 850
 851     die $msg;
 852 }
 853
 854 ####################
 855 # }}} TB1.5 stuff  #
 856 ####################
 857
 858 ##################################
 859 # {{{ Legacy support, do not use #
 860 ##################################
 861
 862 # These are here to support old versions of Test::More which may be bundled
 863 # with some dists. See https://github.com/Test-More/test-more/issues/479
 864
 865 sub _try {
 866     my( $self, $code, %opts ) = @_;
 867
 868     my $error;
 869     my $return;
 870     protect {
 871         $return = eval { $code->() };
 872         $error = $@;
 873     };
 874
 875     die $error if $error and $opts{die_on_fail};
 876
 877     return wantarray ? ( $return, $error ) : $return;
 878 }
 879
 880 sub _unoverload {
 881     my $self = shift;
 882     my $type = shift;
 883
 884     $self->_try(sub { require overload; }, die_on_fail => 1);
 885
 886     foreach my $thing (@_) {
 887         if( $self->_is_object($$thing) ) {
 888             if( my $string_meth = overload::Method( $$thing, $type ) ) {
 889                 $$thing = $$thing->$string_meth();
 890             }
 891         }
 892     }
 893
 894     return;
 895 }
 896
 897 sub _is_object {
 898     my( $self, $thing ) = @_;
 899
 900     return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
 901 }
 902
 903 sub _unoverload_str {
 904     my $self = shift;
 905
 906     return $self->_unoverload( q[""], @_ );
 907 }
 908
 909 sub _unoverload_num {
 910     my $self = shift;
 911
 912     $self->_unoverload( '0+', @_ );
 913
 914     for my $val (@_) {
 915         next unless $self->_is_dualvar($$val);
 916         $$val = $$val + 0;
 917     }
 918
 919     return;
 920 }
 921
 922 # This is a hack to detect a dualvar such as $!
 923 sub _is_dualvar {
 924     my( $self, $val ) = @_;
 925
 926     # Objects are not dualvars.
 927     return 0 if ref $val;
 928
 929     no warnings 'numeric';
 930     my $numval = $val + 0;
 931     return ($numval != 0 and $numval ne $val ? 1 : 0);
 932 }
 933
 934 ##################################
 935 # }}} Legacy support, do not use #
 936 ##################################
 937
 938 1;
 939
 940 __END__
 941
 942 =pod
 943
 944 =head1 NAME
 945
 946 Test::Builder - *DEPRECATED* Module for building testing libraries.
 947
 948 =head1 DESCRIPTION
 949
 950 This module was previously the base module for almost any testing library. This
 951 module is now little more than a compatability wrapper around L<Test::Stream>.
 952 If you are looking to write or update a testing library you should look at
 953 L<Test::Stream::Toolset>.
 954
 955 =head1 PACKAGE VARS
 956
 957 =over 4
 958
 959 =item $Test::Builder::Test
 960
 961 The variable that holds the Test::Builder singleton.
 962
 963 =item $Test::Builder::Level
 964
 965 In the past this variable was used to track stack depth so that Test::Builder
 966 could report the correct line number. If you use Test::Builder this will still
 967 work, but in new code it is better to use the L<Test::Stream::Context> module.
 968
 969 =back
 970
 971 =head1 METHODS
 972
 973 =head2 CONSTRUCTORS
 974
 975 =over 4
 976
 977 =item Test::Builder->new
 978
 979 Returns the singleton stored in C<$Test::Builder::Test>.
 980
 981 =item Test::Builder->create
 982
 983 =item Test::Builder->create(use_shared => 1)
 984
 985 Returns a new instance of Test::Builder. It is important to note that this
 986 instance will not use the shared L<Test::Stream> object unless you pass in the
 987 C<< use_shared => 1 >> argument.
 988
 989 =back
 990
 991 =head2 UTIL
 992
 993 =over 4
 994
 995 =item $TB->ctx
 996
 997 Helper method for Test::Builder to get a L<Test::Stream::Context> object.
 998
 999 =item $TB->depth
1000
1001 Get the subtest depth
1002
1003 =item $TB->find_TODO
1004
1005 =item $TB->in_todo
1006
1007 =item $TB->todo
1008
1009 These all check on todo state and value
1010
1011 =back
1012
1013 =head2 OTHER
1014
1015 =over 4
1016
1017 =item $TB->caller
1018
1019 =item $TB->carp
1020
1021 =item $TB->croak
1022
1023 These let you figure out when/where the test is defined in the test file.
1024
1025 =item $TB->child
1026
1027 Start a subtest (Please do not use this)
1028
1029 =item $TB->finalize
1030
1031 Finish a subtest (Please do not use this)
1032
1033 =item $TB->explain
1034
1035 Interface to Data::Dumper that dumps whatever you give it.
1036
1037 =item $TB->exported_to
1038
1039 This used to tell you what package used Test::Builder, it never worked well.
1040 The previous bad and unpredictable behavior of this has largely been preserved,
1041 however nothing internal uses it in any meaningful way anymore.
1042
1043 =item $TB->is_fh
1044
1045 Check if something is a filehandle
1046
1047 =item $TB->level
1048
1049 Get/Set C<$Test::Builder::Level>. $Level is a package var, and most things
1050 localize it, so this method is pretty useless.
1051
1052 =item $TB->maybe_regex
1053
1054 Check if something might be a regex.
1055
1056 =item $TB->reset
1057
1058 Reset the builder object to a very basic and default state. You almost
1059 certainly do not need this unless you are writing a tool to test testing
1060 libraries. Even then you probably do not want this.
1061
1062 =item $TB->todo_end
1063
1064 =item $TB->todo_start
1065
1066 Start/end TODO state, there are better ways to do this now.
1067
1068 =back
1069
1070 =head2 STREAM INTERFACE
1071
1072 These simply interface into functionality of L<Test::Stream>.
1073
1074 =over 4
1075
1076 =item $TB->failure_output
1077
1078 =item $TB->output
1079
1080 =item $TB->reset_outputs
1081
1082 =item $TB->todo_output
1083
1084 These get/set the IO handle used in the 'legacy' tap encoding.
1085
1086 =item $TB->no_diag
1087
1088 Do not display L<Test::Stream::Event::Diag> events.
1089
1090 =item $TB->no_ending
1091
1092 Do not do some special magic at the end that tells you what went wrong with
1093 tests.
1094
1095 =item $TB->no_header
1096
1097 Do not display the plan
1098
1099 =item $TB->use_numbers
1100
1101 Turn numbers in TAP on and off.
1102
1103 =back
1104
1105 =head2 HISTORY
1106
1107 =over
1108
1109 =item $TB->details
1110
1111 Get all the events that occured on this object. Each event will be transformed
1112 into a hash that matches the legacy output of this method.
1113
1114 =item $TB->expected_tests
1115
1116 Set/Get expected number of tests
1117
1118 =item $TB->has_plan
1119
1120 Check if there is a plan
1121
1122 =item $TB->summary
1123
1124 List of pass/fail results.
1125
1126 =back
1127
1128 =head2 EVENT GENERATORS
1129
1130 See L<Test::Stream::Context>, L<Test::Stream::Toolset>, and
1131 L<Test::More::Tools>. Calling the methods below is not advised.
1132
1133 =over 4
1134
1135 =item $TB->BAILOUT
1136
1137 =item $TB->BAIL_OUT
1138
1139 =item $TB->cmp_ok
1140
1141 =item $TB->current_test
1142
1143 =item $TB->diag
1144
1145 =item $TB->done_testing
1146
1147 =item $TB->is_eq
1148
1149 =item $TB->is_num
1150
1151 =item $TB->is_passing
1152
1153 =item $TB->isnt_eq
1154
1155 =item $TB->isnt_num
1156
1157 =item $TB->like
1158
1159 =item $TB->no_plan
1160
1161 =item $TB->note
1162
1163 =item $TB->ok
1164
1165 =item $TB->plan
1166
1167 =item $TB->skip
1168
1169 =item $TB->skip_all
1170
1171 =item $TB->subtest
1172
1173 =item $TB->todo_skip
1174
1175 =item $TB->unlike
1176
1177 =back
1178
1179 =head2 ACCESSORS
1180
1181 =over 4
1182
1183 =item $TB->stream
1184
1185 Get the stream used by this builder (or the shared stream).
1186
1187 =item $TB->name
1188
1189 Name of the test
1190
1191 =item $TB->parent
1192
1193 Parent if this is a child.
1194
1195 =back
1196
1197 =head1 MONKEYPATCHING
1198
1199 Many legacy testing modules monkeypatch C<ok()>, C<plan()>, and others. The
1200 abillity to monkeypatch these to effect all events of the specified type is now
1201 considered discouraged. For backwords compatability monkeypatching continues to
1202 work, however in the distant future it will be removed. L<Test::Stream> upon
1203 which Test::Builder is now built, provides hooks and API's for doing everything
1204 that previously required monkeypatching.
1205
1206 =encoding utf8
1207
1208 =head1 TUTORIALS
1209
1210 =over 4
1211
1212 =item L<Test::Tutorial>
1213
1214 The original L<Test::Tutorial>. Uses comedy to introduce you to testing from
1215 scratch.
1216
1217 =item L<Test::Tutorial::WritingTests>
1218
1219 The L<Test::Tutorial::WritingTests> tutorial takes a more technical approach.
1220 The idea behind this tutorial is to give you a technical introduction to
1221 testing that can easily be used as a reference. This is for people who say
1222 "Just tell me how to do it, and quickly!".
1223
1224 =item L<Test::Tutorial::WritingTools>
1225
1226 The L<Test::Tutorial::WritingTools> tutorial is an introduction to writing
1227 testing tools that play nicely with other L<Test::Stream> and L<Test::Builder>
1228 based tools. This is what you should look at if you want to write
1229 Test::MyWidget.
1230
1231 =back
1232
1233 =head1 SOURCE
1234
1235 The source code repository for Test::More can be found at
1236 F<http://github.com/Test-More/test-more/>.
1237
1238 =head1 MAINTAINER
1239
1240 =over 4
1241
1242 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
1243
1244 =back
1245
1246 =head1 AUTHORS
1247
1248 The following people have all contributed to the Test-More dist (sorted using
1249 VIM's sort function).
1250
1251 =over 4
1252
1253 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
1254
1255 =item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
1256
1257 =item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
1258
1259 =item Michael G Schwern E<lt>schwern@pobox.comE<gt>
1260
1261 =item 唐鳳
1262
1263 =back
1264
1265 =head1 COPYRIGHT
1266
1267 There has been a lot of code migration between modules,
1268 here are all the original copyrights together:
1269
1270 =over 4
1271
1272 =item Test::Stream
1273
1274 =item Test::Stream::Tester
1275
1276 Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
1277
1278 This program is free software; you can redistribute it and/or
1279 modify it under the same terms as Perl itself.
1280
1281 See F<http://www.perl.com/perl/misc/Artistic.html>
1282
1283 =item Test::Simple
1284
1285 =item Test::More
1286
1287 =item Test::Builder
1288
1289 Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
1290 inspiration from Joshua Pritikin's Test module and lots of help from Barrie
1291 Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
1292 gang.
1293
1294 Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
1295 E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
1296
1297 Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1298
1299 This program is free software; you can redistribute it and/or
1300 modify it under the same terms as Perl itself.
1301
1302 See F<http://www.perl.com/perl/misc/Artistic.html>
1303
1304 =item Test::use::ok
1305
1306 To the extent possible under law, 唐鳳 has waived all copyright and related
1307 or neighboring rights to L<Test-use-ok>.
1308
1309 This work is published from Taiwan.
1310
1311 L<http://creativecommons.org/publicdomain/zero/1.0>
1312
1313 =item Test::Tester
1314
1315 This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
1316 are based on other people's work.
1317
1318 Under the same license as Perl itself
1319
1320 See http://www.perl.com/perl/misc/Artistic.html
1321
1322 =item Test::Builder::Tester
1323
1324 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
1325
1326 This program is free software; you can redistribute it
1327 and/or modify it under the same terms as Perl itself.
1328
1329 =back