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