This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
podcheck.t: Reduce F<> message false positives
[perl5.git] / t / porting / podcheck.t
1 #!/usr/bin/perl -w
2
3 use strict;
4 use warnings;
5 use feature 'unicode_strings';
6
7 use Carp;
8 use Digest;
9 use File::Find;
10 use File::Spec;
11 use Scalar::Util;
12 use Text::Tabs;
13
14 BEGIN {
15     require '../regen/regen_lib.pl';
16 }
17
18 sub DEBUG { 0 };
19
20 =pod
21
22 =head1 NAME
23
24 podcheck.t - Look for possible problems in the Perl pods
25
26 =head1 SYNOPSIS
27
28  cd t
29  ./perl -I../lib porting/podcheck.t [--show_all] [--cpan] [--counts]
30                                                             [ FILE ...]
31  ./perl -I../lib porting/podcheck.t --add_link MODULE ...
32
33  ./perl -I../lib porting/podcheck.t --regen
34
35 =head1 DESCRIPTION
36
37 podcheck.t is an extension of Pod::Checker.  It looks for pod errors and
38 potential errors in the files given as arguments, or if none specified, in all
39 pods in the distribution workspace, except those in the cpan directory (unless
40 C<--cpan> is specified).  It does additional checking beyond that done by
41 Pod::Checker, and keeps a database of known potential problems, and will
42 fail a pod only if the number of such problems differs from that given in the
43 database.  It also suppresses the C<(section) deprecated> message from
44 Pod::Checker, since specifying the man page section number is quite proper to do.
45
46 The additional checks it makes are:
47
48 =over
49
50 =item Cross-pod link checking
51
52 Pod::Checker verifies that links to an internal target in a pod are not
53 broken.  podcheck.t extends that (when called without FILE arguments) to
54 external links.  It does this by gathering up all the possible targets in the
55 workspace, and cross-checking them.  It also checks that a non-broken link
56 points to just one target.  (The destination pod could have two targets with
57 the same name.)
58
59 The way that the C<LE<lt>E<gt>> pod command works (for links outside the pod)
60 is to actually create a link to C<search.cpan.org> with an embedded query for
61 the desired pod or man page.  That means that links outside the distribution
62 are valid.  podcheck.t doesn't verify the validity of such links, but instead
63 keeps a data base of those known to be valid.  This means that if a link to a
64 target not on the list is created, the target needs to be added to the data
65 base.  This is accomplished via the L<--add_link|/--add_link MODULE ...>
66 option to podcheck.t, described below.
67
68 =item An internal link that isn't so specified
69
70 If a link is broken, but there is an existing internal target of the same
71 name, it is likely that the internal target was meant, and the C<"/"> is
72 missing from the C<LE<lt>E<gt>> pod command.
73
74 =item Verbatim paragraphs that wrap in an 80 column window
75
76 It's annoying to have lines wrap when displaying pod documentation in a
77 terminal window.  This checks that all such lines fit, and for those that
78 don't, it tells you how much needs to be cut in order to fit.  However,
79 if you're fixing these, keep in mind that some terminal/pager combinations
80 require really a maximum of 79 or 78 columns to display properly.
81
82 Often, the easiest thing to do to gain space for these is to lower the indent
83 to just one space.
84
85 =item Missing or duplicate NAME or missing NAME short description
86
87 A pod can't be linked to unless it has a unique name.
88 And a NAME should have a dash and short description after it.
89
90 =item =encoding statement issues
91
92 This indicates if an C<=encoding> statement should be present, or moved to the
93 front of the pod.
94
95 =item Items that perhaps should be links
96
97 There are mentions of apparent files in the pods that perhaps should be links
98 instead, using C<LE<lt>...E<gt>>
99
100 =item Items that perhaps should be C<FE<lt>...E<gt>>
101
102 What look like path names enclosed in C<CE<lt>...E<gt>> should perhaps have
103 C<FE<lt>...E<gt>> mark-up instead.
104
105 =back
106
107 A number of issues raised by podcheck.t and by the base Pod::Checker are not
108 really problems, but merely potential problems.  After inspecting them and
109 deciding that they aren't real problems, it is possible to shut up this program
110 about them, unlike base Pod::Checker.  To do this, call podcheck.t with the
111 C<--regen> option to regenerate the database.  This tells it that all existing
112 issues are to not be mentioned again.
113
114 This isn't fool-proof.  The database merely keeps track of the number of these
115 potential problems of each type for each pod.  If a new problem of a given
116 type is introduced into the pod, podcheck.t will spit out all of them.  You
117 then have to figure out which is the new one, and should it be changed or not.
118 But doing it this way insulates the database from having to keep track of line
119 numbers of problems, which may change, or the exact wording of each problem
120 which might also change without affecting whether it is a problem or not.
121
122 Also, if the count of potential problems of a given type for a pod decreases,
123 the database must be regenerated so that it knows the new number.  The program
124 gives instructions when this happens.
125
126 There is currently no check that modules listed as valid in the data base
127 actually are.  Thus any errors introduced there will remain there.
128
129 =head1 OPTIONS
130
131 =over
132
133 =item --add_link MODULE ...
134
135 Use this option to teach podcheck.t that the C<MODULE>s or man pages actually
136 exist, and to silence any messages that links to them are broken.
137
138 podcheck.t checks that links within the Perl core distribution are valid, but
139 it doesn't check links to man pages or external modules.  When it finds
140 a broken link, it checks its data base of external modules and man pages,
141 and only if not found there does it raise a message.  This option just adds
142 the list of modules and man page references that follow it on the command line
143 to that data base.
144
145 For example,
146
147     cd t
148     ./perl -I../lib porting/podcheck.t --add_link Unicode::Casing
149
150 causes the external module "Unicode::Casing" to be added to the data base, so
151 C<LE<lt>Unicode::Casing<gt>> will be considered valid.
152
153 =item --regen
154
155 Regenerate the data base used by podcheck.t to include all the existing
156 potential problems.  Future runs of the program will not then flag any of
157 these.
158
159 =item --cpan
160
161 Normally, all pods in the cpan directory are skipped, except to make sure that
162 any blead-upstream links to such pods are valid.
163 This option will cause cpan upstream pods to be checked.
164
165 =item --show_all
166
167 Normally, if the number of potential problems of a given type found for a
168 pod matches the expected value in the database, they will not be displayed.
169 This option forces the database to be ignored during the run, so all potential
170 problems are displayed and will fail their respective pod test.  Specifying
171 any particular FILES to operate on automatically selects this option.
172
173 =item --counts
174
175 Instead of testing, this just dumps the counts of the occurrences of the
176 various types of potential problems in the data base.
177
178 =back
179
180 =head1 FILES
181
182 The database is stored in F<t/porting/known_pod_issues.dat>
183
184 =head1 SEE ALSO
185
186 L<Pod::Checker>
187
188 =cut
189
190 #####################################################
191 # HOW IT WORKS (in general)
192 #
193 # If not called with specific files to check, the directory structure is
194 # examined for files that have pods in them.  Files that might not have to be
195 # fully parsed (e.g. in cpan) are parsed enough at this time to find their
196 # pod's NAME, and to get a checksum.
197 #
198 # Those kinds of files are sorted last, but otherwise the pods are parsed with
199 # the package coded here, My::Pod::Checker, which is an extension to
200 # Pod::Checker that adds some tests and suppresses others that aren't
201 # appropriate.  The latter module has no provision for capturing diagnostics,
202 # so a package, Tie_Array_to_FH, is used to force them to be placed into an
203 # array instead of printed.
204 #
205 # Parsing the files builds up a list of links.  The files are gone through
206 # again, doing cross-link checking and outputting all saved-up problems with
207 # each pod.
208 #
209 # Sorting the files last that potentially don't need to be fully parsed allows
210 # us to not parse them unless there is a link to an internal anchor in them
211 # from something that we have already parsed.  Keeping checksums allows us to
212 # not parse copies of other pods.
213 #
214 #####################################################
215
216 # 1 => Exclude low priority messages that aren't likely to be problems, and
217 # has many false positives; higher numbers give more messages.
218 my $Warnings_Level = 200;
219
220 # perldelta during construction may have place holder links.
221 our @perldelta_ignore_links = ( "XXX", "perl5YYYdelta" );
222
223 # To see if two pods with the same NAME are actually copies of the same pod,
224 # which is not an error, it uses a checksum to save work.
225 my $digest_type = "SHA-1";
226
227 my $original_dir = File::Spec->rel2abs(File::Spec->curdir);
228 my $data_dir = File::Spec->catdir($original_dir, 'porting');
229 my $known_issues = File::Spec->catfile($data_dir, 'known_pod_issues.dat');
230 my $copy_fh;
231
232 my $MAX_LINE_LENGTH = 80;   # 80 columns
233 my $INDENT = 8;             # default nroff indent
234
235 # Our warning messages.  Better not have [('"] in them, as those are used as
236 # delimiters for variable parts of the messages by poderror.
237 my $line_length = "Verbatim line length including indents exceeds $MAX_LINE_LENGTH by";
238 my $broken_link = "Apparent broken link";
239 my $broken_internal_link = "Apparent internal link is missing its forward slash";
240 my $see_not_linked = "? Should you be using L<...> instead of";
241 my $C_with_slash = "? Should you be using F<...> or maybe L<...> instead of";
242 my $multiple_targets = "There is more than one target";
243 my $duplicate_name = "Pod NAME already used";
244 my $need_encoding = "Should have =encoding statement because have non-ASCII";
245 my $encoding_first = "=encoding must be first command (if present)";
246 my $no_name = "There is no NAME";
247 my $missing_name_description = "The NAME should have a dash and short description after it";
248
249 # objects, tests, etc can't be pods, so don't look for them. Also skip
250 # files output by the patch program.  Could also ignore most of .gitignore
251 # files, but not all, so don't.
252 my $non_pods = qr/ (?: \.
253                        (?: [achot]  | zip | gz | bz2 | jar | tar | tgz | PL | so
254                            | orig | rej | patch   # Patch program output
255                            | sw[op] | \#.*  # Editor droppings
256                        )
257                        $
258                     ) | ~$      # Another editor dropping
259                 /x;
260
261
262 # Pod::Checker messages to suppress
263 my @suppressed_messages = (
264     "(section) in",                         # Checker is wrong to flag this
265     "multiple occurrence of link target",   # We catch independently the ones
266                                             # that are real problems.
267     "unescaped <>",
268     "Entity number out of range",   # Checker outputs this for anything above
269                                     # 255, and all Unicode is valid
270 );
271
272 sub suppressed {
273     # Returns bool as to if input message is one that is to be suppressed
274
275     my $message = shift;
276     return grep { $message =~ /^\Q$_/i } @suppressed_messages;
277 }
278
279 {   # Closure to contain a simple subset of test.pl.  This is to get rid of the
280     # unnecessary 'failed at' messages that would otherwise be output pointing
281     # to a particular line in this file.
282
283     my $current_test = 0;
284     my $planned;
285
286     sub plan {
287         my %plan = @_;
288         $planned = $plan{tests};
289         print "1..$planned\n";
290         return;
291     }
292
293     sub ok {
294         my $success = shift;
295         my $message = shift;
296
297         chomp $message;
298
299         $current_test++;
300         print "not " unless $success;
301         print "ok $current_test - $message\n";
302         return;
303     }
304
305     sub skip {
306         my $why = shift;
307         my $n    = @_ ? shift : 1;
308         for (1..$n) {
309             $current_test++;
310             print "ok $current_test # skip $why\n";
311         }
312         no warnings 'exiting';
313         last SKIP;
314     }
315
316     sub note {
317         my $message = shift;
318
319         chomp $message;
320
321         print $message =~ s/^/# /mgr;
322         print "\n";
323         return;
324     }
325
326     END {
327         if ($planned && $planned != $current_test) {
328             print STDERR
329             "# Looks like you planned $planned tests but ran $current_test.\n";
330         }
331     }
332 }
333
334 # This is to get this to work across multiple file systems, including those
335 # that are not case sensitive.  The db is stored in lower case, Un*x style,
336 # and all file name comparisons are done that way.
337 sub canonicalize($) {
338     my $input = shift;
339     my ($volume, $directories, $file)
340                     = File::Spec->splitpath(File::Spec->canonpath($input));
341     # Assumes $volume is constant for everything in this directory structure
342     $directories = "" if ! $directories;
343     $file = "" if ! $file;
344     my $output = lc join '/', File::Spec->splitdir($directories), $file;
345     $output =~ s! / /+ !/!gx;       # Multiple slashes => single slash
346     return $output;
347 }
348
349
350 # List of known potential problems by pod and type.
351 my %known_problems;
352
353 # Pods given by the keys contain an interior node that is referred to from
354 # outside it.
355 my %has_referred_to_node;
356
357 my $show_counts = 0;
358 my $regen = 0;
359 my $add_link = 0;
360 my $show_all = 0;
361
362 # Assume that are to skip anything in /cpan
363 my $do_upstream_cpan = 0;
364
365 while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
366     my $arg = shift @ARGV;
367
368     $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
369     if ($arg eq '-regen') {
370         $regen = 1;
371     }
372     elsif ($arg eq '-add_link') {
373         $add_link = 1;
374     }
375     elsif ($arg eq '-cpan') {
376         $do_upstream_cpan = 1;
377     }
378     elsif ($arg eq '-show_all') {
379         $show_all = 1;
380     }
381     elsif ($arg eq '-counts') {
382         $show_counts = 1;
383     }
384     else {
385         die <<EOF;
386 Unknown option '$arg'
387
388 Usage: $0 [ --regen | --cpan | --show_all | FILE ... | --add_link MODULE ... ]\n"
389     --add_link -> Add the MODULE and man page references to the data base
390     --regen    -> Regenerate the data file for $0
391     --cpan     -> Include files in the cpan subdirectory.
392     --show_all -> Show all known potential problems
393     --counts   -> Don't test, but give summary counts of the currently
394                   existing database
395 EOF
396     }
397 }
398
399 my @files = @ARGV;
400
401 if (($regen + $show_all + $show_counts + $do_upstream_cpan + $add_link) > 1) {
402     croak "--regen, --show_all, --cpan, --counts, and --add_link are mutually exclusive";
403 }
404
405 my $has_input_files = @files;
406
407 if ($has_input_files && ($regen || $show_counts || $do_upstream_cpan)) {
408     croak "--regen, --counts and --cpan can't be used since using specific files";
409 }
410
411 if ($add_link && ! $has_input_files) {
412     croak "--add_link requires at least one module or man page reference";
413 }
414
415 our %problems;  # potential problems found in this run
416
417 package My::Pod::Checker {      # Extend Pod::Checker
418     use parent 'Pod::Checker';
419
420     # Uses inside out hash to protect from typos
421     # For new fields, remember to add to destructor DESTROY()
422     my %indents;            # Stack of indents from =over's in effect for
423                             # current line
424     my %current_indent;     # Current line's indent
425     my %filename;           # The pod is store in this file
426     my %skip;               # is SKIP set for this pod
427     my %in_NAME;            # true if within NAME section
428     my %in_begin;           # true if within =begin section
429     my %linkable_item;      # Bool: if the latest =item is linkable.  It isn't
430                             # for bullet and number lists
431     my %linkable_nodes;     # Pod::Checker adds all =items to its node list,
432                             # but not all =items are linkable to
433     my %seen_encoding_cmd;  # true if have =encoding earlier
434     my %command_count;      # Number of commands seen
435     my %seen_pod_cmd;       # true if have =pod earlier
436     my %warned_encoding;    # true if already have warned about =encoding
437                             # problems
438
439     sub DESTROY {
440         my $addr = Scalar::Util::refaddr $_[0];
441         delete $command_count{$addr};
442         delete $current_indent{$addr};
443         delete $filename{$addr};
444         delete $in_begin{$addr};
445         delete $indents{$addr};
446         delete $in_NAME{$addr};
447         delete $linkable_item{$addr};
448         delete $linkable_nodes{$addr};
449         delete $seen_encoding_cmd{$addr};
450         delete $seen_pod_cmd{$addr};
451         delete $skip{$addr};
452         delete $warned_encoding{$addr};
453         return;
454     }
455
456     sub new {
457         my $class = shift;
458         my $filename = shift;
459
460         my $self = $class->SUPER::new(-quiet => 1,
461                                      -warnings => $Warnings_Level);
462         my $addr = Scalar::Util::refaddr $self;
463         $command_count{$addr} = 0;
464         $current_indent{$addr} = 0;
465         $filename{$addr} = $filename;
466         $in_begin{$addr} = 0;
467         $in_NAME{$addr} = 0;
468         $linkable_item{$addr} = 0;
469         $seen_encoding_cmd{$addr} = 0;
470         $seen_pod_cmd{$addr} = 0;
471         $warned_encoding{$addr} = 0;
472         return $self;
473     }
474
475     # re's for messages that Pod::Checker outputs
476     my $location = qr/ \b (?:in|at|on|near) \s+ /xi;
477     my $optional_location = qr/ (?: $location )? /xi;
478     my $line_reference = qr/ [('"]? $optional_location \b line \s+
479                              (?: \d+ | EOF | \Q???\E | - )
480                              [)'"]? /xi;
481
482     sub poderror {  # Called to register a potential problem
483
484         # This adds an extra field to the parent hash, 'parameter'.  It is
485         # used to extract the variable parts of a message leaving just the
486         # constant skeleton.  This in turn allows the message to be
487         # categorized better, so that it shows up as a single type in our
488         # database, with the specifics of each occurrence not being stored with
489         # it.
490
491         my $self = shift;
492         my $opts = shift;
493
494         my $addr = Scalar::Util::refaddr $self;
495         return if $skip{$addr};
496
497         # Input can be a string or hash.  If a string, parse it to separate
498         # out the line number and convert to a hash for easier further
499         # processing
500         my $message;
501         if (ref $opts ne 'HASH') {
502             $message = join "", $opts, @_;
503             my $line_number;
504             if ($message =~ s/\s*($line_reference)//) {
505                 ($line_number = $1) =~ s/\s*$optional_location//;
506             }
507             else {
508                 $line_number = '???';
509             }
510             $opts = { -msg => $message, -line => $line_number };
511         } else {
512             $message = $opts->{'-msg'};
513
514         }
515
516         $message =~ s/^\d+\s+//;
517         return if main::suppressed($message);
518
519         $self->SUPER::poderror($opts, @_);
520
521         $opts->{parameter} = "" unless $opts->{parameter};
522
523         # The variable parts of the message tend to be enclosed in '...',
524         # "....", or (...).  Extract them and put them in an extra field,
525         # 'parameter'.  This is trickier because the matching delimiter to a
526         # '(' is its mirror, and not itself.  Text::Balanced could be used
527         # instead.
528         while ($message =~ m/ \s* $optional_location ( [('"] )/xg) {
529             my $delimiter = $1;
530             my $start = $-[0];
531             $delimiter = ')' if $delimiter eq '(';
532
533             # If there is no ending delimiter, don't consider it to be a
534             # variable part.  Most likely it is a contraction like "Don't"
535             last unless $message =~ m/\G .+? \Q$delimiter/xg;
536
537             my $length = $+[0] - $start;
538
539             # Get the part up through the closing delimiter
540             my $special = substr($message, $start, $length);
541             $special =~ s/^\s+//;   # No leading whitespace
542
543             # And add that variable part to the parameter, while removing it
544             # from the message.  This isn't a foolproof way of finding the
545             # variable part.  For example '(s)' can occur in e.g.,
546             # 'paragraph(s)'
547             if ($special ne '(s)') {
548                 substr($message, $start, $length) = "";
549                 pos $message = $start;
550                 $opts->{-msg} = $message;
551                 $opts->{parameter} .= " " if $opts->{parameter};
552                 $opts->{parameter} .= $special;
553             }
554         }
555
556         # Extract any additional line number given.  This is often the
557         # beginning location of something whereas the main line number gives
558         # the ending one.
559         if ($message =~ /( $line_reference )/xi) {
560             my $line_ref = $1;
561             while ($message =~ s/\s*\Q$line_ref//) {
562                 $opts->{-msg} = $message;
563                 $opts->{parameter} .= " " if $opts->{parameter};
564                 $opts->{parameter} .= $line_ref;
565             }
566         }
567
568         Carp::carp("Couldn't extract line number from '$message'") if $message =~ /line \d+/;
569         push @{$problems{$filename{$addr}}{$message}}, $opts;
570         #push @{$problems{$self->get_filename}{$message}}, $opts;
571     }
572
573     sub check_encoding {    # Does it need an =encoding statement?
574         my ($self, $paragraph, $line_num, $pod_para) = @_;
575
576         # Do nothing if there is an =encoding in the file, or if the line
577         # doesn't require an =encoding, or have already warned.
578         my $addr = Scalar::Util::refaddr $self;
579         return if $seen_encoding_cmd{$addr}
580                     || $warned_encoding{$addr}
581                     || $paragraph !~ /\P{ASCII}/;
582
583         $warned_encoding{$addr} = 1;
584         my ($file, $line) = $pod_para->file_line;
585         $self->poderror({ -line => $line, -file => $file,
586                           -msg => $need_encoding
587                         });
588         return;
589     }
590
591     sub verbatim {
592         my ($self, $paragraph, $line_num, $pod_para) = @_;
593         $self->check_encoding($paragraph, $line_num, $pod_para);
594
595         $self->SUPER::verbatim($paragraph, $line_num, $pod_para);
596
597         my $addr = Scalar::Util::refaddr $self;
598
599         # Pick up the name, since the parent class doesn't in verbatim
600         # NAMEs; so treat as non-verbatim.  The parent class only allows one
601         # paragraph in a NAME section, so if there is an extra blank line, it
602         # will trigger a message, but such a blank line is harmless, so skip
603         # in that case.
604         if ($in_NAME{$addr} && $paragraph =~ /\S/) {
605             $self->textblock($paragraph, $line_num, $pod_para);
606         }
607
608         my @lines = split /^/, $paragraph;
609         for my $i (0 .. @lines - 1) {
610             if ( my $encoding = $seen_encoding_cmd{$addr} ) {
611               require Encode;
612               $lines[$i] = Encode::decode($encoding, $lines[$i]);
613             }
614             $lines[$i] =~ s/\s+$//;
615             my $indent = $self->get_current_indent;
616             my $exceeds = length(Text::Tabs::expand($lines[$i]))
617                           + $indent - $MAX_LINE_LENGTH;
618             next unless $exceeds > 0;
619             my ($file, $line) = $pod_para->file_line;
620             $self->poderror({ -line => $line + $i, -file => $file,
621                 -msg => $line_length,
622                 parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
623             });
624         }
625     }
626
627     sub textblock {
628         my ($self, $paragraph, $line_num, $pod_para) = @_;
629         $self->check_encoding($paragraph, $line_num, $pod_para);
630
631         $self->SUPER::textblock($paragraph, $line_num, $pod_para);
632
633         my ($file, $line) = $pod_para->file_line;
634         my $addr = Scalar::Util::refaddr $self;
635         if ($in_NAME{$addr}) {
636             if (! $self->name) {
637                 my $text = $self->interpolate($paragraph, $line_num);
638                 if ($text =~ /^\s*(\S+?)\s*$/) {
639                     $self->name($1);
640                     $self->poderror({ -line => $line, -file => $file,
641                         -msg => $missing_name_description,
642                         parameter => $1});
643                 }
644             }
645         }
646         $paragraph = join " ", split /^/, $paragraph;
647
648         # Matches something that looks like a file name, but is enclosed in
649         # C<...>
650         my $C_path_re = qr{ \b ( C<
651                                 # exclude various things that have slashes
652                                 # in them but aren't paths
653                                 (?!
654                                     (?: (?: s | qr | m) / ) # regexes
655                                     | \d+/\d+>       # probable fractions
656                                     | OS/2>
657                                     | Perl/Tk>
658                                     | origin/blead>
659                                     | origin/maint
660                                     | -    # File names don't begin with "-"
661                                  )
662                                  [-\w]+ (?: / [-\w]+ )+ (?: \. \w+ )? > )
663                           }x;
664
665         # If looks like a reference to other documentation by containing the
666         # word 'See' and then a likely pod directive, warn.
667         while ($paragraph =~ m{
668                                 ( (?: \w+ \s+ )* )  # The phrase before, if any
669                                 \b [Ss]ee \s+
670                                 ( ( [^L] )
671                                   <
672                                   ( [^<]*? )  # The not < excludes nested C<L<...
673                                   >
674                                 )
675                                 ( \s+ (?: under | in ) \s+ L< )?
676                             }xg) {
677             my $prefix = $1 // "";
678             my $construct = $2;     # The whole thing, like C<...>
679             my $type = $3;
680             my $interior = $4;
681             my $trailing = $5;      # After the whole thing ending in "L<"
682
683             # If the full phrase is something like, "you might see C<", or
684             # similar, it really isn't a reference to a link.  The ones I saw
685             # all had the word "you" in them; and the "you" wasn't the
686             # beginning of a sentence.
687             if ($prefix !~ / \b you \b /x) {
688
689                 # Now, find what the module or man page name within the
690                 # construct would be if it actually has L<> syntax.  If it
691                 # doesn't have that syntax, will set the module to the entire
692                 # interior.
693                 $interior =~ m/ ^
694                                 (?: [^|]+ \| )? # Optional arbitrary text ending
695                                                 # in "|"
696                                 ( .+? )         # module, etc. name
697                                 (?: \/ .+ )?    # target within module
698                                 $
699                             /xs;
700                 my $module = $1;
701                 if (! defined $trailing # not referring to something in another
702                                         # section
703                     && $interior !~ /$non_pods/
704
705                     # C<> that look like files have their own message below, so
706                     # exclude them
707                     && $construct !~ /$C_path_re/g
708
709                     # There can't be spaces (I think) in module names or man
710                     # pages
711                     && $module !~ / \s /x
712
713                     # F<> that end in eg \.pl are almost certainly ok, as are
714                     # those that look like a path with multiple "/" chars
715                     && ($type ne "F"
716                         || (! -e $interior
717                             && $interior !~ /\.\w+$/
718                             && $interior !~ /\/.+\//)
719                     )
720                 ) {
721                     $self->poderror({ -line => $line, -file => $file,
722                         -msg => $see_not_linked,
723                         parameter => $construct
724                     });
725                 }
726             }
727         }
728         while ($paragraph =~ m/$C_path_re/g) {
729             my $construct = $1;
730             $self->poderror({ -line => $line, -file => $file,
731                 -msg => $C_with_slash,
732                 parameter => $construct
733             });
734         }
735         return;
736     }
737
738     sub command {
739         my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
740         my $addr = Scalar::Util::refaddr $self;
741         if ($cmd eq "pod") {
742             $seen_pod_cmd{$addr}++;
743         }
744         elsif ($cmd eq "encoding") {
745             my ($file, $line) = $pod_para->file_line;
746             $seen_encoding_cmd{$addr} = $paragraph; # for later decoding
747             if ($command_count{$addr} != 1 && $seen_pod_cmd{$addr}) {
748                 $self->poderror({ -line => $line, -file => $file,
749                                   -msg => $encoding_first
750                                 });
751             }
752         }
753         $self->check_encoding($paragraph, $line_num, $pod_para);
754
755         # Pod::Check treats all =items as linkable, but the bullet and
756         # numbered lists really aren't.  So keep our own list.  This has to be
757         # processed before SUPER is called so that the list is started before
758         # the rest of it gets parsed.
759         if ($cmd eq 'item') { # Not linkable if item begins with * or a digit
760             $linkable_item{$addr} = ($paragraph !~ / ^ \s*
761                                                    (?: [*]
762                                                    | \d+ \.? (?: \$ | \s+ )
763                                                    )/x)
764                                   ? 1
765                                   : 0;
766
767         }
768         $self->SUPER::command($cmd, $paragraph, $line_num, $pod_para);
769
770         $command_count{$addr}++;
771
772         $in_NAME{$addr} = 0;    # Will change to 1 below if necessary
773         $in_begin{$addr} = 0;   # ibid
774         if ($cmd eq 'over') {
775             my $text = $self->interpolate($paragraph, $line_num);
776             my $indent = 4; # default
777             $indent = $1 if $text && $text =~ /^\s*(\d+)\s*$/;
778             push @{$indents{$addr}}, $indent;
779             $current_indent{$addr} += $indent;
780         }
781         elsif ($cmd eq 'back') {
782             if (@{$indents{$addr}}) {
783                 $current_indent{$addr} -= pop @{$indents{$addr}};
784             }
785             else {
786                  # =back without corresponding =over, but should have
787                  # warned already
788                 $current_indent{$addr} = 0;
789             }
790         }
791         elsif ($cmd =~ /^head/) {
792             if (! $in_begin{$addr}) {
793
794                 # If a particular formatter, then this command doesn't really
795                 # apply
796                 $current_indent{$addr} = 0;
797                 undef @{$indents{$addr}};
798             }
799
800             my $text = $self->interpolate($paragraph, $line_num);
801             $in_NAME{$addr} = 1 if $cmd eq 'head1'
802                                    && $text && $text =~ /^NAME\b/;
803         }
804         elsif ($cmd eq 'begin') {
805             $in_begin{$addr} = 1;
806         }
807
808         return;
809     }
810
811     sub hyperlink {
812         my $self = shift;
813
814         # If the hyperlink is to an interior node of another page, save it
815         # so that we can see if we need to parse normally skipped files.
816         $has_referred_to_node{$_[0][1]{'-page'}} = 1
817                             if $_[0] && $_[0][1]{'-page'} && $_[0][1]{'-node'};
818         return $self->SUPER::hyperlink($_[0]);
819     }
820
821     sub node {
822         my $self = shift;
823         my $text = $_[0];
824         if($text) {
825             $text =~ s/\s+$//s; # strip trailing whitespace
826             $text =~ s/\s+/ /gs; # collapse whitespace
827             my $addr = Scalar::Util::refaddr $self;
828             push(@{$linkable_nodes{$addr}}, $text) if
829                                     ! $current_indent{$addr}
830                                     || $linkable_item{$addr};
831         }
832         return $self->SUPER::node($_[0]);
833     }
834
835     sub get_current_indent {
836         return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
837     }
838
839     sub get_filename {
840         return $filename{Scalar::Util::refaddr $_[0]};
841     }
842
843     sub linkable_nodes {
844         my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
845         return undef unless $linkables;
846         return @$linkables;
847     }
848
849     sub get_skip {
850         return $skip{Scalar::Util::refaddr $_[0]} // 0;
851     }
852
853     sub set_skip {
854         my $self = shift;
855         $skip{Scalar::Util::refaddr $self} = shift;
856
857         # If skipping, no need to keep the problems for it
858         delete $problems{$self->get_filename};
859         return;
860     }
861 }
862
863 package Tie_Array_to_FH {  # So printing actually goes to an array
864
865     my %array;
866
867     sub TIEHANDLE {
868         my $class = shift;
869         my $array_ref = shift;
870
871         my $self = bless \do{ my $anonymous_scalar }, $class;
872         $array{Scalar::Util::refaddr $self} = $array_ref;
873
874         return $self;
875     }
876
877     sub PRINT {
878         my $self = shift;
879         push @{$array{Scalar::Util::refaddr $self}}, @_;
880         return 1;
881     }
882 }
883
884
885 my %filename_to_checker; # Map a filename to it's pod checker object
886 my %id_to_checker;      # Map a checksum to it's pod checker object
887 my %nodes;              # key is filename, values are nodes in that file.
888 my %nodes_first_word;   # same, but value is first word of each node
889 my %valid_modules;      # List of modules known to exist outside us.
890 my %digests;            # checksums of files, whose names are the keys
891 my %filename_to_pod;    # Map a filename to its pod NAME
892 my %files_with_unknown_issues;
893 my %files_with_fixes;
894
895 my $data_fh;
896 open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
897
898 my %counts; # For --counts param, count of each issue type
899 my %suppressed_files;   # Files with at least one issue type to suppress
900
901
902 if ($add_link) {
903     $copy_fh = open_new($known_issues);
904     my @existing_db = <$data_fh>;
905     my_safer_print($copy_fh, @existing_db);
906
907     foreach my $module (@files) {
908         die "\"$module\" does not look like a module or man page"
909             # Must look like (A or A::B or A::B::C ..., or foo(3C)
910             if $module !~ /^ (?: \w+ (?: :: \w+ )* | \w+ \( \d \w* \) ) $/x;
911         $module .= "\n";
912         next if grep { $module eq $_ } @existing_db;
913         my_safer_print($copy_fh, $module);
914     }
915     close_and_rename($copy_fh);
916     exit;
917 }
918
919 while (<$data_fh>) {    # Read the data base
920     chomp;
921     next if /^\s*(?:#|$)/;  # Skip comment and empty lines
922     if (/\t/) {
923         next if $show_all;
924
925         # Keep track of counts of each issue type for each file
926         my ($filename, $message, $count) = split /\t/;
927         $known_problems{$filename}{$message} = $count;
928
929         if ($show_counts) {
930             if ($count < 0) {   # -1 means to suppress this issue type
931                 $suppressed_files{$filename} = $filename;
932             }
933             else {
934                 $counts{$message} += $count;
935             }
936         }
937     }
938     else {  # Lines without a tab are modules known to be valid
939         $valid_modules{$_} = 1
940     }
941 }
942 close $data_fh;
943
944 if ($show_counts) {
945     my $total = 0;
946     foreach my $message (sort keys %counts) {
947         $total += $counts{$message};
948         note(Text::Tabs::expand("$counts{$message}\t$message"));
949     }
950     note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
951     if (%suppressed_files) {
952         note("\nFiles that have all messages of at least one type suppressed:");
953         note(join ",", keys %suppressed_files);
954     }
955     exit 0;
956 }
957
958
959 my %excluded_files = (
960                         "lib/unicore/mktables" => 1,
961                         "Porting/perldelta_template.pod" => 1,
962                         "autodoc.pl" => 1,
963                         "configpm" => 1,
964                         "miniperl" => 1,
965                         "perl" => 1,
966                     );
967
968 # Convert to more generic form.
969 foreach my $file (keys %excluded_files) {
970     delete $excluded_files{$file};
971     $excluded_files{canonicalize($file)} = 1;
972 }
973
974 # re to match files that are to be parsed only if there is an internal link
975 # to them.  It does not include cpan, as whether those are parsed depends
976 # on a switch.  Currently, only perltoc and the stable perldelta.pod's
977 # are included.  The latter all have characters between 'perl' and
978 # 'delta'.  (Actually the currently developed one matches as well, but
979 # is a duplicate of perldelta.pod, so can be skipped, so fine for it to
980 # match this.
981 my $only_for_interior_links_re = qr/ \b perl \d+ delta \. pod \b
982                                      | ^ pod\/perltoc.pod $
983                                    /x;
984
985 { # Closure
986     my $first_time = 1;
987
988     sub output_thanks ($$$$) {  # Called when an issue has been fixed
989         my $filename = shift;
990         my $original_count = shift;
991         my $current_count = shift;
992         my $message = shift;
993
994         $files_with_fixes{$filename} = 1;
995         my $return;
996         my $fixed_count = $original_count - $current_count;
997         my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
998         my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
999         my $diff;
1000         if ($message) {
1001             $diff = <<EOF;
1002 There were $original_count occurrences (now $current_count) in this pod of type
1003 "$message",
1004 EOF
1005         } else {
1006             $diff = <<EOF;
1007 There are no longer any problems found in this pod!
1008 EOF
1009         }
1010
1011         if ($first_time) {
1012             $first_time = 0;
1013             $return = <<EOF;
1014 Thanks for fixing $a_problem!
1015 $diff
1016 Now you must teach $0 that this was fixed.
1017 EOF
1018         }
1019         else {
1020             $return = <<EOF
1021 Thanks for fixing $another_problem.
1022 $diff
1023 EOF
1024         }
1025
1026         return $return;
1027     }
1028 }
1029
1030 sub my_safer_print {    # print, with error checking for outputting to db
1031     my ($fh, @lines) = @_;
1032
1033     if (! print $fh @lines) {
1034         my $save_error = $!;
1035         close($fh);
1036         die "Write failure: $save_error";
1037     }
1038 }
1039
1040 sub extract_pod {   # Extracts just the pod from a file
1041     my $filename = shift;
1042
1043     my @pod;
1044
1045     # Arrange for the output of Pod::Parser to be collected in an array we can
1046     # look at instead of being printed
1047     tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
1048     open my $in_fh, '<:bytes', $filename
1049
1050         # The file should already have been opened once to get here, so if
1051         # fails, just die.  It's possible that a transitory file containing a
1052         # pod would get here, but not bothering to add code for that very
1053         # unlikely event.
1054         or die "Can't open '$filename': $!\n";
1055
1056     my $parser = Pod::Parser->new();
1057     $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
1058     close $in_fh;
1059
1060     return join "", @pod
1061 }
1062
1063 my $digest = Digest->new($digest_type);
1064
1065 sub is_pod_file {
1066     # If $_ is a pod file, add it to the lists and do other prep work.
1067
1068     if (-d $_) {
1069         # Don't look at files in directories that are for tests, nor those
1070         # beginning with a dot
1071         if ($_ eq 't' || $_ =~ /^\../) {
1072             $File::Find::prune = 1;
1073         }
1074         return;
1075     }
1076
1077     return if $_ =~ /^\./;           # No hidden Unix files
1078     return if $_ =~ $non_pods;
1079
1080     my $filename = $File::Find::name;
1081
1082     # Assumes that the path separator is exactly one character.
1083     $filename =~ s/^\..//;
1084
1085     return if $excluded_files{canonicalize($filename)};
1086
1087     my $contents = do {
1088         local $/;
1089         my $candidate;
1090         if (! open $candidate, '<:bytes', $_) {
1091
1092             # If a transitory file was found earlier, the open could fail
1093             # legitimately and we just skip the file; also skip it if it is a
1094             # broken symbolic link, as it is probably just a build problem;
1095             # certainly not a file that we would want to check the pod of.
1096             # Otherwise fail it here and no reason to process it further.
1097             # (But the test count will be off too)
1098             ok(0, "Can't open '$filename': $!")
1099                                             if -e $filename && ! -l $filename;
1100             return;
1101         }
1102         <$candidate>;
1103     };
1104
1105     # If the file is a .pm or .pod, having any initial '=' on a line is
1106     # grounds for testing it.  Otherwise, require a head1 NAME line to view it
1107     # as a potential pod
1108     if ($filename =~ /\.(?:pm|pod)/) {
1109         return unless $contents =~ /^=/m;
1110     } else {
1111         return unless $contents =~ /^=head1 +NAME/m;
1112     }
1113
1114     # Here, we know that the file is a pod.  Add it to the list of files
1115     # to check and create a checker object for it.
1116
1117     push @files, $filename;
1118     my $checker = My::Pod::Checker->new($filename);
1119     $filename_to_checker{$filename} = $checker;
1120
1121     # In order to detect duplicate pods and only analyze them once, we
1122     # compute checksums for the file, so don't have to do an exact
1123     # compare.  Note that if the pod is just part of the file, the
1124     # checksums can differ for the same pod.  That special case is handled
1125     # later, since if the checksums of the whole file are the same, that
1126     # case won't even come up.  We don't need the checksums for files that
1127     # we parse only if there is a link to its interior, but we do need its
1128     # NAME, which is also retrieved in the code below.
1129
1130     if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
1131                         | $only_for_interior_links_re
1132                     /x) {
1133         $digest->add($contents);
1134         $digests{$filename} = $digest->digest;
1135
1136         # lib files aren't analyzed if they are duplicates of files copied
1137         # there from some other directory.  But to determine this, we need
1138         # to know their NAMEs.  We might as well find the NAME now while
1139         # the file is open.  Similarly, cpan files aren't analyzed unless
1140         # we're analyzing all of them, or this particular file is linked
1141         # to by a file we are analyzing, and thus we will want to verify
1142         # that the target exists in it.  We need to know at least the NAME
1143         # to see if it's worth analyzing, or so we can determine if a lib
1144         # file is a copy of a cpan one.
1145         if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
1146                             | $only_for_interior_links_re
1147                             }x) {
1148             if ($contents =~ /^=head1 +NAME.*/mg) {
1149                 # The NAME is the first non-spaces on the line up to a
1150                 # comma, dash or end of line.  Otherwise, it's invalid and
1151                 # this pod doesn't have a legal name that we're smart
1152                 # enough to find currently.  But the  parser will later
1153                 # find it if it thinks there is a legal name, and set the
1154                 # name
1155                 if ($contents =~ /\G    # continue from the line after =head1
1156                                   \s*   # ignore any empty lines
1157                                   ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
1158                     my $name = $1;
1159                     $checker->name($name);
1160                     $id_to_checker{$name} = $checker
1161                         if $filename =~ m{^cpan/};
1162                 }
1163             }
1164             elsif ($filename =~ m{^cpan/}) {
1165                 $id_to_checker{$digests{$filename}} = $checker;
1166             }
1167         }
1168     }
1169
1170     return;
1171 } # End of is_pod_file()
1172
1173 # Start of real code that isn't processing the command line (except the
1174 # db is read in above, as is processing of the --add_link option).
1175 # Here, @files contains list of files on the command line.  If have any of
1176 # these, unconditionally test them, and show all the errors, even the known
1177 # ones, and, since not testing other pods, don't do cross-pod link tests.
1178 # (Could add extra code to do cross-pod tests for the ones in the list.)
1179
1180 if ($has_input_files) {
1181     undef %known_problems;
1182     $do_upstream_cpan = 1;  # In case one of the inputs is from cpan
1183
1184 }
1185 else { # No input files -- go find all the possibilities.
1186     if ($regen) {
1187         $copy_fh = open_new($known_issues);
1188         note("Regenerating $known_issues, please be patient...");
1189         print $copy_fh <<END;
1190 # This file is the data file for $0.
1191 # There are three types of lines.
1192 # Comment lines are white-space only or begin with a '#', like this one.  Any
1193 #   changes you make to the comment lines will be lost when the file is
1194 #   regen'd.
1195 # Lines without tab characters are simply NAMES of pods that the program knows
1196 #   will have links to them and the program does not check if those links are
1197 #   valid.
1198 # All other lines should have three fields, each separated by a tab.  The
1199 #   first field is the name of a pod; the second field is an error message
1200 #   generated by this program; and the third field is a count of how many
1201 #   known instances of that message there are in the pod.  -1 means that the
1202 #   program can expect any number of this type of message.
1203 END
1204     }
1205
1206     # Move to the directory above us, but have to adjust @INC to account for
1207     # that.
1208     s{^\.\./lib$}{lib} for @INC;
1209     chdir File::Spec->updir;
1210
1211     # And look in this directory and all its subdirectories
1212     find( \&is_pod_file, '.');
1213
1214     # Add ourselves to the test
1215     push @files, "t/porting/podcheck.t";
1216 }
1217
1218 # Now we know how many tests there will be.
1219 plan (tests => scalar @files) if ! $regen;
1220
1221
1222  # Sort file names so we get consistent results, and to put cpan last,
1223  # preceeded by the ones that we don't generally parse.  This is because both
1224  # these classes are generally parsed only if there is a link to the interior
1225  # of them, and we have to parse all others first to guarantee that they don't
1226  # have such a link. 'lib' files come just before these, as some of these are
1227  # duplicates of others.  We already have figured this out when gathering the
1228  # data as a special case for all such files, but this, while unnecessary,
1229  # puts the derived file last in the output.  'readme' files come before those,
1230  # as those also could be duplicates of others, which are considered the
1231  # primary ones.  These currently aren't figured out when gathering data, so
1232  # are done here.
1233  @files = sort { if ($a =~ /^cpan/) {
1234                     return 1 if $b !~ /^cpan/;
1235                     return $a cmp $b;
1236                 }
1237                 elsif ($b =~ /^cpan/) {
1238                     return -1;
1239                 }
1240                 elsif ($a =~ /$only_for_interior_links_re/) {
1241                     return 1 if $b !~ /$only_for_interior_links_re/;
1242                     return $a cmp $b;
1243                 }
1244                 elsif ($b =~ /$only_for_interior_links_re/) {
1245                     return -1;
1246                 }
1247                 elsif ($a =~ /^lib/) {
1248                     return 1 if $b !~ /^lib/;
1249                     return $a cmp $b;
1250                 }
1251                 elsif ($b =~ /^lib/) {
1252                     return -1;
1253                 } elsif ($a =~ /\breadme\b/i) {
1254                     return 1 if $b !~ /\breadme\b/i;
1255                     return $a cmp $b;
1256                 }
1257                 elsif ($b =~ /\breadme\b/i) {
1258                     return -1;
1259                 }
1260                 else {
1261                     return lc $a cmp lc $b;
1262                 }
1263             }
1264             @files;
1265
1266 # Now go through all the files and parse them
1267 foreach my $filename (@files) {
1268     my $parsed = 0;
1269     note("parsing $filename") if DEBUG;
1270
1271     # We may have already figured out some things in the process of generating
1272     # the file list.  If so, have a $checker object already.  But if not,
1273     # generate one now.
1274     my $checker = $filename_to_checker{$filename};
1275     if (! $checker) {
1276         $checker = My::Pod::Checker->new($filename);
1277         $filename_to_checker{$filename} = $checker;
1278     }
1279
1280     # We have set the name in the checker object if there is a possibility
1281     # that no further parsing is necessary, but otherwise do the parsing now.
1282     if (! $checker->name) {
1283         $parsed = 1;
1284         $checker->parse_from_file($filename, undef);
1285     }
1286
1287     if ($checker->num_errors() < 0) {   # Returns negative if not a pod
1288         $checker->set_skip("$filename is not a pod");
1289     }
1290     else {
1291
1292         # Here, is a pod.  See if it is one that has already been tested,
1293         # or should be tested under another directory.  Use either its NAME
1294         # if it has one, or a checksum if not.
1295         my $name = $checker->name;
1296         my $id;
1297
1298         if ($name) {
1299             $id = $name;
1300         }
1301         else {
1302             my $digest = Digest->new($digest_type);
1303             $digest->add(extract_pod($filename));
1304             $id = $digest->digest;
1305         }
1306
1307         # If there is a match for this pod with something that we've already
1308         # processed, don't process it, and output why.
1309         my $prior_checker;
1310         if (defined ($prior_checker = $id_to_checker{$id})
1311             && $prior_checker != $checker)  # Could have defined the checker
1312                                             # earlier without pursuing it
1313         {
1314
1315             # If the pods are identical, then it's just a copy, and isn't an
1316             # error.  First use the checksums we have already computed to see
1317             # if the entire files are identical, which means that the pods are
1318             # identical too.
1319             my $prior_filename = $prior_checker->get_filename;
1320             my $same = (! $name
1321                         || ($digests{$prior_filename}
1322                             && $digests{$filename}
1323                             && $digests{$prior_filename} eq $digests{$filename}));
1324
1325             # If they differ, it could be that the files differ for some
1326             # reason, but the pods they contain are identical.  Extract the
1327             # pods and do the comparisons on just those.
1328             if (! $same && $name) {
1329                 $same = extract_pod($prior_filename) eq extract_pod($filename);
1330             }
1331
1332             if ($same) {
1333                 $checker->set_skip("The pod of $filename is a duplicate of "
1334                                     . "the pod for $prior_filename");
1335             } elsif ($prior_filename =~ /\breadme\b/i) {
1336                 $checker->set_skip("$prior_filename is a README apparently for $filename");
1337             } elsif ($filename =~ /\breadme\b/i) {
1338                 $checker->set_skip("$filename is a README apparently for $prior_filename");
1339             } elsif (! $do_upstream_cpan && $filename =~ /^cpan/) {
1340                 $checker->set_skip("CPAN is upstream for $filename");
1341             } else { # Here have two pods with identical names that differ
1342                 $prior_checker->poderror(
1343                         { -msg => $duplicate_name,
1344                             -line => "???",
1345                             parameter => "'$filename' also has NAME '$name'"
1346                         });
1347                 $checker->poderror(
1348                     { -msg => $duplicate_name,
1349                         -line => "???",
1350                         parameter => "'$prior_filename' also has NAME '$name'"
1351                     });
1352
1353                 # Changing the names helps later.
1354                 $prior_checker->name("$name version arbitrarily numbered 1");
1355                 $checker->name("$name version arbitrarily numbered 2");
1356             }
1357
1358             # In any event, don't process this pod that has the same name as
1359             # another.
1360             next;
1361         }
1362
1363         # A unique pod.
1364         $id_to_checker{$id} = $checker;
1365
1366         my $parsed_for_links = ", but parsed for its interior links";
1367         if ((! $do_upstream_cpan && $filename =~ /^cpan/)
1368              || $filename =~ $only_for_interior_links_re)
1369         {
1370             if ($filename =~ /^cpan/) {
1371                 $checker->set_skip("CPAN is upstream for $filename");
1372             }
1373             elsif ($filename =~ /perl\d+delta/) {
1374                 $checker->set_skip("$filename is a stable perldelta");
1375             }
1376             elsif ($filename =~ /perltoc/) {
1377                 $checker->set_skip("$filename dependent on component pods");
1378             }
1379             else {
1380                 croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
1381             }
1382
1383             if ($name && $has_referred_to_node{$name}) {
1384                 $checker->set_skip($checker->get_skip() . $parsed_for_links);
1385             }
1386         }
1387
1388         # Need a name in order to process it, because not meaningful
1389         # otherwise, and also can't test links to this without a name.
1390         if (!defined $name) {
1391             $checker->poderror( { -msg => $no_name,
1392                                   -line => '???'
1393                                 });
1394             next;
1395         }
1396
1397         # For skipped files, just get its NAME
1398         my $skip;
1399         if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
1400         {
1401             $checker->node($name) if $name;
1402         }
1403         else {
1404             $checker->parse_from_file($filename, undef) if ! $parsed;
1405         }
1406
1407         # Go through everything in the file that could be an anchor that
1408         # could be a link target.  Count how many there are of the same name.
1409         foreach my $node ($checker->linkable_nodes) {
1410             next if ! $node;        # Can be empty is like '=item *'
1411             if (exists $nodes{$name}{$node}) {
1412                 $nodes{$name}{$node}++;
1413             }
1414             else {
1415                 $nodes{$name}{$node} = 1;
1416             }
1417
1418             # Experiments have shown that cpan search can figure out the
1419             # target of a link even if the exact wording is incorrect, as long
1420             # as the first word is.  This happens frequently in perlfunc.pod,
1421             # where the link will be just to the function, but the target
1422             # entry also includes parameters to the function.
1423             my $first_word = $node;
1424             if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
1425                 $nodes_first_word{$name}{$first_word} = $node;
1426             }
1427         }
1428         $filename_to_pod{$filename} = $name;
1429     }
1430 }
1431
1432 # Here, all files have been parsed, and all links and link targets are stored.
1433 # Now go through the files again and see which don't have matches.
1434 if (! $has_input_files) {
1435     foreach my $filename (@files) {
1436         next if $filename_to_checker{$filename}->get_skip;
1437         my $checker = $filename_to_checker{$filename};
1438         foreach my $link ($checker->hyperlink) {
1439             my $linked_to_page = $link->[1]->page;
1440             next unless $linked_to_page;   # intra-file checks are handled by std
1441                                            # Pod::Checker
1442
1443             # Initialize the potential message.
1444             my %problem = ( -msg => $broken_link,
1445                             -line => $link->[0],
1446                             parameter => "to \"$linked_to_page\"",
1447                         );
1448
1449             # See if we have found the linked-to_file in our parse
1450             if (exists $nodes{$linked_to_page}) {
1451                 my $node = $link->[1]->node;
1452
1453                 # If link is only to the page-level, already have it
1454                 next if ! $node;
1455
1456                 # Transform pod language to what we are expecting
1457                 $node =~ s,E<sol>,/,g;
1458                 $node =~ s/E<verbar>/|/g;
1459
1460                 # If link is to a node that exists in the file, is ok
1461                 if ($nodes{$linked_to_page}{$node}) {
1462
1463                     # But if the page has multiple targets with the same name,
1464                     # it's ambiguous which one this should be to.
1465                     if ($nodes{$linked_to_page}{$node} > 1) {
1466                         $problem{-msg} = $multiple_targets;
1467                         $problem{parameter} = "in $linked_to_page that $node could be pointing to";
1468                         $checker->poderror(\%problem);
1469                     }
1470                 } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
1471
1472                     # Here the link target was not found, either exactly or to
1473                     # the first word.  Is an error.
1474                     $problem{parameter} =~ s,"$,/$node",;
1475                     $checker->poderror(\%problem);
1476                 }
1477
1478             } # Linked-to-file not in parse; maybe is in exception list
1479             elsif (! exists $valid_modules{$link->[1]->page}) {
1480
1481                 # Here, is a link to a target that we can't find.  Check if
1482                 # there is an internal link on the page with the target name.
1483                 # If so, it could be that they just forgot the initial '/'
1484                 # But perldelta is handled specially: only do this if the
1485                 # broken link isn't one of the known bad ones (that are
1486                 # placemarkers and should be removed for the final)
1487                 my $NAME = $filename_to_pod{$filename};
1488                 if (! defined $NAME) {
1489                     $checker->poderror(\%problem);
1490                 }
1491                 elsif ($NAME ne "perldelta"
1492                     || ! grep { $linked_to_page eq $_ } @perldelta_ignore_links)
1493                 {
1494                     if ($nodes{$NAME}{$linked_to_page}) {
1495                         $problem{-msg} =  $broken_internal_link;
1496                     }
1497                     $checker->poderror(\%problem);
1498                 }
1499             }
1500         }
1501     }
1502 }
1503
1504 # If regenerating the data file, start with the modules for which we don't
1505 # check targets
1506 if ($regen) {
1507     foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1508         my_safer_print($copy_fh, $_, "\n");
1509     }
1510 }
1511
1512 # Now ready to output the messages.
1513 foreach my $filename (@files) {
1514     my $test_name = "POD of $filename";
1515     my $canonical = canonicalize($filename);
1516     SKIP: {
1517         my $skip = $filename_to_checker{$filename}->get_skip // "";
1518
1519         if ($regen) {
1520             foreach my $message ( sort keys %{$problems{$filename}}) {
1521                 my $count;
1522
1523                 # Preserve a negative setting.
1524                 if ($known_problems{$canonical}{$message}
1525                     && $known_problems{$canonical}{$message} < 0)
1526                 {
1527                     $count = $known_problems{$canonical}{$message};
1528                 }
1529                 else {
1530                     $count = @{$problems{$filename}{$message}};
1531                 }
1532                 my_safer_print($copy_fh, canonicalize($filename) . "\t$message\t$count\n");
1533             }
1534             next;
1535         }
1536
1537         skip($skip, 1) if $skip;
1538         my @diagnostics;
1539         my $indent = '  ';
1540
1541         my $total_known = 0;
1542         foreach my $message ( sort keys %{$problems{$filename}}) {
1543             $known_problems{$canonical}{$message} = 0
1544                                     if ! $known_problems{$canonical}{$message};
1545             my $diagnostic = "";
1546             my $problem_count = scalar @{$problems{$filename}{$message}};
1547             $total_known += $problem_count;
1548             next if $known_problems{$canonical}{$message} < 0;
1549             if ($problem_count > $known_problems{$canonical}{$message}) {
1550
1551                 # Here we are about to output all the messages for this type,
1552                 # subtract back this number we previously added in.
1553                 $total_known -= $problem_count;
1554
1555                 $diagnostic .= $indent . $message;
1556                 if ($problem_count > 2) {
1557                     $diagnostic .= "  ($problem_count occurrences)";
1558                 }
1559                 foreach my $problem (@{$problems{$filename}{$message}}) {
1560                     $diagnostic .= " " if $problem_count == 1;
1561                     $diagnostic .= "\n$indent$indent";
1562                     $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
1563                     $diagnostic .= " near line $problem->{-line}";
1564                     $diagnostic .= " $problem->{comment}" if $problem->{comment};
1565                 }
1566                 $diagnostic .= "\n";
1567                 $files_with_unknown_issues{$filename} = 1;
1568             } elsif ($problem_count < $known_problems{$canonical}{$message}) {
1569                $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
1570             }
1571             push @diagnostics, $diagnostic if $diagnostic;
1572         }
1573
1574         # The above loop has output messages where there are current potential
1575         # issues.  But it misses where there were some that have been entirely
1576         # fixed.  For those, we need to look through the old issues
1577         foreach my $message ( sort keys %{$known_problems{$canonical}}) {
1578             next if $problems{$filename}{$message};
1579             next if ! $known_problems{$canonical}{$message};
1580             next if $known_problems{$canonical}{$message} < 0; # Preserve negs
1581             my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
1582             push @diagnostics, $diagnostic if $diagnostic;
1583         }
1584
1585         my $output = "POD of $filename";
1586         $output .= ", excluding $total_known not shown known potential problems"
1587                                                                 if $total_known;
1588         ok(@diagnostics == 0, $output);
1589         if (@diagnostics) {
1590             note(join "", @diagnostics,
1591             "See end of this test output for your options on silencing this");
1592         }
1593     }
1594 }
1595
1596 my $how_to = <<EOF;
1597    run this test script by hand, using the following formula (on
1598    Un*x-like machines):
1599         cd t
1600         ./perl -I../lib porting/podcheck.t --regen
1601 EOF
1602
1603 if (%files_with_unknown_issues) {
1604     my $were_count_files = scalar keys %files_with_unknown_issues;
1605     $were_count_files = ($were_count_files == 1)
1606                         ? "was $were_count_files file"
1607                         : "were $were_count_files files";
1608     my $message = <<EOF;
1609
1610 HOW TO GET THIS .t TO PASS
1611
1612 There $were_count_files that had new potential problems identified.
1613 Some of them may be real, and some of them may be because this program
1614 isn't as smart as it likes to think it is.  You can teach this program
1615 to ignore the issues it has identified, and hence pass, by doing the
1616 following:
1617
1618 1) If a problem is about a link to an unknown module or man page that
1619    you know exists, re-run the command something like:
1620       ./perl -I../lib porting/podcheck.t --add_link MODULE man_page ...
1621    (MODULEs should look like Foo::Bar, and man_pages should look like
1622    bar(3c); don't do this for a module or man page that you aren't sure
1623    about; instead treat as another type of issue and follow the
1624    instructions below.)
1625
1626 2) For other issues, decide if each should be fixed now or not.  Fix the
1627    ones you decided to, and rerun this test to verify that the fixes
1628    worked.
1629
1630 3) If there remain potential problems that you don't plan to fix right
1631    now (or aren't really problems),
1632 $how_to
1633    That should cause all current potential problems to be accepted by
1634    the program, so that the next time it runs, they won't be flagged.
1635 EOF
1636     if (%files_with_fixes) {
1637         $message .= "   This step will also take care of the files that have fixes in them\n";
1638     }
1639
1640     $message .= <<EOF;
1641    For a few files, such as perltoc, certain issues will always be
1642    expected, and more of the same will be added over time.  For those,
1643    before you do the regen, you can edit
1644    $known_issues
1645    and find the entry for the module's file and specific error message,
1646    and change the count of known potential problems to -1.
1647 EOF
1648
1649     note($message);
1650 } elsif (%files_with_fixes) {
1651     note(<<EOF
1652 To teach this test script that the potential problems have been fixed,
1653 $how_to
1654 EOF
1655     );
1656 }
1657
1658 if ($regen) {
1659     chdir $original_dir || die "Can't change directories to $original_dir";
1660     close_and_rename($copy_fh);
1661 }