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