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