File Coverage

blib/lib/CPANPLUS/Dist/Debora/Pod.pm
Criterion Covered Total %
statement 126 128 98.4
branch 24 36 66.6
condition n/a
subroutine 18 18 100.0
pod 8 8 100.0
total 176 190 92.6


line stmt bran cond sub pod time code
1             package CPANPLUS::Dist::Debora::Pod;
2              
3             # SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
4              
5 9     9   1261 use 5.016;
  9         38  
6 9     9   56 use warnings;
  9         31  
  9         347  
7 9     9   56 use utf8;
  9         22  
  9         71  
8              
9             our $VERSION = '0.011';
10              
11 9     9   849 use parent qw(Pod::Simple);
  9         347  
  9         71  
12              
13 9     9   284950 use Pod::Simple;
  9         28  
  9         220  
14 9     9   5950 use Pod::Simple::Search;
  9         56706  
  9         17899  
15              
16             sub find {
17 4     4 1 118 my ($class, $module_name, @dirs) = @_;
18              
19 4         18 my $pod;
20              
21 4         119 my $podfile = Pod::Simple::Search->new->inc(0)->find($module_name, @dirs);
22 4 50       2967 if ($podfile) {
23 4         34 $pod = CPANPLUS::Dist::Debora::Pod->new;
24 4         70 $pod->parse_file($podfile);
25             }
26              
27 4         179 return $pod;
28             }
29              
30             sub new {
31 4     4 1 15 my $class = shift;
32              
33 4         104 my $self = $class->SUPER::new(@_);
34              
35 4         497 $self->{buf} = q{};
36 4         34 $self->{text} = q{};
37              
38 4         17 return $self;
39             }
40              
41             sub text {
42 4     4 1 11 my $self = shift;
43              
44 4         37 return $self->{text};
45             }
46              
47             sub title {
48 2     2 1 5 my $self = shift;
49              
50 2         31 return $self->section(q{1}, qr{NAME}xmsi);
51             }
52              
53             sub summary {
54 2     2 1 634 my $self = shift;
55              
56 2         11 my $summary = $self->title;
57 2 50       12 if ($summary) {
58 2 50       107 if ($summary =~ m{\h+ - \h+ (.*)}xms) {
59 2         10 $summary = $1;
60             }
61             }
62              
63 2         12 return $summary;
64             }
65              
66             sub description {
67 4     4 1 14 my $self = shift;
68              
69 4         12 my $length = 500;
70              
71             my @headings
72 4         36 = (qr{DESCRIPTION}xmsi, qr{INTRODUCTION}xmsi, qr{SYNOPSIS}xmsi);
73              
74 4         11 my $description;
75             SECTION:
76 4         29 for my $heading (@headings) {
77 4         27 my $section = $self->section(q{1}, $heading);
78 4 50       36 next SECTION if !$section;
79              
80 4         29 $description = q{};
81              
82             # Remove subheadings.
83 4         104 $section =~ s{^ =head\d \h (\V+) \v+}{}xmsg;
84              
85             # Add the first paragraphs to the description.
86             PARAGRAPH:
87 4         161 for my $paragraph (split qr{\v\v+}xms, $section) {
88 28 100       63 if ($description) {
89 24         48 $description .= "\n\n";
90             }
91 28         67 $description .= $paragraph;
92 28 100       127 last PARAGRAPH if length $description > $length;
93             }
94              
95             # Remove the last sentence if the sentence ends with ":".
96 4         45 $description =~ s{[.] [^.]* : \z}{.}xms;
97              
98             # Remove the last sentence if the sentence contains the word "below".
99 4         34 $description =~ s{[.] [^.]+ \b (?:below) \b [^.]* [.] \z}{.}xms;
100              
101 4 50       21 last SECTION if $description;
102             }
103              
104 4         27 return $description;
105             }
106              
107             sub _copyrights_from_text {
108 5     5   20 my ($self, $text) = @_;
109              
110 5         25 my $COPYRIGHT = qr{Copyright (?:\h+ (?:[(]c[)] | ©))?}xmsi;
111 5         19 my $YEAR = qr{\d+ (?: \s* [-,] \s* \d+)*}xms;
112 5         18 my $HOLDER = qr{[^\v]+}xms;
113              
114 5         215 my $COPYRIGHT_NOTICE = qr{
115             $COPYRIGHT
116             \s+
117             ($YEAR) [-,]?
118             \s+
119             ($HOLDER)
120             }xms;
121              
122 5         25 my $MARKS = qr{[.,;!?:]}xms;
123              
124 5         20 my $AUTHOR_REFERENCE = qr{
125             \b (?:above | aforementioned ) \b
126             | "AUTHORS?"
127             }xmsi;
128              
129             # Put a newline before any copyright notice so that we can find
130             # consecutive copyright notices.
131 5         216 $text =~ s{($COPYRIGHT \s+ $YEAR)}{\n$1}xmsg;
132              
133             # Remove some phrases.
134 5         96 my @phrases = (
135             qr{\b by \b}xmsi, # "by"
136             qr{[(] [^)]* [)]}xms, # text in parens
137             qr{(?:All | Some) \h+ rights \h+ reserved \V*}xmsi,
138             qr{This [\h\w]* \h+ is \h+ free \h+ software \V*}xmsi,
139             qr{This [\h\w]* \h+ is \h+ made \h+ available \V*}xmsi,
140             qr{License [\h\w]* \h+ granted \V*}xmsi,
141             qr{Licensed \h+ under \V*}xmsi,
142             qr{Same \h+ license \V*}xmsi,
143             qr{You \h+ (?:may | should) \V*}xmsi,
144             qr{[^.,;:]+ \h+ is \h+ (?:distributed | released) \V*}xmsi,
145             qr{?}xms, # email addresses
146             qr{https?://[^\h]+}xms, # URLs
147             );
148              
149 5         29 for my $phrase (@phrases) {
150 60         3843 $text =~ s{$MARKS* \h* $phrase}{}xmsg;
151             }
152              
153 5         18 my %unique_copyrights;
154             COPYRIGHT_NOTICE:
155 5         67 while ($text =~ m{$COPYRIGHT_NOTICE}xmsg) {
156 6         21 my $year = $1;
157 6         16 my $holder = $2;
158              
159 6         39 $year =~ s{\h* -+ \h*}{-}xmsg; # Remove spaces from hyphens.
160 6         29 $year =~ s{,(\S)}{, $1}xmsg; # Put a space after commas.
161 6         24 $year =~ s{\s+}{ }xmsg; # Squeeze spaces.
162              
163 6         29 $holder =~ s{\s+ \z}{}xms; # Remove trailing spaces.
164 6         33 $holder =~ s{\s+}{ }xmsg; # Squeeze spaces.
165 6         107 $holder =~ s{$MARKS+ \z}{}xms; # Remove trailing punctuation marks.
166              
167 6 50       61 next COPYRIGHT_NOTICE if $holder =~ $AUTHOR_REFERENCE;
168              
169 6         85 $unique_copyrights{"$year $holder"}
170             = {year => $year, holder => $holder};
171             }
172              
173             my @copyrights
174 5         48 = sort { $a->{year} cmp $b->{year} } values %unique_copyrights;
  1         8  
175              
176 5         48 return \@copyrights;
177             }
178              
179             sub copyrights {
180 4     4 1 12 my $self = shift;
181              
182 4         22 my $COPYRIGHT_HEADINGS = qr{
183             (?: LICEN[CS]E | LICENSING | COPYRIGHT | LEGAL ) \b [^\v]*
184             }xmsi;
185              
186 4         9 my @copyrights;
187              
188 4         22 my $section = $self->section(qr{\d}xms, $COPYRIGHT_HEADINGS);
189 4 50       25 if ($section) {
190 4         12 push @copyrights, @{$self->_copyrights_from_text($section)};
  4         24  
191             }
192              
193 4         31 return \@copyrights;
194             }
195              
196             sub section {
197 10     10 1 41 my ($self, $level, $title) = @_;
198              
199 10         22 my $section;
200 10 50       926 if ($self->{text} =~ m{^ =head($level) \h $title \v+ (.*)}xms) {
201 10         41 my $n = $1;
202 10         118 $section = $2;
203 10         773 $section =~ s{\v* ^ =head$n \h .*}{}xms; # Remove other sections.
204 10         167 $section =~ s{\v+ \z}{}xms; # Remove trailing newlines.
205             }
206              
207 10         79 return $section;
208             }
209              
210             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
211              
212             sub _handle_element_start {
213 636     636   189168 my ($self, $name, $attrs) = @_;
214              
215 636         1200 my %do_clear = map { $_ => 1 } qw(
  4452         8235  
216             head1
217             head2
218             head3
219             head4
220             item-text
221             Para
222             Verbatim
223             );
224              
225 636 50       2457 if ($name eq 'item-bullet') {
    50          
    100          
226 0         0 $self->{buf} = q{ * };
227             }
228             elsif ($name eq 'item-number') {
229 0         0 $self->{buf} = q{ } . $attrs->{number} . q{. };
230             }
231             elsif ($do_clear{$name}) {
232 484         899 $self->{buf} = q{};
233             }
234              
235 636         1693 return;
236             }
237              
238             sub _handle_element_end {
239 636     636   3466 my ($self, $name) = @_;
240              
241 636         1085 my %do_output = map { $_ => 1 } qw(
  5724         9737  
242             head1
243             head2
244             head3
245             head4
246             item-bullet
247             item-number
248             item-text
249             Para
250             Verbatim
251             );
252              
253 636         1333 my %do_newline = map { $_ => 1 } qw(
  3816         6249  
254             head1
255             head2
256             head3
257             head4
258             Para
259             Verbatim
260             );
261              
262 636 100       2186 if ($name =~ m{^ head\d}xms) {
263 144         406 $self->{text} .= "=$name ";
264             }
265              
266 636 100       1335 if ($do_output{$name}) {
267 484         1157 $self->{text} .= $self->{buf};
268 484         917 $self->{text} .= "\n";
269 484 100       1086 if ($do_newline{$name}) {
270 444         734 $self->{text} .= "\n";
271             }
272 484         819 $self->{buf} = q{};
273             }
274              
275 636         1830 return;
276             }
277              
278             sub _handle_text {
279 688     688   5908 my ($self, $text) = @_;
280              
281             # Pod::Simple provides nbsp and shy since Perl 5.24.
282             ## no critic (Variables::ProhibitPackageVars)
283 688 50       1393 if (defined $Pod::Simple::nbsp) {
284 688         1930 $text =~ s{$Pod::Simple::nbsp}{ }xmsg;
285             }
286 688 50       1351 if (defined $Pod::Simple::shy) {
287 688         1323 $text =~ s{$Pod::Simple::shy}{}xmsg;
288             }
289 688         1338 $self->{buf} .= $text;
290              
291 688         1391 return;
292             }
293              
294             1;
295             __END__