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