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