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