This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Typo in podcheck.t
[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 regexes and 'OS/2'
652                                 (?! (?: (?: s | qr | m) / ) | OS/2 > )
653                                 \w+ (?: / \w+ )+ > (?: \. \w+ )? )
654                           }x;
655
656         # If looks like a reference to other documentation by containing the
657         # word 'See' and then a likely pod directive, warn.
658
659         while ($paragraph =~ m{ \b See \s+ ( ( [^L] ) <
660                                 ( [^<]*? )  # The not-< excludes nested C<L<...
661                                 > ) }ixg) {
662             my $construct = $1;
663             my $type = $2;
664             my $interior = $3;
665             if ($interior !~ /$non_pods/
666                 && $construct !~ /$C_path_re/g) {
667                 $self->poderror({ -line => $line, -file => $file,
668                     -msg => $see_not_linked,
669                     parameter => $construct
670                 });
671             }
672         }
673         while ($paragraph =~ m/$C_path_re/g) {
674             my $construct = $1;
675             $self->poderror({ -line => $line, -file => $file,
676                 -msg => $C_with_slash,
677                 parameter => $construct
678             });
679         }
680         return;
681     }
682
683     sub command {
684         my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
685         my $addr = Scalar::Util::refaddr $self;
686         if ($cmd eq "pod") {
687             $seen_pod_cmd{$addr}++;
688         }
689         elsif ($cmd eq "encoding") {
690             my ($file, $line) = $pod_para->file_line;
691             $seen_encoding_cmd{$addr} = $paragraph; # for later decoding
692             if ($command_count{$addr} != 1 && $seen_pod_cmd{$addr}) {
693                 $self->poderror({ -line => $line, -file => $file,
694                                   -msg => $encoding_first
695                                 });
696             }
697         }
698         $self->check_encoding($paragraph, $line_num, $pod_para);
699
700         # Pod::Check treats all =items as linkable, but the bullet and
701         # numbered lists really aren't.  So keep our own list.  This has to be
702         # processed before SUPER is called so that the list is started before
703         # the rest of it gets parsed.
704         if ($cmd eq 'item') { # Not linkable if item begins with * or a digit
705             $linkable_item{$addr} = ($paragraph !~ / ^ \s*
706                                                    (?: [*]
707                                                    | \d+ \.? (?: \$ | \s+ )
708                                                    )/x)
709                                   ? 1
710                                   : 0;
711
712         }
713         $self->SUPER::command($cmd, $paragraph, $line_num, $pod_para);
714
715         $command_count{$addr}++;
716
717         $in_NAME{$addr} = 0;    # Will change to 1 below if necessary
718         $in_begin{$addr} = 0;   # ibid
719         if ($cmd eq 'over') {
720             my $text = $self->interpolate($paragraph, $line_num);
721             my $indent = 4; # default
722             $indent = $1 if $text && $text =~ /^\s*(\d+)\s*$/;
723             push @{$indents{$addr}}, $indent;
724             $current_indent{$addr} += $indent;
725         }
726         elsif ($cmd eq 'back') {
727             if (@{$indents{$addr}}) {
728                 $current_indent{$addr} -= pop @{$indents{$addr}};
729             }
730             else {
731                  # =back without corresponding =over, but should have
732                  # warned already
733                 $current_indent{$addr} = 0;
734             }
735         }
736         elsif ($cmd =~ /^head/) {
737             if (! $in_begin{$addr}) {
738
739                 # If a particular formatter, then this command doesn't really
740                 # apply
741                 $current_indent{$addr} = 0;
742                 undef @{$indents{$addr}};
743             }
744
745             my $text = $self->interpolate($paragraph, $line_num);
746             $in_NAME{$addr} = 1 if $cmd eq 'head1'
747                                    && $text && $text =~ /^NAME\b/;
748         }
749         elsif ($cmd eq 'begin') {
750             $in_begin{$addr} = 1;
751         }
752
753         return;
754     }
755
756     sub hyperlink {
757         my $self = shift;
758
759         # If the hyperlink is to an interior node of another page, save it
760         # so that we can see if we need to parse normally skipped files.
761         $has_referred_to_node{$_[0][1]{'-page'}} = 1
762                             if $_[0] && $_[0][1]{'-page'} && $_[0][1]{'-node'};
763         return $self->SUPER::hyperlink($_[0]);
764     }
765
766     sub node {
767         my $self = shift;
768         my $text = $_[0];
769         if($text) {
770             $text =~ s/\s+$//s; # strip trailing whitespace
771             $text =~ s/\s+/ /gs; # collapse whitespace
772             my $addr = Scalar::Util::refaddr $self;
773             push(@{$linkable_nodes{$addr}}, $text) if
774                                     ! $current_indent{$addr}
775                                     || $linkable_item{$addr};
776         }
777         return $self->SUPER::node($_[0]);
778     }
779
780     sub get_current_indent {
781         return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
782     }
783
784     sub get_filename {
785         return $filename{Scalar::Util::refaddr $_[0]};
786     }
787
788     sub linkable_nodes {
789         my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
790         return undef unless $linkables;
791         return @$linkables;
792     }
793
794     sub get_skip {
795         return $skip{Scalar::Util::refaddr $_[0]} // 0;
796     }
797
798     sub set_skip {
799         my $self = shift;
800         $skip{Scalar::Util::refaddr $self} = shift;
801
802         # If skipping, no need to keep the problems for it
803         delete $problems{$self->get_filename};
804         return;
805     }
806 }
807
808 package Tie_Array_to_FH {  # So printing actually goes to an array
809
810     my %array;
811
812     sub TIEHANDLE {
813         my $class = shift;
814         my $array_ref = shift;
815
816         my $self = bless \do{ my $anonymous_scalar }, $class;
817         $array{Scalar::Util::refaddr $self} = $array_ref;
818
819         return $self;
820     }
821
822     sub PRINT {
823         my $self = shift;
824         push @{$array{Scalar::Util::refaddr $self}}, @_;
825         return 1;
826     }
827 }
828
829
830 my %filename_to_checker; # Map a filename to it's pod checker object
831 my %id_to_checker;      # Map a checksum to it's pod checker object
832 my %nodes;              # key is filename, values are nodes in that file.
833 my %nodes_first_word;   # same, but value is first word of each node
834 my %valid_modules;      # List of modules known to exist outside us.
835 my %digests;            # checksums of files, whose names are the keys
836 my %filename_to_pod;    # Map a filename to its pod NAME
837 my %files_with_unknown_issues;
838 my %files_with_fixes;
839
840 my $data_fh;
841 open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
842
843 my %counts; # For --counts param, count of each issue type
844 my %suppressed_files;   # Files with at least one issue type to suppress
845
846
847 if ($add_link) {
848     $copy_fh = open_new($known_issues);
849     my @existing_db = <$data_fh>;
850     my_safer_print($copy_fh, @existing_db);
851
852     foreach my $module (@files) {
853         die "\"$module\" does not look like a module or man page"
854             # Must look like (A or A::B or A::B::C ..., or foo(3C)
855             if $module !~ /^ (?: \w+ (?: :: \w+ )* | \w+ \( \d \w* \) ) $/x;
856         $module .= "\n";
857         next if grep { $module eq $_ } @existing_db;
858         my_safer_print($copy_fh, $module);
859     }
860     close_and_rename($copy_fh);
861     exit;
862 }
863
864 while (<$data_fh>) {    # Read the data base
865     chomp;
866     next if /^\s*(?:#|$)/;  # Skip comment and empty lines
867     if (/\t/) {
868         next if $show_all;
869
870         # Keep track of counts of each issue type for each file
871         my ($filename, $message, $count) = split /\t/;
872         $known_problems{$filename}{$message} = $count;
873
874         if ($show_counts) {
875             if ($count < 0) {   # -1 means to suppress this issue type
876                 $suppressed_files{$filename} = $filename;
877             }
878             else {
879                 $counts{$message} += $count;
880             }
881         }
882     }
883     else {  # Lines without a tab are modules known to be valid
884         $valid_modules{$_} = 1
885     }
886 }
887 close $data_fh;
888
889 if ($show_counts) {
890     my $total = 0;
891     foreach my $message (sort keys %counts) {
892         $total += $counts{$message};
893         note(Text::Tabs::expand("$counts{$message}\t$message"));
894     }
895     note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
896     if (%suppressed_files) {
897         note("\nFiles that have all messages of at least one type suppressed:");
898         note(join ",", keys %suppressed_files);
899     }
900     exit 0;
901 }
902
903
904 my %excluded_files = (
905                         "lib/unicore/mktables" => 1,
906                         "Porting/perldelta_template.pod" => 1,
907                         "autodoc.pl" => 1,
908                         "configpm" => 1,
909                         "miniperl" => 1,
910                         "perl" => 1,
911                     );
912
913 # Convert to more generic form.
914 foreach my $file (keys %excluded_files) {
915     delete $excluded_files{$file};
916     $excluded_files{canonicalize($file)} = 1;
917 }
918
919 # re to match files that are to be parsed only if there is an internal link
920 # to them.  It does not include cpan, as whether those are parsed depends
921 # on a switch.  Currently, only perltoc and the stable perldelta.pod's
922 # are included.  The latter all have characters between 'perl' and
923 # 'delta'.  (Actually the currently developed one matches as well, but
924 # is a duplicate of perldelta.pod, so can be skipped, so fine for it to
925 # match this.
926 my $only_for_interior_links_re = qr/ \b perl \d+ delta \. pod \b
927                                      | ^ pod\/perltoc.pod $
928                                    /x;
929
930 { # Closure
931     my $first_time = 1;
932
933     sub output_thanks ($$$$) {  # Called when an issue has been fixed
934         my $filename = shift;
935         my $original_count = shift;
936         my $current_count = shift;
937         my $message = shift;
938
939         $files_with_fixes{$filename} = 1;
940         my $return;
941         my $fixed_count = $original_count - $current_count;
942         my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
943         my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
944         my $diff;
945         if ($message) {
946             $diff = <<EOF;
947 There were $original_count occurrences (now $current_count) in this pod of type
948 "$message",
949 EOF
950         } else {
951             $diff = <<EOF;
952 There are no longer any problems found in this pod!
953 EOF
954         }
955
956         if ($first_time) {
957             $first_time = 0;
958             $return = <<EOF;
959 Thanks for fixing $a_problem!
960 $diff
961 Now you must teach $0 that this was fixed.
962 EOF
963         }
964         else {
965             $return = <<EOF
966 Thanks for fixing $another_problem.
967 $diff
968 EOF
969         }
970
971         return $return;
972     }
973 }
974
975 sub my_safer_print {    # print, with error checking for outputting to db
976     my ($fh, @lines) = @_;
977
978     if (! print $fh @lines) {
979         my $save_error = $!;
980         close($fh);
981         die "Write failure: $save_error";
982     }
983 }
984
985 sub extract_pod {   # Extracts just the pod from a file
986     my $filename = shift;
987
988     my @pod;
989
990     # Arrange for the output of Pod::Parser to be collected in an array we can
991     # look at instead of being printed
992     tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
993     open my $in_fh, '<:bytes', $filename
994
995         # The file should already have been opened once to get here, so if
996         # fails, just die.  It's possible that a transitory file containing a
997         # pod would get here, but not bothering to add code for that very
998         # unlikely event.
999         or die "Can't open '$filename': $!\n";
1000
1001     my $parser = Pod::Parser->new();
1002     $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
1003     close $in_fh;
1004
1005     return join "", @pod
1006 }
1007
1008 my $digest = Digest->new($digest_type);
1009
1010 sub is_pod_file {
1011     # If $_ is a pod file, add it to the lists and do other prep work.
1012
1013     if (-d $_) {
1014         # Don't look at files in directories that are for tests, nor those
1015         # beginning with a dot
1016         if ($_ eq 't' || $_ =~ /^\../) {
1017             $File::Find::prune = 1;
1018         }
1019         return;
1020     }
1021
1022     return if $_ =~ /^\./;           # No hidden Unix files
1023     return if $_ =~ $non_pods;
1024
1025     my $filename = $File::Find::name;
1026
1027     # Assumes that the path separator is exactly one character.
1028     $filename =~ s/^\..//;
1029
1030     return if $excluded_files{canonicalize($filename)};
1031
1032     my $contents = do {
1033         local $/;
1034         my $candidate;
1035         if (! open $candidate, '<:bytes', $_) {
1036
1037             # If a transitory file was found earlier, the open could fail
1038             # legitimately and we just skip the file; also skip it if it is a
1039             # broken symbolic link, as it is probably just a build problem;
1040             # certainly not a file that we would want to check the pod of.
1041             # Otherwise fail it here and no reason to process it further.
1042             # (But the test count will be off too)
1043             ok(0, "Can't open '$filename': $!")
1044                                             if -e $filename && ! -l $filename;
1045             return;
1046         }
1047         <$candidate>;
1048     };
1049
1050     # If the file is a .pm or .pod, having any initial '=' on a line is
1051     # grounds for testing it.  Otherwise, require a head1 NAME line to view it
1052     # as a potential pod
1053     if ($filename =~ /\.(?:pm|pod)/) {
1054         return unless $contents =~ /^=/m;
1055     } else {
1056         return unless $contents =~ /^=head1 +NAME/m;
1057     }
1058
1059     # Here, we know that the file is a pod.  Add it to the list of files
1060     # to check and create a checker object for it.
1061
1062     push @files, $filename;
1063     my $checker = My::Pod::Checker->new($filename);
1064     $filename_to_checker{$filename} = $checker;
1065
1066     # In order to detect duplicate pods and only analyze them once, we
1067     # compute checksums for the file, so don't have to do an exact
1068     # compare.  Note that if the pod is just part of the file, the
1069     # checksums can differ for the same pod.  That special case is handled
1070     # later, since if the checksums of the whole file are the same, that
1071     # case won't even come up.  We don't need the checksums for files that
1072     # we parse only if there is a link to its interior, but we do need its
1073     # NAME, which is also retrieved in the code below.
1074
1075     if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
1076                         | $only_for_interior_links_re
1077                     /x) {
1078         $digest->add($contents);
1079         $digests{$filename} = $digest->digest;
1080
1081         # lib files aren't analyzed if they are duplicates of files copied
1082         # there from some other directory.  But to determine this, we need
1083         # to know their NAMEs.  We might as well find the NAME now while
1084         # the file is open.  Similarly, cpan files aren't analyzed unless
1085         # we're analyzing all of them, or this particular file is linked
1086         # to by a file we are analyzing, and thus we will want to verify
1087         # that the target exists in it.  We need to know at least the NAME
1088         # to see if it's worth analyzing, or so we can determine if a lib
1089         # file is a copy of a cpan one.
1090         if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
1091                             | $only_for_interior_links_re
1092                             }x) {
1093             if ($contents =~ /^=head1 +NAME.*/mg) {
1094                 # The NAME is the first non-spaces on the line up to a
1095                 # comma, dash or end of line.  Otherwise, it's invalid and
1096                 # this pod doesn't have a legal name that we're smart
1097                 # enough to find currently.  But the  parser will later
1098                 # find it if it thinks there is a legal name, and set the
1099                 # name
1100                 if ($contents =~ /\G    # continue from the line after =head1
1101                                   \s*   # ignore any empty lines
1102                                   ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
1103                     my $name = $1;
1104                     $checker->name($name);
1105                     $id_to_checker{$name} = $checker
1106                         if $filename =~ m{^cpan/};
1107                 }
1108             }
1109             elsif ($filename =~ m{^cpan/}) {
1110                 $id_to_checker{$digests{$filename}} = $checker;
1111             }
1112         }
1113     }
1114
1115     return;
1116 } # End of is_pod_file()
1117
1118 # Start of real code that isn't processing the command line (except the
1119 # db is read in above, as is processing of the --add_link option).
1120 # Here, @files contains list of files on the command line.  If have any of
1121 # these, unconditionally test them, and show all the errors, even the known
1122 # ones, and, since not testing other pods, don't do cross-pod link tests.
1123 # (Could add extra code to do cross-pod tests for the ones in the list.)
1124
1125 if ($has_input_files) {
1126     undef %known_problems;
1127     $do_upstream_cpan = 1;  # In case one of the inputs is from cpan
1128
1129 }
1130 else { # No input files -- go find all the possibilities.
1131     if ($regen) {
1132         $copy_fh = open_new($known_issues);
1133         note("Regenerating $known_issues, please be patient...");
1134         print $copy_fh <<END;
1135 # This file is the data file for $0.
1136 # There are three types of lines.
1137 # Comment lines are white-space only or begin with a '#', like this one.  Any
1138 #   changes you make to the comment lines will be lost when the file is
1139 #   regen'd.
1140 # Lines without tab characters are simply NAMES of pods that the program knows
1141 #   will have links to them and the program does not check if those links are
1142 #   valid.
1143 # All other lines should have three fields, each separated by a tab.  The
1144 #   first field is the name of a pod; the second field is an error message
1145 #   generated by this program; and the third field is a count of how many
1146 #   known instances of that message there are in the pod.  -1 means that the
1147 #   program can expect any number of this type of message.
1148 END
1149     }
1150
1151     # Move to the directory above us, but have to adjust @INC to account for
1152     # that.
1153     s{^\.\./lib$}{lib} for @INC;
1154     chdir File::Spec->updir;
1155
1156     # And look in this directory and all its subdirectories
1157     find( \&is_pod_file, '.');
1158
1159     # Add ourselves to the test
1160     push @files, "t/porting/podcheck.t";
1161 }
1162
1163 # Now we know how many tests there will be.
1164 plan (tests => scalar @files) if ! $regen;
1165
1166
1167  # Sort file names so we get consistent results, and to put cpan last,
1168  # preceeded by the ones that we don't generally parse.  This is because both
1169  # these classes are generally parsed only if there is a link to the interior
1170  # of them, and we have to parse all others first to guarantee that they don't
1171  # have such a link. 'lib' files come just before these, as some of these are
1172  # duplicates of others.  We already have figured this out when gathering the
1173  # data as a special case for all such files, but this, while unnecessary,
1174  # puts the derived file last in the output.  'readme' files come before those,
1175  # as those also could be duplicates of others, which are considered the
1176  # primary ones.  These currently aren't figured out when gathering data, so
1177  # are done here.
1178  @files = sort { if ($a =~ /^cpan/) {
1179                     return 1 if $b !~ /^cpan/;
1180                     return $a cmp $b;
1181                 }
1182                 elsif ($b =~ /^cpan/) {
1183                     return -1;
1184                 }
1185                 elsif ($a =~ /$only_for_interior_links_re/) {
1186                     return 1 if $b !~ /$only_for_interior_links_re/;
1187                     return $a cmp $b;
1188                 }
1189                 elsif ($b =~ /$only_for_interior_links_re/) {
1190                     return -1;
1191                 }
1192                 elsif ($a =~ /^lib/) {
1193                     return 1 if $b !~ /^lib/;
1194                     return $a cmp $b;
1195                 }
1196                 elsif ($b =~ /^lib/) {
1197                     return -1;
1198                 } elsif ($a =~ /\breadme\b/i) {
1199                     return 1 if $b !~ /\breadme\b/i;
1200                     return $a cmp $b;
1201                 }
1202                 elsif ($b =~ /\breadme\b/i) {
1203                     return -1;
1204                 }
1205                 else {
1206                     return lc $a cmp lc $b;
1207                 }
1208             }
1209             @files;
1210
1211 # Now go through all the files and parse them
1212 foreach my $filename (@files) {
1213     my $parsed = 0;
1214     note("parsing $filename") if DEBUG;
1215
1216     # We may have already figured out some things in the process of generating
1217     # the file list.  If so, have a $checker object already.  But if not,
1218     # generate one now.
1219     my $checker = $filename_to_checker{$filename};
1220     if (! $checker) {
1221         $checker = My::Pod::Checker->new($filename);
1222         $filename_to_checker{$filename} = $checker;
1223     }
1224
1225     # We have set the name in the checker object if there is a possibility
1226     # that no further parsing is necessary, but otherwise do the parsing now.
1227     if (! $checker->name) {
1228         $parsed = 1;
1229         $checker->parse_from_file($filename, undef);
1230     }
1231
1232     if ($checker->num_errors() < 0) {   # Returns negative if not a pod
1233         $checker->set_skip("$filename is not a pod");
1234     }
1235     else {
1236
1237         # Here, is a pod.  See if it is one that has already been tested,
1238         # or should be tested under another directory.  Use either its NAME
1239         # if it has one, or a checksum if not.
1240         my $name = $checker->name;
1241         my $id;
1242
1243         if ($name) {
1244             $id = $name;
1245         }
1246         else {
1247             my $digest = Digest->new($digest_type);
1248             $digest->add(extract_pod($filename));
1249             $id = $digest->digest;
1250         }
1251
1252         # If there is a match for this pod with something that we've already
1253         # processed, don't process it, and output why.
1254         my $prior_checker;
1255         if (defined ($prior_checker = $id_to_checker{$id})
1256             && $prior_checker != $checker)  # Could have defined the checker
1257                                             # earlier without pursuing it
1258         {
1259
1260             # If the pods are identical, then it's just a copy, and isn't an
1261             # error.  First use the checksums we have already computed to see
1262             # if the entire files are identical, which means that the pods are
1263             # identical too.
1264             my $prior_filename = $prior_checker->get_filename;
1265             my $same = (! $name
1266                         || ($digests{$prior_filename}
1267                             && $digests{$filename}
1268                             && $digests{$prior_filename} eq $digests{$filename}));
1269
1270             # If they differ, it could be that the files differ for some
1271             # reason, but the pods they contain are identical.  Extract the
1272             # pods and do the comparisons on just those.
1273             if (! $same && $name) {
1274                 $same = extract_pod($prior_filename) eq extract_pod($filename);
1275             }
1276
1277             if ($same) {
1278                 $checker->set_skip("The pod of $filename is a duplicate of "
1279                                     . "the pod for $prior_filename");
1280             } elsif ($prior_filename =~ /\breadme\b/i) {
1281                 $checker->set_skip("$prior_filename is a README apparently for $filename");
1282             } elsif ($filename =~ /\breadme\b/i) {
1283                 $checker->set_skip("$filename is a README apparently for $prior_filename");
1284             } else { # Here have two pods with identical names that differ
1285                 $prior_checker->poderror(
1286                         { -msg => $duplicate_name,
1287                             -line => "???",
1288                             parameter => "'$filename' also has NAME '$name'"
1289                         });
1290                 $checker->poderror(
1291                     { -msg => $duplicate_name,
1292                         -line => "???",
1293                         parameter => "'$prior_filename' also has NAME '$name'"
1294                     });
1295
1296                 # Changing the names helps later.
1297                 $prior_checker->name("$name version arbitrarily numbered 1");
1298                 $checker->name("$name version arbitrarily numbered 2");
1299             }
1300
1301             # In any event, don't process this pod that has the same name as
1302             # another.
1303             next;
1304         }
1305
1306         # A unique pod.
1307         $id_to_checker{$id} = $checker;
1308
1309         my $parsed_for_links = ", but parsed for its interior links";
1310         if ((! $do_upstream_cpan && $filename =~ /^cpan/)
1311              || $filename =~ $only_for_interior_links_re)
1312         {
1313             if ($filename =~ /^cpan/) {
1314                 $checker->set_skip("CPAN is upstream for $filename");
1315             }
1316             elsif ($filename =~ /perl\d+delta/) {
1317                 $checker->set_skip("$filename is a stable perldelta");
1318             }
1319             elsif ($filename =~ /perltoc/) {
1320                 $checker->set_skip("$filename dependent on component pods");
1321             }
1322             else {
1323                 croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
1324             }
1325
1326             if ($name && $has_referred_to_node{$name}) {
1327                 $checker->set_skip($checker->get_skip() . $parsed_for_links);
1328             }
1329         }
1330
1331         # Need a name in order to process it, because not meaningful
1332         # otherwise, and also can't test links to this without a name.
1333         if (!defined $name) {
1334             $checker->poderror( { -msg => $no_name,
1335                                   -line => '???'
1336                                 });
1337             next;
1338         }
1339
1340         # For skipped files, just get its NAME
1341         my $skip;
1342         if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
1343         {
1344             $checker->node($name) if $name;
1345         }
1346         else {
1347             $checker->parse_from_file($filename, undef) if ! $parsed;
1348         }
1349
1350         # Go through everything in the file that could be an anchor that
1351         # could be a link target.  Count how many there are of the same name.
1352         foreach my $node ($checker->linkable_nodes) {
1353             next if ! $node;        # Can be empty is like '=item *'
1354             if (exists $nodes{$name}{$node}) {
1355                 $nodes{$name}{$node}++;
1356             }
1357             else {
1358                 $nodes{$name}{$node} = 1;
1359             }
1360
1361             # Experiments have shown that cpan search can figure out the
1362             # target of a link even if the exact wording is incorrect, as long
1363             # as the first word is.  This happens frequently in perlfunc.pod,
1364             # where the link will be just to the function, but the target
1365             # entry also includes parameters to the function.
1366             my $first_word = $node;
1367             if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
1368                 $nodes_first_word{$name}{$first_word} = $node;
1369             }
1370         }
1371         $filename_to_pod{$filename} = $name;
1372     }
1373 }
1374
1375 # Here, all files have been parsed, and all links and link targets are stored.
1376 # Now go through the files again and see which don't have matches.
1377 if (! $has_input_files) {
1378     foreach my $filename (@files) {
1379         next if $filename_to_checker{$filename}->get_skip;
1380         my $checker = $filename_to_checker{$filename};
1381         foreach my $link ($checker->hyperlink) {
1382             my $linked_to_page = $link->[1]->page;
1383             next unless $linked_to_page;   # intra-file checks are handled by std
1384                                            # Pod::Checker
1385
1386             # Initialize the potential message.
1387             my %problem = ( -msg => $broken_link,
1388                             -line => $link->[0],
1389                             parameter => "to \"$linked_to_page\"",
1390                         );
1391
1392             # See if we have found the linked-to_file in our parse
1393             if (exists $nodes{$linked_to_page}) {
1394                 my $node = $link->[1]->node;
1395
1396                 # If link is only to the page-level, already have it
1397                 next if ! $node;
1398
1399                 # Transform pod language to what we are expecting
1400                 $node =~ s,E<sol>,/,g;
1401                 $node =~ s/E<verbar>/|/g;
1402
1403                 # If link is to a node that exists in the file, is ok
1404                 if ($nodes{$linked_to_page}{$node}) {
1405
1406                     # But if the page has multiple targets with the same name,
1407                     # it's ambiguous which one this should be to.
1408                     if ($nodes{$linked_to_page}{$node} > 1) {
1409                         $problem{-msg} = $multiple_targets;
1410                         $problem{parameter} = "in $linked_to_page that $node could be pointing to";
1411                         $checker->poderror(\%problem);
1412                     }
1413                 } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
1414
1415                     # Here the link target was not found, either exactly or to
1416                     # the first word.  Is an error.
1417                     $problem{parameter} =~ s,"$,/$node",;
1418                     $checker->poderror(\%problem);
1419                 }
1420
1421             } # Linked-to-file not in parse; maybe is in exception list
1422             elsif (! exists $valid_modules{$link->[1]->page}) {
1423
1424                 # Here, is a link to a target that we can't find.  Check if
1425                 # there is an internal link on the page with the target name.
1426                 # If so, it could be that they just forgot the initial '/'
1427                 # But perldelta is handled specially: only do this if the
1428                 # broken link isn't one of the known bad ones (that are
1429                 # placemarkers and should be removed for the final)
1430                 my $NAME = $filename_to_pod{$filename};
1431                 if (! defined $NAME) {
1432                     $checker->poderror(\%problem);
1433                 }
1434                 elsif ($NAME ne "perldelta"
1435                     || ! grep { $linked_to_page eq $_ } @perldelta_ignore_links)
1436                 {
1437                     if ($nodes{$NAME}{$linked_to_page}) {
1438                         $problem{-msg} =  $broken_internal_link;
1439                     }
1440                     $checker->poderror(\%problem);
1441                 }
1442             }
1443         }
1444     }
1445 }
1446
1447 # If regenerating the data file, start with the modules for which we don't
1448 # check targets
1449 if ($regen) {
1450     foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1451         my_safer_print($copy_fh, $_, "\n");
1452     }
1453 }
1454
1455 # Now ready to output the messages.
1456 foreach my $filename (@files) {
1457     my $test_name = "POD of $filename";
1458     my $canonical = canonicalize($filename);
1459     SKIP: {
1460         my $skip = $filename_to_checker{$filename}->get_skip // "";
1461
1462         if ($regen) {
1463             foreach my $message ( sort keys %{$problems{$filename}}) {
1464                 my $count;
1465
1466                 # Preserve a negative setting.
1467                 if ($known_problems{$canonical}{$message}
1468                     && $known_problems{$canonical}{$message} < 0)
1469                 {
1470                     $count = $known_problems{$canonical}{$message};
1471                 }
1472                 else {
1473                     $count = @{$problems{$filename}{$message}};
1474                 }
1475                 my_safer_print($copy_fh, canonicalize($filename) . "\t$message\t$count\n");
1476             }
1477             next;
1478         }
1479
1480         skip($skip, 1) if $skip;
1481         my @diagnostics;
1482         my $indent = '  ';
1483
1484         my $total_known = 0;
1485         foreach my $message ( sort keys %{$problems{$filename}}) {
1486             $known_problems{$canonical}{$message} = 0
1487                                     if ! $known_problems{$canonical}{$message};
1488             my $diagnostic = "";
1489             my $problem_count = scalar @{$problems{$filename}{$message}};
1490             $total_known += $problem_count;
1491             next if $known_problems{$canonical}{$message} < 0;
1492             if ($problem_count > $known_problems{$canonical}{$message}) {
1493
1494                 # Here we are about to output all the messages for this type,
1495                 # subtract back this number we previously added in.
1496                 $total_known -= $problem_count;
1497
1498                 $diagnostic .= $indent . $message;
1499                 if ($problem_count > 2) {
1500                     $diagnostic .= "  ($problem_count occurrences)";
1501                 }
1502                 foreach my $problem (@{$problems{$filename}{$message}}) {
1503                     $diagnostic .= " " if $problem_count == 1;
1504                     $diagnostic .= "\n$indent$indent";
1505                     $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
1506                     $diagnostic .= " near line $problem->{-line}";
1507                     $diagnostic .= " $problem->{comment}" if $problem->{comment};
1508                 }
1509                 $diagnostic .= "\n";
1510                 $files_with_unknown_issues{$filename} = 1;
1511             } elsif ($problem_count < $known_problems{$canonical}{$message}) {
1512                $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
1513             }
1514             push @diagnostics, $diagnostic if $diagnostic;
1515         }
1516
1517         # The above loop has output messages where there are current potential
1518         # issues.  But it misses where there were some that have been entirely
1519         # fixed.  For those, we need to look through the old issues
1520         foreach my $message ( sort keys %{$known_problems{$canonical}}) {
1521             next if $problems{$filename}{$message};
1522             next if ! $known_problems{$canonical}{$message};
1523             next if $known_problems{$canonical}{$message} < 0; # Preserve negs
1524             my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
1525             push @diagnostics, $diagnostic if $diagnostic;
1526         }
1527
1528         my $output = "POD of $filename";
1529         $output .= ", excluding $total_known not shown known potential problems"
1530                                                                 if $total_known;
1531         ok(@diagnostics == 0, $output);
1532         if (@diagnostics) {
1533             note(join "", @diagnostics,
1534             "See end of this test output for your options on silencing this");
1535         }
1536     }
1537 }
1538
1539 my $how_to = <<EOF;
1540    run this test script by hand, using the following formula (on
1541    Un*x-like machines):
1542         cd t
1543         ./perl -I../lib porting/podcheck.t --regen
1544 EOF
1545
1546 if (%files_with_unknown_issues) {
1547     my $were_count_files = scalar keys %files_with_unknown_issues;
1548     $were_count_files = ($were_count_files == 1)
1549                         ? "was $were_count_files file"
1550                         : "were $were_count_files files";
1551     my $message = <<EOF;
1552
1553 HOW TO GET THIS .t TO PASS
1554
1555 There $were_count_files that had new potential problems identified.
1556 Some of them may be real, and some of them may be because this program
1557 isn't as smart as it likes to think it is.  You can teach this program
1558 to ignore the issues it has identified, and hence pass, by doing the
1559 following:
1560
1561 1) If a problem is about a link to an unknown module or man page that
1562    you know exists, re-run the command something like:
1563       ./perl -I../lib porting/podcheck.t --add_link MODULE man_page ...
1564    (MODULEs should look like Foo::Bar, and man_pages should look like
1565    bar(3c); don't do this for a module or man page that you aren't sure
1566    about; instead treat as another type of issue and follow the
1567    instructions below.)
1568
1569 2) For other issues, decide if each should be fixed now or not.  Fix the
1570    ones you decided to, and rerun this test to verify that the fixes
1571    worked.
1572
1573 3) If there remain potential problems that you don't plan to fix right
1574    now (or aren't really problems),
1575 $how_to
1576    That should cause all current potential problems to be accepted by
1577    the program, so that the next time it runs, they won't be flagged.
1578 EOF
1579     if (%files_with_fixes) {
1580         $message .= "   This step will also take care of the files that have fixes in them\n";
1581     }
1582
1583     $message .= <<EOF;
1584    For a few files, such as perltoc, certain issues will always be
1585    expected, and more of the same will be added over time.  For those,
1586    before you do the regen, you can edit
1587    $known_issues
1588    and find the entry for the module's file and specific error message,
1589    and change the count of known potential problems to -1.
1590 EOF
1591
1592     note($message);
1593 } elsif (%files_with_fixes) {
1594     note(<<EOF
1595 To teach this test script that the potential problems have been fixed,
1596 $how_to
1597 EOF
1598     );
1599 }
1600
1601 if ($regen) {
1602     chdir $original_dir || die "Can't change directories to $original_dir";
1603     close_and_rename($copy_fh);
1604 }