/tags/rel-1.3.35/Examples/test-suite/perl5/Test/Builder.pm
Perl | 1591 lines | 1277 code | 283 blank | 31 comment | 80 complexity | f76bc10c1aa69e373ab6f03ec7d69ceb MD5 | raw file
Possible License(s): LGPL-2.1, Cube, GPL-3.0, 0BSD, GPL-2.0
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;
10use vars qw($VERSION);
11$VERSION = '0.22';
12$VERSION = eval $VERSION; # make the alpha version come out as a number
13
14# Make Test::Builder thread-safe for ithreads.
15BEGIN {
16 use Config;
17 # Load threads::shared when threads are turned on
18 if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) {
19 require threads::shared;
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 };
58 }
59 # 5.8.0's threads::shared is busted when threads are off.
60 # We emulate it here.
61 else {
62 *share = sub { return $_[0] };
63 *lock = sub { 0 };
64 }
65}
66
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
102Test::Simple and Test::More have proven to be popular testing modules,
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>.
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
124my $Test = Test::Builder->new;
125sub new {
126 my($class) = shift;
127 $Test ||= bless ['Move along, nothing to see here'], $class;
128 return $Test;
129}
130
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);
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 = ();
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
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
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
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
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 }
254 else {
255 require Carp;
256 my @args = grep { defined } ($cmd, $arg);
257 Carp::croak("plan() doesn't understand @args");
258 }
259
260 return 1;
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
273sub expected_tests {
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;
280
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
298sub no_plan {
299 $No_Plan = 1;
300 $Have_Plan = 1;
301}
302
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
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
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
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
367 unless( $Have_Plan ) {
368 require Carp;
369 Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
370 }
371
372 lock $Curr_Test;
373 $Curr_Test++;
374
375 # In case $name is a string overloaded object, force it to stringify.
376 $self->_unoverload(\$name);
377
378 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
379 You named your test '$name'. You shouldn't use numbers for your test names.
380 Very confusing.
381ERR
382
383 my($pack, $file, $line) = $self->caller;
384
385 my $todo = $self->todo($pack);
386 $self->_unoverload(\$todo);
387
388 my $out;
389 my $result = &share({});
390
391 unless( $test ) {
392 $out .= "not ";
393 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
394 }
395 else {
396 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
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";
405 $result->{name} = $name;
406 }
407 else {
408 $result->{name} = '';
409 }
410
411 if( $todo ) {
412 $out .= " # TODO $todo";
413 $result->{reason} = $todo;
414 $result->{type} = 'todo';
415 }
416 else {
417 $result->{reason} = '';
418 $result->{type} = '';
419 }
420
421 $Test_Results[$Curr_Test-1] = $result;
422 $out .= "\n";
423
424 $self->_print($out);
425
426 unless( $test ) {
427 my $msg = $todo ? "Failed (TODO)" : "Failed";
428 $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
429 $self->diag(" $msg test ($file at line $line)\n");
430 }
431
432 return $test ? 1 : 0;
433}
434
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
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
464 $Test->is_num($got, $expected, $name);
465
466Like Test::More's is(). Checks if $got == $expected. This is the
467numeric version.
468
469=cut
470
471sub is_eq {
472 my($self, $got, $expect, $name) = @_;
473 local $Level = $Level + 1;
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);
485}
486
487sub is_num {
488 my($self, $got, $expect, $name) = @_;
489 local $Level = $Level + 1;
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);
501}
502
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 }
521
522 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
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);
554 $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
555 return $test;
556 }
557
558 return $self->cmp_ok($got, 'ne', $dont_expect, $name);
559}
560
561sub isnt_num {
562 my($self, $got, $dont_expect, $name) = @_;
563 local $Level = $Level + 1;
564
565 if( !defined $got || !defined $dont_expect ) {
566 # undef only matches undef and nothing else
567 my $test = defined $got || defined $dont_expect;
568
569 $self->ok($test, $name);
570 $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
571 return $test;
572 }
573
574 return $self->cmp_ok($got, '!=', $dont_expect, $name);
575}
576
577
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
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
595=cut
596
597sub like {
598 my($self, $this, $regex, $name) = @_;
599
600 local $Level = $Level + 1;
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
611=item B<maybe_regex>
612
613 $Test->maybe_regex(qr/$regex/);
614 $Test->maybe_regex('/$regex/');
615
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 {
640 my ($self, $regex) = @_;
641 my $usable_regex = undef;
642
643 return $usable_regex unless defined $regex;
644
645 my($re, $opts);
646
647 # Check for qr/foo/
648 if( ref $regex eq 'Regexp' ) {
649 $usable_regex = $regex;
650 }
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 {
656 $usable_regex = length $opts ? "(?$opts)$re" : $re;
657 }
658
659 return $usable_regex;
660};
661
662sub _regex_ok {
663 my($self, $this, $regex, $cmp, $name) = @_;
664
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.");
672 return $ok;
673 }
674
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
682 unless( $ok ) {
683 $this = defined $this ? "'$this'" : 'undef';
684 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
685 $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
686 %s
687 %13s '%s'
688DIAGNOSTIC
689
690 }
691
692 return $ok;
693}
694
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';
734 return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
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
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 ||= '';
772 $self->_unoverload(\$why);
773
774 unless( $Have_Plan ) {
775 require Carp;
776 Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
777 }
778
779 lock($Curr_Test);
780 $Curr_Test++;
781
782 $Test_Results[$Curr_Test-1] = &share({
783 'ok' => 1,
784 actual_ok => 1,
785 name => '',
786 type => 'skip',
787 reason => $why,
788 });
789
790 my $out = "ok";
791 $out .= " $Curr_Test" if $self->use_numbers;
792 $out .= " # skip";
793 $out .= " $why" if length $why;
794 $out .= "\n";
795
796 $Test->_print($out);
797
798 return 1;
799}
800
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 ) {
819 require Carp;
820 Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
821 }
822
823 lock($Curr_Test);
824 $Curr_Test++;
825
826 $Test_Results[$Curr_Test-1] = &share({
827 'ok' => 1,
828 actual_ok => 0,
829 name => '',
830 type => 'todo_skip',
831 reason => $why,
832 });
833
834 my $out = "not ok";
835 $out .= " $Curr_Test" if $self->use_numbers;
836 $out .= " # TODO & SKIP $why\n";
837
838 $Test->_print($out);
839
840 return 1;
841}
842
843
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
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
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
940ends. It also changes the exit code as described below.
941
942If this is true, none of that will be done.
943
944=cut
945
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
971It's ok for your test to change where STDOUT and STDERR point to,
972Test::Builder's default output settings will not be affected.
973
974=over 4
975
976=item B<diag>
977
978 $Test->diag(@msgs);
979
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.
985
986Output will be indented and marked with a # so as not to interfere
987with test output. A newline will be put on the end if there isn't one
988already.
989
990We encourage using this rather than calling print directly.
991
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
1000=cut
1001
1002sub diag {
1003 my($self, @msgs) = @_;
1004 return unless @msgs;
1005
1006 # Prevent printing headers when compiling (i.e. -c)
1007 return if $^C;
1008
1009 # Smash args together like print does.
1010 # Convert undef to 'undef' so its readable.
1011 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1012
1013 # Escape each line with a #.
1014 $msg =~ s/^/# /gm;
1015
1016 # Stick a newline on the end if it needs it.
1017 $msg .= "\n" unless $msg =~ /\n\Z/;
1018
1019 local $Level = $Level + 1;
1020 $self->_print_diag($msg);
1021
1022 return 0;
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
1044 my $msg = join '', @msgs;
1045
1046 local($\, $", $,) = (undef, ' ', '');
1047 my $fh = $self->output;
1048
1049 # Escape each line after the first with a # so we don't
1050 # confuse Test::Harness.
1051 $msg =~ s/\n(.)/\n# $1/sg;
1052
1053 # Stick a newline on the end if it needs it.
1054 $msg .= "\n" unless $msg =~ /\n\Z/;
1055
1056 print $fh $msg;
1057}
1058
1059
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
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
1133
1134sub _new_fh {
1135 my($file_or_fh) = shift;
1136
1137 my $fh;
1138 if( _is_fh($file_or_fh) ) {
1139 $fh = $file_or_fh;
1140 }
1141 else {
1142 $fh = do { local *FH };
1143 open $fh, ">$file_or_fh" or
1144 die "Can't open test output log $file_or_fh: $!";
1145 }
1146
1147 return $fh;
1148}
1149
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
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;
1177
1178 # Set everything to unbuffered else plain prints to STDOUT will
1179 # come out in the wrong order from our own prints.
1180 _autoflush(\*TESTOUT);
1181 _autoflush(\*STDOUT);
1182 _autoflush(\*TESTERR);
1183 _autoflush(\*STDERR);
1184
1185 $Test->output(\*TESTOUT);
1186 $Test->failure_output(\*TESTERR);
1187 $Test->todo_output(\*TESTOUT);
1188}
1189
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;
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
1211Gets/sets the current test number we're on. You usually shouldn't
1212have to set this.
1213
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.
1217
1218=cut
1219
1220sub current_test {
1221 my($self, $num) = @_;
1222
1223 lock($Curr_Test);
1224 if( defined $num ) {
1225 unless( $Have_Plan ) {
1226 require Carp;
1227 Carp::croak("Can't change the current test number without a plan!");
1228 }
1229
1230 $Curr_Test = $num;
1231
1232 # If the test counter is being pushed forward fill in the details.
1233 if( $num > @Test_Results ) {
1234 my $start = @Test_Results ? $#Test_Results + 1 : 0;
1235 for ($start..$num-1) {
1236 $Test_Results[$_] = &share({
1237 'ok' => 1,
1238 actual_ok => undef,
1239 reason => 'incrementing test number',
1240 type => 'unknown',
1241 name => undef
1242 });
1243 }
1244 }
1245 # If backward, wipe history. Its their funeral.
1246 elsif( $num < @Test_Results ) {
1247 $#Test_Results = $num - 1;
1248 }
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
1268 return map { $_->{'ok'} } @Test_Results;
1269}
1270
1271=item B<details>
1272
1273 my @tests = $Test->details;
1274
1275Like summary(), but with a lot more detail.
1276
1277 $tests[$test_num - 1] =
1278 { 'ok' => is the test considered a pass?
1279 actual_ok => did it literally say 'ok'?
1280 name => name of the test (if any)
1281 type => type of test (if any, see below).
1282 reason => reason for the above (if any)
1283 };
1284
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
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;
1367
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
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
1464 # Bailout if plan() was never called. This is so
1465 # "require Test::Simple" doesn't puke.
1466 do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
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
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
1482 unless defined $Test_Results[$idx];
1483 }
1484
1485 my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
1486 $num_failed += abs($Expected_Tests - @Test_Results);
1487
1488 if( $Curr_Test < $Expected_Tests ) {
1489 my $s = $Expected_Tests == 1 ? '' : 's';
1490 $self->diag(<<"FAIL");
1491Looks like you planned $Expected_Tests test$s but only ran $Curr_Test.
1492FAIL
1493 }
1494 elsif( $Curr_Test > $Expected_Tests ) {
1495 my $num_extra = $Curr_Test - $Expected_Tests;
1496 my $s = $Expected_Tests == 1 ? '' : 's';
1497 $self->diag(<<"FAIL");
1498Looks like you planned $Expected_Tests test$s but ran $num_extra extra.
1499FAIL
1500 }
1501 elsif ( $num_failed ) {
1502 my $s = $num_failed == 1 ? '' : 's';
1503 $self->diag(<<"FAIL");
1504Looks like you failed $num_failed test$s of $Expected_Tests.
1505FAIL
1506 }
1507
1508 if( $Test_Died ) {
1509 $self->diag(<<"FAIL");
1510Looks like your test died just after $Curr_Test.
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 }
1521 elsif ( $Test_Died ) {
1522 $self->diag(<<'FAIL');
1523Looks like your test died before it could output anything.
1524FAIL
1525 _my_exit( 255 ) && return;
1526 }
1527 else {
1528 $self->diag("No tests run!\n");
1529 _my_exit( 255 ) && return;
1530 }
1531}
1532
1533END {
1534 $Test->_ending if defined $Test and !$Test->no_ending;
1535}
1536
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
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
1562Test::Builder is only thread-aware if threads.pm is loaded I<before>
1563Test::Builder.
1564
1565=head1 EXAMPLES
1566
1567CPAN can provide the best examples. Test::Simple, Test::More,
1568Test::Exception and Test::Differences all use Test::Builder.
1569
1570=head1 SEE ALSO
1571
1572Test::Simple, Test::More, Test::Harness
1573
1574=head1 AUTHORS
1575
1576Original code by chromatic, maintained by Michael G Schwern
1577E<lt>schwern@pobox.comE<gt>
1578
1579=head1 COPYRIGHT
1580
1581Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1582 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1583
1584This program is free software; you can redistribute it and/or
1585modify it under the same terms as Perl itself.
1586
1587See F<http://www.perl.com/perl/misc/Artistic.html>
1588
1589=cut
1590
15911;