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