File Coverage

blib/lib/Test/Kwalitee.pm
Criterion Covered Total %
statement 70 71 98.5
branch 15 20 75.0
condition 18 27 66.6
subroutine 10 10 100.0
pod 1 1 100.0
total 114 129 88.3


line stmt bran cond sub pod time code
1 8     8   73343 use strict;
  8         31  
  8         241  
2 8     8   52 use warnings;
  8         15  
  8         384  
3             package Test::Kwalitee; # git description: v1.27-5-ge8333c9
4             # vim: set ts=8 sts=4 sw=4 tw=115 et :
5             # ABSTRACT: Test the Kwalitee of a distribution before you release it
6             # KEYWORDS: testing tests kwalitee CPANTS quality lint errors critic
7              
8             our $VERSION = '1.28';
9              
10 8     8   60 use Cwd ();
  8         14  
  8         197  
11 8     8   631 use Test::Builder 0.88;
  8         57614  
  8         221  
12 8     8   3501 use Module::CPANTS::Analyse 0.92;
  8         1479258  
  8         52  
13              
14 8     8   2362284 use parent 'Exporter';
  8         21  
  8         66  
15             our @EXPORT_OK = qw(kwalitee_ok);
16              
17             my $Test;
18 8     8   848 BEGIN { $Test = Test::Builder->new }
19              
20             sub import
21             {
22 10     10   17350 my ($class, @args) = @_;
23              
24             # back-compatibility mode!
25 10 100       55 if (@args % 2 == 0)
26             {
27 8         67 $Test->level($Test->level + 1);
28 8         309 my %args = @args;
29 8         20 my $result = kwalitee_ok(@{$args{tests}});
  8         37  
30 8         188 $Test->done_testing;
31 8         10041 return $result;
32             }
33              
34             # otherwise, do what a regular import would do...
35 2         2540 $class->export_to_level(1, @_);
36             }
37              
38             sub kwalitee_ok
39             {
40 10     10 1 146 my (@tests) = @_;
41              
42             warn "These tests should not be running unless AUTHOR_TESTING=1 and/or RELEASE_TESTING=1!\n"
43             # this setting is internal and for this distribution only - there is
44             # no reason for you to need to circumvent this check in any other context.
45             # Please DO NOT enable this test to run for users, as it can fail
46             # unexpectedly as parts of the toolchain changes!
47             unless $ENV{_KWALITEE_NO_WARN} or $ENV{AUTHOR_TESTING} or $ENV{RELEASE_TESTING}
48 10 100 66     128 or (caller)[1] =~ m{^(?:\.[/\\])?xt\b}
      33        
      66        
      66        
      100        
49             or ((caller)[0]->isa(__PACKAGE__) and (caller(1))[1] =~ m{^(?:\.[/\\])?xt\b});
50              
51 10         34 my @run_tests = grep { /^[^-]/ } @tests;
  18         73  
52 10         27 my @skip_tests = map { s/^-//; $_ } grep { /^-/ } @tests;
  2         6  
  2         7  
  18         52  
53              
54             # These don't really work unless you have a tarball, so skip them
55 10         44 push @skip_tests, qw(extractable extracts_nicely no_generated_files
56             has_proper_version has_version manifest_matches_dist);
57              
58             # MCA has a patch to add 'needs_tarball', 'no_build' as flags
59 10         27 my @skip_flags = qw(is_extra is_experimental needs_db);
60              
61 10         48475 my $basedir = Cwd::cwd;
62              
63 10         899 my $analyzer = Module::CPANTS::Analyse->new({
64             distdir => $basedir,
65             dist => $basedir,
66             # for debugging..
67             opts => { no_capture => 1 },
68             });
69              
70 10         2856 my $ok = 1;
71              
72 10         104 for my $generator (@{ $analyzer->mck->generators })
  10         341  
73             {
74 160         4118 $generator->analyse($analyzer);
75              
76 160         6599798 for my $indicator (sort { $a->{name} cmp $b->{name} } @{ $generator->kwalitee_indicators })
  430         7446  
  160         1535  
77             {
78 300 100       1175 next if grep { $indicator->{$_} } @skip_flags;
  900         2624  
79              
80 180 100 100     538 next if @run_tests and not grep { $indicator->{name} eq $_ } @run_tests;
  288         1601  
81              
82 52 100       114 next if grep { $indicator->{name} eq $_ } @skip_tests;
  348         698  
83              
84 48         1188 my $result = _run_indicator($analyzer->d, $indicator);
85 48   100     478 $ok &&= $result;
86             }
87             }
88              
89 10         3733 return $ok;
90             }
91              
92             sub _run_indicator
93             {
94 48     48   345 my ($dist, $metric) = @_;
95              
96 48         110 my $subname = $metric->{name};
97 48         93 my $ok = 1;
98              
99 48         438 $Test->level($Test->level + 1);
100 48 100       1985 if (not $Test->ok( $metric->{code}->($dist), $subname))
101             {
102 1         955 $ok = 0;
103 1         15 $Test->diag('Error: ', $metric->{error});
104              
105             # NOTE: this is poking into the analyse structures; we really should
106             # have a formal API for accessing this.
107              
108             # attempt to print all the extra information we have
109 1         186 my @details;
110             push @details, $metric->{details}->($dist)
111 1 50 33     19 if $metric->{details} and ref $metric->{details} eq 'CODE';
112             push @details,
113             (ref $dist->{error}{$subname}
114 0         0 ? @{$dist->{error}{$subname}}
115             : $dist->{error}{$subname})
116 1 0 33     22 if defined $dist->{error} and defined $dist->{error}{$subname};
    50          
117 1 50       10 $Test->diag("Details:\n", join("\n", @details)) if @details;
118              
119 1         149 $Test->diag('Remedy: ', $metric->{remedy});
120             }
121 48         25092 $Test->level($Test->level - 1);
122              
123 48         1684 return $ok;
124             }
125              
126             1;
127              
128             __END__