This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Test::Harness 1.26.
[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;
10use vars qw($VERSION $CLASS);
11$VERSION = 0.03;
12$CLASS = __PACKAGE__;
13
14my $IsVMS = $^O eq 'VMS';
15
16use vars qw($Level);
17my @Test_Results = ();
18my @Test_Details = ();
19my($Test_Died) = 0;
20my($Have_Plan) = 0;
21my $Curr_Test = 0;
22
23
24=head1 NAME
25
26Test::Builder - Backend for building test libraries
27
28=head1 SYNOPSIS
29
30 package My::Test::Module;
31 use Test::Builder;
32 require Exporter;
33 @ISA = qw(Exporter);
34 @EXPORT = qw(ok);
35
36 my $Test = Test::Builder->new;
37 $Test->output('my_logfile');
38
39 sub import {
40 my($self) = shift;
41 my $pack = caller;
42
43 $Test->exported_to($pack);
44 $Test->plan(@_);
45
46 $self->export_to_level(1, $self, 'ok');
47 }
48
49 sub ok {
50 my($test, $name) = @_;
51
52 $Test->ok($test, $name);
53 }
54
55
56=head1 DESCRIPTION
57
58I<THIS IS ALPHA GRADE SOFTWARE> The interface will change.
59
60Test::Simple and Test::More have proven to be popular testing modules,
61but they're not always flexible enough. Test::Builder provides the
62a building block upon which to write your own test libraries.
63
64=head2 Construction
65
66=over 4
67
68=item B<new>
69
70 my $Test = Test::Builder->new;
71
72Returns a Test::Builder object representing the current state of the
73test.
74
75Since you only run one test per program, there is B<one and only one>
76Test::Builder object. No matter how many times you call new(), you're
77getting the same object. (This is called a singleton).
78
79=cut
80
81my $Test;
82sub new {
83 my($class) = shift;
84 $Test ||= bless ['Move along, nothing to see here'], $class;
85 return $Test;
86}
87
88=back
89
90=head2 Setting up tests
91
92These methods are for setting up tests and declaring how many there
93are. You usually only want to call one of these methods.
94
95=over 4
96
97=item B<exported_to>
98
99 my $pack = $Test->exported_to;
100 $Test->exported_to($pack);
101
102Tells Test::Builder what package you exported your functions to.
103This is important for getting TODO tests right.
104
105=cut
106
107my $Exported_To;
108sub exported_to {
109 my($self, $pack) = @_;
110
111 if( defined $pack ) {
112 $Exported_To = $pack;
113 }
114 return $Exported_To;
115}
116
117=item B<plan>
118
119 $Test->plan('no_plan');
120 $Test->plan( skip_all => $reason );
121 $Test->plan( tests => $num_tests );
122
123A convenient way to set up your tests. Call this and Test::Builder
124will print the appropriate headers and take the appropriate actions.
125
126If you call plan(), don't call any of the other methods below.
127
128=cut
129
130sub plan {
131 my($self, $cmd, $arg) = @_;
132
133 return unless $cmd;
134
135 if( $cmd eq 'no_plan' ) {
136 $self->no_plan;
137 }
138 elsif( $cmd eq 'skip_all' ) {
139 return $self->skip_all($arg);
140 }
141 elsif( $cmd eq 'tests' ) {
142 if( $arg ) {
143 return $self->expected_tests($arg);
144 }
145 elsif( !defined $arg ) {
146 die "Got an undefined number of tests. Looks like you tried to ".
147 "say how many tests you plan to run but made a mistake.\n";
148 }
149 elsif( !$arg ) {
150 die "You said to run 0 tests! You've got to run something.\n";
151 }
152 }
153}
154
155=item B<expected_tests>
156
157 my $max = $Test->expected_tests;
158 $Test->expected_tests($max);
159
160Gets/sets the # of tests we expect this test to run and prints out
161the appropriate headers.
162
163=cut
164
165my $Expected_Tests = 0;
166sub expected_tests {
167 my($self, $max) = @_;
168
169 if( defined $max ) {
170 $Expected_Tests = $max;
171 $Have_Plan = 1;
172
173 $self->_print("1..$max\n") unless $self->no_header;
174 }
175 return $Expected_Tests;
176}
177
178
179=item B<no_plan>
180
181 $Test->no_plan;
182
183Declares that this test will run an indeterminate # of tests.
184
185=cut
186
187my($No_Plan) = 0;
188sub no_plan {
189 $No_Plan = 1;
190 $Have_Plan = 1;
191}
192
193=item B<skip_all>
194
195 $Test->skip_all;
196 $Test->skip_all($reason);
197
198Skips all the tests, using the given $reason. Exits immediately with 0.
199
200=cut
201
202my $Skip_All = 0;
203sub skip_all {
204 my($self, $reason) = @_;
205
206 my $out = "1..0";
207 $out .= " # Skip $reason" if $reason;
208 $out .= "\n";
209
210 $Skip_All = 1;
211
212 $self->_print($out) unless $self->no_header;
213 exit(0);
214}
215
216=back
217
218=head2 Running tests
219
220These actually run the tests, analogous to the functions in
221Test::More.
222
223$name is always optional.
224
225=over 4
226
227=item B<ok>
228
229 $Test->ok($test, $name);
230
231Your basic test. Pass if $test is true, fail if $test is false. Just
232like Test::Simple's ok().
233
234=cut
235
236sub ok {
237 my($self, $test, $name) = @_;
238
239 unless( $Have_Plan ) {
240 die "You tried to run a test without a plan! Gotta have a plan.\n";
241 }
242
243 $Curr_Test++;
244
245 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
246You named your test '$name'. You shouldn't use numbers for your test names.
247Very confusing.
248ERR
249
250 my($pack, $file, $line) = $self->caller;
251
252 my $todo = $self->todo($pack);
253
254 my $out;
255 unless( $test ) {
256 $out .= "not ";
257 $Test_Results[$Curr_Test-1] = $todo ? 1 : 0;
258 }
259 else {
260 $Test_Results[$Curr_Test-1] = 1;
261 }
262
263 $out .= "ok";
264 $out .= " $Curr_Test" if $self->use_numbers;
265
266 if( defined $name ) {
267 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
268 $out .= " - $name";
269 }
270
271 if( $todo ) {
272 my $what_todo = $todo;
273 $out .= " # TODO $what_todo";
274 }
275
276 $out .= "\n";
277
278 $self->_print($out);
279
280 unless( $test ) {
281 my $msg = $todo ? "Failed (TODO)" : "Failed";
282 $self->diag("$msg test ($file at line $line)\n");
283 }
284
285 return $test ? 1 : 0;
286}
287
288=item B<is_eq>
289
290 $Test->is_eq($got, $expected, $name);
291
292Like Test::More's is(). Checks if $got eq $expected. This is the
293string version.
294
295=item B<is_num>
296
297 $Test->is_num($get, $expected, $name);
298
299Like Test::More's is(). Checks if $got == $expected. This is the
300numeric version.
301
302=cut
303
304sub is_eq {
305 my $self = shift;
306 local $Level = $Level + 1;
307 return $self->_is('eq', @_);
308}
309
310sub is_num {
311 my $self = shift;
312 local $Level = $Level + 1;
313 return $self->_is('==', @_);
314}
315
316sub _is {
317 my($self, $type, $got, $expect, $name) = @_;
318
319 my $test;
320 {
321 local $^W = 0; # so we can compare undef quietly
322 $test = $type eq 'eq' ? $got eq $expect
323 : $got == $expect;
324 }
325 local $Level = $Level + 1;
326 my $ok = $self->ok($test, $name);
327
328 unless( $ok ) {
329 $got = defined $got ? "'$got'" : 'undef';
330 $expect = defined $expect ? "'$expect'" : 'undef';
331 $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
332 got: %s
333expected: %s
334DIAGNOSTIC
335 }
336
337 return $ok;
338}
339
340=item B<like>
341
342 $Test->like($this, qr/$regex/, $name);
343 $Test->like($this, '/$regex/', $name);
344
345Like Test::More's like(). Checks if $this matches the given $regex.
346
347You'll want to avoid qr// if you want your tests to work before 5.005.
348
349=cut
350
351sub like {
352 my($self, $this, $regex, $name) = @_;
353
354 local $Level = $Level + 1;
355
356 my $ok = 0;
357 if( ref $regex eq 'Regexp' ) {
358 local $^W = 0;
359 $ok = $self->ok( $this =~ $regex ? 1 : 0, $name );
360 }
361 # Check if it looks like '/foo/'
362 elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
363 local $^W = 0;
364 $ok = $self->ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name );
365 }
366 else {
367 $ok = $self->ok( 0, $name );
368
369 $self->diag("'$regex' doesn't look much like a regex to me.");
370
371 return $ok;
372 }
373
374 unless( $ok ) {
375 $this = defined $this ? "'$this'" : 'undef';
376 $self->diag(sprintf <<DIAGNOSTIC, $this);
377 %s
378doesn't match '$regex'
379DIAGNOSTIC
380
381 }
382
383 return $ok;
384}
385
386=item B<skip>
387
388 $Test->skip;
389 $Test->skip($why);
390
391Skips the current test, reporting $why.
392
393=cut
394
395sub skip {
396 my($self, $why) = @_;
397 $why ||= '';
398
399 unless( $Have_Plan ) {
400 die "You tried to run tests without a plan! Gotta have a plan.\n";
401 }
402
403 $Curr_Test++;
404
405 $Test_Results[$Curr_Test-1] = 1;
406
407 my $out = "ok";
408 $out .= " $Curr_Test" if $self->use_numbers;
409 $out .= " # skip $why\n";
410
411 $Test->_print($out);
412
413 return 1;
414}
415
416=begin _unimplemented
417
418=item B<skip_rest>
419
420 $Test->skip_rest;
421 $Test->skip_rest($reason);
422
423Like skip(), only it skips all the rest of the tests you plan to run
424and terminates the test.
425
426If you're running under no_plan, it skips once and terminates the
427test.
428
429=end _unimplemented
430
431=back
432
433
434=head2 Test style
435
436=over 4
437
438=item B<level>
439
440 $Test->level($how_high);
441
442How far up the call stack should $Test look when reporting where the
443test failed.
444
445Defaults to 1.
446
447Setting $Test::Builder::Level overrides. This is typically useful
448localized:
449
450 {
451 local $Test::Builder::Level = 2;
452 $Test->ok($test);
453 }
454
455=cut
456
457sub level {
458 my($self, $level) = @_;
459
460 if( defined $level ) {
461 $Level = $level;
462 }
463 return $Level;
464}
465
466$CLASS->level(1);
467
468
469=item B<use_numbers>
470
471 $Test->use_numbers($on_or_off);
472
473Whether or not the test should output numbers. That is, this if true:
474
475 ok 1
476 ok 2
477 ok 3
478
479or this if false
480
481 ok
482 ok
483 ok
484
485Most useful when you can't depend on the test output order, such as
486when threads or forking is involved.
487
488Test::Harness will accept either, but avoid mixing the two styles.
489
490Defaults to on.
491
492=cut
493
494my $Use_Nums = 1;
495sub use_numbers {
496 my($self, $use_nums) = @_;
497
498 if( defined $use_nums ) {
499 $Use_Nums = $use_nums;
500 }
501 return $Use_Nums;
502}
503
504=item B<no_header>
505
506 $Test->no_header($no_header);
507
508If set to true, no "1..N" header will be printed.
509
510=item B<no_ending>
511
512 $Test->no_ending($no_ending);
513
514Normally, Test::Builder does some extra diagnostics when the test
515ends. It also changes the exit code as described in Test::Simple.
516
517If this is true, none of that will be done.
518
519=cut
520
521my($No_Header, $No_Ending) = (0,0);
522sub no_header {
523 my($self, $no_header) = @_;
524
525 if( defined $no_header ) {
526 $No_Header = $no_header;
527 }
528 return $No_Header;
529}
530
531sub no_ending {
532 my($self, $no_ending) = @_;
533
534 if( defined $no_ending ) {
535 $No_Ending = $no_ending;
536 }
537 return $No_Ending;
538}
539
540
541=back
542
543=head2 Output
544
545Controlling where the test output goes.
546
547=over 4
548
549=item B<diag>
550
551 $Test->diag(@msgs);
552
553Prints out the given $message. Normally, it uses the failure_output()
554handle, but if this is for a TODO test, the todo_output() handle is
555used.
556
557Output will be indented and prepended with a # as not to interfere
558with test output.
559
560We encourage using this rather than calling print directly.
561
562=cut
563
564sub diag {
565 my($self, @msgs) = @_;
566
567 # Prevent printing headers when compiling (ie. -c)
568 return if $^C;
569
570 # Escape each line with a #.
571 foreach (@msgs) {
572 s/^([^#])/# $1/;
573 s/\n([^#])/\n# $1/g;
574 }
575
576 local $Level = $Level + 1;
577 my $fh = $self->todo ? $self->todo_output : $self->failure_output;
578 local($\, $", $,) = (undef, ' ', '');
579 print $fh @msgs;
580}
581
582=begin _private
583
584=item B<_print>
585
586 $Test->_print(@msgs);
587
588Prints to the output() filehandle.
589
590=end _private
591
592=cut
593
594sub _print {
595 my($self, @msgs) = @_;
596
597 # Prevent printing headers when only compiling. Mostly for when
598 # tests are deparsed with B::Deparse
599 return if $^C;
600
601 local($\, $", $,) = (undef, ' ', '');
602 my $fh = $self->output;
603 print $fh @msgs;
604}
605
606
607=item B<output>
608
609 $Test->output($fh);
610 $Test->output($file);
611
612Where normal "ok/not ok" test output should go.
613
614Defaults to STDOUT.
615
616=item B<failure_output>
617
618 $Test->failure_output($fh);
619 $Test->failure_output($file);
620
621Where diagnostic output on test failures and diag() should go.
622
623Defaults to STDERR.
624
625=item B<todo_output>
626
627 $Test->todo_output($fh);
628 $Test->todo_output($file);
629
630Where diagnostics about todo test failures and diag() should go.
631
632Defaults to STDOUT.
633
634=cut
635
636my($Out_FH, $Fail_FH, $Todo_FH);
637sub output {
638 my($self, $fh) = @_;
639
640 if( defined $fh ) {
641 $Out_FH = _new_fh($fh);
642 }
643 return $Out_FH;
644}
645
646sub failure_output {
647 my($self, $fh) = @_;
648
649 if( defined $fh ) {
650 $Fail_FH = _new_fh($fh);
651 }
652 return $Fail_FH;
653}
654
655sub todo_output {
656 my($self, $fh) = @_;
657
658 if( defined $fh ) {
659 $Todo_FH = _new_fh($fh);
660 }
661 return $Todo_FH;
662}
663
664sub _new_fh {
665 my($file_or_fh) = shift;
666
667 my $fh;
668 unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
669 $fh = do { local *FH };
670 open $fh, ">$file_or_fh" or
671 die "Can't open test output log $file_or_fh: $!";
672 }
673 else {
674 $fh = $file_or_fh;
675 }
676
677 return $fh;
678}
679
680unless( $^C ) {
681 # We dup STDOUT and STDERR so people can change them in their
682 # test suites while still getting normal test output.
683 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
684 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
685 _autoflush(\*TESTOUT);
686 _autoflush(\*TESTERR);
687 $CLASS->output(\*TESTOUT);
688 $CLASS->failure_output(\*TESTERR);
689 $CLASS->todo_output(\*TESTOUT);
690}
691
692sub _autoflush {
693 my($fh) = shift;
694 my $old_fh = select $fh;
695 $| = 1;
696 select $old_fh;
697}
698
699
700=back
701
702
703=head2 Test Status and Info
704
705=over 4
706
707=item B<current_test>
708
709 my $curr_test = $Test->current_test;
710 $Test->current_test($num);
711
712Gets/sets the current test # we're on.
713
714You usually shouldn't have to set this.
715
716=cut
717
718sub current_test {
719 my($self, $num) = @_;
720
721 if( defined $num ) {
722 $Curr_Test = $num;
723 }
724 return $Curr_Test;
725}
726
727
728=item B<summary>
729
730 my @tests = $Test->summary;
731
732A simple summary of the tests so far. True for pass, false for fail.
733This is a logical pass/fail, so todos are passes.
734
735Of course, test #1 is $tests[0], etc...
736
737=cut
738
739sub summary {
740 my($self) = shift;
741
742 return @Test_Results;
743}
744
745=item B<details> I<UNIMPLEMENTED>
746
747 my @tests = $Test->details;
748
749Like summary(), but with a lot more detail.
750
751 $tests[$test_num - 1] =
752 { ok => is the test considered ok?
753 actual_ok => did it literally say 'ok'?
754 name => name of the test (if any)
755 type => 'skip' or 'todo' (if any)
756 reason => reason for the above (if any)
757 };
758
759=item B<todo>
760
761 my $todo_reason = $Test->todo;
762 my $todo_reason = $Test->todo($pack);
763
764todo() looks for a $TODO variable in your tests. If set, all tests
765will be considered 'todo' (see Test::More and Test::Harness for
766details). Returns the reason (ie. the value of $TODO) if running as
767todo tests, false otherwise.
768
769todo() is pretty part about finding the right package to look for
770$TODO in. It uses the exported_to() package to find it. If that's
771not set, it's pretty good at guessing the right package to look at.
772
773Sometimes there is some confusion about where todo() should be looking
774for the $TODO variable. If you want to be sure, tell it explicitly
775what $pack to use.
776
777=cut
778
779sub todo {
780 my($self, $pack) = @_;
781
782 $pack = $pack || $self->exported_to || $self->caller(1);
783
784 no strict 'refs';
785 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
786 : 0;
787}
788
789=item B<caller>
790
791 my $package = $Test->caller;
792 my($pack, $file, $line) = $Test->caller;
793 my($pack, $file, $line) = $Test->caller($height);
794
795Like the normal caller(), except it reports according to your level().
796
797=cut
798
799sub caller {
800 my($self, $height) = @_;
801 $height ||= 0;
802
803 my @caller = CORE::caller($self->level + $height + 1);
804 return wantarray ? @caller : $caller[0];
805}
806
807=back
808
809=cut
810
811=begin _private
812
813=over 4
814
815=item B<_sanity_check>
816
817 _sanity_check();
818
819Runs a bunch of end of test sanity checks to make sure reality came
820through ok. If anything is wrong it will die with a fairly friendly
821error message.
822
823=cut
824
825#'#
826sub _sanity_check {
827 _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
828 _whoa(!$Have_Plan and $Curr_Test,
829 'Somehow your tests ran without a plan!');
830 _whoa($Curr_Test != @Test_Results,
831 'Somehow you got a different number of results than tests ran!');
832}
833
834=item B<_whoa>
835
836 _whoa($check, $description);
837
838A sanity check, similar to assert(). If the $check is true, something
839has gone horribly wrong. It will die with the given $description and
840a note to contact the author.
841
842=cut
843
844sub _whoa {
845 my($check, $desc) = @_;
846 if( $check ) {
847 die <<WHOA;
848WHOA! $desc
849This should never happen! Please contact the author immediately!
850WHOA
851 }
852}
853
854=item B<_my_exit>
855
856 _my_exit($exit_num);
857
858Perl seems to have some trouble with exiting inside an END block. 5.005_03
859and 5.6.1 both seem to do odd things. Instead, this function edits $?
860directly. It should ONLY be called from inside an END block. It
861doesn't actually exit, that's your job.
862
863=cut
864
865sub _my_exit {
866 $? = $_[0];
867
868 return 1;
869}
870
871
872=back
873
874=end _private
875
876=cut
877
878$SIG{__DIE__} = sub {
879 # We don't want to muck with death in an eval, but $^S isn't
880 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
881 # with it. Instead, we use caller. This also means it runs under
882 # 5.004!
883 my $in_eval = 0;
884 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
885 $in_eval = 1 if $sub =~ /^\(eval\)/;
886 }
887 $Test_Died = 1 unless $in_eval;
888};
889
890sub _ending {
891 my $self = shift;
892
893 _sanity_check();
894
895 # Bailout if plan() was never called. This is so
896 # "require Test::Simple" doesn't puke.
897 do{ _my_exit(0) && return } if !$Have_Plan;
898
899 # Figure out if we passed or failed and print helpful messages.
900 if( @Test_Results ) {
901 # The plan? We have no plan.
902 if( $No_Plan ) {
903 $self->_print("1..$Curr_Test\n") unless $self->no_header;
904 $Expected_Tests = $Curr_Test;
905 }
906
907 my $num_failed = grep !$_, @Test_Results[0..$Expected_Tests-1];
908 $num_failed += abs($Expected_Tests - @Test_Results);
909
910 if( $Curr_Test < $Expected_Tests ) {
911 $self->diag(<<"FAIL");
912# Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
913FAIL
914 }
915 elsif( $Curr_Test > $Expected_Tests ) {
916 my $num_extra = $Curr_Test - $Expected_Tests;
917 $self->diag(<<"FAIL");
918# Looks like you planned $Expected_Tests tests but ran $num_extra extra.
919FAIL
920 }
921 elsif ( $num_failed ) {
922 $self->diag(<<"FAIL");
923# Looks like you failed $num_failed tests of $Expected_Tests.
924FAIL
925 }
926
927 if( $Test_Died ) {
928 $self->diag(<<"FAIL");
929# Looks like your test died just after $Curr_Test.
930FAIL
931
932 _my_exit( 255 ) && return;
933 }
934
935 _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
936 }
937 elsif ( $Skip_All ) {
938 _my_exit( 0 ) && return;
939 }
940 else {
941 $self->diag("# No tests run!\n");
942 _my_exit( 255 ) && return;
943 }
944}
945
946END {
947 $Test->_ending if defined $Test and !$Test->no_ending;
948}
949
950=head1 EXAMPLES
951
952At this point, Test::Simple and Test::More are your best examples.
953
954=head1 AUTHOR
955
956Original code by chromatic, maintained by Michael G Schwern
957E<lt>schwern@pobox.comE<gt>
958
959=head1 SEE ALSO
960
961Test::Simple, Test::More, Test::Harness
962
963=cut
964
9651;