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