File Coverage

blib/lib/Test/Most.pm

Criterion	Covered	Total	%
statement	201	219	91.7
branch	44	58	75.8
condition	12	18	66.6
subroutine	37	41	90.2
pod	10	10	100.0
total	304	346	87.8

package Test::Most;

use warnings;
use strict;

use Test::Most::Exception 'throw_failure';

# XXX don't use 'base' as it can override signal handlers
use Test::Builder::Module;
our ( @ISA, @EXPORT, $DATA_DUMPER_NAMES_INSTALLED );
my $HAVE_TIME_HIRES;

BEGIN {

    require Test::More;
    if (Test::More->can('TB_PROVIDER_META')) {
        Test::More->import(import => [ '!explain' ]);
    }
    else {
        # There's some strange fiddling around with import(), so this allows us to
        # be nicely backwards compatible to earlier versions of Test::More.
        local @Test::More::EXPORT = grep { $_ ne 'explain' } @Test::More::EXPORT;
        Test::More->import;
    }

    eval "use Time::HiRes";
    $HAVE_TIME_HIRES = 1 unless $@;
}

use Test::Builder;
my $OK_FUNC;
BEGIN {
    $OK_FUNC = \&Test::Builder::ok;
}

our $VERSION = '0.42';
$VERSION = eval $VERSION;

BEGIN {
    @ISA    = qw(Test::Builder::Module);
    @EXPORT = (
        Test::More->can('TB_PROVIDER_META')
            ? grep { $_ ne 'TODO' } keys( %{Test::More->TB_PROVIDER_META->{attrs}})
            : @Test::More::EXPORT,
        qw<
            $TODO
            all_done
            bail_on_fail
            die_on_fail
            explain
            always_explain
            last_test_failed
            restore_fail
            set_failure_handler
            show
            always_show
        >
    );
}

sub import {
    my $class = shift;
    my $bail_set = 0;
    local @EXPORT = @EXPORT; # localize effect of %exclude_symbol

    my %modules_to_load = map { $_ => 1 } qw/
        Test::Differences
        Test::Exception
        Test::Deep
        Test::Warn
    /;
    warnings->import;
    strict->import;
    eval "use Data::Dumper::Names 0.03";
    $DATA_DUMPER_NAMES_INSTALLED = !$@;

    if ( $ENV{BAIL_ON_FAIL} ) {
        $bail_set = 1;
        bail_on_fail();
    }
    if ( !$bail_set and $ENV{DIE_ON_FAIL} ) {
        die_on_fail();
    }
    for my $i ( 0 .. $#_ ) {
        if ( 'bail' eq $_[$i] ) {
            splice @_, $i, 1;
            bail_on_fail();
            $bail_set = 1;
            last;
        }
    }
    my $caller = caller;
    for my $i ( 0 .. $#_ ) {
        if ( 'timeit' eq $_[$i] ) {
            splice @_, $i, 1;
            no strict;
            *{"${caller}::timeit"} = \&timeit;
            last;
        }
    }

    my %exclude_symbol;
    my $i = 0;

    # Pull out `import => [...]` so it doesn't fall through to plan(), which
    # doesn't understand it. The list drives export_to_level below.
    #
    # The while-with-index loop is intentional: we mutate @_ via splice as
    # we go, and this matches the existing parser further down the sub.
    my @explicit;
    while ( $i < @_ ) {
        if ( $_[$i] eq 'import' && ref $_[ $i + 1 ] eq 'ARRAY' ) {
            @explicit = @{ ( splice @_, $i, 2 )[1] };
            last;
        }
        $i++;
    }
    $i = 0;

    foreach my $do_not_import_by_default (qw/blessed reftype/) {
        if ( grep { $_ eq $do_not_import_by_default } @_, @explicit ) {
            @_ = grep { $_ ne $do_not_import_by_default } @_;
            # If the user opted in positionally AND used import => [...],
            # the explicit list is the export source — make sure the symbol
            # is in it, or it would be silently dropped.
            if ( @explicit
                && !grep { $_ eq $do_not_import_by_default } @explicit ) {
                push @explicit, $do_not_import_by_default;
            }
        }
        else {
            $exclude_symbol{$do_not_import_by_default} = 1;
        }
    }

    while ($i < @_) {
        if ( !$bail_set and ( 'die' eq $_[$i] ) ) {
            splice @_, $i, 1;
            die_on_fail();
            $i = 0;
            next;
        }
        if ( $_[$i] =~ /^-(.*)/ ) {
            my $module = $1;
            splice @_, $i, 1;
            unless (exists $modules_to_load{$module}) {
                require Carp;
                Carp::croak("Cannot remove non-existent Test::Module ($module)");
            }
            delete $modules_to_load{$module};
            $i = 0;
            next;
        }
        if ( $_[$i] =~ /^!(.*)/ ) {
            splice @_, $i, 1;
            $exclude_symbol{$1} = 1;
            $i = 0;
            next;
        }
        if ( 'defer_plan' eq $_[$i] ) {
            require Carp;
            Carp::carp(<<'END') unless $ENV{DO_NOT_WARN_ON_DEFER_PLAN};
defer_plan() is deprecated and will be removed in a future release of
Test::Most. It's functionality is provided by Test::More's done_testing(),
first added in 2009 (0.88).
END
            splice @_, $i, 1;

            my $builder = Test::Builder->new;

            # XXX I don't like setting this directly, but
            # Test::Builder::has_plan isn't public
            $builder->{Have_Plan}               = 1;
            $builder->{TEST_MOST_deferred_plan} = 1;
            $builder->{TEST_MOST_all_done}      = 0;
            $i = 0;
            next;
        }
        $i++;
    }
    local @EXPORT = @EXPORT; # localize effect of %exclude_symbol
    foreach my $module (keys %modules_to_load) {
        eval "use $module";

        if ( my $error = $@) {
            require Carp;
            Carp::croak($error);
        }
        no strict 'refs';
        push @EXPORT => grep { !$exclude_symbol{$_} } @{"${module}::EXPORT"};
    }

    my $test = $class->builder;
    $test->exported_to($caller);
    $test->plan(@_);

    # Empty @explicit covers two cases that should both fall through to the
    # default exports: no `import =>` was given, or `import => []` was given
    # (which matches Test::Builder::Module / Exporter, where an empty import
    # list means "use defaults"). When @explicit has items but `!sym`
    # exclusions empty it out, @to_export is empty and we export nothing.
    my @to_export
        = @explicit ? grep { !$exclude_symbol{$_} } @explicit : @EXPORT;
    $class->export_to_level( 1, $class, @to_export ) if @to_export;
}

sub explain {
    _explain(\&Test::More::note, @_);
}


sub timeit(&;$) {
    my ( $code, $message ) = @_;
    unless($HAVE_TIME_HIRES) {
        Test::Most::diag("timeit: Time::HiRes not installed");
        $code->();
    }
    if ( !$message ) {
        my ( $package, $filename, $line ) = caller;
        $message = "$filename line $line";
    }
    my $start = [Time::HiRes::gettimeofday()];
    $code->();
    explain(
        sprintf "$message: took %s seconds" => Time::HiRes::tv_interval($start) );
}

sub always_explain {
    _explain(\&Test::More::diag, @_);
}

sub _explain {
    my $diag = shift;
    no warnings 'once';
    $diag->(
        map {
            ref $_
              ? do {
                require Data::Dumper;
                local $Data::Dumper::Indent   = 1;
                local $Data::Dumper::Sortkeys = 1;
                local $Data::Dumper::Terse    = 1;
                Data::Dumper::Dumper($_);
              }
              : $_
          } @_
    );
}

sub show {
    _show(\&Test::More::note, @_);
}

sub always_show {
    _show(\&Test::More::diag, @_);
}

sub _show {
    unless ( $DATA_DUMPER_NAMES_INSTALLED ) {
        require Carp;
	Carp::carp("Data::Dumper::Names 0.03 not found.  Use explain() instead of show()");
        goto &_explain;
    }
    my $diag = shift;
    no warnings 'once';
    local $Data::Dumper::Indent         = 1;
    local $Data::Dumper::Sortkeys       = 1;
    local $Data::Dumper::Names::UpLevel = $Data::Dumper::Names::UpLevel + 2;
    $diag->(Data::Dumper::Names::Dumper(@_));
}

sub die_on_fail {
    set_failure_handler( sub { throw_failure } );
}

sub bail_on_fail {
    set_failure_handler(
        sub { Test::More::BAIL_OUT("Test failed.  BAIL OUT!.\n") } );
}

sub restore_fail {
    no warnings 'redefine';
    *Test::Builder::ok = $OK_FUNC;
}

sub all_done {
   my $builder = Test::Builder->new;
   if ($builder->{TEST_MOST_deferred_plan}) {
       $builder->{TEST_MOST_all_done} = 1;
       $builder->expected_tests(@_ ? $_[0] : $builder->current_test);
   }
}


sub set_failure_handler {
    my $action = shift;
    no warnings 'redefine';
    Test::Builder->new->{TEST_MOST_failure_action} = $action; # for DESTROY
    *Test::Builder::ok = sub {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        my $builder = $_[0];
        if ( $builder->{TEST_MOST_test_failed} ) {
            $builder->{TEST_MOST_test_failed} = 0;
            $action->($builder);
        }
        $builder->{TEST_MOST_test_failed} = 0;
        my $result = $OK_FUNC->(@_);
        $builder->{TEST_MOST_test_failed} = !( $builder->summary )[-1];
        return $result;
    };
}

{
    no warnings 'redefine';
    my $orig_destroy = Test::Builder->can('DESTROY');

    # we need this because if the failure is on the final test, we won't have
    # a subsequent test triggering the behavior.
    *Test::Builder::DESTROY = sub {
        my $builder = $_[0];
        if ( $builder->{TEST_MOST_test_failed} ) {
            ( $builder->{TEST_MOST_failure_action} || sub {} )->();
        }
        $orig_destroy->(@_) if $orig_destroy;
    };
}

sub _deferred_plan_handler {
   my $builder = Test::Builder->new;
   if ($builder->{TEST_MOST_deferred_plan} and !$builder->{TEST_MOST_all_done})
   {
       $builder->expected_tests($builder->current_test + 1);
   }
}

# This should work because the END block defined by Test::Builder should be
# guaranteed to be run before t one, since we use'd Test::Builder way up top.
# The other two alternatives would be either to replace Test::Builder::_ending
# similar to how we did Test::Builder::ok, or to call Test::Builder::no_ending
# and basically rewrite _ending in our own image.  Neither is very palatable,
# considering _ending's initial underscore.

END {
   _deferred_plan_handler();
}

1;
__END__