package Test::Builder;
use 5.006;
use strict;
use warnings;
our $VERSION = '0.92';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
if( $] < 5.008 ) {
require Test::Builder::IO::Scalar;
}
}
# Make Test::Builder thread-safe for ithreads.
BEGIN {
use Config;
# Load threads::shared when threads are turned on.
# 5.8.0's threads are so busted we no longer support them.
if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
# occassionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
my $data;
if( $type eq 'HASH' ) {
%$data = %{ $_[0] };
}
elsif( $type eq 'ARRAY' ) {
@$data = @{ $_[0] };
}
elsif( $type eq 'SCALAR' ) {
$$data = ${ $_[0] };
}
else {
die( "Unknown type: " . $type );
}
$_[0] = &threads::shared::share( $_[0] );
if( $type eq 'HASH' ) {
%{ $_[0] } = %$data;
}
elsif( $type eq 'ARRAY' ) {
@{ $_[0] } = @$data;
}
elsif( $type eq 'SCALAR' ) {
${ $_[0] } = $$data;
}
else {
die( "Unknown type: " . $type );
}
return $_[0];
};
}
# 5.8.0's threads::shared is busted when threads are off
# and earlier Perls just don't have that module at all.
else {
*share = sub { return $_[0] };
*lock = sub { 0 };
}
}
=head1 NAME
Test::Builder - Backend for building test libraries
=head1 SYNOPSIS
package My::Test::Module;
use base 'Test::Builder::Module';
my $CLASS = __PACKAGE__;
sub ok {
my($test, $name) = @_;
my $tb = $CLASS->builder;
$tb->ok($test, $name);
}
=head1 DESCRIPTION
Test::Simple and Test::More have proven to be popular testing modules,
but they're not always flexible enough. Test::Builder provides the a
building block upon which to write your own test libraries I.
=head2 Construction
=over 4
=item B
my $Test = Test::Builder->new;
Returns a Test::Builder object representing the current state of the
test.
Since you only run one test per program C always returns the same
Test::Builder object. No matter how many times you call C, you're
getting the same object. This is called a singleton. This is done so that
multiple modules share such global information as the test counter and
where test output is going.
If you want a completely new Test::Builder object different from the
singleton, use C.
=cut
my $Test = Test::Builder->new;
sub new {
my($class) = shift;
$Test ||= $class->create;
return $Test;
}
=item B
my $Test = Test::Builder->create;
Ok, so there can be more than one Test::Builder object and this is how
you get it. You might use this instead of C if you're testing
a Test::Builder based module, but otherwise you probably want C.
B: the implementation is not complete. C, for example, is
still shared amongst B Test::Builder objects, even ones created using
this method. Also, the method name may change in the future.
=cut
sub create {
my $class = shift;
my $self = bless {}, $class;
$self->reset;
return $self;
}
=item B
$Test->reset;
Reinitializes the Test::Builder singleton to its original state.
Mostly useful for tests run in persistent environments where the same
test might be run multiple times in the same process.
=cut
our $Level;
sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
my($self) = @_;
# We leave this a global because it has to be localized and localizing
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Have_Output_Plan} = 0;
$self->{Original_Pid} = $$;
share( $self->{Curr_Test} );
$self->{Curr_Test} = 0;
$self->{Test_Results} = &share( [] );
$self->{Exported_To} = undef;
$self->{Expected_Tests} = 0;
$self->{Skip_All} = 0;
$self->{Use_Nums} = 1;
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
$self->{Todo} = undef;
$self->{Todo_Stack} = [];
$self->{Start_Todo} = 0;
$self->{Opened_Testhandles} = 0;
$self->_dup_stdhandles;
return;
}
=back
=head2 Setting up tests
These methods are for setting up tests and declaring how many there
are. You usually only want to call one of these methods.
=over 4
=item B
$Test->plan('no_plan');
$Test->plan( skip_all => $reason );
$Test->plan( tests => $num_tests );
A convenient way to set up your tests. Call this and Test::Builder
will print the appropriate headers and take the appropriate actions.
If you call C, don't call any of the other methods below.
=cut
my %plan_cmds = (
no_plan => \&no_plan,
skip_all => \&skip_all,
tests => \&_plan_tests,
);
sub plan {
my( $self, $cmd, $arg ) = @_;
return unless $cmd;
local $Level = $Level + 1;
$self->croak("You tried to plan twice") if $self->{Have_Plan};
if( my $method = $plan_cmds{$cmd} ) {
local $Level = $Level + 1;
$self->$method($arg);
}
else {
my @args = grep { defined } ( $cmd, $arg );
$self->croak("plan() doesn't understand @args");
}
return 1;
}
sub _plan_tests {
my($self, $arg) = @_;
if($arg) {
local $Level = $Level + 1;
return $self->expected_tests($arg);
}
elsif( !defined $arg ) {
$self->croak("Got an undefined number of tests");
}
else {
$self->croak("You said to run 0 tests");
}
return;
}
=item B
my $max = $Test->expected_tests;
$Test->expected_tests($max);
Gets/sets the number of tests we expect this test to run and prints out
the appropriate headers.
=cut
sub expected_tests {
my $self = shift;
my($max) = @_;
if(@_) {
$self->croak("Number of tests must be a positive integer. You gave it '$max'")
unless $max =~ /^\+?\d+$/;
$self->{Expected_Tests} = $max;
$self->{Have_Plan} = 1;
$self->_output_plan($max) unless $self->no_header;
}
return $self->{Expected_Tests};
}
=item B
$Test->no_plan;
Declares that this test will run an indeterminate number of tests.
=cut
sub no_plan {
my($self, $arg) = @_;
$self->carp("no_plan takes no arguments") if $arg;
$self->{No_Plan} = 1;
$self->{Have_Plan} = 1;
return 1;
}
=begin private
=item B<_output_plan>
$tb->_output_plan($max);
$tb->_output_plan($max, $directive);
$tb->_output_plan($max, $directive => $reason);
Handles displaying the test plan.
If a C<$directive> and/or C<$reason> are given they will be output with the
plan. So here's what skipping all tests looks like:
$tb->_output_plan(0, "SKIP", "Because I said so");
It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
output.
=end private
=cut
sub _output_plan {
my($self, $max, $directive, $reason) = @_;
$self->carp("The plan was already output") if $self->{Have_Output_Plan};
my $plan = "1..$max";
$plan .= " # $directive" if defined $directive;
$plan .= " $reason" if defined $reason;
$self->_print("$plan\n");
$self->{Have_Output_Plan} = 1;
return;
}
=item B
$Test->done_testing();
$Test->done_testing($num_tests);
Declares that you are done testing, no more tests will be run after this point.
If a plan has not yet been output, it will do so.
$num_tests is the number of tests you planned to run. If a numbered
plan was already declared, and if this contradicts, a failing test
will be run to reflect the planning mistake. If C was declared,
this will override.
If C is called twice, the second call will issue a
failing test.
If C<$num_tests> is omitted, the number of tests run will be used, like
no_plan.
C is, in effect, used when you'd want to use C, but
safer. You'd use it like so:
$Test->ok($a == $b);
$Test->done_testing();
Or to plan a variable number of tests:
for my $test (@tests) {
$Test->ok($test);
}
$Test->done_testing(@tests);
=cut
sub done_testing {
my($self, $num_tests) = @_;
# If done_testing() specified the number of tests, shut off no_plan.
if( defined $num_tests ) {
$self->{No_Plan} = 0;
}
else {
$num_tests = $self->current_test;
}
if( $self->{Done_Testing} ) {
my($file, $line) = @{$self->{Done_Testing}}[1,2];
$self->ok(0, "done_testing() was already called at $file line $line");
return;
}
$self->{Done_Testing} = [caller];
if( $self->expected_tests && $num_tests != $self->expected_tests ) {
$self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
"but done_testing() expects $num_tests");
}
else {
$self->{Expected_Tests} = $num_tests;
}
$self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
$self->{Have_Plan} = 1;
return 1;
}
=item B
$plan = $Test->has_plan
Find out whether a plan has been defined. C<$plan> is either C (no plan
has been set), C (indeterminate # of tests) or an integer (the number
of expected tests).
=cut
sub has_plan {
my $self = shift;
return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
return('no_plan') if $self->{No_Plan};
return(undef);
}
=item B
$Test->skip_all;
$Test->skip_all($reason);
Skips all the tests, using the given C<$reason>. Exits immediately with 0.
=cut
sub skip_all {
my( $self, $reason ) = @_;
$self->{Skip_All} = 1;
$self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
exit(0);
}
=item B
my $pack = $Test->exported_to;
$Test->exported_to($pack);
Tells Test::Builder what package you exported your functions to.
This method isn't terribly useful since modules which share the same
Test::Builder object might get exported to different packages and only
the last one will be honored.
=cut
sub exported_to {
my( $self, $pack ) = @_;
if( defined $pack ) {
$self->{Exported_To} = $pack;
}
return $self->{Exported_To};
}
=back
=head2 Running tests
These actually run the tests, analogous to the functions in Test::More.
They all return true if the test passed, false if the test failed.
C<$name> is always optional.
=over 4
=item B
$Test->ok($test, $name);
Your basic test. Pass if C<$test> is true, fail if $test is false. Just
like Test::Simple's C.
=cut
sub ok {
my( $self, $test, $name ) = @_;
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
lock $self->{Curr_Test};
$self->{Curr_Test}++;
# In case $name is a string overloaded object, force it to stringify.
$self->_unoverload_str( \$name );
$self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
You named your test '$name'. You shouldn't use numbers for your test names.
Very confusing.
ERR
# Capture the value of $TODO for the rest of this ok() call
# so it can more easily be found by other routines.
my $todo = $self->todo();
my $in_todo = $self->in_todo;
local $self->{Todo} = $todo if $in_todo;
$self->_unoverload_str( \$todo );
my $out;
my $result = &share( {} );
unless($test) {
$out .= "not ";
@$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
}
else {
@$result{ 'ok', 'actual_ok' } = ( 1, $test );
}
$out .= "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
if( defined $name ) {
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
$out .= " - $name";
$result->{name} = $name;
}
else {
$result->{name} = '';
}
if( $self->in_todo ) {
$out .= " # TODO $todo";
$result->{reason} = $todo;
$result->{type} = 'todo';
}
else {
$result->{reason} = '';
$result->{type} = '';
}
$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
$out .= "\n";
$self->_print($out);
unless($test) {
my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
$self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
my( undef, $file, $line ) = $self->caller;
if( defined $name ) {
$self->diag(qq[ $msg test '$name'\n]);
$self->diag(qq[ at $file line $line.\n]);
}
else {
$self->diag(qq[ $msg test at $file line $line.\n]);
}
}
return $test ? 1 : 0;
}
sub _unoverload {
my $self = shift;
my $type = shift;
$self->_try(sub { require overload; }, die_on_fail => 1);
foreach my $thing (@_) {
if( $self->_is_object($$thing) ) {
if( my $string_meth = overload::Method( $$thing, $type ) ) {
$$thing = $$thing->$string_meth();
}
}
}
return;
}
sub _is_object {
my( $self, $thing ) = @_;
return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
}
sub _unoverload_str {
my $self = shift;
return $self->_unoverload( q[""], @_ );
}
sub _unoverload_num {
my $self = shift;
$self->_unoverload( '0+', @_ );
for my $val (@_) {
next unless $self->_is_dualvar($$val);
$$val = $$val + 0;
}
return;
}
# This is a hack to detect a dualvar such as $!
sub _is_dualvar {
my( $self, $val ) = @_;
# Objects are not dualvars.
return 0 if ref $val;
no warnings 'numeric';
my $numval = $val + 0;
return $numval != 0 and $numval ne $val ? 1 : 0;
}
=item B
$Test->is_eq($got, $expected, $name);
Like Test::More's C. Checks if C<$got eq $expected>. This is the
string version.
=item B
$Test->is_num($got, $expected, $name);
Like Test::More's C. Checks if C<$got == $expected>. This is the
numeric version.
=cut
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
$self->_unoverload_str( \$got, \$expect );
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok( $test, $name );
$self->_is_diag( $got, 'eq', $expect ) unless $test;
return $test;
}
return $self->cmp_ok( $got, 'eq', $expect, $name );
}
sub is_num {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
$self->_unoverload_num( \$got, \$expect );
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok( $test, $name );
$self->_is_diag( $got, '==', $expect ) unless $test;
return $test;
}
return $self->cmp_ok( $got, '==', $expect, $name );
}
sub _diag_fmt {
my( $self, $type, $val ) = @_;
if( defined $$val ) {
if( $type eq 'eq' or $type eq 'ne' ) {
# quote and force string context
$$val = "'$$val'";
}
else {
# force numeric context
$self->_unoverload_num($val);
}
}
else {
$$val = 'undef';
}
return;
}
sub _is_diag {
my( $self, $got, $type, $expect ) = @_;
$self->_diag_fmt( $type, $_ ) for \$got, \$expect;
local $Level = $Level + 1;
return $self->diag(<<"DIAGNOSTIC");
got: $got
expected: $expect
DIAGNOSTIC
}
sub _isnt_diag {
my( $self, $got, $type ) = @_;
$self->_diag_fmt( $type, \$got );
local $Level = $Level + 1;
return $self->diag(<<"DIAGNOSTIC");
got: $got
expected: anything else
DIAGNOSTIC
}
=item B
$Test->isnt_eq($got, $dont_expect, $name);
Like Test::More's C. Checks if C<$got ne $dont_expect>. This is
the string version.
=item B
$Test->isnt_num($got, $dont_expect, $name);
Like Test::More's C. Checks if C<$got ne $dont_expect>. This is
the numeric version.
=cut
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok( $test, $name );
$self->_isnt_diag( $got, 'ne' ) unless $test;
return $test;
}
return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
}
sub isnt_num {
my( $self, $got, $dont_expect, $name ) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok( $test, $name );
$self->_isnt_diag( $got, '!=' ) unless $test;
return $test;
}
return $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
=item B
$Test->like($this, qr/$regex/, $name);
$Test->like($this, '/$regex/', $name);
Like Test::More's C. Checks if $this matches the given C<$regex>.
You'll want to avoid C if you want your tests to work before 5.005.
=item B
$Test->unlike($this, qr/$regex/, $name);
$Test->unlike($this, '/$regex/', $name);
Like Test::More's C. Checks if $this B the
given C<$regex>.
=cut
sub like {
my( $self, $this, $regex, $name ) = @_;
local $Level = $Level + 1;
return $self->_regex_ok( $this, $regex, '=~', $name );
}
sub unlike {
my( $self, $this, $regex, $name ) = @_;
local $Level = $Level + 1;
return $self->_regex_ok( $this, $regex, '!~', $name );
}
=item B
$Test->cmp_ok($this, $type, $that, $name);
Works just like Test::More's C.
$Test->cmp_ok($big_num, '!=', $other_big_num);
=cut
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
sub cmp_ok {
my( $self, $got, $type, $expect, $name ) = @_;
my $test;
my $error;
{
## no critic (BuiltinFunctions::ProhibitStringyEval)
local( $@, $!, $SIG{__DIE__} ); # isolate eval
my($pack, $file, $line) = $self->caller();
$test = eval qq[
#line 1 "cmp_ok [from $file line $line]"
\$got $type \$expect;
];
$error = $@;
}
local $Level = $Level + 1;
my $ok = $self->ok( $test, $name );
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
my $unoverload
= $numeric_cmps{$type}
? '_unoverload_num'
: '_unoverload_str';
$self->diag(<<"END") if $error;
An error occurred while using $type:
------------------------------------
$error
------------------------------------
END
unless($ok) {
$self->$unoverload( \$got, \$expect );
if( $type =~ /^(eq|==)$/ ) {
$self->_is_diag( $got, $type, $expect );
}
elsif( $type =~ /^(ne|!=)$/ ) {
$self->_isnt_diag( $got, $type );
}
else {
$self->_cmp_diag( $got, $type, $expect );
}
}
return $ok;
}
sub _cmp_diag {
my( $self, $got, $type, $expect ) = @_;
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
local $Level = $Level + 1;
return $self->diag(<<"DIAGNOSTIC");
$got
$type
$expect
DIAGNOSTIC
}
sub _caller_context {
my $self = shift;
my( $pack, $file, $line ) = $self->caller(1);
my $code = '';
$code .= "#line $line $file\n" if defined $file and defined $line;
return $code;
}
=back
=head2 Other Testing Methods
These are methods which are used in the course of writing a test but are not themselves tests.
=over 4
=item B
$Test->BAIL_OUT($reason);
Indicates to the Test::Harness that things are going so badly all
testing should terminate. This includes running any additional test
scripts.
It will exit with 255.
=cut
sub BAIL_OUT {
my( $self, $reason ) = @_;
$self->{Bailed_Out} = 1;
$self->_print("Bail out! $reason");
exit 255;
}
=for deprecated
BAIL_OUT() used to be BAILOUT()
=cut
*BAILOUT = \&BAIL_OUT;
=item B
$Test->skip;
$Test->skip($why);
Skips the current test, reporting C<$why>.
=cut
sub skip {
my( $self, $why ) = @_;
$why ||= '';
$self->_unoverload_str( \$why );
lock( $self->{Curr_Test} );
$self->{Curr_Test}++;
$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
{
'ok' => 1,
actual_ok => 1,
name => '',
type => 'skip',
reason => $why,
}
);
my $out = "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # skip";
$out .= " $why" if length $why;
$out .= "\n";
$self->_print($out);
return 1;
}
=item B
$Test->todo_skip;
$Test->todo_skip($why);
Like C, only it will declare the test as failing and TODO. Similar
to
print "not ok $tnum # TODO $why\n";
=cut
sub todo_skip {
my( $self, $why ) = @_;
$why ||= '';
lock( $self->{Curr_Test} );
$self->{Curr_Test}++;
$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
{
'ok' => 1,
actual_ok => 0,
name => '',
type => 'todo_skip',
reason => $why,
}
);
my $out = "not ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # TODO & SKIP $why\n";
$self->_print($out);
return 1;
}
=begin _unimplemented
=item B
$Test->skip_rest;
$Test->skip_rest($reason);
Like C, only it skips all the rest of the tests you plan to run
and terminates the test.
If you're running under C, it skips once and terminates the
test.
=end _unimplemented
=back
=head2 Test building utility methods
These methods are useful when writing your own test methods.
=over 4
=item B
$Test->maybe_regex(qr/$regex/);
$Test->maybe_regex('/$regex/');
Convenience method for building testing functions that take regular
expressions as arguments, but need to work before perl 5.005.
Takes a quoted regular expression produced by C, or a string
representing a regular expression.
Returns a Perl value which may be used instead of the corresponding
regular expression, or C if its argument is not recognised.
For example, a version of C, sans the useful diagnostic messages,
could be written as:
sub laconic_like {
my ($self, $this, $regex, $name) = @_;
my $usable_regex = $self->maybe_regex($regex);
die "expecting regex, found '$regex'\n"
unless $usable_regex;
$self->ok($this =~ m/$usable_regex/, $name);
}
=cut
sub maybe_regex {
my( $self, $regex ) = @_;
my $usable_regex = undef;
return $usable_regex unless defined $regex;
my( $re, $opts );
# Check for qr/foo/
if( _is_qr($regex) ) {
$usable_regex = $regex;
}
# Check for '/foo/' or 'm,foo,'
elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
)
{
$usable_regex = length $opts ? "(?$opts)$re" : $re;
}
return $usable_regex;
}
sub _is_qr {
my $regex = shift;
# is_regexp() checks for regexes in a robust manner, say if they're
# blessed.
return re::is_regexp($regex) if defined &re::is_regexp;
return ref $regex eq 'Regexp';
}
sub _regex_ok {
my( $self, $this, $regex, $cmp, $name ) = @_;
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
unless( defined $usable_regex ) {
local $Level = $Level + 1;
$ok = $self->ok( 0, $name );
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
{
## no critic (BuiltinFunctions::ProhibitStringyEval)
my $test;
my $code = $self->_caller_context;
local( $@, $!, $SIG{__DIE__} ); # isolate eval
# Yes, it has to look like this or 5.4.5 won't see the #line
# directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
$test = !$test if $cmp eq '!~';
local $Level = $Level + 1;
$ok = $self->ok( $test, $name );
}
unless($ok) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
local $Level = $Level + 1;
$self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
%s
%13s '%s'
DIAGNOSTIC
}
return $ok;
}
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
=begin private
=item B<_try>
my $return_from_code = $Test->try(sub { code });
my($return_from_code, $error) = $Test->try(sub { code });
Works like eval BLOCK except it ensures it has no effect on the rest
of the test (ie. C<$@> is not set) nor is effected by outside
interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
Perls.
C<$error> is what would normally be in C<$@>.
It is suggested you use this in place of eval BLOCK.
=cut
sub _try {
my( $self, $code, %opts ) = @_;
my $error;
my $return;
{
local $!; # eval can mess up $!
local $@; # don't set $@ in the test
local $SIG{__DIE__}; # don't trip an outside DIE handler.
$return = eval { $code->() };
$error = $@;
}
die $error if $error and $opts{die_on_fail};
return wantarray ? ( $return, $error ) : $return;
}
=end private
=item B
my $is_fh = $Test->is_fh($thing);
Determines if the given C<$thing> can be used as a filehandle.
=cut
sub is_fh {
my $self = shift;
my $maybe_fh = shift;
return 0 unless defined $maybe_fh;
return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
return eval { $maybe_fh->isa("IO::Handle") } ||
# 5.5.4's tied() and can() doesn't like getting undef
eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
}
=back
=head2 Test style
=over 4
=item B
$Test->level($how_high);
How far up the call stack should C<$Test> look when reporting where the
test failed.
Defaults to 1.
Setting L<$Test::Builder::Level> overrides. This is typically useful
localized:
sub my_ok {
my $test = shift;
local $Test::Builder::Level = $Test::Builder::Level + 1;
$TB->ok($test);
}
To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
=cut
sub level {
my( $self, $level ) = @_;
if( defined $level ) {
$Level = $level;
}
return $Level;
}
=item B
$Test->use_numbers($on_or_off);
Whether or not the test should output numbers. That is, this if true:
ok 1
ok 2
ok 3
or this if false
ok
ok
ok
Most useful when you can't depend on the test output order, such as
when threads or forking is involved.
Defaults to on.
=cut
sub use_numbers {
my( $self, $use_nums ) = @_;
if( defined $use_nums ) {
$self->{Use_Nums} = $use_nums;
}
return $self->{Use_Nums};
}
=item B
$Test->no_diag($no_diag);
If set true no diagnostics will be printed. This includes calls to
C.
=item B
$Test->no_ending($no_ending);
Normally, Test::Builder does some extra diagnostics when the test
ends. It also changes the exit code as described below.
If this is true, none of that will be done.
=item B
$Test->no_header($no_header);
If set to true, no "1..N" header will be printed.
=cut
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
my $code = sub {
my( $self, $no ) = @_;
if( defined $no ) {
$self->{$attribute} = $no;
}
return $self->{$attribute};
};
no strict 'refs'; ## no critic
*{ __PACKAGE__ . '::' . $method } = $code;
}
=back
=head2 Output
Controlling where the test output goes.
It's ok for your test to change where STDOUT and STDERR point to,
Test::Builder's default output settings will not be affected.
=over 4
=item B
$Test->diag(@msgs);
Prints out the given C<@msgs>. Like C, arguments are simply
appended together.
Normally, it uses the C handle, but if this is for a
TODO test, the C handle is used.
Output will be indented and marked with a # so as not to interfere
with test output. A newline will be put on the end if there isn't one
already.
We encourage using this rather than calling print directly.
Returns false. Why? Because C is often used in conjunction with
a failing test (C) it "passes through" the failure.
return ok(...) || diag(...);
=for blame transfer
Mark Fowler
=cut
sub diag {
my $self = shift;
$self->_print_comment( $self->_diag_fh, @_ );
}
=item B
$Test->note(@msgs);
Like C, but it prints to the C handle so it will not
normally be seen by the user except in verbose mode.
=cut
sub note {
my $self = shift;
$self->_print_comment( $self->output, @_ );
}
sub _diag_fh {
my $self = shift;
local $Level = $Level + 1;
return $self->in_todo ? $self->todo_output : $self->failure_output;
}
sub _print_comment {
my( $self, $fh, @msgs ) = @_;
return if $self->no_diag;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Smash args together like print does.
# Convert undef to 'undef' so its readable.
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
# Escape the beginning, _print will take care of the rest.
$msg =~ s/^/# /;
local $Level = $Level + 1;
$self->_print_to_fh( $fh, $msg );
return 0;
}
=item B
my @dump = $Test->explain(@msgs);
Will dump the contents of any references in a human readable format.
Handy for things like...
is_deeply($have, $want) || diag explain $have;
or
is_deeply($have, $want) || note explain $have;
=cut
sub explain {
my $self = shift;
return map {
ref $_
? do {
$self->_try(sub { require Data::Dumper }, die_on_fail => 1);
my $dumper = Data::Dumper->new( [$_] );
$dumper->Indent(1)->Terse(1);
$dumper->Sortkeys(1) if $dumper->can("Sortkeys");
$dumper->Dump;
}
: $_
} @_;
}
=begin _private
=item B<_print>
$Test->_print(@msgs);
Prints to the C filehandle.
=end _private
=cut
sub _print {
my $self = shift;
return $self->_print_to_fh( $self->output, @_ );
}
sub _print_to_fh {
my( $self, $fh, @msgs ) = @_;
# Prevent printing headers when only compiling. Mostly for when
# tests are deparsed with B::Deparse
return if $^C;
my $msg = join '', @msgs;
local( $\, $", $, ) = ( undef, ' ', '' );
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
$msg =~ s{\n(?!\z)}{\n# }sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\z/;
return print $fh $msg;
}
=item B