5
# $^C was only introduced in 5.005-ish. We do this to prevent
6
# use of uninitialized value warnings in older perls.
10
use vars qw($VERSION);
12
$VERSION = eval $VERSION; # make the alpha version come out as a number
14
# Make Test::Builder thread-safe for ithreads.
17
# Load threads::shared when threads are turned on
18
if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) {
19
require threads::shared;
21
# Hack around YET ANOTHER threads::shared bug. It would
22
# occassionally forget the contents of the variable when sharing it.
23
# So we first copy the data, then share, then put our copy back.
24
*share = sub (\[$@%]) {
28
if( $type eq 'HASH' ) {
31
elsif( $type eq 'ARRAY' ) {
34
elsif( $type eq 'SCALAR' ) {
38
die "Unknown type: ".$type;
41
$_[0] = &threads::shared::share($_[0]);
43
if( $type eq 'HASH' ) {
46
elsif( $type eq 'ARRAY' ) {
49
elsif( $type eq 'SCALAR' ) {
53
die "Unknown type: ".$type;
59
# 5.8.0's threads::shared is busted when threads are off.
62
*share = sub { return $_[0] };
70
Test::Builder - Backend for building test libraries
74
package My::Test::Module;
80
my $Test = Test::Builder->new;
81
$Test->output('my_logfile');
87
$Test->exported_to($pack);
90
$self->export_to_level(1, $self, 'ok');
94
my($test, $name) = @_;
96
$Test->ok($test, $name);
102
Test::Simple and Test::More have proven to be popular testing modules,
103
but they're not always flexible enough. Test::Builder provides the a
104
building block upon which to write your own test libraries I<which can
113
my $Test = Test::Builder->new;
115
Returns a Test::Builder object representing the current state of the
118
Since you only run one test per program C<new> always returns the same
119
Test::Builder object. No matter how many times you call new(), you're
120
getting the same object. This is called a singleton. This is done so that
121
multiple modules share such global information as the test counter and
122
where test output is going.
124
If you want a completely new Test::Builder object different from the
125
singleton, use C<create>.
129
my $Test = Test::Builder->new;
132
$Test ||= $class->create;
139
my $Test = Test::Builder->create;
141
Ok, so there can be more than one Test::Builder object and this is how
142
you get it. You might use this instead of C<new()> if you're testing
143
a Test::Builder based module, but otherwise you probably want C<new>.
145
B<NOTE>: the implementation is not complete. C<level>, for example, is
146
still shared amongst B<all> Test::Builder objects, even ones created using
147
this method. Also, the method name may change in the future.
154
my $self = bless {}, $class;
164
Reinitializes the Test::Builder singleton to its original state.
165
Mostly useful for tests run in persistent environments where the same
166
test might be run multiple times in the same process.
175
# We leave this a global because it has to be localized and localizing
176
# hash keys is just asking for pain. Also, it was documented.
179
$self->{Test_Died} = 0;
180
$self->{Have_Plan} = 0;
181
$self->{No_Plan} = 0;
182
$self->{Original_Pid} = $$;
184
share($self->{Curr_Test});
185
$self->{Curr_Test} = 0;
186
$self->{Test_Results} = &share([]);
188
$self->{Exported_To} = undef;
189
$self->{Expected_Tests} = 0;
191
$self->{Skip_All} = 0;
193
$self->{Use_Nums} = 1;
195
$self->{No_Header} = 0;
196
$self->{No_Ending} = 0;
198
$self->_dup_stdhandles unless $^C;
205
=head2 Setting up tests
207
These methods are for setting up tests and declaring how many there
208
are. You usually only want to call one of these methods.
214
my $pack = $Test->exported_to;
215
$Test->exported_to($pack);
217
Tells Test::Builder what package you exported your functions to.
218
This is important for getting TODO tests right.
223
my($self, $pack) = @_;
225
if( defined $pack ) {
226
$self->{Exported_To} = $pack;
228
return $self->{Exported_To};
233
$Test->plan('no_plan');
234
$Test->plan( skip_all => $reason );
235
$Test->plan( tests => $num_tests );
237
A convenient way to set up your tests. Call this and Test::Builder
238
will print the appropriate headers and take the appropriate actions.
240
If you call plan(), don't call any of the other methods below.
245
my($self, $cmd, $arg) = @_;
249
if( $self->{Have_Plan} ) {
250
die sprintf "You tried to plan twice! Second plan at %s line %d\n",
251
($self->caller)[1,2];
254
if( $cmd eq 'no_plan' ) {
257
elsif( $cmd eq 'skip_all' ) {
258
return $self->skip_all($arg);
260
elsif( $cmd eq 'tests' ) {
262
return $self->expected_tests($arg);
264
elsif( !defined $arg ) {
265
die "Got an undefined number of tests. Looks like you tried to ".
266
"say how many tests you plan to run but made a mistake.\n";
269
die "You said to run 0 tests! You've got to run something.\n";
274
my @args = grep { defined } ($cmd, $arg);
275
Carp::croak("plan() doesn't understand @args");
281
=item B<expected_tests>
283
my $max = $Test->expected_tests;
284
$Test->expected_tests($max);
286
Gets/sets the # of tests we expect this test to run and prints out
287
the appropriate headers.
296
die "Number of tests must be a postive integer. You gave it '$max'.\n"
297
unless $max =~ /^\+?\d+$/ and $max > 0;
299
$self->{Expected_Tests} = $max;
300
$self->{Have_Plan} = 1;
302
$self->_print("1..$max\n") unless $self->no_header;
304
return $self->{Expected_Tests};
312
Declares that this test will run an indeterminate # of tests.
319
$self->{No_Plan} = 1;
320
$self->{Have_Plan} = 1;
325
$plan = $Test->has_plan
327
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).
334
return($self->{Expected_Tests}) if $self->{Expected_Tests};
335
return('no_plan') if $self->{No_Plan};
343
$Test->skip_all($reason);
345
Skips all the tests, using the given $reason. Exits immediately with 0.
350
my($self, $reason) = @_;
353
$out .= " # Skip $reason" if $reason;
356
$self->{Skip_All} = 1;
358
$self->_print($out) unless $self->no_header;
366
These actually run the tests, analogous to the functions in
369
$name is always optional.
375
$Test->ok($test, $name);
377
Your basic test. Pass if $test is true, fail if $test is false. Just
378
like Test::Simple's ok().
383
my($self, $test, $name) = @_;
385
# $test might contain an object which we don't want to accidentally
386
# store, so we turn it into a boolean.
387
$test = $test ? 1 : 0;
389
unless( $self->{Have_Plan} ) {
391
Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
394
lock $self->{Curr_Test};
395
$self->{Curr_Test}++;
397
# In case $name is a string overloaded object, force it to stringify.
398
$self->_unoverload_str(\$name);
400
$self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
401
You named your test '$name'. You shouldn't use numbers for your test names.
405
my($pack, $file, $line) = $self->caller;
407
my $todo = $self->todo($pack);
408
$self->_unoverload_str(\$todo);
411
my $result = &share({});
415
@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
418
@$result{ 'ok', 'actual_ok' } = ( 1, $test );
422
$out .= " $self->{Curr_Test}" if $self->use_numbers;
424
if( defined $name ) {
425
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
427
$result->{name} = $name;
430
$result->{name} = '';
434
$out .= " # TODO $todo";
435
$result->{reason} = $todo;
436
$result->{type} = 'todo';
439
$result->{reason} = '';
440
$result->{type} = '';
443
$self->{Test_Results}[$self->{Curr_Test}-1] = $result;
449
my $msg = $todo ? "Failed (TODO)" : "Failed";
450
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
452
if( defined $name ) {
453
$self->diag(qq[ $msg test '$name'\n]);
454
$self->diag(qq[ in $file at line $line.\n]);
457
$self->diag(qq[ $msg test in $file at line $line.\n]);
461
return $test ? 1 : 0;
471
eval { require overload } || return;
473
foreach my $thing (@_) {
475
if( _is_object($$thing) ) {
476
if( my $string_meth = overload::Method($$thing, $type) ) {
477
$$thing = $$thing->$string_meth();
488
return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
492
sub _unoverload_str {
495
$self->_unoverload(q[""], @_);
498
sub _unoverload_num {
501
$self->_unoverload('0+', @_);
504
next unless $self->_is_dualvar($$val);
510
# This is a hack to detect a dualvar such as $!
512
my($self, $val) = @_;
516
return 1 if $numval != 0 and $numval ne $val;
523
$Test->is_eq($got, $expected, $name);
525
Like Test::More's is(). Checks if $got eq $expected. This is the
530
$Test->is_num($got, $expected, $name);
532
Like Test::More's is(). Checks if $got == $expected. This is the
538
my($self, $got, $expect, $name) = @_;
539
local $Level = $Level + 1;
541
$self->_unoverload_str(\$got, \$expect);
543
if( !defined $got || !defined $expect ) {
544
# undef only matches undef and nothing else
545
my $test = !defined $got && !defined $expect;
547
$self->ok($test, $name);
548
$self->_is_diag($got, 'eq', $expect) unless $test;
552
return $self->cmp_ok($got, 'eq', $expect, $name);
556
my($self, $got, $expect, $name) = @_;
557
local $Level = $Level + 1;
559
$self->_unoverload_num(\$got, \$expect);
561
if( !defined $got || !defined $expect ) {
562
# undef only matches undef and nothing else
563
my $test = !defined $got && !defined $expect;
565
$self->ok($test, $name);
566
$self->_is_diag($got, '==', $expect) unless $test;
570
return $self->cmp_ok($got, '==', $expect, $name);
574
my($self, $got, $type, $expect) = @_;
576
foreach my $val (\$got, \$expect) {
577
if( defined $$val ) {
578
if( $type eq 'eq' ) {
579
# quote and force string context
583
# force numeric context
584
$self->_unoverload_num($val);
592
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
601
$Test->isnt_eq($got, $dont_expect, $name);
603
Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
608
$Test->isnt_num($got, $dont_expect, $name);
610
Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
616
my($self, $got, $dont_expect, $name) = @_;
617
local $Level = $Level + 1;
619
if( !defined $got || !defined $dont_expect ) {
620
# undef only matches undef and nothing else
621
my $test = defined $got || defined $dont_expect;
623
$self->ok($test, $name);
624
$self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
628
return $self->cmp_ok($got, 'ne', $dont_expect, $name);
632
my($self, $got, $dont_expect, $name) = @_;
633
local $Level = $Level + 1;
635
if( !defined $got || !defined $dont_expect ) {
636
# undef only matches undef and nothing else
637
my $test = defined $got || defined $dont_expect;
639
$self->ok($test, $name);
640
$self->_cmp_diag($got, '!=', $dont_expect) unless $test;
644
return $self->cmp_ok($got, '!=', $dont_expect, $name);
650
$Test->like($this, qr/$regex/, $name);
651
$Test->like($this, '/$regex/', $name);
653
Like Test::More's like(). Checks if $this matches the given $regex.
655
You'll want to avoid qr// if you want your tests to work before 5.005.
659
$Test->unlike($this, qr/$regex/, $name);
660
$Test->unlike($this, '/$regex/', $name);
662
Like Test::More's unlike(). Checks if $this B<does not match> the
668
my($self, $this, $regex, $name) = @_;
670
local $Level = $Level + 1;
671
$self->_regex_ok($this, $regex, '=~', $name);
675
my($self, $this, $regex, $name) = @_;
677
local $Level = $Level + 1;
678
$self->_regex_ok($this, $regex, '!~', $name);
683
$Test->maybe_regex(qr/$regex/);
684
$Test->maybe_regex('/$regex/');
686
Convenience method for building testing functions that take regular
687
expressions as arguments, but need to work before perl 5.005.
689
Takes a quoted regular expression produced by qr//, or a string
690
representing a regular expression.
692
Returns a Perl value which may be used instead of the corresponding
693
regular expression, or undef if it's argument is not recognised.
695
For example, a version of like(), sans the useful diagnostic messages,
699
my ($self, $this, $regex, $name) = @_;
700
my $usable_regex = $self->maybe_regex($regex);
701
die "expecting regex, found '$regex'\n"
702
unless $usable_regex;
703
$self->ok($this =~ m/$usable_regex/, $name);
710
my ($self, $regex) = @_;
711
my $usable_regex = undef;
713
return $usable_regex unless defined $regex;
718
if( ref $regex eq 'Regexp' ) {
719
$usable_regex = $regex;
721
# Check for '/foo/' or 'm,foo,'
722
elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
723
(undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
726
$usable_regex = length $opts ? "(?$opts)$re" : $re;
729
return $usable_regex;
733
my($self, $this, $regex, $cmp, $name) = @_;
736
my $usable_regex = $self->maybe_regex($regex);
737
unless (defined $usable_regex) {
738
$ok = $self->ok( 0, $name );
739
$self->diag(" '$regex' doesn't look much like a regex to me.");
745
my $code = $self->_caller_context;
749
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
750
# Don't ask me, man, I just work here.
752
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
754
$test = !$test if $cmp eq '!~';
756
local $Level = $Level + 1;
757
$ok = $self->ok( $test, $name );
761
$this = defined $this ? "'$this'" : 'undef';
762
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
763
$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
775
$Test->cmp_ok($this, $type, $that, $name);
777
Works just like Test::More's cmp_ok().
779
$Test->cmp_ok($big_num, '!=', $other_big_num);
784
my %numeric_cmps = map { ($_, 1) }
785
("<", "<=", ">", ">=", "==", "!=", "<=>");
788
my($self, $got, $type, $expect, $name) = @_;
790
# Treat overloaded objects as numbers if we're asked to do a
791
# numeric comparison.
792
my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
795
$self->$unoverload(\$got, \$expect);
800
local($@,$!); # don't interfere with $@
801
# eval() sometimes resets $!
803
my $code = $self->_caller_context;
805
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
806
# Don't ask me, man, I just work here.
808
$code" . "\$got $type \$expect;";
811
local $Level = $Level + 1;
812
my $ok = $self->ok($test, $name);
815
if( $type =~ /^(eq|==)$/ ) {
816
$self->_is_diag($got, $type, $expect);
819
$self->_cmp_diag($got, $type, $expect);
826
my($self, $got, $type, $expect) = @_;
828
$got = defined $got ? "'$got'" : 'undef';
829
$expect = defined $expect ? "'$expect'" : 'undef';
830
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
838
sub _caller_context {
841
my($pack, $file, $line) = $self->caller(1);
844
$code .= "#line $line $file\n" if defined $file and defined $line;
852
$Test->BAIL_OUT($reason);
854
Indicates to the Test::Harness that things are going so badly all
855
testing should terminate. This includes running any additional test
858
It will exit with 255.
863
my($self, $reason) = @_;
865
$self->{Bailed_Out} = 1;
866
$self->_print("Bail out! $reason");
871
BAIL_OUT() used to be BAILOUT()
875
*BAILOUT = \&BAIL_OUT;
883
Skips the current test, reporting $why.
888
my($self, $why) = @_;
890
$self->_unoverload_str(\$why);
892
unless( $self->{Have_Plan} ) {
894
Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
897
lock($self->{Curr_Test});
898
$self->{Curr_Test}++;
900
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
909
$out .= " $self->{Curr_Test}" if $self->use_numbers;
911
$out .= " $why" if length $why;
923
$Test->todo_skip($why);
925
Like skip(), only it will declare the test as failing and TODO. Similar
928
print "not ok $tnum # TODO $why\n";
933
my($self, $why) = @_;
936
unless( $self->{Have_Plan} ) {
938
Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
941
lock($self->{Curr_Test});
942
$self->{Curr_Test}++;
944
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
953
$out .= " $self->{Curr_Test}" if $self->use_numbers;
954
$out .= " # TODO & SKIP $why\n";
962
=begin _unimplemented
967
$Test->skip_rest($reason);
969
Like skip(), only it skips all the rest of the tests you plan to run
970
and terminates the test.
972
If you're running under no_plan, it skips once and terminates the
986
$Test->level($how_high);
988
How far up the call stack should $Test look when reporting where the
993
Setting $Test::Builder::Level overrides. This is typically useful
997
local $Test::Builder::Level = 2;
1004
my($self, $level) = @_;
1006
if( defined $level ) {
1013
=item B<use_numbers>
1015
$Test->use_numbers($on_or_off);
1017
Whether or not the test should output numbers. That is, this if true:
1029
Most useful when you can't depend on the test output order, such as
1030
when threads or forking is involved.
1032
Test::Harness will accept either, but avoid mixing the two styles.
1039
my($self, $use_nums) = @_;
1041
if( defined $use_nums ) {
1042
$self->{Use_Nums} = $use_nums;
1044
return $self->{Use_Nums};
1050
$Test->no_diag($no_diag);
1052
If set true no diagnostics will be printed. This includes calls to
1057
$Test->no_ending($no_ending);
1059
Normally, Test::Builder does some extra diagnostics when the test
1060
ends. It also changes the exit code as described below.
1062
If this is true, none of that will be done.
1066
$Test->no_header($no_header);
1068
If set to true, no "1..N" header will be printed.
1072
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1073
my $method = lc $attribute;
1076
my($self, $no) = @_;
1079
$self->{$attribute} = $no;
1081
return $self->{$attribute};
1085
*{__PACKAGE__.'::'.$method} = $code;
1093
Controlling where the test output goes.
1095
It's ok for your test to change where STDOUT and STDERR point to,
1096
Test::Builder's default output settings will not be affected.
1104
Prints out the given @msgs. Like C<print>, arguments are simply
1107
Normally, it uses the failure_output() handle, but if this is for a
1108
TODO test, the todo_output() handle is used.
1110
Output will be indented and marked with a # so as not to interfere
1111
with test output. A newline will be put on the end if there isn't one
1114
We encourage using this rather than calling print directly.
1116
Returns false. Why? Because diag() is often used in conjunction with
1117
a failing test (C<ok() || diag()>) it "passes through" the failure.
1119
return ok(...) || diag(...);
1122
Mark Fowler <mark@twoshortplanks.com>
1127
my($self, @msgs) = @_;
1129
return if $self->no_diag;
1130
return unless @msgs;
1132
# Prevent printing headers when compiling (i.e. -c)
1135
# Smash args together like print does.
1136
# Convert undef to 'undef' so its readable.
1137
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1139
# Escape each line with a #.
1142
# Stick a newline on the end if it needs it.
1143
$msg .= "\n" unless $msg =~ /\n\Z/;
1145
local $Level = $Level + 1;
1146
$self->_print_diag($msg);
1155
$Test->_print(@msgs);
1157
Prints to the output() filehandle.
1164
my($self, @msgs) = @_;
1166
# Prevent printing headers when only compiling. Mostly for when
1167
# tests are deparsed with B::Deparse
1170
my $msg = join '', @msgs;
1172
local($\, $", $,) = (undef, ' ', '');
1173
my $fh = $self->output;
1175
# Escape each line after the first with a # so we don't
1176
# confuse Test::Harness.
1177
$msg =~ s/\n(.)/\n# $1/sg;
1179
# Stick a newline on the end if it needs it.
1180
$msg .= "\n" unless $msg =~ /\n\Z/;
1186
=item B<_print_diag>
1188
$Test->_print_diag(@msg);
1190
Like _print, but prints to the current diagnostic filehandle.
1197
local($\, $", $,) = (undef, ' ', '');
1198
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1205
$Test->output($file);
1207
Where normal "ok/not ok" test output should go.
1211
=item B<failure_output>
1213
$Test->failure_output($fh);
1214
$Test->failure_output($file);
1216
Where diagnostic output on test failures and diag() should go.
1220
=item B<todo_output>
1222
$Test->todo_output($fh);
1223
$Test->todo_output($file);
1225
Where diagnostics about todo test failures and diag() should go.
1232
my($self, $fh) = @_;
1235
$self->{Out_FH} = _new_fh($fh);
1237
return $self->{Out_FH};
1240
sub failure_output {
1241
my($self, $fh) = @_;
1244
$self->{Fail_FH} = _new_fh($fh);
1246
return $self->{Fail_FH};
1250
my($self, $fh) = @_;
1253
$self->{Todo_FH} = _new_fh($fh);
1255
return $self->{Todo_FH};
1260
my($file_or_fh) = shift;
1263
if( _is_fh($file_or_fh) ) {
1267
$fh = do { local *FH };
1268
open $fh, ">$file_or_fh" or
1269
die "Can't open test output log $file_or_fh: $!";
1278
my $maybe_fh = shift;
1279
return 0 unless defined $maybe_fh;
1281
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1283
return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
1284
UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
1286
# 5.5.4's tied() and can() doesn't like getting undef
1287
UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
1293
my $old_fh = select $fh;
1299
sub _dup_stdhandles {
1302
$self->_open_testhandles;
1304
# Set everything to unbuffered else plain prints to STDOUT will
1305
# come out in the wrong order from our own prints.
1306
_autoflush(\*TESTOUT);
1307
_autoflush(\*STDOUT);
1308
_autoflush(\*TESTERR);
1309
_autoflush(\*STDERR);
1311
$self->output(\*TESTOUT);
1312
$self->failure_output(\*TESTERR);
1313
$self->todo_output(\*TESTOUT);
1317
my $Opened_Testhandles = 0;
1318
sub _open_testhandles {
1319
return if $Opened_Testhandles;
1320
# We dup STDOUT and STDERR so people can change them in their
1321
# test suites while still getting normal test output.
1322
open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
1323
open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
1324
$Opened_Testhandles = 1;
1331
=head2 Test Status and Info
1335
=item B<current_test>
1337
my $curr_test = $Test->current_test;
1338
$Test->current_test($num);
1340
Gets/sets the current test number we're on. You usually shouldn't
1343
If set forward, the details of the missing tests are filled in as 'unknown'.
1344
if set backward, the details of the intervening tests are deleted. You
1345
can erase history if you really want to.
1350
my($self, $num) = @_;
1352
lock($self->{Curr_Test});
1353
if( defined $num ) {
1354
unless( $self->{Have_Plan} ) {
1356
Carp::croak("Can't change the current test number without a plan!");
1359
$self->{Curr_Test} = $num;
1361
# If the test counter is being pushed forward fill in the details.
1362
my $test_results = $self->{Test_Results};
1363
if( $num > @$test_results ) {
1364
my $start = @$test_results ? @$test_results : 0;
1365
for ($start..$num-1) {
1366
$test_results->[$_] = &share({
1369
reason => 'incrementing test number',
1375
# If backward, wipe history. Its their funeral.
1376
elsif( $num < @$test_results ) {
1377
$#{$test_results} = $num - 1;
1380
return $self->{Curr_Test};
1386
my @tests = $Test->summary;
1388
A simple summary of the tests so far. True for pass, false for fail.
1389
This is a logical pass/fail, so todos are passes.
1391
Of course, test #1 is $tests[0], etc...
1398
return map { $_->{'ok'} } @{ $self->{Test_Results} };
1403
my @tests = $Test->details;
1405
Like summary(), but with a lot more detail.
1407
$tests[$test_num - 1] =
1408
{ 'ok' => is the test considered a pass?
1409
actual_ok => did it literally say 'ok'?
1410
name => name of the test (if any)
1411
type => type of test (if any, see below).
1412
reason => reason for the above (if any)
1415
'ok' is true if Test::Harness will consider the test to be a pass.
1417
'actual_ok' is a reflection of whether or not the test literally
1418
printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1421
'name' is the name of the test.
1423
'type' indicates if it was a special test. Normal tests have a type
1424
of ''. Type can be one of the following:
1428
todo_skip see todo_skip()
1431
Sometimes the Test::Builder test counter is incremented without it
1432
printing any test output, for example, when current_test() is changed.
1433
In these cases, Test::Builder doesn't know the result of the test, so
1434
it's type is 'unkown'. These details for these tests are filled in.
1435
They are considered ok, but the name and actual_ok is left undef.
1437
For example "not ok 23 - hole count # TODO insufficient donuts" would
1438
result in this structure:
1440
$tests[22] = # 23 - 1, since arrays start from 0.
1441
{ ok => 1, # logically, the test passed since it's todo
1442
actual_ok => 0, # in absolute terms, it failed
1443
name => 'hole count',
1445
reason => 'insufficient donuts'
1452
return @{ $self->{Test_Results} };
1457
my $todo_reason = $Test->todo;
1458
my $todo_reason = $Test->todo($pack);
1460
todo() looks for a $TODO variable in your tests. If set, all tests
1461
will be considered 'todo' (see Test::More and Test::Harness for
1462
details). Returns the reason (ie. the value of $TODO) if running as
1463
todo tests, false otherwise.
1465
todo() is about finding the right package to look for $TODO in. It
1466
uses the exported_to() package to find it. If that's not set, it's
1467
pretty good at guessing the right package to look at based on $Level.
1469
Sometimes there is some confusion about where todo() should be looking
1470
for the $TODO variable. If you want to be sure, tell it explicitly
1476
my($self, $pack) = @_;
1478
$pack = $pack || $self->exported_to || $self->caller($Level);
1479
return 0 unless $pack;
1482
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1488
my $package = $Test->caller;
1489
my($pack, $file, $line) = $Test->caller;
1490
my($pack, $file, $line) = $Test->caller($height);
1492
Like the normal caller(), except it reports according to your level().
1497
my($self, $height) = @_;
1500
my @caller = CORE::caller($self->level + $height + 1);
1501
return wantarray ? @caller : $caller[0];
1512
=item B<_sanity_check>
1514
$self->_sanity_check();
1516
Runs a bunch of end of test sanity checks to make sure reality came
1517
through ok. If anything is wrong it will die with a fairly friendly
1526
_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1527
_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1528
'Somehow your tests ran without a plan!');
1529
_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1530
'Somehow you got a different number of results than tests ran!');
1535
_whoa($check, $description);
1537
A sanity check, similar to assert(). If the $check is true, something
1538
has gone horribly wrong. It will die with the given $description and
1539
a note to contact the author.
1544
my($check, $desc) = @_;
1548
This should never happen! Please contact the author immediately!
1555
_my_exit($exit_num);
1557
Perl seems to have some trouble with exiting inside an END block. 5.005_03
1558
and 5.6.1 both seem to do odd things. Instead, this function edits $?
1559
directly. It should ONLY be called from inside an END block. It
1560
doesn't actually exit, that's your job.
1577
$SIG{__DIE__} = sub {
1578
# We don't want to muck with death in an eval, but $^S isn't
1579
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1580
# with it. Instead, we use caller. This also means it runs under
1583
for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1584
$in_eval = 1 if $sub =~ /^\(eval\)/;
1586
$Test->{Test_Died} = 1 unless $in_eval;
1592
$self->_sanity_check();
1594
# Don't bother with an ending if this is a forked copy. Only the parent
1595
# should do the ending.
1596
# Exit if plan() was never called. This is so "require Test::Simple"
1598
# Don't do an ending if we bailed out.
1599
if( ($self->{Original_Pid} != $$) or
1600
(!$self->{Have_Plan} && !$self->{Test_Died}) or
1608
# Figure out if we passed or failed and print helpful messages.
1609
my $test_results = $self->{Test_Results};
1610
if( @$test_results ) {
1611
# The plan? We have no plan.
1612
if( $self->{No_Plan} ) {
1613
$self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1614
$self->{Expected_Tests} = $self->{Curr_Test};
1617
# Auto-extended arrays and elements which aren't explicitly
1618
# filled in with a shared reference will puke under 5.8.0
1619
# ithreads. So we have to fill them in by hand. :(
1620
my $empty_result = &share({});
1621
for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1622
$test_results->[$idx] = $empty_result
1623
unless defined $test_results->[$idx];
1626
my $num_failed = grep !$_->{'ok'},
1627
@{$test_results}[0..$self->{Curr_Test}-1];
1629
my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1631
if( $num_extra < 0 ) {
1632
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1633
$self->diag(<<"FAIL");
1634
Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1637
elsif( $num_extra > 0 ) {
1638
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1639
$self->diag(<<"FAIL");
1640
Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1644
if ( $num_failed ) {
1645
my $num_tests = $self->{Curr_Test};
1646
my $s = $num_failed == 1 ? '' : 's';
1648
my $qualifier = $num_extra == 0 ? '' : ' run';
1650
$self->diag(<<"FAIL");
1651
Looks like you failed $num_failed test$s of $num_tests$qualifier.
1655
if( $self->{Test_Died} ) {
1656
$self->diag(<<"FAIL");
1657
Looks like your test died just after $self->{Curr_Test}.
1660
_my_exit( 255 ) && return;
1665
$exit_code = $num_failed <= 254 ? $num_failed : 254;
1667
elsif( $num_extra != 0 ) {
1674
_my_exit( $exit_code ) && return;
1676
elsif ( $self->{Skip_All} ) {
1677
_my_exit( 0 ) && return;
1679
elsif ( $self->{Test_Died} ) {
1680
$self->diag(<<'FAIL');
1681
Looks like your test died before it could output anything.
1683
_my_exit( 255 ) && return;
1686
$self->diag("No tests run!\n");
1687
_my_exit( 255 ) && return;
1692
$Test->_ending if defined $Test and !$Test->no_ending;
1697
If all your tests passed, Test::Builder will exit with zero (which is
1698
normal). If anything failed it will exit with how many failed. If
1699
you run less (or more) tests than you planned, the missing (or extras)
1700
will be considered failures. If no tests were ever run Test::Builder
1701
will throw a warning and exit with 255. If the test died, even after
1702
having successfully completed all its tests, it will still be
1703
considered a failure and will exit with 255.
1705
So the exit codes are...
1707
0 all tests successful
1708
255 test died or all passed but wrong # of tests run
1709
any other number how many failed (including missing or extras)
1711
If you fail more than 254 tests, it will be reported as 254.
1716
In perl 5.8.0 and later, Test::Builder is thread-safe. The test
1717
number is shared amongst all threads. This means if one thread sets
1718
the test number using current_test() they will all be effected.
1720
Test::Builder is only thread-aware if threads.pm is loaded I<before>
1725
CPAN can provide the best examples. Test::Simple, Test::More,
1726
Test::Exception and Test::Differences all use Test::Builder.
1730
Test::Simple, Test::More, Test::Harness
1734
Original code by chromatic, maintained by Michael G Schwern
1735
E<lt>schwern@pobox.comE<gt>
1739
Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1740
Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1742
This program is free software; you can redistribute it and/or
1743
modify it under the same terms as Perl itself.
1745
See F<http://www.perl.com/perl/misc/Artistic.html>
added
removed
t/lib/Test/Builder.pm
