File Coverage

blib/lib/Test/Builder/SubtestSelection.pm
Criterion Covered Total %
statement 20 20 100.0
branch 4 4 100.0
condition 6 6 100.0
subroutine 6 6 100.0
pod 1 1 100.0
total 37 37 100.0


line stmt bran cond sub pod time code
1             #<<<
2 6     6   2967 use strict; use warnings;
  6     6   41  
  6         165  
  6         38  
  6         10  
  6         483  
3             #>>>
4              
5             package Test::Builder::SubtestSelection;
6              
7             our $VERSION = '0.001001';
8              
9             BEGIN {
10 6     6   2822 require parent;
11 6         2005 local $ENV{ TB_NO_EARLY_INIT } = 1;
12 6         35 parent->import( qw( Test::Builder ) );
13             }
14 6     6   365834 use Getopt::Long qw( GetOptions :config posix_default );
  6         78376  
  6         37  
15              
16             my @subtest_selection;
17             # parse @ARGV
18             GetOptions(
19             's|subtest=s' => sub {
20             ( undef, my $opt_value ) = @_;
21             push @subtest_selection, eval { qr/$opt_value/ } ? $opt_value : "\Q$opt_value\E";
22             }
23             );
24              
25 6     6   106 sub import { shift->new; }
26              
27             # override Test::Builder::subtest()
28             sub subtest {
29 13     13 1 31563 my ( $self, $name ) = @_;
30              
31 13         35 my $class = ref $self;
32 13         40 my $current_test = $self->current_test + 1;
33 13 100 100     1493 if (
      100        
34             defined $self->parent # ignore nested subtests
35             or not @subtest_selection
36 12 100       1486 or grep { m/\A [1-9]\d* \z/x ? $current_test == $_ : $name =~ m/$_/ } @subtest_selection
37             )
38             {
39 9         499 goto $class->can( 'SUPER::subtest' );
40             } else {
41 4         35 $self->skip( "forced by $class", $name );
42             }
43             }
44              
45             1;