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