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