This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1378242a06f5eb2884850c50c31e3482105b433e
[perl5.git] / lib / Test / Builder.pm
1 package Test::Builder;
2
3 use 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
9 use strict;
10 use vars qw($VERSION $CLASS);
11 $VERSION = 0.05;
12 $CLASS = __PACKAGE__;
13
14 my $IsVMS = $^O eq 'VMS';
15
16 use vars qw($Level);
17 my @Test_Results = ();
18 my @Test_Details = ();
19 my($Test_Died) = 0;
20 my($Have_Plan) = 0;
21 my $Curr_Test = 0;
22
23
24 =head1 NAME
25
26 Test::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
58 I<THIS IS ALPHA GRADE SOFTWARE>  The interface will change.
59
60 Test::Simple and Test::More have proven to be popular testing modules,
61 but they're not always flexible enough.  Test::Builder provides the
62 a 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
72 Returns a Test::Builder object representing the current state of the
73 test.
74
75 Since you only run one test per program, there is B<one and only one>
76 Test::Builder object.  No matter how many times you call new(), you're
77 getting the same object.  (This is called a singleton).
78
79 =cut
80
81 my $Test;
82 sub 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
92 These methods are for setting up tests and declaring how many there
93 are.  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
102 Tells Test::Builder what package you exported your functions to.
103 This is important for getting TODO tests right.
104
105 =cut
106
107 my $Exported_To;
108 sub 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
123 A convenient way to set up your tests.  Call this and Test::Builder
124 will print the appropriate headers and take the appropriate actions.
125
126 If you call plan(), don't call any of the other methods below.
127
128 =cut
129
130 sub 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
160 Gets/sets the # of tests we expect this test to run and prints out
161 the appropriate headers.
162
163 =cut
164
165 my $Expected_Tests = 0;
166 sub 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
183 Declares that this test will run an indeterminate # of tests.
184
185 =cut
186
187 my($No_Plan) = 0;
188 sub 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
198 Skips all the tests, using the given $reason.  Exits immediately with 0.
199
200 =cut
201
202 my $Skip_All = 0;
203 sub 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
220 These actually run the tests, analogous to the functions in
221 Test::More.
222
223 $name is always optional.
224
225 =over 4
226
227 =item B<ok>
228
229   $Test->ok($test, $name);
230
231 Your basic test.  Pass if $test is true, fail if $test is false.  Just
232 like Test::Simple's ok().
233
234 =cut
235
236 sub 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]+$/;
246 You named your test '$name'.  You shouldn't use numbers for your test names.
247 Very confusing.
248 ERR
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
292 Like Test::More's is().  Checks if $got eq $expected.  This is the
293 string version.
294
295 =item B<is_num>
296
297   $Test->is_num($get, $expected, $name);
298
299 Like Test::More's is().  Checks if $got == $expected.  This is the
300 numeric version.
301
302 =cut
303
304 sub is_eq {
305     my $self = shift;
306     local $Level = $Level + 1;
307     return $self->_is('eq', @_);
308 }
309
310 sub is_num {
311     my $self = shift;
312     local $Level = $Level + 1;
313     return $self->_is('==', @_);
314 }
315
316 sub _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
333 expected: %s
334 DIAGNOSTIC
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
345 Like Test::More's like().  Checks if $this matches the given $regex.
346
347 You'll want to avoid qr// if you want your tests to work before 5.005.
348
349 =cut
350
351 sub 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
378 doesn't match '$regex'
379 DIAGNOSTIC
380
381     }
382
383     return $ok;
384 }
385
386 =item B<skip>
387
388     $Test->skip;
389     $Test->skip($why);
390
391 Skips the current test, reporting $why.
392
393 =cut
394
395 sub 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
423 Like skip(), only it skips all the rest of the tests you plan to run
424 and terminates the test.
425
426 If you're running under no_plan, it skips once and terminates the
427 test.
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
442 How far up the call stack should $Test look when reporting where the
443 test failed.
444
445 Defaults to 1.
446
447 Setting $Test::Builder::Level overrides.  This is typically useful
448 localized:
449
450     {
451         local $Test::Builder::Level = 2;
452         $Test->ok($test);
453     }
454
455 =cut
456
457 sub 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
473 Whether or not the test should output numbers.  That is, this if true:
474
475   ok 1
476   ok 2
477   ok 3
478
479 or this if false
480
481   ok
482   ok
483   ok
484
485 Most useful when you can't depend on the test output order, such as
486 when threads or forking is involved.
487
488 Test::Harness will accept either, but avoid mixing the two styles.
489
490 Defaults to on.
491
492 =cut
493
494 my $Use_Nums = 1;
495 sub 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
508 If set to true, no "1..N" header will be printed.
509
510 =item B<no_ending>
511
512     $Test->no_ending($no_ending);
513
514 Normally, Test::Builder does some extra diagnostics when the test
515 ends.  It also changes the exit code as described in Test::Simple.
516
517 If this is true, none of that will be done.
518
519 =cut
520
521 my($No_Header, $No_Ending) = (0,0);
522 sub 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
531 sub 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
545 Controlling where the test output goes.
546
547 It's ok for your test to change where STDOUT and STDERR point to,
548 Test::Builder's default output settings will not be affected.
549
550 =over 4
551
552 =item B<diag>
553
554     $Test->diag(@msgs);
555
556 Prints out the given $message.  Normally, it uses the failure_output()
557 handle, but if this is for a TODO test, the todo_output() handle is
558 used.
559
560 Output will be indented and marked with a # so as not to interfere
561 with test output.
562
563 We encourage using this rather than calling print directly.
564
565 =cut
566
567 sub diag {
568     my($self, @msgs) = @_;
569
570     # Prevent printing headers when compiling (i.e. -c)
571     return if $^C;
572
573     # Escape each line with a #.
574     foreach (@msgs) {
575         s/^([^#])/#     $1/;
576         s/\n([^#])/\n#     $1/g;
577     }
578
579     local $Level = $Level + 1;
580     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
581     local($\, $", $,) = (undef, ' ', '');
582     print $fh @msgs;
583 }
584
585 =begin _private
586
587 =item B<_print>
588
589     $Test->_print(@msgs);
590
591 Prints to the output() filehandle.
592
593 =end _private
594
595 =cut
596
597 sub _print {
598     my($self, @msgs) = @_;
599
600     # Prevent printing headers when only compiling.  Mostly for when
601     # tests are deparsed with B::Deparse
602     return if $^C;
603
604     local($\, $", $,) = (undef, ' ', '');
605     my $fh = $self->output;
606     print $fh @msgs;
607 }
608
609
610 =item B<output>
611
612     $Test->output($fh);
613     $Test->output($file);
614
615 Where normal "ok/not ok" test output should go.
616
617 Defaults to STDOUT.
618
619 =item B<failure_output>
620
621     $Test->failure_output($fh);
622     $Test->failure_output($file);
623
624 Where diagnostic output on test failures and diag() should go.
625
626 Defaults to STDERR.
627
628 =item B<todo_output>
629
630     $Test->todo_output($fh);
631     $Test->todo_output($file);
632
633 Where diagnostics about todo test failures and diag() should go.
634
635 Defaults to STDOUT.
636
637 =cut
638
639 my($Out_FH, $Fail_FH, $Todo_FH);
640 sub output {
641     my($self, $fh) = @_;
642
643     if( defined $fh ) {
644         $Out_FH = _new_fh($fh);
645     }
646     return $Out_FH;
647 }
648
649 sub failure_output {
650     my($self, $fh) = @_;
651
652     if( defined $fh ) {
653         $Fail_FH = _new_fh($fh);
654     }
655     return $Fail_FH;
656 }
657
658 sub todo_output {
659     my($self, $fh) = @_;
660
661     if( defined $fh ) {
662         $Todo_FH = _new_fh($fh);
663     }
664     return $Todo_FH;
665 }
666
667 sub _new_fh {
668     my($file_or_fh) = shift;
669
670     my $fh;
671     unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
672         $fh = do { local *FH };
673         open $fh, ">$file_or_fh" or 
674             die "Can't open test output log $file_or_fh: $!";
675     }
676     else {
677         $fh = $file_or_fh;
678     }
679
680     return $fh;
681 }
682
683 unless( $^C ) {
684     # We dup STDOUT and STDERR so people can change them in their
685     # test suites while still getting normal test output.
686     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
687     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
688     _autoflush(\*TESTOUT);
689     _autoflush(\*TESTERR);
690     $CLASS->output(\*TESTOUT);
691     $CLASS->failure_output(\*TESTERR);
692     $CLASS->todo_output(\*TESTOUT);
693 }
694
695 sub _autoflush {
696     my($fh) = shift;
697     my $old_fh = select $fh;
698     $| = 1;
699     select $old_fh;
700 }
701
702
703 =back
704
705
706 =head2 Test Status and Info
707
708 =over 4
709
710 =item B<current_test>
711
712     my $curr_test = $Test->current_test;
713     $Test->current_test($num);
714
715 Gets/sets the current test # we're on.
716
717 You usually shouldn't have to set this.
718
719 =cut
720
721 sub current_test {
722     my($self, $num) = @_;
723
724     if( defined $num ) {
725         $Curr_Test = $num;
726     }
727     return $Curr_Test;
728 }
729
730
731 =item B<summary>
732
733     my @tests = $Test->summary;
734
735 A simple summary of the tests so far.  True for pass, false for fail.
736 This is a logical pass/fail, so todos are passes.
737
738 Of course, test #1 is $tests[0], etc...
739
740 =cut
741
742 sub summary {
743     my($self) = shift;
744
745     return @Test_Results;
746 }
747
748 =item B<details>  I<UNIMPLEMENTED>
749
750     my @tests = $Test->details;
751
752 Like summary(), but with a lot more detail.
753
754     $tests[$test_num - 1] = 
755             { ok         => is the test considered ok?
756               actual_ok  => did it literally say 'ok'?
757               name       => name of the test (if any)
758               type       => 'skip' or 'todo' (if any)
759               reason     => reason for the above (if any)
760             };
761
762 =item B<todo>
763
764     my $todo_reason = $Test->todo;
765     my $todo_reason = $Test->todo($pack);
766
767 todo() looks for a $TODO variable in your tests.  If set, all tests
768 will be considered 'todo' (see Test::More and Test::Harness for
769 details).  Returns the reason (ie. the value of $TODO) if running as
770 todo tests, false otherwise.
771
772 todo() is pretty part about finding the right package to look for
773 $TODO in.  It uses the exported_to() package to find it.  If that's
774 not set, it's pretty good at guessing the right package to look at.
775
776 Sometimes there is some confusion about where todo() should be looking
777 for the $TODO variable.  If you want to be sure, tell it explicitly
778 what $pack to use.
779
780 =cut
781
782 sub todo {
783     my($self, $pack) = @_;
784
785     $pack = $pack || $self->exported_to || $self->caller(1);
786
787     no strict 'refs';
788     return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
789                                      : 0;
790 }
791
792 =item B<caller>
793
794     my $package = $Test->caller;
795     my($pack, $file, $line) = $Test->caller;
796     my($pack, $file, $line) = $Test->caller($height);
797
798 Like the normal caller(), except it reports according to your level().
799
800 =cut
801
802 sub caller {
803     my($self, $height) = @_;
804     $height ||= 0;
805     
806     my @caller = CORE::caller($self->level + $height + 1);
807     return wantarray ? @caller : $caller[0];
808 }
809
810 =back
811
812 =cut
813
814 =begin _private
815
816 =over 4
817
818 =item B<_sanity_check>
819
820   _sanity_check();
821
822 Runs a bunch of end of test sanity checks to make sure reality came
823 through ok.  If anything is wrong it will die with a fairly friendly
824 error message.
825
826 =cut
827
828 #'#
829 sub _sanity_check {
830     _whoa($Curr_Test < 0,  'Says here you ran a negative number of tests!');
831     _whoa(!$Have_Plan and $Curr_Test, 
832           'Somehow your tests ran without a plan!');
833     _whoa($Curr_Test != @Test_Results,
834           'Somehow you got a different number of results than tests ran!');
835 }
836
837 =item B<_whoa>
838
839   _whoa($check, $description);
840
841 A sanity check, similar to assert().  If the $check is true, something
842 has gone horribly wrong.  It will die with the given $description and
843 a note to contact the author.
844
845 =cut
846
847 sub _whoa {
848     my($check, $desc) = @_;
849     if( $check ) {
850         die <<WHOA;
851 WHOA!  $desc
852 This should never happen!  Please contact the author immediately!
853 WHOA
854     }
855 }
856
857 =item B<_my_exit>
858
859   _my_exit($exit_num);
860
861 Perl seems to have some trouble with exiting inside an END block.  5.005_03
862 and 5.6.1 both seem to do odd things.  Instead, this function edits $?
863 directly.  It should ONLY be called from inside an END block.  It
864 doesn't actually exit, that's your job.
865
866 =cut
867
868 sub _my_exit {
869     $? = $_[0];
870
871     return 1;
872 }
873
874
875 =back
876
877 =end _private
878
879 =cut
880
881 $SIG{__DIE__} = sub {
882     # We don't want to muck with death in an eval, but $^S isn't
883     # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
884     # with it.  Instead, we use caller.  This also means it runs under
885     # 5.004!
886     my $in_eval = 0;
887     for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
888         $in_eval = 1 if $sub =~ /^\(eval\)/;
889     }
890     $Test_Died = 1 unless $in_eval;
891 };
892
893 sub _ending {
894     my $self = shift;
895
896     _sanity_check();
897
898     # Bailout if plan() was never called.  This is so
899     # "require Test::Simple" doesn't puke.
900     do{ _my_exit(0) && return } if !$Have_Plan;
901
902     # Figure out if we passed or failed and print helpful messages.
903     if( @Test_Results ) {
904         # The plan?  We have no plan.
905         if( $No_Plan ) {
906             $self->_print("1..$Curr_Test\n") unless $self->no_header;
907             $Expected_Tests = $Curr_Test;
908         }
909
910         my $num_failed = grep !$_, @Test_Results[0..$Expected_Tests-1];
911         $num_failed += abs($Expected_Tests - @Test_Results);
912
913         if( $Curr_Test < $Expected_Tests ) {
914             $self->diag(<<"FAIL");
915 # Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
916 FAIL
917         }
918         elsif( $Curr_Test > $Expected_Tests ) {
919             my $num_extra = $Curr_Test - $Expected_Tests;
920             $self->diag(<<"FAIL");
921 # Looks like you planned $Expected_Tests tests but ran $num_extra extra.
922 FAIL
923         }
924         elsif ( $num_failed ) {
925             $self->diag(<<"FAIL");
926 # Looks like you failed $num_failed tests of $Expected_Tests.
927 FAIL
928         }
929
930         if( $Test_Died ) {
931             $self->diag(<<"FAIL");
932 # Looks like your test died just after $Curr_Test.
933 FAIL
934
935             _my_exit( 255 ) && return;
936         }
937
938         _my_exit( $num_failed <= 254 ? $num_failed : 254  ) && return;
939     }
940     elsif ( $Skip_All ) {
941         _my_exit( 0 ) && return;
942     }
943     else {
944         $self->diag("# No tests run!\n");
945         _my_exit( 255 ) && return;
946     }
947 }
948
949 END {
950     $Test->_ending if defined $Test and !$Test->no_ending;
951 }
952
953 =head1 EXAMPLES
954
955 At this point, Test::Simple and Test::More are your best examples.
956
957 =head1 SEE ALSO
958
959 Test::Simple, Test::More, Test::Harness
960
961 =head1 AUTHORS
962
963 Original code by chromatic, maintained by Michael G Schwern
964 E<lt>schwern@pobox.comE<gt>
965
966 =head1 COPYRIGHT
967
968 Copyright 2001 by chromatic E<lt>chromatic@wgz.orgE<gt>,
969                   Michael G Schwern E<lt>schwern@pobox.comE<gt>.
970
971 This program is free software; you can redistribute it and/or 
972 modify it under the same terms as Perl itself.
973
974 See L<http://www.perl.com/perl/misc/Artistic.html>
975
976 =cut
977
978 1;