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   89070 use strict;
  8         41  
  8         294  
2 8     8   56 use warnings;
  8         20  
  8         486  
3             package Test::Kwalitee; # git description: v1.26-10-gb95ec58
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.27';
9              
10 8     8   57 use Cwd ();
  8         23  
  8         216  
11 8     8   571 use Test::Builder 0.88;
  8         43629  
  8         247  
12 8     8   2618 use Module::CPANTS::Analyse 0.92;
  8         1567735  
  8         52  
13              
14 8     8   81625 use parent 'Exporter';
  8         24  
  8         89  
15             our @EXPORT_OK = qw(kwalitee_ok);
16              
17             my $Test;
18 8     8   731 BEGIN { $Test = Test::Builder->new }
19              
20             sub import
21             {
22 10     10   15981 my ($class, @args) = @_;
23              
24             # back-compatibility mode!
25 10 100       64 if (@args % 2 == 0)
26             {
27 8         68 $Test->level($Test->level + 1);
28 8         347 my %args = @args;
29 8         23 my $result = kwalitee_ok(@{$args{tests}});
  8         34  
30 8         135 $Test->done_testing;
31 8         8846 return $result;
32             }
33              
34             # otherwise, do what a regular import would do...
35 2         2122 $class->export_to_level(1, @_);
36             }
37              
38             sub kwalitee_ok
39             {
40 10     10 1 162 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     168 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         45 my @run_tests = grep { /^[^-]/ } @tests;
  18         86  
52 10         45 my @skip_tests = map { s/^-//; $_ } grep { /^-/ } @tests;
  2         7  
  2         13  
  18         56  
53              
54             # These don't really work unless you have a tarball, so skip them
55 10         48 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         68 my @skip_flags = qw(is_extra is_experimental needs_db);
60              
61 10         48362 my $basedir = Cwd::cwd;
62              
63 10         506 my $analyzer = Module::CPANTS::Analyse->new({
64             distdir => $basedir,
65             dist => $basedir,
66             # for debugging..
67             opts => { no_capture => 1 },
68             });
69              
70 10         2377096 my $ok = 1;
71              
72 10         48 for my $generator (@{ $analyzer->mck->generators })
  10         52  
73             {
74 160         2432 $generator->analyse($analyzer);
75              
76 160         4591383 for my $indicator (sort { $a->{name} cmp $b->{name} } @{ $generator->kwalitee_indicators })
  460         4523  
  160         1197  
77             {
78 290 100       1041 next if grep { $indicator->{$_} } @skip_flags;
  870         2971  
79              
80 180 100 100     632 next if @run_tests and not grep { $indicator->{name} eq $_ } @run_tests;
  288         1876  
81              
82 52 100       120 next if grep { $indicator->{name} eq $_ } @skip_tests;
  348         804  
83              
84 48         181 my $result = _run_indicator($analyzer->d, $indicator);
85 48   100     446 $ok &&= $result;
86             }
87             }
88              
89 10         4672 return $ok;
90             }
91              
92             sub _run_indicator
93             {
94 48     48   630 my ($dist, $metric) = @_;
95              
96 48         106 my $subname = $metric->{name};
97 48         81 my $ok = 1;
98              
99 48         359 $Test->level($Test->level + 1);
100 48 100       2288 if (not $Test->ok( $metric->{code}->($dist), $subname))
101             {
102 1         863 $ok = 0;
103 1         10 $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         175 my @details;
110             push @details, $metric->{details}->($dist)
111 1 50 33     16 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     21 if defined $dist->{error} and defined $dist->{error}{$subname};
    50          
117 1 50       16 $Test->diag("Details:\n", join("\n", @details)) if @details;
118              
119 1         139 $Test->diag('Remedy: ', $metric->{remedy});
120             }
121 48         26648 $Test->level($Test->level - 1);
122              
123 48         1553 return $ok;
124             }
125              
126             1;
127              
128             __END__