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