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