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