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