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