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