File Coverage

blib/lib/Module/CPANTS/Kwalitee/Pod.pm
Criterion Covered Total %
statement 73 98 74.4
branch 41 70 58.5
condition 5 14 35.7
subroutine 11 13 84.6
pod 3 3 100.0
total 133 198 67.1


line stmt bran cond sub pod time code
1             package Module::CPANTS::Kwalitee::Pod;
2 7     7   3216 use warnings;
  7         14  
  7         198  
3 7     7   33 use strict;
  7         16  
  7         144  
4 7     7   36 use File::Spec::Functions qw/catfile/;
  7         16  
  7         321  
5 7     7   55 use Encode;
  7         17  
  7         669  
6 7     7   2571 use Data::Binary qw/is_binary/;
  7         35398  
  7         7823  
7              
8             our $VERSION = '1.01';
9             $VERSION =~ s/_//; ## no critic
10              
11             our @ABSTRACT_STUBS = (
12             q{Perl extension for blah blah blah}, # h2xs
13             q{[One line description of module's purpose here]}, # Module::Starter etc
14             q{The great new}, # Module::Starter
15             q{It's new $module}, # Minilla
16             );
17              
18 42     42 1 125 sub order { 100 }
19              
20             ##################################################################
21             # Analyse
22             ##################################################################
23              
24             sub analyse {
25 11     11 1 52 my ($class, $me) = @_;
26 11         209 my $distdir = $me->distdir;
27 11         61 my %abstract;
28             my @errors;
29 11 100       21 for my $module (@{$me->d->{modules} || []}) {
  11         178  
30 9         240 my ($package, $abstract, $error, $has_binary_data) = $class->_parse_abstract(catfile($distdir, $module->{file}));
31 9 100       44 push @errors, "$error ($package)" if $error;
32 9 100       53 $me->d->{abstracts_in_pod}{$package} = $abstract if $package;
33 9 50       39 $me->d->{files_hash}{$module->{file}}{has_binary_data} = 1 if $has_binary_data;
34             }
35              
36             # sometimes pod for .pm file is put into .pod
37 11 50       54 for my $file (@{$me->d->{files_array} || []}) {
  11         237  
38 19 50 0     166 next unless $file =~ /\.pod$/ && ($file =~ m!^lib/! or $file =~ m!^[^/]+$!);
      33        
39 0         0 local $@;
40 0         0 my ($package, $abstract, $error, $has_binary_data) = $class->_parse_abstract(catfile($distdir, $file));
41 0 0       0 push @errors, "$error ($package)" if $error;
42 0 0       0 $me->d->{abstracts_in_pod}{$package} = $abstract if $package;
43 0 0       0 $me->d->{files_hash}{$file}{has_binary_data} = 1 if $has_binary_data;
44             }
45 11 100       67 $me->d->{error}{has_abstract_in_pod} = join ';', @errors if @errors;
46             }
47              
48             # adapted from ExtUtils::MM_Unix and Module::Build::PodParser
49             sub _parse_abstract {
50 9     9   35 my ($class, $file) = @_;
51 9         37 my ($package, $abstract);
52 9         24 my $inpod = 0;
53 9 50       329 open my $fh, '<', $file or return;
54 9         30 my $directive;
55             my $encoding;
56 9         35 my $package_name_pattern = '(?:[A-Za-z0-9_]+::)*[A-Za-z0-9_]+ | [BCIF] < (?:[A-Za-z0-9_]+::)*[A-Za-z0-9_]+ >';
57 9 50       112 if ( $file !~ /\.p(?:m|od)$/ ) {
58 0         0 $package_name_pattern .= ' | [A-Za-z0-9_.-]+ | [BCIF] < [A-Za-z0-9_.-]+ >';
59             }
60 9         140 while(<$fh>) {
61 31 50       82 if (/^\s*__DATA__\s*$/) {
62 0         0 my $copy = $_ = <$fh>;
63 0 0       0 last unless defined $copy;
64 0 0       0 return (undef, undef, undef, 1) if is_binary($copy);
65             }
66 31 100       90 if (substr($_, 0, 1) eq '=') {
67 3 100       8 if (/^=encoding\s+(.+)/) {
68 1         3 $encoding = $1;
69             }
70 3 50       13 if (/^=cut/) {
    50          
71 0         0 $inpod = 0;
72             } elsif (/^=(?!cut)(.+)/) {
73 3         5 $directive = $1;
74 3         5 $inpod = 1;
75             }
76             }
77 31 100       121 next if !$inpod;
78 8 100       26 next unless $directive =~ /^head/;
79 4 100       69 if ( /^\s*(${package_name_pattern}) \s+ -+ (?:\s+ (.*)\s*$|$)/x ) {
80 1         5 ($package, $abstract) = ($1, $2);
81 1         3 $package =~ s![BCIF]<([^>]+)>!$1!;
82 1         3 next;
83             }
84 3 100       12 next unless $abstract;
85 1 50 33     5 last if /^\s*$/ || /^=/;
86 0         0 s/\s+$//s;
87 0         0 $abstract .= "\n$_";
88             }
89              
90 9         24 my $error;
91 9 100 66     32 if ($encoding && $abstract) {
92 1         5 my $encoder = find_encoding($encoding);
93 1 50       806 if (!$encoder) {
94 1         4 $error = "unknown encoding: $encoding";
95             } else {
96 0         0 $abstract = eval { $encoder->decode($abstract) };
  0         0  
97 0 0       0 if ($@) {
98 0         0 $error = $@;
99 0         0 $error =~ s|\s*at .+ line \d+.+$||s;
100             }
101             }
102             }
103 9         123 return ($package, $abstract, $error);
104             }
105              
106             ##################################################################
107             # Kwalitee Indicators
108             ##################################################################
109              
110             sub kwalitee_indicators {
111             return [
112             {
113             name => 'has_abstract_in_pod',
114             error => q{No abstract (short description of a module) is found in pod from this distribution.},
115             remedy => q{Provide a short description in the NAME section of the pod (after the module name followed by a hyphen) at least for the main module of this distribution.},
116             code => sub {
117 11     11   83 my $d = shift;
118 11 100       46 return 0 if $d->{error}{has_abstract_in_pod};
119 10 0       20 my @abstracts = grep {defined $_ && length $_} values %{$d->{abstracts_in_pod} || {}};
  0 50       0  
  10         95  
120 10 50       52 return @abstracts ? 1 : 0;
121             },
122             details => sub {
123 0     0   0 my $d = shift;
124 0         0 return "No abstracts in pod";
125             },
126             },
127             {
128             name => 'no_abstract_stub_in_pod',
129             is_extra => 1,
130             error => q{A well-known abstract stub (typically generated by an authoring tool) is found in this distribution.},
131             remedy => q{Modify the stub. You might need to modify other stubs (for name, synopsis, license, etc) as well.},
132             code => sub {
133 11     11   74 my $d = shift;
134 11         35 my %mapping = map {$_ => 1} @ABSTRACT_STUBS;
  44         270  
135 11         28 my @errors;
136 11 100       21 for (sort keys %{$d->{abstracts_in_pod} || {}}) {
  11         117  
137 1 50 50     6 push @errors, $_ if $mapping{$d->{abstracts_in_pod}{$_} || ''};
138             }
139 11 50       42 if (@errors) {
140 0         0 $d->{error}{no_abstract_stub_in_pod} = join ',', @errors;
141             }
142 11 50       60 return @errors ? 0 : 1;
143             },
144             details => sub {
145 0     0   0 my $d = shift;
146 0         0 my %mapping = map {$_ => 1} @ABSTRACT_STUBS;
  0         0  
147 0         0 return "Abstracts in the following packages are stubs:". $d->{error}{no_abstract_stub_in_pod};
148             },
149             },
150 8     8 1 141 ];
151             }
152              
153              
154             q{Favourite record of the moment:
155             Fat Freddys Drop: Based on a true story};
156              
157             __END__