This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Test-Harness-3.10
[perl5.git] / lib / Test / Builder.pm
CommitLineData
33459055
MS
1package Test::Builder;
2
3use 5.004;
4
5# $^C was only introduced in 5.005-ish. We do this to prevent
6# use of uninitialized value warnings in older perls.
7$^C ||= 0;
8
9use strict;
30e302f8 10use vars qw($VERSION);
0fc92fc6 11$VERSION = '0.74_1';
7483b81c 12$VERSION = eval $VERSION; # make the alpha version come out as a number
33459055 13
a344be10
MS
14# Make Test::Builder thread-safe for ithreads.
15BEGIN {
16 use Config;
b7f9bbeb
SP
17 # Load threads::shared when threads are turned on.
18 # 5.8.0's threads are so busted we no longer support them.
19 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
a344be10 20 require threads::shared;
7483b81c
RGS
21
22 # Hack around YET ANOTHER threads::shared bug. It would
23 # occassionally forget the contents of the variable when sharing it.
24 # So we first copy the data, then share, then put our copy back.
25 *share = sub (\[$@%]) {
26 my $type = ref $_[0];
27 my $data;
28
29 if( $type eq 'HASH' ) {
30 %$data = %{$_[0]};
31 }
32 elsif( $type eq 'ARRAY' ) {
33 @$data = @{$_[0]};
34 }
35 elsif( $type eq 'SCALAR' ) {
36 $$data = ${$_[0]};
37 }
38 else {
b7f9bbeb 39 die("Unknown type: ".$type);
7483b81c
RGS
40 }
41
42 $_[0] = &threads::shared::share($_[0]);
43
44 if( $type eq 'HASH' ) {
45 %{$_[0]} = %$data;
46 }
47 elsif( $type eq 'ARRAY' ) {
48 @{$_[0]} = @$data;
49 }
50 elsif( $type eq 'SCALAR' ) {
51 ${$_[0]} = $$data;
52 }
53 else {
b7f9bbeb 54 die("Unknown type: ".$type);
7483b81c
RGS
55 }
56
57 return $_[0];
58 };
a344be10 59 }
b7f9bbeb
SP
60 # 5.8.0's threads::shared is busted when threads are off
61 # and earlier Perls just don't have that module at all.
a344be10 62 else {
30e302f8 63 *share = sub { return $_[0] };
60ffb308 64 *lock = sub { 0 };
a344be10
MS
65 }
66}
67
33459055
MS
68
69=head1 NAME
70
71Test::Builder - Backend for building test libraries
72
73=head1 SYNOPSIS
74
75 package My::Test::Module;
76 use Test::Builder;
77 require Exporter;
78 @ISA = qw(Exporter);
79 @EXPORT = qw(ok);
80
81 my $Test = Test::Builder->new;
82 $Test->output('my_logfile');
83
84 sub import {
85 my($self) = shift;
86 my $pack = caller;
87
88 $Test->exported_to($pack);
89 $Test->plan(@_);
90
91 $self->export_to_level(1, $self, 'ok');
92 }
93
94 sub ok {
95 my($test, $name) = @_;
96
97 $Test->ok($test, $name);
98 }
99
100
101=head1 DESCRIPTION
102
33459055 103Test::Simple and Test::More have proven to be popular testing modules,
a9153838
MS
104but they're not always flexible enough. Test::Builder provides the a
105building block upon which to write your own test libraries I<which can
106work together>.
33459055
MS
107
108=head2 Construction
109
110=over 4
111
112=item B<new>
113
114 my $Test = Test::Builder->new;
115
116Returns a Test::Builder object representing the current state of the
117test.
118
5143c659 119Since you only run one test per program C<new> always returns the same
33459055 120Test::Builder object. No matter how many times you call new(), you're
5143c659
RGS
121getting the same object. This is called a singleton. This is done so that
122multiple modules share such global information as the test counter and
123where test output is going.
124
125If you want a completely new Test::Builder object different from the
126singleton, use C<create>.
33459055
MS
127
128=cut
129
30e302f8 130my $Test = Test::Builder->new;
33459055
MS
131sub new {
132 my($class) = shift;
5143c659 133 $Test ||= $class->create;
33459055
MS
134 return $Test;
135}
136
5143c659
RGS
137
138=item B<create>
139
140 my $Test = Test::Builder->create;
141
142Ok, so there can be more than one Test::Builder object and this is how
143you get it. You might use this instead of C<new()> if you're testing
144a Test::Builder based module, but otherwise you probably want C<new>.
145
146B<NOTE>: the implementation is not complete. C<level>, for example, is
147still shared amongst B<all> Test::Builder objects, even ones created using
148this method. Also, the method name may change in the future.
149
150=cut
151
152sub create {
153 my $class = shift;
154
155 my $self = bless {}, $class;
156 $self->reset;
157
158 return $self;
159}
160
30e302f8
NC
161=item B<reset>
162
163 $Test->reset;
164
165Reinitializes the Test::Builder singleton to its original state.
166Mostly useful for tests run in persistent environments where the same
167test might be run multiple times in the same process.
168
169=cut
170
30e302f8 171use vars qw($Level);
30e302f8
NC
172
173sub reset {
174 my ($self) = @_;
175
5143c659
RGS
176 # We leave this a global because it has to be localized and localizing
177 # hash keys is just asking for pain. Also, it was documented.
178 $Level = 1;
179
180 $self->{Test_Died} = 0;
181 $self->{Have_Plan} = 0;
182 $self->{No_Plan} = 0;
183 $self->{Original_Pid} = $$;
30e302f8 184
5143c659
RGS
185 share($self->{Curr_Test});
186 $self->{Curr_Test} = 0;
187 $self->{Test_Results} = &share([]);
30e302f8 188
5143c659
RGS
189 $self->{Exported_To} = undef;
190 $self->{Expected_Tests} = 0;
30e302f8 191
5143c659 192 $self->{Skip_All} = 0;
30e302f8 193
5143c659
RGS
194 $self->{Use_Nums} = 1;
195
196 $self->{No_Header} = 0;
197 $self->{No_Ending} = 0;
30e302f8
NC
198
199 $self->_dup_stdhandles unless $^C;
200
705e6672 201 return;
30e302f8
NC
202}
203
33459055
MS
204=back
205
206=head2 Setting up tests
207
208These methods are for setting up tests and declaring how many there
209are. You usually only want to call one of these methods.
210
211=over 4
212
213=item B<exported_to>
214
215 my $pack = $Test->exported_to;
216 $Test->exported_to($pack);
217
218Tells Test::Builder what package you exported your functions to.
219This is important for getting TODO tests right.
220
221=cut
222
33459055
MS
223sub exported_to {
224 my($self, $pack) = @_;
225
226 if( defined $pack ) {
5143c659 227 $self->{Exported_To} = $pack;
33459055 228 }
5143c659 229 return $self->{Exported_To};
33459055
MS
230}
231
232=item B<plan>
233
234 $Test->plan('no_plan');
235 $Test->plan( skip_all => $reason );
236 $Test->plan( tests => $num_tests );
237
238A convenient way to set up your tests. Call this and Test::Builder
239will print the appropriate headers and take the appropriate actions.
240
241If you call plan(), don't call any of the other methods below.
242
243=cut
244
245sub plan {
246 my($self, $cmd, $arg) = @_;
247
248 return unless $cmd;
249
004caa16
RGS
250 local $Level = $Level + 1;
251
5143c659 252 if( $self->{Have_Plan} ) {
b7f9bbeb 253 $self->croak("You tried to plan twice");
a344be10
MS
254 }
255
33459055
MS
256 if( $cmd eq 'no_plan' ) {
257 $self->no_plan;
258 }
259 elsif( $cmd eq 'skip_all' ) {
260 return $self->skip_all($arg);
261 }
262 elsif( $cmd eq 'tests' ) {
263 if( $arg ) {
b7f9bbeb 264 local $Level = $Level + 1;
33459055
MS
265 return $self->expected_tests($arg);
266 }
267 elsif( !defined $arg ) {
b7f9bbeb 268 $self->croak("Got an undefined number of tests");
33459055
MS
269 }
270 elsif( !$arg ) {
b7f9bbeb 271 $self->croak("You said to run 0 tests");
33459055
MS
272 }
273 }
89c1e84a 274 else {
89c1e84a 275 my @args = grep { defined } ($cmd, $arg);
b7f9bbeb 276 $self->croak("plan() doesn't understand @args");
89c1e84a 277 }
a344be10
MS
278
279 return 1;
33459055
MS
280}
281
282=item B<expected_tests>
283
284 my $max = $Test->expected_tests;
285 $Test->expected_tests($max);
286
287Gets/sets the # of tests we expect this test to run and prints out
288the appropriate headers.
289
290=cut
291
33459055 292sub expected_tests {
7483b81c
RGS
293 my $self = shift;
294 my($max) = @_;
295
296 if( @_ ) {
b7f9bbeb 297 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
7483b81c 298 unless $max =~ /^\+?\d+$/ and $max > 0;
33459055 299
5143c659
RGS
300 $self->{Expected_Tests} = $max;
301 $self->{Have_Plan} = 1;
33459055
MS
302
303 $self->_print("1..$max\n") unless $self->no_header;
304 }
5143c659 305 return $self->{Expected_Tests};
33459055
MS
306}
307
308
309=item B<no_plan>
310
311 $Test->no_plan;
312
313Declares that this test will run an indeterminate # of tests.
314
315=cut
316
33459055 317sub no_plan {
5143c659
RGS
318 my $self = shift;
319
320 $self->{No_Plan} = 1;
321 $self->{Have_Plan} = 1;
33459055
MS
322}
323
60ffb308
MS
324=item B<has_plan>
325
326 $plan = $Test->has_plan
5143c659 327
60ffb308
MS
328Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
329
330=cut
331
332sub has_plan {
5143c659
RGS
333 my $self = shift;
334
335 return($self->{Expected_Tests}) if $self->{Expected_Tests};
336 return('no_plan') if $self->{No_Plan};
337 return(undef);
60ffb308
MS
338};
339
340
33459055
MS
341=item B<skip_all>
342
343 $Test->skip_all;
344 $Test->skip_all($reason);
345
346Skips all the tests, using the given $reason. Exits immediately with 0.
347
348=cut
349
33459055
MS
350sub skip_all {
351 my($self, $reason) = @_;
352
353 my $out = "1..0";
354 $out .= " # Skip $reason" if $reason;
355 $out .= "\n";
356
5143c659 357 $self->{Skip_All} = 1;
33459055
MS
358
359 $self->_print($out) unless $self->no_header;
360 exit(0);
361}
362
363=back
364
365=head2 Running tests
366
c00d8759
SP
367These actually run the tests, analogous to the functions in Test::More.
368
369They all return true if the test passed, false if the test failed.
33459055
MS
370
371$name is always optional.
372
373=over 4
374
375=item B<ok>
376
377 $Test->ok($test, $name);
378
379Your basic test. Pass if $test is true, fail if $test is false. Just
380like Test::Simple's ok().
381
382=cut
383
384sub ok {
385 my($self, $test, $name) = @_;
386
60ffb308
MS
387 # $test might contain an object which we don't want to accidentally
388 # store, so we turn it into a boolean.
389 $test = $test ? 1 : 0;
390
b7f9bbeb 391 $self->_plan_check;
33459055 392
5143c659
RGS
393 lock $self->{Curr_Test};
394 $self->{Curr_Test}++;
a344be10 395
30e302f8 396 # In case $name is a string overloaded object, force it to stringify.
b1ddf169 397 $self->_unoverload_str(\$name);
30e302f8 398
33459055 399 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
a9153838
MS
400 You named your test '$name'. You shouldn't use numbers for your test names.
401 Very confusing.
33459055
MS
402ERR
403
705e6672 404 my $todo = $self->todo();
b1ddf169 405 $self->_unoverload_str(\$todo);
33459055
MS
406
407 my $out;
30e302f8 408 my $result = &share({});
60ffb308 409
33459055
MS
410 unless( $test ) {
411 $out .= "not ";
60ffb308 412 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
33459055
MS
413 }
414 else {
60ffb308 415 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
33459055
MS
416 }
417
418 $out .= "ok";
5143c659 419 $out .= " $self->{Curr_Test}" if $self->use_numbers;
33459055
MS
420
421 if( defined $name ) {
422 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
423 $out .= " - $name";
7483b81c 424 $result->{name} = $name;
60ffb308
MS
425 }
426 else {
427 $result->{name} = '';
33459055
MS
428 }
429
430 if( $todo ) {
7483b81c
RGS
431 $out .= " # TODO $todo";
432 $result->{reason} = $todo;
60ffb308
MS
433 $result->{type} = 'todo';
434 }
435 else {
436 $result->{reason} = '';
437 $result->{type} = '';
33459055
MS
438 }
439
5143c659 440 $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
33459055
MS
441 $out .= "\n";
442
443 $self->_print($out);
444
445 unless( $test ) {
446 my $msg = $todo ? "Failed (TODO)" : "Failed";
30e302f8 447 $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
b1ddf169 448
705e6672
SP
449 my(undef, $file, $line) = $self->caller;
450 if( defined $name ) {
451 $self->diag(qq[ $msg test '$name'\n]);
452 $self->diag(qq[ at $file line $line.\n]);
453 }
454 else {
455 $self->diag(qq[ $msg test at $file line $line.\n]);
456 }
33459055
MS
457 }
458
459 return $test ? 1 : 0;
460}
461
7483b81c
RGS
462
463sub _unoverload {
464 my $self = shift;
b1ddf169 465 my $type = shift;
7483b81c 466
c00d8759 467 $self->_try(sub { require overload } ) || return;
7483b81c
RGS
468
469 foreach my $thing (@_) {
c00d8759
SP
470 if( $self->_is_object($$thing) ) {
471 if( my $string_meth = overload::Method($$thing, $type) ) {
472 $$thing = $$thing->$string_meth();
7483b81c 473 }
c00d8759 474 }
7483b81c
RGS
475 }
476}
477
478
b1ddf169 479sub _is_object {
c00d8759 480 my($self, $thing) = @_;
b1ddf169 481
c00d8759 482 return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
b1ddf169
RGS
483}
484
485
486sub _unoverload_str {
487 my $self = shift;
488
489 $self->_unoverload(q[""], @_);
490}
491
492sub _unoverload_num {
493 my $self = shift;
494
495 $self->_unoverload('0+', @_);
496
497 for my $val (@_) {
498 next unless $self->_is_dualvar($$val);
499 $$val = $$val+0;
500 }
501}
502
503
504# This is a hack to detect a dualvar such as $!
505sub _is_dualvar {
506 my($self, $val) = @_;
507
508 local $^W = 0;
509 my $numval = $val+0;
510 return 1 if $numval != 0 and $numval ne $val;
511}
512
513
514
33459055
MS
515=item B<is_eq>
516
517 $Test->is_eq($got, $expected, $name);
518
519Like Test::More's is(). Checks if $got eq $expected. This is the
520string version.
521
522=item B<is_num>
523
a9153838 524 $Test->is_num($got, $expected, $name);
33459055
MS
525
526Like Test::More's is(). Checks if $got == $expected. This is the
527numeric version.
528
529=cut
530
531sub is_eq {
a9153838 532 my($self, $got, $expect, $name) = @_;
33459055 533 local $Level = $Level + 1;
a9153838 534
b1ddf169
RGS
535 $self->_unoverload_str(\$got, \$expect);
536
a9153838
MS
537 if( !defined $got || !defined $expect ) {
538 # undef only matches undef and nothing else
539 my $test = !defined $got && !defined $expect;
540
541 $self->ok($test, $name);
542 $self->_is_diag($got, 'eq', $expect) unless $test;
543 return $test;
544 }
545
546 return $self->cmp_ok($got, 'eq', $expect, $name);
33459055
MS
547}
548
549sub is_num {
a9153838 550 my($self, $got, $expect, $name) = @_;
33459055 551 local $Level = $Level + 1;
a9153838 552
b1ddf169
RGS
553 $self->_unoverload_num(\$got, \$expect);
554
a9153838
MS
555 if( !defined $got || !defined $expect ) {
556 # undef only matches undef and nothing else
557 my $test = !defined $got && !defined $expect;
558
559 $self->ok($test, $name);
560 $self->_is_diag($got, '==', $expect) unless $test;
561 return $test;
562 }
563
564 return $self->cmp_ok($got, '==', $expect, $name);
33459055
MS
565}
566
a9153838
MS
567sub _is_diag {
568 my($self, $got, $type, $expect) = @_;
569
570 foreach my $val (\$got, \$expect) {
571 if( defined $$val ) {
572 if( $type eq 'eq' ) {
573 # quote and force string context
574 $$val = "'$$val'"
575 }
576 else {
577 # force numeric context
b1ddf169 578 $self->_unoverload_num($val);
a9153838
MS
579 }
580 }
581 else {
582 $$val = 'undef';
583 }
584 }
33459055 585
89c1e84a 586 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
a9153838
MS
587 got: %s
588 expected: %s
589DIAGNOSTIC
590
591}
592
593=item B<isnt_eq>
594
595 $Test->isnt_eq($got, $dont_expect, $name);
596
597Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
598the string version.
599
600=item B<isnt_num>
601
68938d83 602 $Test->isnt_num($got, $dont_expect, $name);
a9153838
MS
603
604Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
605the numeric version.
606
607=cut
608
609sub isnt_eq {
610 my($self, $got, $dont_expect, $name) = @_;
611 local $Level = $Level + 1;
612
613 if( !defined $got || !defined $dont_expect ) {
614 # undef only matches undef and nothing else
615 my $test = defined $got || defined $dont_expect;
616
617 $self->ok($test, $name);
30e302f8 618 $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
a9153838 619 return $test;
33459055 620 }
a9153838
MS
621
622 return $self->cmp_ok($got, 'ne', $dont_expect, $name);
623}
624
625sub isnt_num {
626 my($self, $got, $dont_expect, $name) = @_;
33459055 627 local $Level = $Level + 1;
33459055 628
a9153838
MS
629 if( !defined $got || !defined $dont_expect ) {
630 # undef only matches undef and nothing else
631 my $test = defined $got || defined $dont_expect;
33459055 632
a9153838 633 $self->ok($test, $name);
30e302f8 634 $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
a9153838
MS
635 return $test;
636 }
637
638 return $self->cmp_ok($got, '!=', $dont_expect, $name);
33459055
MS
639}
640
a9153838 641
33459055
MS
642=item B<like>
643
644 $Test->like($this, qr/$regex/, $name);
645 $Test->like($this, '/$regex/', $name);
646
647Like Test::More's like(). Checks if $this matches the given $regex.
648
649You'll want to avoid qr// if you want your tests to work before 5.005.
650
a9153838
MS
651=item B<unlike>
652
653 $Test->unlike($this, qr/$regex/, $name);
654 $Test->unlike($this, '/$regex/', $name);
655
656Like Test::More's unlike(). Checks if $this B<does not match> the
657given $regex.
658
33459055
MS
659=cut
660
661sub like {
662 my($self, $this, $regex, $name) = @_;
663
664 local $Level = $Level + 1;
a9153838
MS
665 $self->_regex_ok($this, $regex, '=~', $name);
666}
667
668sub unlike {
669 my($self, $this, $regex, $name) = @_;
670
671 local $Level = $Level + 1;
672 $self->_regex_ok($this, $regex, '!~', $name);
673}
674
33459055 675
a9153838
MS
676=item B<cmp_ok>
677
678 $Test->cmp_ok($this, $type, $that, $name);
679
680Works just like Test::More's cmp_ok().
681
682 $Test->cmp_ok($big_num, '!=', $other_big_num);
683
684=cut
685
b1ddf169
RGS
686
687my %numeric_cmps = map { ($_, 1) }
688 ("<", "<=", ">", ">=", "==", "!=", "<=>");
689
a9153838
MS
690sub cmp_ok {
691 my($self, $got, $type, $expect, $name) = @_;
692
b1ddf169
RGS
693 # Treat overloaded objects as numbers if we're asked to do a
694 # numeric comparison.
695 my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
696 : '_unoverload_str';
697
698 $self->$unoverload(\$got, \$expect);
699
700
a9153838
MS
701 my $test;
702 {
c00d8759 703 local($@,$!,$SIG{__DIE__}); # isolate eval
b1ddf169
RGS
704
705 my $code = $self->_caller_context;
706
705e6672
SP
707 # Yes, it has to look like this or 5.4.5 won't see the #line
708 # directive.
b1ddf169
RGS
709 # Don't ask me, man, I just work here.
710 $test = eval "
711$code" . "\$got $type \$expect;";
712
a9153838
MS
713 }
714 local $Level = $Level + 1;
715 my $ok = $self->ok($test, $name);
716
717 unless( $ok ) {
718 if( $type =~ /^(eq|==)$/ ) {
719 $self->_is_diag($got, $type, $expect);
720 }
721 else {
722 $self->_cmp_diag($got, $type, $expect);
723 }
724 }
725 return $ok;
726}
727
728sub _cmp_diag {
729 my($self, $got, $type, $expect) = @_;
730
731 $got = defined $got ? "'$got'" : 'undef';
732 $expect = defined $expect ? "'$expect'" : 'undef';
89c1e84a 733 return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
a9153838
MS
734 %s
735 %s
736 %s
737DIAGNOSTIC
738}
739
a9153838 740
b1ddf169
RGS
741sub _caller_context {
742 my $self = shift;
743
744 my($pack, $file, $line) = $self->caller(1);
745
746 my $code = '';
747 $code .= "#line $line $file\n" if defined $file and defined $line;
748
749 return $code;
750}
751
c00d8759
SP
752=back
753
754
755=head2 Other Testing Methods
756
757These are methods which are used in the course of writing a test but are not themselves tests.
758
759=over 4
b1ddf169
RGS
760
761=item B<BAIL_OUT>
762
763 $Test->BAIL_OUT($reason);
a9153838
MS
764
765Indicates to the Test::Harness that things are going so badly all
766testing should terminate. This includes running any additional test
767scripts.
768
769It will exit with 255.
770
771=cut
772
b1ddf169 773sub BAIL_OUT {
a9153838
MS
774 my($self, $reason) = @_;
775
b1ddf169 776 $self->{Bailed_Out} = 1;
a9153838
MS
777 $self->_print("Bail out! $reason");
778 exit 255;
779}
780
b1ddf169
RGS
781=for deprecated
782BAIL_OUT() used to be BAILOUT()
783
845d7e37
SP
784=cut
785
b1ddf169
RGS
786*BAILOUT = \&BAIL_OUT;
787
788
33459055
MS
789=item B<skip>
790
791 $Test->skip;
792 $Test->skip($why);
793
794Skips the current test, reporting $why.
795
796=cut
797
798sub skip {
799 my($self, $why) = @_;
800 $why ||= '';
b1ddf169 801 $self->_unoverload_str(\$why);
33459055 802
b7f9bbeb 803 $self->_plan_check;
33459055 804
5143c659
RGS
805 lock($self->{Curr_Test});
806 $self->{Curr_Test}++;
33459055 807
5143c659 808 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
60ffb308
MS
809 'ok' => 1,
810 actual_ok => 1,
811 name => '',
812 type => 'skip',
813 reason => $why,
30e302f8 814 });
33459055
MS
815
816 my $out = "ok";
5143c659 817 $out .= " $self->{Curr_Test}" if $self->use_numbers;
0257f296
RGS
818 $out .= " # skip";
819 $out .= " $why" if length $why;
820 $out .= "\n";
33459055 821
5143c659 822 $self->_print($out);
33459055
MS
823
824 return 1;
825}
826
a9153838
MS
827
828=item B<todo_skip>
829
830 $Test->todo_skip;
831 $Test->todo_skip($why);
832
833Like skip(), only it will declare the test as failing and TODO. Similar
834to
835
836 print "not ok $tnum # TODO $why\n";
837
838=cut
839
840sub todo_skip {
841 my($self, $why) = @_;
842 $why ||= '';
843
b7f9bbeb 844 $self->_plan_check;
a9153838 845
5143c659
RGS
846 lock($self->{Curr_Test});
847 $self->{Curr_Test}++;
a9153838 848
5143c659 849 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
60ffb308
MS
850 'ok' => 1,
851 actual_ok => 0,
852 name => '',
853 type => 'todo_skip',
854 reason => $why,
30e302f8 855 });
a9153838
MS
856
857 my $out = "not ok";
5143c659 858 $out .= " $self->{Curr_Test}" if $self->use_numbers;
89c1e84a 859 $out .= " # TODO & SKIP $why\n";
a9153838 860
5143c659 861 $self->_print($out);
a9153838
MS
862
863 return 1;
864}
865
866
33459055
MS
867=begin _unimplemented
868
869=item B<skip_rest>
870
871 $Test->skip_rest;
872 $Test->skip_rest($reason);
873
874Like skip(), only it skips all the rest of the tests you plan to run
875and terminates the test.
876
877If you're running under no_plan, it skips once and terminates the
878test.
879
880=end _unimplemented
881
882=back
883
884
c00d8759
SP
885=head2 Test building utility methods
886
887These methods are useful when writing your own test methods.
888
889=over 4
890
891=item B<maybe_regex>
892
893 $Test->maybe_regex(qr/$regex/);
894 $Test->maybe_regex('/$regex/');
895
896Convenience method for building testing functions that take regular
897expressions as arguments, but need to work before perl 5.005.
898
899Takes a quoted regular expression produced by qr//, or a string
900representing a regular expression.
901
902Returns a Perl value which may be used instead of the corresponding
903regular expression, or undef if it's argument is not recognised.
904
905For example, a version of like(), sans the useful diagnostic messages,
906could be written as:
907
908 sub laconic_like {
909 my ($self, $this, $regex, $name) = @_;
910 my $usable_regex = $self->maybe_regex($regex);
911 die "expecting regex, found '$regex'\n"
912 unless $usable_regex;
913 $self->ok($this =~ m/$usable_regex/, $name);
914 }
915
916=cut
917
918
919sub maybe_regex {
920 my ($self, $regex) = @_;
921 my $usable_regex = undef;
922
923 return $usable_regex unless defined $regex;
924
925 my($re, $opts);
926
927 # Check for qr/foo/
0fc92fc6
YO
928 if ( $] >= 5.009004
929 ? re::is_regexp($regex)
930 : ref $regex eq 'Regexp'
931 )
932 {
c00d8759
SP
933 $usable_regex = $regex;
934 }
935 # Check for '/foo/' or 'm,foo,'
936 elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
937 (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
938 )
939 {
940 $usable_regex = length $opts ? "(?$opts)$re" : $re;
941 }
942
943 return $usable_regex;
944};
945
946sub _regex_ok {
947 my($self, $this, $regex, $cmp, $name) = @_;
948
949 my $ok = 0;
950 my $usable_regex = $self->maybe_regex($regex);
951 unless (defined $usable_regex) {
952 $ok = $self->ok( 0, $name );
953 $self->diag(" '$regex' doesn't look much like a regex to me.");
954 return $ok;
955 }
956
957 {
958 my $test;
959 my $code = $self->_caller_context;
960
961 local($@, $!, $SIG{__DIE__}); # isolate eval
962
705e6672
SP
963 # Yes, it has to look like this or 5.4.5 won't see the #line
964 # directive.
c00d8759
SP
965 # Don't ask me, man, I just work here.
966 $test = eval "
967$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
968
969 $test = !$test if $cmp eq '!~';
970
971 local $Level = $Level + 1;
972 $ok = $self->ok( $test, $name );
973 }
974
975 unless( $ok ) {
976 $this = defined $this ? "'$this'" : 'undef';
977 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
978 $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
979 %s
980 %13s '%s'
981DIAGNOSTIC
982
983 }
984
985 return $ok;
986}
987
988
989# I'm not ready to publish this. It doesn't deal with array return
990# values from the code or context.
eb820256 991
c00d8759
SP
992=begin private
993
994=item B<_try>
995
996 my $return_from_code = $Test->try(sub { code });
997 my($return_from_code, $error) = $Test->try(sub { code });
998
999Works like eval BLOCK except it ensures it has no effect on the rest of the test (ie. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls.
1000
1001$error is what would normally be in $@.
1002
1003It is suggested you use this in place of eval BLOCK.
1004
1005=cut
1006
1007sub _try {
1008 my($self, $code) = @_;
1009
1010 local $!; # eval can mess up $!
1011 local $@; # don't set $@ in the test
1012 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1013 my $return = eval { $code->() };
1014
1015 return wantarray ? ($return, $@) : $return;
1016}
1017
1018=end private
1019
1020
1021=item B<is_fh>
1022
1023 my $is_fh = $Test->is_fh($thing);
1024
1025Determines if the given $thing can be used as a filehandle.
1026
1027=cut
1028
1029sub is_fh {
1030 my $self = shift;
1031 my $maybe_fh = shift;
1032 return 0 unless defined $maybe_fh;
1033
6b38a9b9
SP
1034 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1035 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
c00d8759 1036
0753bcb5 1037 return eval { $maybe_fh->isa("IO::Handle") } ||
c00d8759
SP
1038 # 5.5.4's tied() and can() doesn't like getting undef
1039 eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
1040}
1041
1042
1043=back
1044
1045
33459055
MS
1046=head2 Test style
1047
c00d8759 1048
33459055
MS
1049=over 4
1050
1051=item B<level>
1052
1053 $Test->level($how_high);
1054
1055How far up the call stack should $Test look when reporting where the
1056test failed.
1057
1058Defaults to 1.
1059
c00d8759 1060Setting L<$Test::Builder::Level> overrides. This is typically useful
33459055
MS
1061localized:
1062
c00d8759
SP
1063 sub my_ok {
1064 my $test = shift;
1065
1066 local $Test::Builder::Level = $Test::Builder::Level + 1;
1067 $TB->ok($test);
33459055
MS
1068 }
1069
c00d8759
SP
1070To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1071
33459055
MS
1072=cut
1073
1074sub level {
1075 my($self, $level) = @_;
1076
1077 if( defined $level ) {
1078 $Level = $level;
1079 }
1080 return $Level;
1081}
1082
33459055
MS
1083
1084=item B<use_numbers>
1085
1086 $Test->use_numbers($on_or_off);
1087
1088Whether or not the test should output numbers. That is, this if true:
1089
1090 ok 1
1091 ok 2
1092 ok 3
1093
1094or this if false
1095
1096 ok
1097 ok
1098 ok
1099
1100Most useful when you can't depend on the test output order, such as
1101when threads or forking is involved.
1102
33459055
MS
1103Defaults to on.
1104
1105=cut
1106
33459055
MS
1107sub use_numbers {
1108 my($self, $use_nums) = @_;
1109
1110 if( defined $use_nums ) {
5143c659 1111 $self->{Use_Nums} = $use_nums;
33459055 1112 }
5143c659 1113 return $self->{Use_Nums};
33459055
MS
1114}
1115
33459055 1116
b1ddf169 1117=item B<no_diag>
33459055 1118
b1ddf169
RGS
1119 $Test->no_diag($no_diag);
1120
1121If set true no diagnostics will be printed. This includes calls to
1122diag().
33459055
MS
1123
1124=item B<no_ending>
1125
1126 $Test->no_ending($no_ending);
1127
1128Normally, Test::Builder does some extra diagnostics when the test
30e302f8 1129ends. It also changes the exit code as described below.
33459055
MS
1130
1131If this is true, none of that will be done.
1132
b1ddf169
RGS
1133=item B<no_header>
1134
1135 $Test->no_header($no_header);
1136
1137If set to true, no "1..N" header will be printed.
1138
33459055
MS
1139=cut
1140
b1ddf169
RGS
1141foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1142 my $method = lc $attribute;
33459055 1143
b1ddf169
RGS
1144 my $code = sub {
1145 my($self, $no) = @_;
33459055 1146
b1ddf169
RGS
1147 if( defined $no ) {
1148 $self->{$attribute} = $no;
1149 }
1150 return $self->{$attribute};
1151 };
33459055 1152
705e6672 1153 no strict 'refs'; ## no critic
b1ddf169 1154 *{__PACKAGE__.'::'.$method} = $code;
33459055
MS
1155}
1156
1157
1158=back
1159
1160=head2 Output
1161
1162Controlling where the test output goes.
1163
4bd4e70a 1164It's ok for your test to change where STDOUT and STDERR point to,
71373de2 1165Test::Builder's default output settings will not be affected.
4bd4e70a 1166
33459055
MS
1167=over 4
1168
1169=item B<diag>
1170
1171 $Test->diag(@msgs);
1172
7483b81c
RGS
1173Prints out the given @msgs. Like C<print>, arguments are simply
1174appended together.
1175
1176Normally, it uses the failure_output() handle, but if this is for a
1177TODO test, the todo_output() handle is used.
33459055 1178
71373de2 1179Output will be indented and marked with a # so as not to interfere
a9153838
MS
1180with test output. A newline will be put on the end if there isn't one
1181already.
33459055
MS
1182
1183We encourage using this rather than calling print directly.
1184
89c1e84a
MS
1185Returns false. Why? Because diag() is often used in conjunction with
1186a failing test (C<ok() || diag()>) it "passes through" the failure.
1187
1188 return ok(...) || diag(...);
1189
1190=for blame transfer
1191Mark Fowler <mark@twoshortplanks.com>
1192
33459055
MS
1193=cut
1194
1195sub diag {
1196 my($self, @msgs) = @_;
b1ddf169
RGS
1197
1198 return if $self->no_diag;
a9153838 1199 return unless @msgs;
33459055 1200
4bd4e70a 1201 # Prevent printing headers when compiling (i.e. -c)
33459055
MS
1202 return if $^C;
1203
7483b81c
RGS
1204 # Smash args together like print does.
1205 # Convert undef to 'undef' so its readable.
1206 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1207
33459055 1208 # Escape each line with a #.
7483b81c 1209 $msg =~ s/^/# /gm;
33459055 1210
7483b81c
RGS
1211 # Stick a newline on the end if it needs it.
1212 $msg .= "\n" unless $msg =~ /\n\Z/;
a9153838 1213
33459055 1214 local $Level = $Level + 1;
7483b81c 1215 $self->_print_diag($msg);
89c1e84a
MS
1216
1217 return 0;
33459055
MS
1218}
1219
1220=begin _private
1221
1222=item B<_print>
1223
1224 $Test->_print(@msgs);
1225
1226Prints to the output() filehandle.
1227
1228=end _private
1229
1230=cut
1231
1232sub _print {
1233 my($self, @msgs) = @_;
1234
1235 # Prevent printing headers when only compiling. Mostly for when
1236 # tests are deparsed with B::Deparse
1237 return if $^C;
1238
7483b81c
RGS
1239 my $msg = join '', @msgs;
1240
33459055
MS
1241 local($\, $", $,) = (undef, ' ', '');
1242 my $fh = $self->output;
89c1e84a
MS
1243
1244 # Escape each line after the first with a # so we don't
1245 # confuse Test::Harness.
7483b81c 1246 $msg =~ s/\n(.)/\n# $1/sg;
89c1e84a 1247
7483b81c
RGS
1248 # Stick a newline on the end if it needs it.
1249 $msg .= "\n" unless $msg =~ /\n\Z/;
89c1e84a 1250
7483b81c 1251 print $fh $msg;
33459055
MS
1252}
1253
b7f9bbeb 1254=begin private
33459055 1255
30e302f8
NC
1256=item B<_print_diag>
1257
1258 $Test->_print_diag(@msg);
1259
1260Like _print, but prints to the current diagnostic filehandle.
1261
b7f9bbeb
SP
1262=end private
1263
30e302f8
NC
1264=cut
1265
1266sub _print_diag {
1267 my $self = shift;
1268
1269 local($\, $", $,) = (undef, ' ', '');
1270 my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1271 print $fh @_;
1272}
1273
33459055
MS
1274=item B<output>
1275
1276 $Test->output($fh);
1277 $Test->output($file);
1278
1279Where normal "ok/not ok" test output should go.
1280
1281Defaults to STDOUT.
1282
1283=item B<failure_output>
1284
1285 $Test->failure_output($fh);
1286 $Test->failure_output($file);
1287
1288Where diagnostic output on test failures and diag() should go.
1289
1290Defaults to STDERR.
1291
1292=item B<todo_output>
1293
1294 $Test->todo_output($fh);
1295 $Test->todo_output($file);
1296
1297Where diagnostics about todo test failures and diag() should go.
1298
1299Defaults to STDOUT.
1300
1301=cut
1302
33459055
MS
1303sub output {
1304 my($self, $fh) = @_;
1305
1306 if( defined $fh ) {
b7f9bbeb 1307 $self->{Out_FH} = $self->_new_fh($fh);
33459055 1308 }
5143c659 1309 return $self->{Out_FH};
33459055
MS
1310}
1311
1312sub failure_output {
1313 my($self, $fh) = @_;
1314
1315 if( defined $fh ) {
b7f9bbeb 1316 $self->{Fail_FH} = $self->_new_fh($fh);
33459055 1317 }
5143c659 1318 return $self->{Fail_FH};
33459055
MS
1319}
1320
1321sub todo_output {
1322 my($self, $fh) = @_;
1323
1324 if( defined $fh ) {
b7f9bbeb 1325 $self->{Todo_FH} = $self->_new_fh($fh);
33459055 1326 }
5143c659 1327 return $self->{Todo_FH};
33459055
MS
1328}
1329
0257f296 1330
33459055 1331sub _new_fh {
b7f9bbeb 1332 my $self = shift;
33459055
MS
1333 my($file_or_fh) = shift;
1334
1335 my $fh;
c00d8759 1336 if( $self->is_fh($file_or_fh) ) {
0257f296
RGS
1337 $fh = $file_or_fh;
1338 }
1339 else {
705e6672 1340 open $fh, ">", $file_or_fh or
b7f9bbeb 1341 $self->croak("Can't open test output log $file_or_fh: $!");
705e6672 1342 _autoflush($fh);
33459055 1343 }
33459055
MS
1344
1345 return $fh;
1346}
1347
0257f296 1348
30e302f8
NC
1349sub _autoflush {
1350 my($fh) = shift;
1351 my $old_fh = select $fh;
1352 $| = 1;
1353 select $old_fh;
1354}
1355
1356
30e302f8
NC
1357sub _dup_stdhandles {
1358 my $self = shift;
1359
5143c659 1360 $self->_open_testhandles;
a9153838
MS
1361
1362 # Set everything to unbuffered else plain prints to STDOUT will
1363 # come out in the wrong order from our own prints.
33459055 1364 _autoflush(\*TESTOUT);
a9153838 1365 _autoflush(\*STDOUT);
33459055 1366 _autoflush(\*TESTERR);
a9153838
MS
1367 _autoflush(\*STDERR);
1368
5143c659
RGS
1369 $self->output(\*TESTOUT);
1370 $self->failure_output(\*TESTERR);
1371 $self->todo_output(\*TESTOUT);
33459055
MS
1372}
1373
5143c659
RGS
1374
1375my $Opened_Testhandles = 0;
30e302f8 1376sub _open_testhandles {
5143c659 1377 return if $Opened_Testhandles;
30e302f8
NC
1378 # We dup STDOUT and STDERR so people can change them in their
1379 # test suites while still getting normal test output.
1380 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
1381 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
1382 $Opened_Testhandles = 1;
33459055
MS
1383}
1384
1385
b7f9bbeb
SP
1386=item carp
1387
1388 $tb->carp(@message);
1389
1390Warns with C<@message> but the message will appear to come from the
1391point where the original test function was called (C<$tb->caller>).
1392
1393=item croak
1394
1395 $tb->croak(@message);
1396
1397Dies with C<@message> but the message will appear to come from the
1398point where the original test function was called (C<$tb->caller>).
1399
1400=cut
1401
1402sub _message_at_caller {
1403 my $self = shift;
1404
004caa16 1405 local $Level = $Level + 1;
b7f9bbeb
SP
1406 my($pack, $file, $line) = $self->caller;
1407 return join("", @_) . " at $file line $line.\n";
1408}
1409
1410sub carp {
1411 my $self = shift;
1412 warn $self->_message_at_caller(@_);
1413}
1414
1415sub croak {
1416 my $self = shift;
1417 die $self->_message_at_caller(@_);
1418}
1419
1420sub _plan_check {
1421 my $self = shift;
1422
1423 unless( $self->{Have_Plan} ) {
004caa16 1424 local $Level = $Level + 2;
b7f9bbeb
SP
1425 $self->croak("You tried to run a test without a plan");
1426 }
1427}
1428
33459055
MS
1429=back
1430
1431
1432=head2 Test Status and Info
1433
1434=over 4
1435
1436=item B<current_test>
1437
1438 my $curr_test = $Test->current_test;
1439 $Test->current_test($num);
1440
0257f296
RGS
1441Gets/sets the current test number we're on. You usually shouldn't
1442have to set this.
33459055 1443
0257f296
RGS
1444If set forward, the details of the missing tests are filled in as 'unknown'.
1445if set backward, the details of the intervening tests are deleted. You
1446can erase history if you really want to.
33459055
MS
1447
1448=cut
1449
1450sub current_test {
1451 my($self, $num) = @_;
1452
5143c659 1453 lock($self->{Curr_Test});
33459055 1454 if( defined $num ) {
5143c659 1455 unless( $self->{Have_Plan} ) {
b7f9bbeb 1456 $self->croak("Can't change the current test number without a plan!");
89c1e84a
MS
1457 }
1458
5143c659 1459 $self->{Curr_Test} = $num;
0257f296
RGS
1460
1461 # If the test counter is being pushed forward fill in the details.
5143c659
RGS
1462 my $test_results = $self->{Test_Results};
1463 if( $num > @$test_results ) {
1464 my $start = @$test_results ? @$test_results : 0;
89c1e84a 1465 for ($start..$num-1) {
5143c659 1466 $test_results->[$_] = &share({
30e302f8
NC
1467 'ok' => 1,
1468 actual_ok => undef,
1469 reason => 'incrementing test number',
1470 type => 'unknown',
1471 name => undef
1472 });
6686786d
MS
1473 }
1474 }
0257f296 1475 # If backward, wipe history. Its their funeral.
5143c659
RGS
1476 elsif( $num < @$test_results ) {
1477 $#{$test_results} = $num - 1;
0257f296 1478 }
33459055 1479 }
5143c659 1480 return $self->{Curr_Test};
33459055
MS
1481}
1482
1483
1484=item B<summary>
1485
1486 my @tests = $Test->summary;
1487
1488A simple summary of the tests so far. True for pass, false for fail.
1489This is a logical pass/fail, so todos are passes.
1490
1491Of course, test #1 is $tests[0], etc...
1492
1493=cut
1494
1495sub summary {
1496 my($self) = shift;
1497
5143c659 1498 return map { $_->{'ok'} } @{ $self->{Test_Results} };
33459055
MS
1499}
1500
60ffb308 1501=item B<details>
33459055
MS
1502
1503 my @tests = $Test->details;
1504
1505Like summary(), but with a lot more detail.
1506
1507 $tests[$test_num - 1] =
60ffb308 1508 { 'ok' => is the test considered a pass?
33459055
MS
1509 actual_ok => did it literally say 'ok'?
1510 name => name of the test (if any)
60ffb308 1511 type => type of test (if any, see below).
33459055
MS
1512 reason => reason for the above (if any)
1513 };
1514
60ffb308
MS
1515'ok' is true if Test::Harness will consider the test to be a pass.
1516
1517'actual_ok' is a reflection of whether or not the test literally
1518printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1519tests.
1520
1521'name' is the name of the test.
1522
1523'type' indicates if it was a special test. Normal tests have a type
1524of ''. Type can be one of the following:
1525
1526 skip see skip()
1527 todo see todo()
1528 todo_skip see todo_skip()
1529 unknown see below
1530
1531Sometimes the Test::Builder test counter is incremented without it
1532printing any test output, for example, when current_test() is changed.
1533In these cases, Test::Builder doesn't know the result of the test, so
1534it's type is 'unkown'. These details for these tests are filled in.
1535They are considered ok, but the name and actual_ok is left undef.
1536
1537For example "not ok 23 - hole count # TODO insufficient donuts" would
1538result in this structure:
1539
1540 $tests[22] = # 23 - 1, since arrays start from 0.
1541 { ok => 1, # logically, the test passed since it's todo
1542 actual_ok => 0, # in absolute terms, it failed
1543 name => 'hole count',
1544 type => 'todo',
1545 reason => 'insufficient donuts'
1546 };
1547
1548=cut
1549
1550sub details {
5143c659
RGS
1551 my $self = shift;
1552 return @{ $self->{Test_Results} };
60ffb308
MS
1553}
1554
33459055
MS
1555=item B<todo>
1556
1557 my $todo_reason = $Test->todo;
1558 my $todo_reason = $Test->todo($pack);
1559
1560todo() looks for a $TODO variable in your tests. If set, all tests
1561will be considered 'todo' (see Test::More and Test::Harness for
1562details). Returns the reason (ie. the value of $TODO) if running as
1563todo tests, false otherwise.
1564
5143c659
RGS
1565todo() is about finding the right package to look for $TODO in. It
1566uses the exported_to() package to find it. If that's not set, it's
1567pretty good at guessing the right package to look at based on $Level.
33459055
MS
1568
1569Sometimes there is some confusion about where todo() should be looking
1570for the $TODO variable. If you want to be sure, tell it explicitly
1571what $pack to use.
1572
1573=cut
1574
1575sub todo {
1576 my($self, $pack) = @_;
1577
5143c659
RGS
1578 $pack = $pack || $self->exported_to || $self->caller($Level);
1579 return 0 unless $pack;
33459055 1580
705e6672 1581 no strict 'refs'; ## no critic
33459055
MS
1582 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1583 : 0;
1584}
1585
1586=item B<caller>
1587
1588 my $package = $Test->caller;
1589 my($pack, $file, $line) = $Test->caller;
1590 my($pack, $file, $line) = $Test->caller($height);
1591
1592Like the normal caller(), except it reports according to your level().
1593
1594=cut
1595
1596sub caller {
1597 my($self, $height) = @_;
1598 $height ||= 0;
a344be10 1599
33459055
MS
1600 my @caller = CORE::caller($self->level + $height + 1);
1601 return wantarray ? @caller : $caller[0];
1602}
1603
1604=back
1605
1606=cut
1607
1608=begin _private
1609
1610=over 4
1611
1612=item B<_sanity_check>
1613
5143c659 1614 $self->_sanity_check();
33459055
MS
1615
1616Runs a bunch of end of test sanity checks to make sure reality came
1617through ok. If anything is wrong it will die with a fairly friendly
1618error message.
1619
1620=cut
1621
1622#'#
1623sub _sanity_check {
5143c659
RGS
1624 my $self = shift;
1625
b7f9bbeb
SP
1626 $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1627 $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
33459055 1628 'Somehow your tests ran without a plan!');
b7f9bbeb 1629 $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
33459055
MS
1630 'Somehow you got a different number of results than tests ran!');
1631}
1632
1633=item B<_whoa>
1634
b7f9bbeb 1635 $self->_whoa($check, $description);
33459055
MS
1636
1637A sanity check, similar to assert(). If the $check is true, something
1638has gone horribly wrong. It will die with the given $description and
1639a note to contact the author.
1640
1641=cut
1642
1643sub _whoa {
b7f9bbeb 1644 my($self, $check, $desc) = @_;
33459055 1645 if( $check ) {
b7f9bbeb
SP
1646 local $Level = $Level + 1;
1647 $self->croak(<<"WHOA");
33459055
MS
1648WHOA! $desc
1649This should never happen! Please contact the author immediately!
1650WHOA
1651 }
1652}
1653
1654=item B<_my_exit>
1655
1656 _my_exit($exit_num);
1657
1658Perl seems to have some trouble with exiting inside an END block. 5.005_03
1659and 5.6.1 both seem to do odd things. Instead, this function edits $?
1660directly. It should ONLY be called from inside an END block. It
1661doesn't actually exit, that's your job.
1662
1663=cut
1664
1665sub _my_exit {
1666 $? = $_[0];
1667
1668 return 1;
1669}
1670
1671
1672=back
1673
1674=end _private
1675
1676=cut
1677
1678$SIG{__DIE__} = sub {
1679 # We don't want to muck with death in an eval, but $^S isn't
1680 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1681 # with it. Instead, we use caller. This also means it runs under
1682 # 5.004!
1683 my $in_eval = 0;
1684 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1685 $in_eval = 1 if $sub =~ /^\(eval\)/;
1686 }
5143c659 1687 $Test->{Test_Died} = 1 unless $in_eval;
33459055
MS
1688};
1689
1690sub _ending {
1691 my $self = shift;
1692
5143c659 1693 $self->_sanity_check();
33459055 1694
60ffb308
MS
1695 # Don't bother with an ending if this is a forked copy. Only the parent
1696 # should do the ending.
5143c659
RGS
1697 # Exit if plan() was never called. This is so "require Test::Simple"
1698 # doesn't puke.
b1ddf169
RGS
1699 # Don't do an ending if we bailed out.
1700 if( ($self->{Original_Pid} != $$) or
1701 (!$self->{Have_Plan} && !$self->{Test_Died}) or
1702 $self->{Bailed_Out}
1703 )
5143c659
RGS
1704 {
1705 _my_exit($?);
1706 return;
1707 }
33459055
MS
1708
1709 # Figure out if we passed or failed and print helpful messages.
5143c659
RGS
1710 my $test_results = $self->{Test_Results};
1711 if( @$test_results ) {
33459055 1712 # The plan? We have no plan.
5143c659
RGS
1713 if( $self->{No_Plan} ) {
1714 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1715 $self->{Expected_Tests} = $self->{Curr_Test};
33459055
MS
1716 }
1717
30e302f8
NC
1718 # Auto-extended arrays and elements which aren't explicitly
1719 # filled in with a shared reference will puke under 5.8.0
1720 # ithreads. So we have to fill them in by hand. :(
1721 my $empty_result = &share({});
5143c659
RGS
1722 for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1723 $test_results->[$idx] = $empty_result
1724 unless defined $test_results->[$idx];
60ffb308 1725 }
a344be10 1726
5143c659 1727 my $num_failed = grep !$_->{'ok'},
b1ddf169 1728 @{$test_results}[0..$self->{Curr_Test}-1];
33459055 1729
b1ddf169
RGS
1730 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1731
1732 if( $num_extra < 0 ) {
5143c659 1733 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
33459055 1734 $self->diag(<<"FAIL");
5143c659 1735Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
33459055
MS
1736FAIL
1737 }
b1ddf169 1738 elsif( $num_extra > 0 ) {
5143c659 1739 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
33459055 1740 $self->diag(<<"FAIL");
5143c659 1741Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
33459055
MS
1742FAIL
1743 }
b1ddf169
RGS
1744
1745 if ( $num_failed ) {
1746 my $num_tests = $self->{Curr_Test};
30e302f8 1747 my $s = $num_failed == 1 ? '' : 's';
b1ddf169
RGS
1748
1749 my $qualifier = $num_extra == 0 ? '' : ' run';
1750
33459055 1751 $self->diag(<<"FAIL");
b1ddf169 1752Looks like you failed $num_failed test$s of $num_tests$qualifier.
33459055
MS
1753FAIL
1754 }
1755
5143c659 1756 if( $self->{Test_Died} ) {
33459055 1757 $self->diag(<<"FAIL");
5143c659 1758Looks like your test died just after $self->{Curr_Test}.
33459055
MS
1759FAIL
1760
1761 _my_exit( 255 ) && return;
1762 }
1763
b1ddf169
RGS
1764 my $exit_code;
1765 if( $num_failed ) {
1766 $exit_code = $num_failed <= 254 ? $num_failed : 254;
1767 }
1768 elsif( $num_extra != 0 ) {
1769 $exit_code = 255;
1770 }
1771 else {
1772 $exit_code = 0;
1773 }
1774
1775 _my_exit( $exit_code ) && return;
33459055 1776 }
5143c659 1777 elsif ( $self->{Skip_All} ) {
33459055
MS
1778 _my_exit( 0 ) && return;
1779 }
5143c659 1780 elsif ( $self->{Test_Died} ) {
60ffb308
MS
1781 $self->diag(<<'FAIL');
1782Looks like your test died before it could output anything.
1783FAIL
30e302f8 1784 _my_exit( 255 ) && return;
60ffb308 1785 }
33459055 1786 else {
a9153838 1787 $self->diag("No tests run!\n");
33459055
MS
1788 _my_exit( 255 ) && return;
1789 }
1790}
1791
1792END {
1793 $Test->_ending if defined $Test and !$Test->no_ending;
1794}
1795
30e302f8
NC
1796=head1 EXIT CODES
1797
1798If all your tests passed, Test::Builder will exit with zero (which is
1799normal). If anything failed it will exit with how many failed. If
1800you run less (or more) tests than you planned, the missing (or extras)
1801will be considered failures. If no tests were ever run Test::Builder
1802will throw a warning and exit with 255. If the test died, even after
1803having successfully completed all its tests, it will still be
1804considered a failure and will exit with 255.
1805
1806So the exit codes are...
1807
1808 0 all tests successful
b1ddf169 1809 255 test died or all passed but wrong # of tests run
30e302f8
NC
1810 any other number how many failed (including missing or extras)
1811
1812If you fail more than 254 tests, it will be reported as 254.
1813
1814
a344be10
MS
1815=head1 THREADS
1816
b7f9bbeb 1817In perl 5.8.1 and later, Test::Builder is thread-safe. The test
a344be10
MS
1818number is shared amongst all threads. This means if one thread sets
1819the test number using current_test() they will all be effected.
1820
b7f9bbeb
SP
1821While versions earlier than 5.8.1 had threads they contain too many
1822bugs to support.
1823
30e302f8
NC
1824Test::Builder is only thread-aware if threads.pm is loaded I<before>
1825Test::Builder.
1826
33459055
MS
1827=head1 EXAMPLES
1828
a344be10
MS
1829CPAN can provide the best examples. Test::Simple, Test::More,
1830Test::Exception and Test::Differences all use Test::Builder.
33459055 1831
4bd4e70a
JH
1832=head1 SEE ALSO
1833
1834Test::Simple, Test::More, Test::Harness
1835
1836=head1 AUTHORS
33459055
MS
1837
1838Original code by chromatic, maintained by Michael G Schwern
1839E<lt>schwern@pobox.comE<gt>
1840
4bd4e70a 1841=head1 COPYRIGHT
33459055 1842
7483b81c
RGS
1843Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1844 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
4bd4e70a
JH
1845
1846This program is free software; you can redistribute it and/or
1847modify it under the same terms as Perl itself.
1848
a9153838 1849See F<http://www.perl.com/perl/misc/Artistic.html>
33459055
MS
1850
1851=cut
1852
18531;