File Coverage

blib/lib/App/PodLinkCheck.pm
Criterion Covered Total %
statement 119 348 34.2
branch 32 158 20.2
condition 9 53 16.9
subroutine 21 46 45.6
pod 4 13 30.7
total 185 618 29.9


line stmt bran cond sub pod time code
1             # Copyright 2010, 2011, 2012, 2013, 2016 Kevin Ryde
2              
3             # This file is part of PodLinkCheck.
4              
5             # PodLinkCheck is free software; you can redistribute it and/or modify it
6             # under the terms of the GNU General Public License as published by the Free
7             # Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # PodLinkCheck is distributed in the hope that it will be useful, but
11             # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
12             # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with PodLinkCheck. If not, see <http://www.gnu.org/licenses/>.
17              
18             package App::PodLinkCheck;
19 1     1   465 use 5.006;
  1         2  
20 1     1   3 use strict;
  1         2  
  1         18  
21 1     1   3 use warnings;
  1         1  
  1         24  
22 1     1   3 use Carp;
  1         0  
  1         51  
23 1     1   3 use File::Spec;
  1         0  
  1         16  
24 1     1   438 use Locale::TextDomain ('App-PodLinkCheck');
  1         12886  
  1         4  
25              
26 1     1   5671 use vars '$VERSION';
  1         1  
  1         885  
27             $VERSION = 14;
28              
29             # uncomment this to run the ### lines
30             # use Smart::Comments;
31              
32             sub command_line {
33 0     0 1 0   my ($self) = @_;
34             ### command_line(): @ARGV
35 0 0       0   ref $self or $self = $self->new;
36              
37 0         0   require Getopt::Long;
38 0         0   Getopt::Long::Configure ('permute', # options with args, callback '<>'
39                                        'no_ignore_case',
40                                        'bundling');
41               Getopt::Long::GetOptions
42 0     0   0       ('version' => sub { $self->action_version },
43 0     0   0        'help' => sub { $self->action_help },
44                    'verbose:i' => \$self->{'verbose'},
45                    'V+' => \$self->{'verbose'},
46                    'I=s' => $self->{'extra_INC'}, # push onto arrayref
47                    '<>' => sub {
48 0     0   0          my ($value) = @_;
49             # stringize to avoid Getopt::Long object
50 0         0          $self->check_tree ("$value");
51                    },
52 0         0       );
53             ### final ARGV: @ARGV
54 0         0   $self->check_tree (@ARGV);
55 0         0   return 0;
56             }
57              
58             sub action_version {
59 0     0 0 0   my ($self) = @_;
60 0         0   print __x("PodLinkCheck version {version}\n", version => $self->VERSION);
61 0 0       0   if ($self->{'verbose'} >= 2) {
62 0         0     require Pod::Simple;
63 0         0     print __x(" Perl version {version}\n", version => $]);
64 0         0     print __x(" Pod::Simple version {version}\n", version => Pod::Simple->VERSION);
65               }
66 0         0   return 0;
67             }
68              
69             sub action_help {
70 0     0 0 0   my ($self) = @_;
71 0         0   require FindBin;
72 1     1   5   no warnings 'once';
  1         0  
  1         284  
73 0         0   my $progname = $FindBin::Script;
74 0         0   print __x("Usage: $progname [--options] file-or-dir...\n");
75 0         0   print __x(" --help print this message\n");
76 0         0   print __x(" --version print version number (and module versions if --verbose=2)\n");
77 0         0   print __x(" --verbose print diagnostic details\n");
78 0         0   print __x(" --verbose=2 print even more diagnostics\n");
79 0         0   return 0;
80             }
81              
82              
83             #------------------------------------------------------------------------------
84              
85             sub new {
86 6     6 1 3681   my ($class, @options) = @_;
87 6         32   return bless { verbose => 0,
88                              cpan_methods => ['CPAN_SQLite','cpanminus','CPAN','CPANPLUS'],
89                              extra_INC => [],
90                              @options }, $class;
91             }
92              
93             sub check_tree {
94 0     0 1 0   my ($self, @files_or_directories) = @_;
95             ### check_tree(): \@files_or_directories
96              
97 0         0   foreach my $filename (@files_or_directories) {
98 0 0       0     if (-d $filename) {
99 0         0       require File::Find::Iterator;
100 0         0       my $finder = File::Find::Iterator->create (dir => [$filename],
101                                                              order => \&_find_order,
102                                                              filter => \&_is_perlfile);
103 0         0       while ($filename = $finder->next) {
104 0         0         print "$filename:\n";
105 0         0         $self->check_file ($filename);
106                   }
107                 } else {
108 0         0       print "$filename:\n";
109 0         0       $self->check_file ($filename);
110                 }
111               }
112              
113             # ### recurse dir: $filename
114             # require File::Find;
115             # File::Find::find ({ wanted => sub {
116             # #### file: $_
117             # if (_is_perlfile()) {
118             # print "$_:\n";
119             # $self->check_file ($_);
120             # }
121             # },
122             # follow_fast => 1,
123             # preprocess => \&_find_sort,
124             # no_chdir => 1,
125             # },
126             # $filename);
127             # } else {
128             # print "$filename:\n";
129             # $self->check_file ($filename);
130             # }
131             # }
132             }
133              
134             # $_ is a filename.
135             # Return true if it looks like a Perl .pl .pm .pod.
136             # Any emacs .#foo.pm etc lockfile is excluded.
137             # (Emacs auto-saves and backups change the suffix so don't have
138             # to be excluded.)
139             #
140             sub _is_perlfile {
141             ### _is_perlfile(): $_
142               return (! -d
143 0   0 0   0           && ! m{/\.#} # not emacs lockfile
144                       && /\.p([lm]|od)$/);
145             }
146              
147             use constant::defer _HAVE_SORT_KEY_NATURAL => sub {
148 0         0   eval { require Sort::Key::Natural; 1 };
  0         0  
  0         0  
149 1     1   398 };
  1         510  
  1         8  
150              
151             # _find_order($x,$y) compares filenames $x,$y
152             # Return spaceship style 1,false,-1 order.
153             # File::Find::Iterator 0.4 wants a reverse order since it pop()s off its
154             # pending filenames, hence the nasty hack to swap here.
155             #
156             # File::Find::Iterator also sorts with a mixture of current directory and
157             # subdirectory. Not sure if the result is a strict pre-order traversal if
158             # some directory names have chars before or after "/". Would like to ask it
159             # for pre-order.
160             #
161             sub _find_order {
162 0     0   0   my ($x, $y) = @_;
163 0         0   ($x,$y) = ($y,$x);
164               return (_cmp_file_before_directory($x,$y)
165 0   0     0           || do {
166                         if (_HAVE_SORT_KEY_NATURAL) {
167                           $x = Sort::Key::Natural::mkkey_natural($x);
168                           $y = Sort::Key::Natural::mkkey_natural($y);
169                         }
170                         lc($x) cmp lc($y) || $x cmp $y
171                       });
172             }
173              
174             # $x,$y are filenames.
175             # Return spaceship style <=> comparision 1,false,-1 which reckons
176             # file < directory.
177             sub _cmp_file_before_directory {
178 4     4   412   my ($x, $y) = @_;
179             # If $x or $y is a dangling symlink then -d is undef rather than '' false,
180             # hence "||0" for the compare.
181 4   100     81   return (-d $x || 0) <=> (-d $y || 0);
      100        
182             }
183              
184             sub check_file {
185 0     0 1 0   my ($self, $filename) = @_;
186 0         0   require App::PodLinkCheck::ParseLinks;
187 0         0   my $parser = App::PodLinkCheck::ParseLinks->new ($self);
188 0         0   $parser->parse_from_file ($filename);
189              
190 0         0   my $own_sections = $parser->sections_hashref;
191             ### $own_sections
192              
193 0         0   foreach my $link (@{$parser->links_arrayref}) {
  0         0  
194 0         0     my ($type, $to, $section, $linenum, $column) = @$link;
195              
196 0 0       0     if ($self->{'verbose'}) {
197 0 0       0       print "Link: $type ",(defined $to ? $to : '[undef]'),
    0          
198                     (defined $section ? " / $section" : ""), "\n";
199                 }
200              
201 0 0       0     if ($type eq 'man') {
202 0 0       0       if (! $self->manpage_is_known($to)) {
203 0         0         $self->report ($filename, $linenum, $column,
204                                    __x('no man page "{name}"', name => $to));
205                   }
206 0         0       next;
207                 }
208              
209 0 0       0     if (! defined $to) {
210 0 0 0     0       if (defined $section
211                       && ! $own_sections->{$section}) {
212 0 0       0         if (my $approximations
213                         = _section_approximations($section,$own_sections)) {
214 0         0           $self->report ($filename, $linenum, $column,
215                                      __x("no section \"{section}\"\n perhaps it should be {approximations}",
216                                          section => $section,
217                                          approximations => $approximations));
218                     } else {
219 0         0           $self->report ($filename, $linenum, $column,
220                                      __x('no section "{section}"',
221                                          section => $section));
222                     }
223 0 0       0         if ($self->{'verbose'} >= 2) {
224 0         0           print __(" available sections:\n");
225 0         0           foreach my $section (sort keys %$own_sections) {
226 0         0             print " $section\n";
227                       }
228                     }
229                   }
230 0         0       next;
231                 }
232              
233 0   0     0     my $podfile = ($self->module_to_podfile($to)
234                                || $self->find_script($to));
235             ### $podfile
236 0 0       0     if (! defined $podfile) {
237 0 0       0       if (my $method = $self->_module_known_cpan($to)) {
238 0 0 0     0         if (defined $section && $section ne '') {
239 0         0           $self->report ($filename, $linenum, $column,
240                                      __x('target "{name}" on cpan ({method}) but no local copy to check section "{section}"',
241                                          name => $to,
242                                          method => $method,
243                                          section => $section));
244                     }
245 0         0         next;
246                   }
247                 }
248              
249 0 0 0     0     if (! defined $podfile
      0        
250                     && ! defined $section
251                     && $self->manpage_is_known($to)) {
252             # perhaps a script or something we can't find the source but does
253             # have a manpage -- take that as good enough
254 0         0       next;
255                 }
256 0 0 0     0     if (! defined $section
      0        
257                     && _is_one_word($to)
258                     && $own_sections->{$to}) {
259             # one-word internal section
260 0 0       0       if (defined $podfile) {
261             # print "$filename:$linenum:$column: target \"$to\" is both external module/program and internal section\n";
262                   } else {
263 0         0         $self->report ($filename, $linenum, $column,
264                                    __x('internal one-word link recommend guard against ambiguity with {slash} or {quote}',
265                                        slash => "L</"._escape_angles($to).">",
266                                        quote => "L<\""._escape_angles($to)."\">"));
267                   }
268 0         0       next;
269                 }
270 0 0       0     if (! defined $podfile) {
271 0 0       0       if ($own_sections->{$to}) {
272             # multi-word internal section
273 0         0         return;
274                   }
275 0         0       $self->report ($filename, $linenum, $column,
276                                  "no module/program/pod \"$to\"");
277 0         0       next;
278                 }
279              
280 0 0 0     0     if (defined $section && $section ne '') {
281 0         0       my $podfile_sections = $self->filename_to_sections ($podfile);
282 0 0       0       if (! $podfile_sections->{$section}) {
283 0 0       0         if (my $approximations
284                         = _section_approximations($section,$podfile_sections)) {
285 0         0           $self->report ($filename, $linenum, $column,
286                                      __x("no section \"{section}\" in \"{name}\" (file {filename})\n perhaps it should be {approximations}",
287                                          name => $to,
288                                          section => $section,
289                                          filename => $podfile,
290                                          approximations => $approximations));
291                     } else {
292 0         0           $self->report ($filename, $linenum, $column,
293                                      __x('no section "{section}" in "{name}" (file {filename})',
294                                          name => $to,
295                                          section => $section,
296                                          filename => $podfile));
297                     }
298 0 0       0         if ($self->{'verbose'} >= 2) {
299 0         0           print __(" available sections:\n");
300 0         0           foreach my $section (keys %$podfile_sections) {
301 0         0             print " $section\n";
302                       }
303                     }
304                   }
305                 }
306               }
307             }
308              
309             sub report {
310 0     0 0 0   my ($self, $filename, $linenum, $column, $message) = @_;
311 0         0   print "$filename:$linenum:$column: $message\n";
312             }
313              
314             # return a string of close matches of $section in the keys of %$hashref
315             sub _section_approximations {
316 0     0   0   my ($section, $hashref) = @_;
317 0         0   $section = _section_approximation_crunch($section);
318               return join(' or ',
319 0         0               map {"\"$_\""}
320 0         0               grep {_section_approximation_crunch($_) eq $section}
  0         0  
321                           keys %$hashref);
322             }
323             sub _section_approximation_crunch {
324 0     0   0   my ($section) = @_;
325 0         0   $section =~ s/(\W|_)+//g;
326 0         0   return lc($section);
327             }
328              
329             sub _is_one_word {
330 0     0   0   my ($link) = @_;
331 0         0   return ($link !~ /\W/);
332             }
333              
334             # change all < and > in $str to pod style E<lt> and E<gt>
335             sub _escape_angles {
336 3     3   1377   my ($str) = @_;
337 3         15   $str =~ s{([<>])}
338 4 100       18 { 'E<'.($1 eq '<' ? 'lt' : 'gt').'>' }ge;
339 3         13   return $str;
340             }
341              
342             sub module_to_podfile {
343 0     0 0 0   my ($self, $module) = @_;
344             ### module_to_podfile(): $module
345             ### dirs: $self->{'extra_INC'}
346 0         0   require Pod::Find;
347 0         0   return Pod::Find::pod_where ({ '-dirs' => $self->{'extra_INC'},
348                                              '-inc' => 1,
349                                            },
350                                            $module);
351             }
352              
353             # return hashref
354             sub filename_to_sections {
355 0     0 0 0   my ($self, $filename) = @_;
356 0   0     0   return ($self->{'sections_cache'}->{$filename} ||= do {
357             ### parse file for sections: $filename
358 0         0     my $parser = App::PodLinkCheck::ParseSections->new;
359 0         0     $parser->parse_file ($filename);
360             ### file sections: $parser->sections_hashref
361 0         0     $parser->sections_hashref;
362               });
363             }
364              
365             #------------------------------------------------------------------------------
366             # CPAN
367             #
368             # cf CPAN::API::HOWTO
369              
370             # look for $module in the cpan indexes
371             # if found return the name of the cpan method it was found in
372             # if not found return false
373             sub _module_known_cpan {
374 0     0   0   my ($self, $module) = @_;
375 0         0   foreach my $method (@{$self->{'cpan_methods'}}) {
  0         0  
376 0         0     my $fullmethod = "_module_known_$method";
377 0 0       0     if ($self->$fullmethod ($module)) {
378 0         0       return $method;
379                 }
380               }
381 0         0   return 0;
382             }
383              
384             {
385             # a bit of a hack to suppress CPAN.pm messages, unless our verbose
386               package App::PodLinkCheck::CPANquiet;
387               our @ISA;
388       0       sub print_ornamented { }
389             }
390             use constant::defer _CPAN_config => sub {
391 1         14   my ($self) = @_;
392             ### _CPAN_config() ...
393              
394 1         1   my $result = 0;
395               eval {
396 1         741     require CPAN;
397 1 50       191582     if (! $self->{'verbose'}) {
398             # usually $CPAN::Frontend is CPAN::Shell
399 1         15       @App::PodLinkCheck::CPANquiet::ISA = ($CPAN::Frontend);
400 1         5       $CPAN::Frontend = 'App::PodLinkCheck::CPANquiet::ISA';
401                 }
402             # not sure how far back this will work, maybe only 5.8.0 up
403 1 50 33     21     if (! $CPAN::Config_loaded
404                     && CPAN::HandleConfig->can('load')) {
405             # fake $loading to avoid running the CPAN::FirstTime dialog -- is
406             # this the right way to do that?
407 1         2       local $CPAN::HandleConfig::loading = 1;
408 1 50       6       if ($self->{'verbose'}) {
409 0         0         print __x("PodLinkCheck: {module} configs\n",
410                               module => 'CPAN');
411                   }
412 1         7       CPAN::HandleConfig->load;
413                 }
414 1         300     $result = 1;
415               }
416 1 50       2     or do {
417 0 0       0       if ($self->{'verbose'}) {
418 0         0         print "CPAN.pm config error: $@\n";
419                   }
420                 };
421 1         8   return $result;
422 1     1   1149 };
  1         4  
  1         6  
423              
424             sub _module_known_CPAN_SQLite {
425 3     3   920   my ($self, $module) = @_;
426              
427 3 100       12   if (! defined $self->{'cpan_sqlite'}) {
428 1         3     $self->{'cpan_sqlite'} = 0; # no sqlite, unless we succeed below
429              
430 1 50       5     if ($self->_CPAN_config($self->{'verbose'})) {
431             # configs loaded
432              
433 1 50       58       if ($self->{'verbose'}) {
434 0         0         print __x("PodLinkCheck: loading {module} for module existence checking\n",
435                               module => 'CPAN::SQLite');
436                   }
437 1 50       1       if (! eval { require CPAN::SQLite }) {
  1         185  
438 1 50       4         if ($self->{'verbose'}) {
439 0         0           print __x("Cannot load {module}, skipping -- {error}\n",
440                                 module => 'CPAN::SQLite',
441                                 error => $@);
442                     }
443 1         7         return 0;
444                   }
445              
446             # Quieten warning messags from CPAN::SQLite apparently when never yet run
447                   local $SIG{'__WARN__'} = sub {
448 0 0   0   0         if ($self->{'verbose'}) {
449 0         0           warn @_;
450                     }
451 0         0       };
452 0 0       0       if (! eval {
453             # fake $loading to avoid running the CPAN::FirstTime dialog -- is
454             # this the right way to do that?
455 0         0         local $CPAN::HandleConfig::loading = 1;
456 0         0         $self->{'cpan_sqlite'} = CPAN::SQLite->new (update_indices => 0);
457                   }) {
458 0 0       0         if ($self->{'verbose'}) {
459 0         0           print __x("{module} error: {error}\n",
460                                 module => 'CPAN::SQLite',
461                                 error => $@);
462                     }
463                   }
464                 }
465               }
466              
467 2   50     17   my $cpan_sqlite = $self->{'cpan_sqlite'} || return 0;
468              
469             # Have struck errors from cpantesters creating db tables. Not sure if it
470             # might happen in a real run. Guard with an eval.
471             #
472 0         0   my $result;
473 0 0       0   if (! eval { $result = $cpan_sqlite->query (mode => 'module',
  0         0  
474                                                           name => $module);
475 0         0                1 }) {
476 0 0       0     if ($self->{'verbose'}) {
477 0         0       print __x("{module} error, disabling -- {error}\n",
478                             module => 'CPAN::SQLite',
479                             error => $@);
480                 }
481 0         0     $self->{'cpan_sqlite'} = 0;
482 0         0     return 0;
483               }
484 0         0   return $result;
485             }
486              
487             my $use_CPAN;
488             sub _module_known_CPAN {
489 3     3   811   my ($self, $module) = @_;
490             ### _module_known_CPAN(): $module
491              
492 3 100       8   if (! defined $use_CPAN) {
493 1         1     $use_CPAN = 0;
494              
495 1 50       10     if ($self->_CPAN_config($self->{'verbose'})) {
496                   eval {
497 1 50       3         if ($self->{'verbose'}) {
498 0         0           print __x("PodLinkCheck: load {module} for module existence checking\n",
499                                 module => 'CPAN');
500                     }
501              
502 1 50 33     24         if (defined $CPAN::META && %$CPAN::META) {
    50          
503 0         0           $use_CPAN = 1;
504                     } elsif (! CPAN::Index->can('read_metadata_cache')) {
505 0 0       0           if ($self->{'verbose'}) {
506 0         0             print __("PodLinkCheck: no Metadata cache in this CPAN.pm\n");
507                       }
508                     } else {
509             # try the .cpan/Metadata even if CPAN::SQLite is installed, just in
510             # case the SQLite is not up-to-date or has not been used yet
511 1         4           local $CPAN::Config->{use_sqlite} = 0;
512 1         7           CPAN::Index->read_metadata_cache;
513 0 0 0     0           if (defined $CPAN::META && %$CPAN::META) {
514 0         0             $use_CPAN = 1;
515                       } else {
516 0 0       0             if ($self->{'verbose'}) {
517 0         0               print __("PodLinkCheck: empty Metadata cache\n");
518                         }
519                       }
520                     }
521 0         0         1;
522                   }
523 1 50       2         or do {
524 1 50       3170           if ($self->{'verbose'}) {
525 0         0             print "CPAN.pm error: $@\n";
526                       }
527                     };
528                 }
529               }
530              
531               return ($use_CPAN
532 3   33     13           && exists($CPAN::META->{'readwrite'}->{'CPAN::Module'}->{$module}));
533             }
534              
535             sub _module_known_CPANPLUS {
536 3     3   800   my ($self, $module) = @_;
537             ### _module_known_CPANPLUS(): $module
538              
539 3 100       12   if (! defined $self->{'cpanplus'}) {
540 1 50       4     if ($self->{'verbose'}) {
541 0         0       print __x("PodLinkCheck: load {module} for module existence checking\n",
542                             module => 'CPANPLUS');
543                 }
544 1 50       2     if (! eval { require CPANPLUS::Backend;
  1         244  
545 0         0                  require CPANPLUS::Configure;
546                            }) {
547 1         5       $self->{'cpanplus'} = 0;
548 1 50       4       if ($self->{'verbose'}) {
549 0         0         print __x("Cannot load {module}, skipping -- {error}\n",
550                               module => 'CPANPLUS',
551                               error => $@);
552                   }
553 1         5       return 0;
554                 }
555 0         0     my $conf = CPANPLUS::Configure->new;
556 0         0     $conf->set_conf (verbose => 1);
557 0         0     $conf->set_conf (no_update => 1);
558 0         0     $self->{'cpanplus'} = CPANPLUS::Backend->new ($conf);
559               }
560              
561 2   50     9   my $cpanplus = $self->{'cpanplus'} || return 0;
562              
563             # module_tree() returns false '' for not found.
564             #
565             # Struck an error from module_tree() somehow relating to
566             # CPANPLUS::Internals::Source::SQLite on cpantesters at one time, so guard
567             # with an eval.
568             #
569 0         0   my $result;
570 0 0       0   if (! eval { $result = $cpanplus->module_tree($module); 1 }) {
  0         0  
  0         0  
571 0 0       0     if ($self->{'verbose'}) {
572 0         0       print __x("{module} error, disabling -- {error}\n",
573                             module => 'CPANPLUS',
574                             error => $@);
575                 }
576 0         0     $self->{'cpanplus'} = 0;
577 0         0     return 0;
578               }
579 0         0   return $result;
580             }
581              
582             sub _module_known_cpanminus {
583 3     3   796   my ($self, $module) = @_;
584             ### _module_known_cpanminus(): $module
585              
586 3         11   foreach my $filename ($self->_cpanminus_packages_details_filenames()) {
587 0         0     my $fh;
588 0 0       0     unless (open $fh, '<', $filename) {
589 0 0       0       unless ($self->{'cpanminus-warned'}->{$filename}++) {
590 0 0       0         if ($self->{'verbose'}) {
591 0         0           print __x("PodLinkCheck: cannot open {filename}: {error}\n",
592                                 filename => $filename,
593                                 error => "$!");
594                     }
595                   }
596 0         0       next;
597                 }
598 0 0       0     unless ($self->{'cpanminus'}->{$filename}++) {
599 0 0       0       if ($self->{'verbose'}) {
600 0         0         print __x("PodLinkCheck: module existence checking in {filename}\n",
601                               filename => $filename);
602                   }
603                 }
604              
605             # binary search
606 0 0       0     if (_packages_details_bsearch($fh, $module)) {
607 0         0       return 1;
608                 }
609              
610             # Plain search.
611             # while (defined(my $line = readline $fh)) {
612             # if ($line =~ /^\Q$module\E /) {
613             # return 1;
614             # }
615             # }
616               }
617 3         9   return 0;
618             }
619              
620             # Return a list of all the 02packages.details.txt files in App::cpanminus.
621             # eg. "/home/foo/.cpanm/sources/http%www.cpan.org/02packages.details.txt".
622             # ENHANCE-ME: Only one of the filenames returned will be its configured
623             # mirror. Will it tell us which?
624             sub _cpanminus_packages_details_filenames {
625             # my ($self) = @_;
626 3     3   13   require File::HomeDir;
627 3         10   my $home = File::HomeDir->my_home;
628 3 50       68   if (! defined $home) { return; } # undef if no $HOME
  0         0  
629              
630 3         31   my $wildcard = File::Spec->catfile($home, '.cpanm', 'sources',
631                                                  '*', '02packages.details.txt');
632 3         64   return glob $wildcard;
633             }
634              
635             # $fh is a file handle open on an 02packages.details.txt file.
636             # Return true if $module exists in the file (any version, any author).
637             #
638             # 02packages header lines are first field with trailing colon like
639             # File: 02packages.details.txt
640             # and a blank line before first module.
641             #
642             # Sort order is lc($a) cmp lc($a) per PAUSE::mldistwatch rewrite02().
643             # https://github.com/andk/pause/raw/master/lib/PAUSE/mldistwatch.pm
644             # This means modules differing only in upper/lower case are ordered by
645             # version number and author, which will be semi-random. Hence linear search
646             # after the bsearch finds the first. This doesn't happen often so the
647             # result is still good speed-wise.
648             #
649             sub _packages_details_bsearch {
650 0     0   0   my ($fh, $module) = @_;
651              
652 0         0   require Search::Dict;
653 0         0   my $lc_module = lc($module);
654             ### $lc_module
655 0         0   my $pos = Search::Dict::look ($fh, $lc_module,
656                                             { xfrm => \&_packages_details_line_to_module });
657             ### $pos
658 0 0       0   next if ! defined $pos;
659              
660 0         0   while (defined(my $line = readline $fh)) {
661 0 0       0     return 1 if $line =~ /^\Q$module\E /;
662 0 0       0     last if $line !~ /^\Q$module\E /i;
663               }
664 0         0   return 0;
665             }
666              
667             # $line is a line from an 02packages.details.txt file.
668             # Return the module name on the line, or empty string "" if not a module line.
669             sub _packages_details_line_to_module {
670 0     0   0   my ($line) = @_;
671 0 0       0   if ($line =~ /^([^ ]*[^ :]) /) {
672             ### at: lc($1)
673 0         0     return lc($1);
674               } else {
675 0         0     return '';
676               }
677             }
678              
679             #------------------------------------------------------------------------------
680             # PATH
681              
682             sub find_script {
683 0     0 0 0   my ($self, $name) = @_;
684 0         0   foreach my $dir ($self->PATH_list) {
685 0         0     my $filename = File::Spec->catfile($dir,$name);
686             #### $filename
687 0 0       0     if (-e $filename) {
688 0         0       return $filename;
689                 }
690               }
691 0         0   return undef;
692             }
693              
694             # return list of directories
695             sub PATH_list {
696 0     0 0 0   my ($self) = @_;
697 0         0   require Config;
698 0         0   return split /\Q$Config::Config{'path_sep'}/o, $self->PATH;
699             }
700              
701             # return string
702             sub PATH {
703 0     0 0 0   my ($self) = @_;
704 0 0       0   if (defined $self->{'PATH'}) {
705 0         0     return $self->{'PATH'};
706               } else {
707 0         0     return $ENV{'PATH'};
708               }
709             }
710              
711             #------------------------------------------------------------------------------
712             # man
713              
714             # return bool
715             sub manpage_is_known {
716 6     6 0 3058   my ($self, $name) = @_;
717 6         6   my @manargs;
718 6         6   my $section = '';
719 6 100       29   if ($name =~ s/\s*\((.+)\)$//) {
720 2         4     $section = $1;
721 2         5     @manargs = ($section);
722               }
723              
724 6         18   my $r = \$self->{'manpage_is_known'}->{$section}->{$name};
725 6 50       13   if (defined $$r) {
726 0         0     return $$r;
727               }
728 6         7   push @manargs, $name;
729             ### man: \@manargs
730              
731 6 50       20   return ($$r = ($self->_man_has_location_option()
732                              ? $self->_manpage_is_known_by_location(@manargs)
733                              : $self->_manpage_is_known_by_output(@manargs)));
734             }
735              
736             # --location is not in posix,
737             # http://www.opengroup.org/onlinepubs/009695399/utilities/man.html
738             # Is it man-db specific, or does it have a chance of working elsewhere?
739             #
740             use constant::defer _man_has_location_option => sub {
741 1         16   my ($self) = @_;
742             ### _man_has_location_option() ...
743 1         716   require IPC::Run;
744 1         29497   my $str = '';
745 1         2   eval {
746 1         19     IPC::Run::run (['man','--help'],
747                                '<', \undef,
748                                '>', \$str,
749                                '2>', File::Spec->devnull);
750               };
751 1         939   my $ret = ($str =~ /--location\b/);
752 1 50       5   if ($self->{'verbose'} >= 2) {
753 0 0       0     if ($ret) {
754 0         0       print __("man \"--location\" option is available\n");
755                 } else {
756 0         0       print __("man \"--location\" option not available (not in its \"--help\")\n");
757                 }
758               }
759             ### $ret
760 1         5   return $ret;
761 1     1   1270 };
  1         1  
  1         6  
762              
763             sub _manpage_is_known_by_location {
764 0     0   0   my ($self, @manargs) = @_;
765             ### _manpage_is_known_by_location() run: \@manargs
766 0         0   require IPC::Run;
767 0         0   my $str;
768 0 0       0   if (! eval {
769 0         0     IPC::Run::run (['man', '--location', @manargs],
770                                '<', \undef, # stdin
771                                '>', \$str, # stdout
772                                '2>', File::Spec->devnull);
773 0         0     1;
774               }) {
775 0         0     my $err = $@;
776 0         0     $err =~ s/\s+$//;
777 0         0     print __x("PodLinkCheck: error running 'man': {error}\n", error => $err);
778 0         0     return 0;
779               }
780             ### _manpage_is_known_by_location() output: $str
781 0 0       0   return ($str =~ /\n/ ? 1 : 0);
782             }
783              
784             sub _manpage_is_known_by_output {
785 6     6   48   my ($self, @manargs) = @_;
786             ### _manpage_is_known_by_output() run: \@manargs
787 6         29   require IPC::Run;
788 6         569   require File::Temp;
789 6         7393   my $fh = File::Temp->new (TEMPLATE => 'PodLinkCheck-man-XXXXXX',
790                                         TMPDIR => 1);
791 6 50       1716   if (! eval {
792 6         38     IPC::Run::run (['man', @manargs],
793                                '<', \undef, # stdin
794                                '>', $fh, # stdout
795                                '2>', File::Spec->devnull);
796 0         0     1;
797               }) {
798 6         5050     my $err = $@;
799 6         30     $err =~ s/\s+$//;
800 6         16     print __x("PodLinkCheck: error running 'man': {error}\n", error => $err);
801 6         1096     return 0;
802               }
803              
804 0             seek $fh, 0, 0;
805 0             foreach (1 .. 5) {
806 0 0             if (! defined (readline $fh)) {
807 0                 return 0;
808                 }
809               }
810 0             return 1;
811             }
812              
813             1;
814             __END__
815            
816             =for stopwords PodLinkCheck Ryde stdout lockfiles symlinks
817            
818             =head1 NAME
819            
820             App::PodLinkCheck -- check Perl pod LE<lt>E<gt> link references
821            
822             =head1 SYNOPSIS
823            
824             use App::PodLinkCheck;
825             exit App::PodLinkCheck->command_line;
826            
827             =head1 FUNCTIONS
828            
829             =over 4
830            
831             =item C<$plc = App::PodLinkCheck-E<gt>new (key =E<gt> value, ...)>
832            
833             Create and return a PodLinkCheck object. The optional key/value parameters
834             are
835            
836             =over
837            
838             =item C<verbose =E<gt> $integer> (default 0)
839            
840             Print some diagnostics about checking. Currently C<verbose=E<gt>1> shows
841             all the links checked, or C<verbose=E<gt>2> shows that and also available
842             targets detected in destination files etc.
843            
844             =back
845            
846             =item C<$exitcode = $plc-E<gt>command_line>
847            
848             Run a PodLinkCheck as from the command line. Arguments are taken from
849             C<@ARGV> and the return is an exit status code suitable for C<exit>, so 0
850             for success.
851            
852             =item C<$plc-E<gt>check_file ($filename)>
853            
854             Run checks on a single file C<$filename> and print reports to stdout.
855            
856             =item C<$plc-E<gt>check_tree ($file_or_dir, ...)>
857            
858             Run checks on all the files or directories given and print reports to
859             stdout. Directories are traversed recursively, checking all Perl files.
860             A Perl file is F<.pm>, F<.pl> or F<.pod>. Emacs F<.#foo.pm> etc lockfiles
861             (dangling symlinks) are ignored.
862            
863             =back
864            
865             =head1 SEE ALSO
866            
867             L<podlinkcheck>
868            
869             L<App::PodLinkCheck::ParseLinks>,
870             L<App::PodLinkCheck::ParseSections>
871            
872             =head1 HOME PAGE
873            
874             http://user42.tuxfamily.org/podlinkcheck/index.html
875            
876             =head1 LICENSE
877            
878             Copyright 2010, 2011, 2012, 2013, 2016 Kevin Ryde
879            
880             PodLinkCheck is free software; you can redistribute it and/or modify it
881             under the terms of the GNU General Public License as published by the Free
882             Software Foundation; either version 3, or (at your option) any later
883             version.
884            
885             PodLinkCheck is distributed in the hope that it will be useful, but WITHOUT
886             ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
887             FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
888             more details.
889            
890             You should have received a copy of the GNU General Public License along with
891             PodLinkCheck. If not, see <http://www.gnu.org/licenses/>.
892            
893             =cut
894            
895