File Coverage

blib/lib/Test/Some.pm

Criterion	Covered	Total	%
statement	68	69	98.5
branch	28	30	93.3
condition			n/a
subroutine	18	18	100.0
pod			n/a
total	114	117	97.4

package Test::Some;
our $AUTHORITY = 'cpan:YANICK';
# ABSTRACT: test a subset of tests
$Test::Some::VERSION = '0.2.0';

use 5.10.0;

use strict;
use warnings;

use Test::More;

use List::MoreUtils qw/ none any /;

our %filters;

our $BYPASS = 0;

sub import {
    my $caller = caller;
    my(undef,@filters) = @_;

    no warnings 'uninitialized';
    @filters = split ',', $ENV{TEST_SOME} unless @filters;

    _groom_filter($caller,$_) for @filters;

    eval <<"END_EVAL";
        package $caller;

        # delaying stuff to INIT
        # because Test::Some can be loaded before Test::More
        INIT {
            my \$original_subtest = $caller->can('subtest')
                or die "no function 'subtest' found in package $caller. Forgot to import Test::More?";

            no warnings 'redefine';
            no strict 'refs';
            *{"${caller}::subtest"} = sub { Test::Some::_subtest( \$original_subtest, \@_ ) };
        }
END_EVAL


}

sub _groom_filter {
    my( $caller, $filter, $is_tag, $is_negated ) = @_;

    if( $filter eq '~' ) {
        $BYPASS = 1;
        return;
    }

    return _groom_filter( $caller, $filter, 1, $is_negated )
        if $filter =~ s/^://;

    return _groom_filter( $caller, $filter, $is_tag, 1 )
        if $filter =~ s/^!//;

    return _groom_filter( $caller, qr/$filter/, $is_tag, $is_negated )
        if $filter =~ s#^/##;

    my $sub = ref $filter eq 'CODE' ? $filter
            : $is_tag               ? sub {
                    if ( ref $filter ) {
                        for my $key ( keys %_ ) {
                            return 1 if $key =~ $filter;
                        }
                        return 0;
                    }

                    return $_{$filter};
                }
            :   sub { ref $filter ? /$filter/ : $_ eq $filter };

    if( $is_negated ) {
        my $prev_sub = $sub;
        $sub = sub { not $prev_sub->() };
    }

    push @{ $filters{$caller} }, $sub;
}

sub _should_be_skipped {
    my( $caller, $name, @tags ) = @_;

    for my $filter ( eval { @{ $filters{$caller}  } } ) {
        local $_ = $name;
        local %_ = map { $_ => 1 } @tags;
        return if $filter->();
    }

    return 1;
}

sub _subtest {
    my( $orig, $name, $code, @tags ) = @_;
    my $caller = caller;

    if( _should_be_skipped($caller,$name,@tags) ) {
        return if $BYPASS;
        $code = sub {
            Test::More::plan( skip_all => 'Test::Some skipping' );
            $orig->($name, sub { } )
        }
    }

    $orig->( $name, $code );
}

1;

__END__