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