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   1322 use 5.016;
  9         43  
6 9     9   50 use warnings;
  9         22  
  9         249  
7 9     9   48 use utf8;
  9         21  
  9         57  
8              
9             our $VERSION = '0.009';
10              
11 9     9   870 use parent qw(Pod::Simple);
  9         350  
  9         65  
12              
13 9     9   285292 use Pod::Simple;
  9         28  
  9         230  
14 9     9   6422 use Pod::Simple::Search;
  9         56229  
  9         18397  
15              
16             sub find {
17 4     4 1 138 my ($class, $module_name, @dirs) = @_;
18              
19 4         20 my $pod;
20              
21 4         98 my $podfile = Pod::Simple::Search->new->inc(0)->find($module_name, @dirs);
22 4 50       2814 if ($podfile) {
23 4         32 $pod = CPANPLUS::Dist::Debora::Pod->new;
24 4         75 $pod->parse_file($podfile);
25             }
26              
27 4         192 return $pod;
28             }
29              
30             sub new {
31 4     4 1 13 my $class = shift;
32              
33 4         109 my $self = $class->SUPER::new(@_);
34              
35 4         412 $self->{buf} = q{};
36 4         32 $self->{text} = q{};
37              
38 4         16 return $self;
39             }
40              
41             sub text {
42 4     4 1 13 my $self = shift;
43              
44 4         34 return $self->{text};
45             }
46              
47             sub title {
48 2     2 1 6 my $self = shift;
49              
50 2         28 return $self->section(q{1}, qr{NAME}xmsi);
51             }
52              
53             sub summary {
54 2     2 1 777 my $self = shift;
55              
56 2         10 my $summary = $self->title;
57 2 50       13 if ($summary) {
58 2 50       29 if ($summary =~ m{\h+ - \h+ (.*)}xms) {
59 2         9 $summary = $1;
60             }
61             }
62              
63 2         12 return $summary;
64             }
65              
66             sub description {
67 4     4 1 12 my $self = shift;
68              
69 4         9 my $length = 500;
70              
71             my @headings
72 4         68 = (qr{DESCRIPTION}xmsi, qr{INTRODUCTION}xmsi, qr{SYNOPSIS}xmsi);
73              
74 4         10 my $description;
75             SECTION:
76 4         23 for my $heading (@headings) {
77 4         27 my $section = $self->section(q{1}, $heading);
78 4 50       20 next SECTION if !$section;
79              
80 4         15 $description = q{};
81              
82             # Remove subheadings.
83 4         102 $section =~ s{^ =head\d \h (\V+) \v+}{}xmsg;
84              
85             # Add the first paragraphs to the description.
86             PARAGRAPH:
87 4         150 for my $paragraph (split qr{\v\v+}xms, $section) {
88 28 100       69 if ($description) {
89 24         45 $description .= "\n\n";
90             }
91 28         57 $description .= $paragraph;
92 28 100       154 last PARAGRAPH if length $description > $length;
93             }
94              
95             # Remove the last sentence if the sentence ends with ":".
96 4         58 $description =~ s{[.] [^.]* : \z}{.}xms;
97              
98             # Remove the last sentence if the sentence contains the word "below".
99 4         43 $description =~ s{[.] [^.]+ \b (?:below) \b [^.]* [.] \z}{.}xms;
100              
101 4 50       40 last SECTION if $description;
102             }
103              
104 4         42 return $description;
105             }
106              
107             sub _copyrights_from_text {
108 5     5   18 my ($self, $text) = @_;
109              
110 5         25 my $COPYRIGHT = qr{Copyright (?:\h+ (?:[(]c[)] | ©))?}xmsi;
111 5         29 my $YEAR = qr{\d+ (?: \s* [-,] \s* \d+)*}xms;
112 5         17 my $HOLDER = qr{[^\v]+}xms;
113              
114 5         201 my $COPYRIGHT_NOTICE = qr{
115             $COPYRIGHT
116             \s+
117             ($YEAR) [-,]?
118             \s+
119             ($HOLDER)
120             }xms;
121              
122 5         22 my $MARKS = qr{[.,;!?:]}xms;
123              
124 5         48 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         223 $text =~ s{($COPYRIGHT \s+ $YEAR)}{\n$1}xmsg;
132              
133             # Remove some phrases.
134 5         100 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         28 for my $phrase (@phrases) {
150 60         3725 $text =~ s{$MARKS* \h* $phrase}{}xmsg;
151             }
152              
153 5         19 my %unique_copyrights;
154             COPYRIGHT_NOTICE:
155 5         83 while ($text =~ m{$COPYRIGHT_NOTICE}xmsg) {
156 6         32 my $year = $1;
157 6         28 my $holder = $2;
158              
159 6         36 $year =~ s{\h* -+ \h*}{-}xmsg; # Remove spaces from hyphens.
160 6         24 $year =~ s{,(\S)}{, $1}xmsg; # Put a space after commas.
161 6         20 $year =~ s{\s+}{ }xmsg; # Squeeze spaces.
162              
163 6         27 $holder =~ s{\s+ \z}{}xms; # Remove trailing spaces.
164 6         33 $holder =~ s{\s+}{ }xmsg; # Squeeze spaces.
165 6         126 $holder =~ s{$MARKS+ \z}{}xms; # Remove trailing punctuation marks.
166              
167 6 50       97 next COPYRIGHT_NOTICE if $holder =~ $AUTHOR_REFERENCE;
168              
169 6         82 $unique_copyrights{"$year $holder"}
170             = {year => $year, holder => $holder};
171             }
172              
173             my @copyrights
174 5         43 = sort { $a->{year} cmp $b->{year} } values %unique_copyrights;
  1         8  
175              
176 5         52 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       23 if ($section) {
190 4         11 push @copyrights, @{$self->_copyrights_from_text($section)};
  4         32  
191             }
192              
193 4         29 return \@copyrights;
194             }
195              
196             sub section {
197 10     10 1 36 my ($self, $level, $title) = @_;
198              
199 10         22 my $section;
200 10 50       909 if ($self->{text} =~ m{^ =head($level) \h $title \v+ (.*)}xms) {
201 10         42 my $n = $1;
202 10         121 $section = $2;
203 10         686 $section =~ s{\v* ^ =head$n \h .*}{}xms; # Remove other sections.
204 10         157 $section =~ s{\v+ \z}{}xms; # Remove trailing newlines.
205             }
206              
207 10         45 return $section;
208             }
209              
210             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
211              
212             sub _handle_element_start {
213 644     644   192341 my ($self, $name, $attrs) = @_;
214              
215 644         1299 my %do_clear = map { $_ => 1 } qw(
  4508         8458  
216             head1
217             head2
218             head3
219             head4
220             item-text
221             Para
222             Verbatim
223             );
224              
225 644 50       2468 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         908 $self->{buf} = q{};
233             }
234              
235 644         1826 return;
236             }
237              
238             sub _handle_element_end {
239 644     644   3529 my ($self, $name) = @_;
240              
241 644         1110 my %do_output = map { $_ => 1 } qw(
  5796         9774  
242             head1
243             head2
244             head3
245             head4
246             item-bullet
247             item-number
248             item-text
249             Para
250             Verbatim
251             );
252              
253 644         1342 my %do_newline = map { $_ => 1 } qw(
  3864         6383  
254             head1
255             head2
256             head3
257             head4
258             Para
259             Verbatim
260             );
261              
262 644 100       1807 if ($name =~ m{^ head\d}xms) {
263 144         409 $self->{text} .= "=$name ";
264             }
265              
266 644 100       1359 if ($do_output{$name}) {
267 484         1176 $self->{text} .= $self->{buf};
268 484         875 $self->{text} .= "\n";
269 484 100       1105 if ($do_newline{$name}) {
270 444         778 $self->{text} .= "\n";
271             }
272 484         810 $self->{buf} = q{};
273             }
274              
275 644         1916 return;
276             }
277              
278             sub _handle_text {
279 704     704   6137 my ($self, $text) = @_;
280              
281             # Pod::Simple provides nbsp and shy since Perl 5.24.
282             ## no critic (Variables::ProhibitPackageVars)
283 704 50       1410 if (defined $Pod::Simple::nbsp) {
284 704         2037 $text =~ s{$Pod::Simple::nbsp}{ }xmsg;
285             }
286 704 50       1362 if (defined $Pod::Simple::shy) {
287 704         1375 $text =~ s{$Pod::Simple::shy}{}xmsg;
288             }
289 704         1380 $self->{buf} .= $text;
290              
291 704         1478 return;
292             }
293              
294             1;
295             __END__