File Coverage

blib/lib/Test/Some.pm
Criterion Covered Total %
statement 59 60 98.3
branch 25 26 96.1
condition n/a
subroutine 18 18 100.0
pod n/a
total 102 104 98.0


line stmt bran cond sub pod time code
1             package Test::Some;
2             our $AUTHORITY = 'cpan:YANICK';
3             # ABSTRACT: test a subset of tests
4             $Test::Some::VERSION = '0.2.1';
5 8     8   18700 use 5.10.0;
  8         19  
6              
7 8     8   32 use strict;
  8         11  
  8         137  
8 8     8   21 use warnings;
  8         7  
  8         150  
9              
10 8     8   4056 use Test::More;
  8         96268  
  8         60  
11              
12 8     8   6454 use List::MoreUtils qw/ none any /;
  8         58757  
  8         41  
13 8     8   7056 use Package::Stash;
  8         43374  
  8         1723  
14              
15             our %filters;
16              
17             our $BYPASS = 0;
18              
19             my @init_namespaces;
20              
21             sub INIT {
22             # delaying stuff to INIT
23             # because Test::Some can be loaded before Test::More if used on the
24             # prompt
25              
26 8     8   39 for my $caller ( keys %filters ) {
27 8 50       108 my $original_subtest = $caller->can('subtest')
28             or die "no function 'subtest' found in package $caller. Forgot to import Test::More?";
29              
30 8         201 Package::Stash->new($caller)->add_symbol( '&subtest' =>
31             _subtest_maker( $original_subtest, $caller )
32             );
33             }
34             }
35              
36             sub import {
37 8     8   134 my $caller = caller;
38 8         18 my(undef,@filters) = @_;
39              
40 8     8   44 no warnings 'uninitialized';
  8         63  
  8         3514  
41 8 100       32 @filters = split ',', $ENV{TEST_SOME} unless @filters;
42              
43 8         26 _groom_filter($caller,$_) for @filters;
44              
45             }
46              
47             sub _groom_filter {
48 34     34   43 my( $caller, $filter, $is_tag, $is_negated ) = @_;
49              
50 34 100       67 return $BYPASS = 1 if $filter eq '~';
51              
52 31 100       86 return _groom_filter( $caller, $filter, 1, $is_negated )
53             if $filter =~ s/^://;
54              
55 26 100       70 return _groom_filter( $caller, $filter, $is_tag, 1 )
56             if $filter =~ s/^!//;
57              
58 23 100       121 return _groom_filter( $caller, qr/$filter/, $is_tag, $is_negated )
59             if $filter =~ s#^/##;
60              
61             my $sub = ref $filter eq 'CODE' ? $filter
62             : $is_tag ? sub {
63 3         23 return ref $filter ? any { /$filter/ } keys %_
64 13 100   13   104 : $_{$filter};
65             }
66 16 100   30   81 : sub { ref $filter ? /$filter/ : $_ eq $filter };
  30 100       195  
    100          
67              
68 16 100       27 if( $is_negated ) {
69 3         4 my $prev_sub = $sub;
70 3     5   5 $sub = sub { not $prev_sub->() };
  5         9  
71             }
72              
73 16         16 push @{ $filters{$caller} }, $sub;
  16         1300  
74             }
75              
76             sub _should_be_skipped {
77 26     26   33 my( $caller, $name, @tags ) = @_;
78              
79             return none {
80 46     46   46 my $filter = $_;
81             {
82 46         34 local( $_, %_ ) = ( $name, map { $_ => 1 } @tags );
  46         69  
  21         51  
83 46         71 $filter->();
84             }
85 26         93 } eval { @{ $filters{$caller} } };
  26         21  
  26         133  
86              
87             }
88              
89             sub _subtest_maker {
90 8     8   16 my( $orig, $caller ) = @_;
91            
92             return sub {
93 26     26   21914 my ( $name, $code, @tags ) = @_;
94              
95 26 100       57 if( _should_be_skipped($caller,$name,@tags) ) {
96 7 100       149 return if $BYPASS;
97             $code = sub {
98 4     4   1399 Test::More::plan( skip_all => 'Test::Some skipping' );
99             $orig->($name, sub { } )
100 0         0 }
101 4         27 }
102              
103 23         136 $orig->( $name, $code );
104             }
105 8         184 }
106              
107             1;
108              
109             __END__