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