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