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