This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
porting/podcheck.t: improve diagnostic
[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 = @_;
da33abaf
KW
461 $planned = $plan{tests} + 1; # +1 for final test that files haven't
462 # been removed
16384ac1
KW
463 print "1..$planned\n";
464 return;
465 }
466
467 sub ok {
468 my $success = shift;
469 my $message = shift;
470
471 chomp $message;
472
473 $current_test++;
474 print "not " unless $success;
475 print "ok $current_test - $message\n";
ef436c1f 476 return $success;
16384ac1
KW
477 }
478
479 sub skip {
480 my $why = shift;
481 my $n = @_ ? shift : 1;
482 for (1..$n) {
483 $current_test++;
484 print "ok $current_test # skip $why\n";
485 }
486 no warnings 'exiting';
487 last SKIP;
488 }
489
490 sub note {
491 my $message = shift;
492
493 chomp $message;
494
495 print $message =~ s/^/# /mgr;
496 print "\n";
497 return;
498 }
499
500 END {
501 if ($planned && $planned != $current_test) {
502 print STDERR
503 "# Looks like you planned $planned tests but ran $current_test.\n";
504 }
505 }
506}
507
16384ac1
KW
508# List of known potential problems by pod and type.
509my %known_problems;
510
511# Pods given by the keys contain an interior node that is referred to from
512# outside it.
513my %has_referred_to_node;
514
515my $show_counts = 0;
516my $regen = 0;
477100f8 517my $add_link = 0;
16384ac1
KW
518my $show_all = 0;
519
d9e2eb4b
KW
520my $do_upstream_cpan = 0; # Assume that are to skip anything in /cpan
521my $do_deltas = 0; # And stable perldeltas
16384ac1
KW
522
523while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
524 my $arg = shift @ARGV;
525
526 $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
527 if ($arg eq '-regen') {
528 $regen = 1;
529 }
477100f8
KW
530 elsif ($arg eq '-add_link') {
531 $add_link = 1;
532 }
16384ac1
KW
533 elsif ($arg eq '-cpan') {
534 $do_upstream_cpan = 1;
535 }
d9e2eb4b
KW
536 elsif ($arg eq '-deltas') {
537 $do_deltas = 1;
538 }
16384ac1
KW
539 elsif ($arg eq '-show_all') {
540 $show_all = 1;
541 }
542 elsif ($arg eq '-counts') {
543 $show_counts = 1;
544 }
545 else {
546 die <<EOF;
547Unknown option '$arg'
548
477100f8
KW
549Usage: $0 [ --regen | --cpan | --show_all | FILE ... | --add_link MODULE ... ]\n"
550 --add_link -> Add the MODULE and man page references to the data base
16384ac1 551 --regen -> Regenerate the data file for $0
477100f8 552 --cpan -> Include files in the cpan subdirectory.
d9e2eb4b 553 --deltas -> Include stable perldeltas
16384ac1
KW
554 --show_all -> Show all known potential problems
555 --counts -> Don't test, but give summary counts of the currently
556 existing database
557EOF
558 }
559}
560
561my @files = @ARGV;
562
d9e2eb4b
KW
563my $cpan_or_deltas = $do_upstream_cpan || $do_deltas;
564if (($regen + $show_all + $show_counts + $add_link + $cpan_or_deltas ) > 1) {
565 croak "--regen, --show_all, --counts, and --add_link are mutually exclusive\n and none can be run with --cpan nor --deltas";
16384ac1
KW
566}
567
568my $has_input_files = @files;
569
d9e2eb4b
KW
570if ($has_input_files
571 && ($regen || $show_counts || $do_upstream_cpan || $do_deltas))
572{
573 croak "--regen, --counts, --deltas, and --cpan can't be used since using specific files";
16384ac1
KW
574}
575
477100f8
KW
576if ($add_link && ! $has_input_files) {
577 croak "--add_link requires at least one module or man page reference";
578}
579
16384ac1
KW
580our %problems; # potential problems found in this run
581
582package My::Pod::Checker { # Extend Pod::Checker
a67b1afa
MM
583 use parent 'Pod::Checker';
584
16384ac1
KW
585 # Uses inside out hash to protect from typos
586 # For new fields, remember to add to destructor DESTROY()
587 my %indents; # Stack of indents from =over's in effect for
588 # current line
589 my %current_indent; # Current line's indent
590 my %filename; # The pod is store in this file
591 my %skip; # is SKIP set for this pod
592 my %in_NAME; # true if within NAME section
593 my %in_begin; # true if within =begin section
594 my %linkable_item; # Bool: if the latest =item is linkable. It isn't
595 # for bullet and number lists
596 my %linkable_nodes; # Pod::Checker adds all =items to its node list,
597 # but not all =items are linkable to
598 my %seen_encoding_cmd; # true if have =encoding earlier
599 my %command_count; # Number of commands seen
600 my %seen_pod_cmd; # true if have =pod earlier
601 my %warned_encoding; # true if already have warned about =encoding
602 # problems
603
604 sub DESTROY {
605 my $addr = Scalar::Util::refaddr $_[0];
606 delete $command_count{$addr};
607 delete $current_indent{$addr};
608 delete $filename{$addr};
609 delete $in_begin{$addr};
610 delete $indents{$addr};
611 delete $in_NAME{$addr};
612 delete $linkable_item{$addr};
613 delete $linkable_nodes{$addr};
614 delete $seen_encoding_cmd{$addr};
615 delete $seen_pod_cmd{$addr};
616 delete $skip{$addr};
617 delete $warned_encoding{$addr};
618 return;
619 }
620
621 sub new {
622 my $class = shift;
623 my $filename = shift;
624
625 my $self = $class->SUPER::new(-quiet => 1,
626 -warnings => $Warnings_Level);
627 my $addr = Scalar::Util::refaddr $self;
628 $command_count{$addr} = 0;
629 $current_indent{$addr} = 0;
630 $filename{$addr} = $filename;
631 $in_begin{$addr} = 0;
632 $in_NAME{$addr} = 0;
633 $linkable_item{$addr} = 0;
634 $seen_encoding_cmd{$addr} = 0;
635 $seen_pod_cmd{$addr} = 0;
636 $warned_encoding{$addr} = 0;
637 return $self;
638 }
639
640 # re's for messages that Pod::Checker outputs
641 my $location = qr/ \b (?:in|at|on|near) \s+ /xi;
642 my $optional_location = qr/ (?: $location )? /xi;
3cb68c65 643 my $line_reference = qr/ [('"]? $optional_location \b line \s+
16384ac1
KW
644 (?: \d+ | EOF | \Q???\E | - )
645 [)'"]? /xi;
646
647 sub poderror { # Called to register a potential problem
648
649 # This adds an extra field to the parent hash, 'parameter'. It is
650 # used to extract the variable parts of a message leaving just the
651 # constant skeleton. This in turn allows the message to be
652 # categorized better, so that it shows up as a single type in our
653 # database, with the specifics of each occurrence not being stored with
654 # it.
655
656 my $self = shift;
657 my $opts = shift;
658
659 my $addr = Scalar::Util::refaddr $self;
660 return if $skip{$addr};
661
662 # Input can be a string or hash. If a string, parse it to separate
663 # out the line number and convert to a hash for easier further
664 # processing
665 my $message;
666 if (ref $opts ne 'HASH') {
667 $message = join "", $opts, @_;
668 my $line_number;
669 if ($message =~ s/\s*($line_reference)//) {
670 ($line_number = $1) =~ s/\s*$optional_location//;
671 }
672 else {
673 $line_number = '???';
674 }
675 $opts = { -msg => $message, -line => $line_number };
676 } else {
677 $message = $opts->{'-msg'};
678
679 }
680
681 $message =~ s/^\d+\s+//;
682 return if main::suppressed($message);
683
684 $self->SUPER::poderror($opts, @_);
685
686 $opts->{parameter} = "" unless $opts->{parameter};
687
688 # The variable parts of the message tend to be enclosed in '...',
689 # "....", or (...). Extract them and put them in an extra field,
690 # 'parameter'. This is trickier because the matching delimiter to a
691 # '(' is its mirror, and not itself. Text::Balanced could be used
692 # instead.
693 while ($message =~ m/ \s* $optional_location ( [('"] )/xg) {
694 my $delimiter = $1;
695 my $start = $-[0];
696 $delimiter = ')' if $delimiter eq '(';
697
698 # If there is no ending delimiter, don't consider it to be a
699 # variable part. Most likely it is a contraction like "Don't"
700 last unless $message =~ m/\G .+? \Q$delimiter/xg;
701
702 my $length = $+[0] - $start;
703
704 # Get the part up through the closing delimiter
705 my $special = substr($message, $start, $length);
706 $special =~ s/^\s+//; # No leading whitespace
707
708 # And add that variable part to the parameter, while removing it
709 # from the message. This isn't a foolproof way of finding the
710 # variable part. For example '(s)' can occur in e.g.,
711 # 'paragraph(s)'
712 if ($special ne '(s)') {
713 substr($message, $start, $length) = "";
714 pos $message = $start;
715 $opts->{-msg} = $message;
716 $opts->{parameter} .= " " if $opts->{parameter};
717 $opts->{parameter} .= $special;
718 }
719 }
720
721 # Extract any additional line number given. This is often the
722 # beginning location of something whereas the main line number gives
723 # the ending one.
724 if ($message =~ /( $line_reference )/xi) {
725 my $line_ref = $1;
726 while ($message =~ s/\s*\Q$line_ref//) {
727 $opts->{-msg} = $message;
728 $opts->{parameter} .= " " if $opts->{parameter};
729 $opts->{parameter} .= $line_ref;
730 }
731 }
732
b3fdb838 733 Carp::carp("Couldn't extract line number from '$message'") if $message =~ /line \d+/;
16384ac1
KW
734 push @{$problems{$filename{$addr}}{$message}}, $opts;
735 #push @{$problems{$self->get_filename}{$message}}, $opts;
736 }
737
738 sub check_encoding { # Does it need an =encoding statement?
739 my ($self, $paragraph, $line_num, $pod_para) = @_;
740
741 # Do nothing if there is an =encoding in the file, or if the line
742 # doesn't require an =encoding, or have already warned.
743 my $addr = Scalar::Util::refaddr $self;
744 return if $seen_encoding_cmd{$addr}
745 || $warned_encoding{$addr}
746 || $paragraph !~ /\P{ASCII}/;
747
748 $warned_encoding{$addr} = 1;
749 my ($file, $line) = $pod_para->file_line;
750 $self->poderror({ -line => $line, -file => $file,
751 -msg => $need_encoding
752 });
753 return;
754 }
755
756 sub verbatim {
757 my ($self, $paragraph, $line_num, $pod_para) = @_;
758 $self->check_encoding($paragraph, $line_num, $pod_para);
759
760 $self->SUPER::verbatim($paragraph, $line_num, $pod_para);
761
2592f3b8
DG
762 my $addr = Scalar::Util::refaddr $self;
763
16384ac1
KW
764 # Pick up the name, since the parent class doesn't in verbatim
765 # NAMEs; so treat as non-verbatim. The parent class only allows one
766 # paragraph in a NAME section, so if there is an extra blank line, it
767 # will trigger a message, but such a blank line is harmless, so skip
768 # in that case.
2592f3b8 769 if ($in_NAME{$addr} && $paragraph =~ /\S/) {
16384ac1
KW
770 $self->textblock($paragraph, $line_num, $pod_para);
771 }
772
773 my @lines = split /^/, $paragraph;
774 for my $i (0 .. @lines - 1) {
2592f3b8
DG
775 if ( my $encoding = $seen_encoding_cmd{$addr} ) {
776 require Encode;
777 $lines[$i] = Encode::decode($encoding, $lines[$i]);
778 }
16384ac1
KW
779 $lines[$i] =~ s/\s+$//;
780 my $indent = $self->get_current_indent;
781 my $exceeds = length(Text::Tabs::expand($lines[$i]))
2cd46bfd 782 + $indent - $MAX_LINE_LENGTH;
16384ac1
KW
783 next unless $exceeds > 0;
784 my ($file, $line) = $pod_para->file_line;
785 $self->poderror({ -line => $line + $i, -file => $file,
786 -msg => $line_length,
787 parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
788 });
789 }
790 }
791
792 sub textblock {
793 my ($self, $paragraph, $line_num, $pod_para) = @_;
794 $self->check_encoding($paragraph, $line_num, $pod_para);
795
796 $self->SUPER::textblock($paragraph, $line_num, $pod_para);
797
798 my ($file, $line) = $pod_para->file_line;
799 my $addr = Scalar::Util::refaddr $self;
800 if ($in_NAME{$addr}) {
801 if (! $self->name) {
802 my $text = $self->interpolate($paragraph, $line_num);
803 if ($text =~ /^\s*(\S+?)\s*$/) {
804 $self->name($1);
805 $self->poderror({ -line => $line, -file => $file,
806 -msg => $missing_name_description,
807 parameter => $1});
808 }
809 }
810 }
811 $paragraph = join " ", split /^/, $paragraph;
812
813 # Matches something that looks like a file name, but is enclosed in
814 # C<...>
815 my $C_path_re = qr{ \b ( C<
a44ad494
KW
816 # exclude various things that have slashes
817 # in them but aren't paths
818 (?!
819 (?: (?: s | qr | m) / ) # regexes
820 | \d+/\d+> # probable fractions
821 | OS/2>
822 | Perl/Tk>
823 | origin/blead>
824 | origin/maint
825 | - # File names don't begin with "-"
826 )
827 [-\w]+ (?: / [-\w]+ )+ (?: \. \w+ )? > )
16384ac1
KW
828 }x;
829
830 # If looks like a reference to other documentation by containing the
831 # word 'See' and then a likely pod directive, warn.
4e9f7dd4
KW
832 while ($paragraph =~ m{
833 ( (?: \w+ \s+ )* ) # The phrase before, if any
834 \b [Ss]ee \s+
835 ( ( [^L] )
836 <
837 ( [^<]*? ) # The not < excludes nested C<L<...
838 >
839 )
2ebce8af 840 ( \s+ (?: under | in ) \s+ L< )?
4e9f7dd4
KW
841 }xg) {
842 my $prefix = $1 // "";
843 my $construct = $2; # The whole thing, like C<...>
844 my $type = $3;
845 my $interior = $4;
846 my $trailing = $5; # After the whole thing ending in "L<"
847
848 # If the full phrase is something like, "you might see C<", or
849 # similar, it really isn't a reference to a link. The ones I saw
850 # all had the word "you" in them; and the "you" wasn't the
851 # beginning of a sentence.
852 if ($prefix !~ / \b you \b /x) {
2ebce8af 853
f274fe9f
KW
854 # Now, find what the module or man page name within the
855 # construct would be if it actually has L<> syntax. If it
856 # doesn't have that syntax, will set the module to the entire
857 # interior.
858 $interior =~ m/ ^
859 (?: [^|]+ \| )? # Optional arbitrary text ending
860 # in "|"
861 ( .+? ) # module, etc. name
862 (?: \/ .+ )? # target within module
863 $
864 /xs;
865 my $module = $1;
866 if (! defined $trailing # not referring to something in another
867 # section
868 && $interior !~ /$non_pods/
869
870 # C<> that look like files have their own message below, so
871 # exclude them
872 && $construct !~ /$C_path_re/g
873
874 # There can't be spaces (I think) in module names or man
875 # pages
876 && $module !~ / \s /x
877
878 # F<> that end in eg \.pl are almost certainly ok, as are
879 # those that look like a path with multiple "/" chars
880 && ($type ne "F"
881 || (! -e $interior
882 && $interior !~ /\.\w+$/
883 && $interior !~ /\/.+\//)
884 )
885 ) {
886 $self->poderror({ -line => $line, -file => $file,
887 -msg => $see_not_linked,
888 parameter => $construct
889 });
890 }
4e9f7dd4 891 }
16384ac1
KW
892 }
893 while ($paragraph =~ m/$C_path_re/g) {
894 my $construct = $1;
895 $self->poderror({ -line => $line, -file => $file,
896 -msg => $C_with_slash,
897 parameter => $construct
898 });
899 }
900 return;
901 }
902
903 sub command {
904 my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
905 my $addr = Scalar::Util::refaddr $self;
906 if ($cmd eq "pod") {
907 $seen_pod_cmd{$addr}++;
908 }
909 elsif ($cmd eq "encoding") {
910 my ($file, $line) = $pod_para->file_line;
2592f3b8 911 $seen_encoding_cmd{$addr} = $paragraph; # for later decoding
16384ac1
KW
912 if ($command_count{$addr} != 1 && $seen_pod_cmd{$addr}) {
913 $self->poderror({ -line => $line, -file => $file,
914 -msg => $encoding_first
915 });
916 }
917 }
918 $self->check_encoding($paragraph, $line_num, $pod_para);
919
920 # Pod::Check treats all =items as linkable, but the bullet and
921 # numbered lists really aren't. So keep our own list. This has to be
922 # processed before SUPER is called so that the list is started before
923 # the rest of it gets parsed.
924 if ($cmd eq 'item') { # Not linkable if item begins with * or a digit
925 $linkable_item{$addr} = ($paragraph !~ / ^ \s*
926 (?: [*]
927 | \d+ \.? (?: \$ | \s+ )
928 )/x)
929 ? 1
930 : 0;
a67b1afa 931
16384ac1
KW
932 }
933 $self->SUPER::command($cmd, $paragraph, $line_num, $pod_para);
934
935 $command_count{$addr}++;
936
937 $in_NAME{$addr} = 0; # Will change to 1 below if necessary
938 $in_begin{$addr} = 0; # ibid
939 if ($cmd eq 'over') {
940 my $text = $self->interpolate($paragraph, $line_num);
941 my $indent = 4; # default
942 $indent = $1 if $text && $text =~ /^\s*(\d+)\s*$/;
943 push @{$indents{$addr}}, $indent;
944 $current_indent{$addr} += $indent;
945 }
946 elsif ($cmd eq 'back') {
947 if (@{$indents{$addr}}) {
948 $current_indent{$addr} -= pop @{$indents{$addr}};
949 }
950 else {
951 # =back without corresponding =over, but should have
952 # warned already
953 $current_indent{$addr} = 0;
954 }
955 }
956 elsif ($cmd =~ /^head/) {
957 if (! $in_begin{$addr}) {
958
959 # If a particular formatter, then this command doesn't really
960 # apply
961 $current_indent{$addr} = 0;
962 undef @{$indents{$addr}};
963 }
964
965 my $text = $self->interpolate($paragraph, $line_num);
966 $in_NAME{$addr} = 1 if $cmd eq 'head1'
967 && $text && $text =~ /^NAME\b/;
968 }
969 elsif ($cmd eq 'begin') {
970 $in_begin{$addr} = 1;
971 }
972
973 return;
974 }
975
976 sub hyperlink {
977 my $self = shift;
978
02987562
KW
979 my $page;
980 if ($_[0] && ($page = $_[0][1]{'-page'})) {
981 my $node = $_[0][1]{'-node'};
982
983 # If the hyperlink is to an interior node of another page, save it
984 # so that we can see if we need to parse normally skipped files.
985 $has_referred_to_node{$page} = 1 if $node;
986
987 # Ignore certain placeholder links in perldelta. Check if the
988 # link is page-level, and also check if to a node within the page
989 if ($self->name && $self->name eq "perldelta"
990 && ((grep { $page eq $_ } @perldelta_ignore_links)
991 || ($node
992 && (grep { "$page/$node" eq $_ } @perldelta_ignore_links)
993 ))) {
994 return;
995 }
996 }
16384ac1
KW
997 return $self->SUPER::hyperlink($_[0]);
998 }
999
1000 sub node {
1001 my $self = shift;
1002 my $text = $_[0];
1003 if($text) {
1004 $text =~ s/\s+$//s; # strip trailing whitespace
1005 $text =~ s/\s+/ /gs; # collapse whitespace
1006 my $addr = Scalar::Util::refaddr $self;
1007 push(@{$linkable_nodes{$addr}}, $text) if
1008 ! $current_indent{$addr}
1009 || $linkable_item{$addr};
1010 }
1011 return $self->SUPER::node($_[0]);
1012 }
1013
1014 sub get_current_indent {
1015 return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
1016 }
1017
1018 sub get_filename {
1019 return $filename{Scalar::Util::refaddr $_[0]};
1020 }
1021
1022 sub linkable_nodes {
1023 my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
1024 return undef unless $linkables;
1025 return @$linkables;
1026 }
1027
1028 sub get_skip {
1029 return $skip{Scalar::Util::refaddr $_[0]} // 0;
1030 }
1031
1032 sub set_skip {
1033 my $self = shift;
1034 $skip{Scalar::Util::refaddr $self} = shift;
1035
1036 # If skipping, no need to keep the problems for it
1037 delete $problems{$self->get_filename};
1038 return;
1039 }
48b96b3d
KW
1040
1041 sub parse_from_file {
1042 # This overrides the super class method so that if an open fails on a
1043 # transitory file, it doesn't croak. It returns 1 if it did find the
1044 # file, 0 if it didn't
1045
1046 my $self = shift;
1047 my $filename = shift;
1048 # ignores 2nd param, which is output file. Always uses undef
1049
1050 if (open my $in_fh, '<:bytes', $filename) {
1051 $self->SUPER::parse_from_filehandle($in_fh, undef);
1052 close $in_fh;
1053 return 1;
1054 }
1055
1056 # If couldn't open file, perhaps it was transitory, and hence not an error
1057 return 0 unless -e $filename;
1058
1059 die "Can't open '$filename': $!\n";
1060 }
16384ac1
KW
1061}
1062
1063package Tie_Array_to_FH { # So printing actually goes to an array
1064
1065 my %array;
1066
1067 sub TIEHANDLE {
1068 my $class = shift;
1069 my $array_ref = shift;
1070
1071 my $self = bless \do{ my $anonymous_scalar }, $class;
1072 $array{Scalar::Util::refaddr $self} = $array_ref;
1073
1074 return $self;
1075 }
1076
1077 sub PRINT {
a67b1afa 1078 my $self = shift;
16384ac1
KW
1079 push @{$array{Scalar::Util::refaddr $self}}, @_;
1080 return 1;
1081 }
a67b1afa
MM
1082}
1083
69f6a9a1 1084
16384ac1
KW
1085my %filename_to_checker; # Map a filename to it's pod checker object
1086my %id_to_checker; # Map a checksum to it's pod checker object
1087my %nodes; # key is filename, values are nodes in that file.
1088my %nodes_first_word; # same, but value is first word of each node
1089my %valid_modules; # List of modules known to exist outside us.
1090my %digests; # checksums of files, whose names are the keys
1091my %filename_to_pod; # Map a filename to its pod NAME
1092my %files_with_unknown_issues;
1093my %files_with_fixes;
69f6a9a1 1094
16384ac1 1095my $data_fh;
be39e7f8 1096open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
69f6a9a1 1097
16384ac1
KW
1098my %counts; # For --counts param, count of each issue type
1099my %suppressed_files; # Files with at least one issue type to suppress
e57d740c
KW
1100my $HEADER = <<END;
1101# This file is the data file for $0.
1102# There are three types of lines.
1103# Comment lines are white-space only or begin with a '#', like this one. Any
1104# changes you make to the comment lines will be lost when the file is
1105# regen'd.
1106# Lines without tab characters are simply NAMES of pods that the program knows
1107# will have links to them and the program does not check if those links are
1108# valid.
1109# All other lines should have three fields, each separated by a tab. The
1110# first field is the name of a pod; the second field is an error message
1111# generated by this program; and the third field is a count of how many
1112# known instances of that message there are in the pod. -1 means that the
1113# program can expect any number of this type of message.
1114END
16384ac1 1115
e57d740c 1116my @existing_issues;
477100f8 1117
477100f8 1118
16384ac1 1119while (<$data_fh>) { # Read the data base
69f6a9a1 1120 chomp;
16384ac1
KW
1121 next if /^\s*(?:#|$)/; # Skip comment and empty lines
1122 if (/\t/) {
1123 next if $show_all;
e57d740c
KW
1124 if ($add_link) { # The issues are saved and later output unchanged
1125 push @existing_issues, $_;
1126 next;
1127 }
16384ac1
KW
1128
1129 # Keep track of counts of each issue type for each file
1130 my ($filename, $message, $count) = split /\t/;
1131 $known_problems{$filename}{$message} = $count;
1132
1133 if ($show_counts) {
1134 if ($count < 0) { # -1 means to suppress this issue type
1135 $suppressed_files{$filename} = $filename;
1136 }
1137 else {
1138 $counts{$message} += $count;
1139 }
1140 }
1141 }
1142 else { # Lines without a tab are modules known to be valid
1143 $valid_modules{$_} = 1
1144 }
1145}
1146close $data_fh;
1147
e57d740c
KW
1148if ($add_link) {
1149 $copy_fh = open_new($known_issues);
1150
1151 # Check for basic sanity, and add each command line argument
1152 foreach my $module (@files) {
1153 die "\"$module\" does not look like a module or man page"
1154 # Must look like (A or A::B or A::B::C ..., or foo(3C)
1155 if $module !~ /^ (?: \w+ (?: :: \w+ )* | \w+ \( \d \w* \) ) $/x;
1156 $valid_modules{$module} = 1
1157 }
1158 my_safer_print($copy_fh, $HEADER);
1159 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1160 my_safer_print($copy_fh, $_, "\n");
1161 }
1162
1163 # The rest of the db file is output unchanged.
63717411 1164 my_safer_print($copy_fh, join "\n", @existing_issues, "");
e57d740c
KW
1165
1166 close_and_rename($copy_fh);
1167 exit;
1168}
1169
16384ac1
KW
1170if ($show_counts) {
1171 my $total = 0;
1172 foreach my $message (sort keys %counts) {
1173 $total += $counts{$message};
1174 note(Text::Tabs::expand("$counts{$message}\t$message"));
1175 }
1176 note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
1177 if (%suppressed_files) {
1178 note("\nFiles that have all messages of at least one type suppressed:");
1179 note(join ",", keys %suppressed_files);
1180 }
1181 exit 0;
1182}
1183
16384ac1
KW
1184# re to match files that are to be parsed only if there is an internal link
1185# to them. It does not include cpan, as whether those are parsed depends
0496e0bb
KW
1186# on a switch. Currently, only perltoc and the stable perldelta.pod's
1187# are included. The latter all have characters between 'perl' and
1188# 'delta'. (Actually the currently developed one matches as well, but
1189# is a duplicate of perldelta.pod, so can be skipped, so fine for it to
1190# match this.
d9e2eb4b 1191my $only_for_interior_links_re = qr/ ^ pod\/perltoc.pod $
0496e0bb 1192 /x;
d9e2eb4b
KW
1193unless ($do_deltas) {
1194 $only_for_interior_links_re = qr/$only_for_interior_links_re |
1195 \b perl \d+ delta \. pod \b
1196 /x;
1197}
16384ac1
KW
1198
1199{ # Closure
1200 my $first_time = 1;
1201
1202 sub output_thanks ($$$$) { # Called when an issue has been fixed
1203 my $filename = shift;
1204 my $original_count = shift;
1205 my $current_count = shift;
1206 my $message = shift;
1207
1208 $files_with_fixes{$filename} = 1;
1209 my $return;
1210 my $fixed_count = $original_count - $current_count;
1211 my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
1212 my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
1213 my $diff;
1214 if ($message) {
1215 $diff = <<EOF;
1216There were $original_count occurrences (now $current_count) in this pod of type
1217"$message",
1218EOF
1219 } else {
1220 $diff = <<EOF;
1221There are no longer any problems found in this pod!
1222EOF
1223 }
1224
1225 if ($first_time) {
1226 $first_time = 0;
1227 $return = <<EOF;
1228Thanks for fixing $a_problem!
1229$diff
1230Now you must teach $0 that this was fixed.
1231EOF
1232 }
1233 else {
1234 $return = <<EOF
1235Thanks for fixing $another_problem.
1236$diff
1237EOF
1238 }
1239
1240 return $return;
1241 }
1242}
1243
1244sub my_safer_print { # print, with error checking for outputting to db
1245 my ($fh, @lines) = @_;
1246
1247 if (! print $fh @lines) {
1248 my $save_error = $!;
1249 close($fh);
1250 die "Write failure: $save_error";
1251 }
1252}
1253
84d2ce66
KW
1254sub extract_pod { # Extracts just the pod from a file; returns undef if file
1255 # doesn't exist
16384ac1
KW
1256 my $filename = shift;
1257
1258 my @pod;
1259
1260 # Arrange for the output of Pod::Parser to be collected in an array we can
1261 # look at instead of being printed
1262 tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
84d2ce66 1263 if (open my $in_fh, '<:bytes', $filename) {
6fca57a1
KW
1264 my $parser = Pod::Parser->new();
1265 $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
1266 close $in_fh;
16384ac1 1267
6fca57a1 1268 return join "", @pod
84d2ce66
KW
1269 }
1270
1271 # The file should already have been opened once to get here, so if that
1272 # fails, something is wrong. It's possible that a transitory file
1273 # containing a pod would get here, so if the file no longer exists just
1274 # return undef.
1275 return unless -e $filename;
1276 die "Can't open '$filename': $!\n";
16384ac1
KW
1277}
1278
1279my $digest = Digest->new($digest_type);
1280
f2317e57
NC
1281# This is used as a callback from File::Find::find(), which always constructs
1282# pathnames using Unix separators
16384ac1 1283sub is_pod_file {
c1dcaaab
KW
1284 # If $_ is a pod file, add it to the lists and do other prep work.
1285
e42a86f0 1286 if (-d) {
16384ac1
KW
1287 # Don't look at files in directories that are for tests, nor those
1288 # beginning with a dot
f2317e57 1289 if (m!/t\z! || m!/\.!) {
16384ac1
KW
1290 $File::Find::prune = 1;
1291 }
1292 return;
1293 }
1294
e42a86f0
KW
1295 return unless -r && -s; # Can't check it if can't read it; no need to
1296 # check if 0 length
1297 return unless -f || -l; # Weird file types won't be pods
1298
f2317e57
NC
1299 my ($leaf) = m!([^/]+)\z!;
1300 if (m!/\.! # No hidden Unix files
1301 || $leaf =~ $non_pods) {
de4da25d
CB
1302 note("Not considering $_") if DEBUG;
1303 return;
1304 }
1305
16384ac1
KW
1306 my $filename = $File::Find::name;
1307
3673acb0 1308 # $filename is relative, like './path'. Strip that initial part away.
f2317e57 1309 $filename =~ s!^\./!! or die 'Unexpected pathname "$filename"';
16384ac1 1310
b3fdb838 1311 return if $excluded_files{canonicalize($filename)};
16384ac1 1312
144a708b
NC
1313 my $contents = do {
1314 local $/;
763df156
KW
1315 my $candidate;
1316 if (! open $candidate, '<:bytes', $_) {
1317
77b8b9ad
KW
1318 # If a transitory file was found earlier, the open could fail
1319 # legitimately and we just skip the file; also skip it if it is a
1320 # broken symbolic link, as it is probably just a build problem;
1321 # certainly not a file that we would want to check the pod of.
1322 # Otherwise fail it here and no reason to process it further.
1323 # (But the test count will be off too)
1324 ok(0, "Can't open '$filename': $!")
e42a86f0 1325 if -r $filename && ! -l $filename;
763df156
KW
1326 return;
1327 }
144a708b
NC
1328 <$candidate>;
1329 };
16384ac1
KW
1330
1331 # If the file is a .pm or .pod, having any initial '=' on a line is
8505a15d
KW
1332 # grounds for testing it. Otherwise, require a head1 NAME line to
1333 # consider it as a potential pod
144a708b
NC
1334 if ($filename =~ /\.(?:pm|pod)/) {
1335 return unless $contents =~ /^=/m;
1336 } else {
1337 return unless $contents =~ /^=head1 +NAME/m;
16384ac1 1338 }
144a708b
NC
1339
1340 # Here, we know that the file is a pod. Add it to the list of files
1341 # to check and create a checker object for it.
1342
1343 push @files, $filename;
1344 my $checker = My::Pod::Checker->new($filename);
1345 $filename_to_checker{$filename} = $checker;
1346
1347 # In order to detect duplicate pods and only analyze them once, we
1348 # compute checksums for the file, so don't have to do an exact
1349 # compare. Note that if the pod is just part of the file, the
1350 # checksums can differ for the same pod. That special case is handled
1351 # later, since if the checksums of the whole file are the same, that
1352 # case won't even come up. We don't need the checksums for files that
1353 # we parse only if there is a link to its interior, but we do need its
1354 # NAME, which is also retrieved in the code below.
1355
1356 if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
1357 | $only_for_interior_links_re
1358 /x) {
1359 $digest->add($contents);
1360 $digests{$filename} = $digest->digest;
1361
1362 # lib files aren't analyzed if they are duplicates of files copied
1363 # there from some other directory. But to determine this, we need
1364 # to know their NAMEs. We might as well find the NAME now while
1365 # the file is open. Similarly, cpan files aren't analyzed unless
1366 # we're analyzing all of them, or this particular file is linked
1367 # to by a file we are analyzing, and thus we will want to verify
1368 # that the target exists in it. We need to know at least the NAME
1369 # to see if it's worth analyzing, or so we can determine if a lib
1370 # file is a copy of a cpan one.
1371 if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
16384ac1 1372 | $only_for_interior_links_re
144a708b
NC
1373 }x) {
1374 if ($contents =~ /^=head1 +NAME.*/mg) {
1375 # The NAME is the first non-spaces on the line up to a
1376 # comma, dash or end of line. Otherwise, it's invalid and
1377 # this pod doesn't have a legal name that we're smart
1378 # enough to find currently. But the parser will later
1379 # find it if it thinks there is a legal name, and set the
1380 # name
1381 if ($contents =~ /\G # continue from the line after =head1
1382 \s* # ignore any empty lines
1383 ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
1384 my $name = $1;
1385 $checker->name($name);
1386 $id_to_checker{$name} = $checker
1387 if $filename =~ m{^cpan/};
16384ac1
KW
1388 }
1389 }
144a708b
NC
1390 elsif ($filename =~ m{^cpan/}) {
1391 $id_to_checker{$digests{$filename}} = $checker;
1392 }
16384ac1
KW
1393 }
1394 }
c1dcaaab
KW
1395
1396 return;
16384ac1
KW
1397} # End of is_pod_file()
1398
477100f8
KW
1399# Start of real code that isn't processing the command line (except the
1400# db is read in above, as is processing of the --add_link option).
16384ac1
KW
1401# Here, @files contains list of files on the command line. If have any of
1402# these, unconditionally test them, and show all the errors, even the known
1403# ones, and, since not testing other pods, don't do cross-pod link tests.
1404# (Could add extra code to do cross-pod tests for the ones in the list.)
477100f8 1405
16384ac1
KW
1406if ($has_input_files) {
1407 undef %known_problems;
d9e2eb4b
KW
1408 $do_upstream_cpan = $do_deltas = 1; # In case one of the inputs is one
1409 # of these types
16384ac1
KW
1410}
1411else { # No input files -- go find all the possibilities.
1412 if ($regen) {
1413 $copy_fh = open_new($known_issues);
1414 note("Regenerating $known_issues, please be patient...");
e57d740c 1415 print $copy_fh $HEADER;
16384ac1
KW
1416 }
1417
1418 # Move to the directory above us, but have to adjust @INC to account for
1419 # that.
1420 s{^\.\./lib$}{lib} for @INC;
1421 chdir File::Spec->updir;
1422
1423 # And look in this directory and all its subdirectories
f2317e57 1424 find( {wanted => \&is_pod_file, no_chdir => 1}, '.');
16384ac1
KW
1425
1426 # Add ourselves to the test
b3fdb838 1427 push @files, "t/porting/podcheck.t";
16384ac1
KW
1428}
1429
1430# Now we know how many tests there will be.
1431plan (tests => scalar @files) if ! $regen;
1432
1433
1434 # Sort file names so we get consistent results, and to put cpan last,
1435 # preceeded by the ones that we don't generally parse. This is because both
1436 # these classes are generally parsed only if there is a link to the interior
1437 # of them, and we have to parse all others first to guarantee that they don't
1438 # have such a link. 'lib' files come just before these, as some of these are
1439 # duplicates of others. We already have figured this out when gathering the
1440 # data as a special case for all such files, but this, while unnecessary,
1441 # puts the derived file last in the output. 'readme' files come before those,
1442 # as those also could be duplicates of others, which are considered the
1443 # primary ones. These currently aren't figured out when gathering data, so
1444 # are done here.
1445 @files = sort { if ($a =~ /^cpan/) {
1446 return 1 if $b !~ /^cpan/;
e08998bf 1447 return lc $a cmp lc $b;
16384ac1
KW
1448 }
1449 elsif ($b =~ /^cpan/) {
1450 return -1;
1451 }
1452 elsif ($a =~ /$only_for_interior_links_re/) {
1453 return 1 if $b !~ /$only_for_interior_links_re/;
e08998bf 1454 return lc $a cmp lc $b;
16384ac1
KW
1455 }
1456 elsif ($b =~ /$only_for_interior_links_re/) {
1457 return -1;
1458 }
1459 elsif ($a =~ /^lib/) {
1460 return 1 if $b !~ /^lib/;
e08998bf 1461 return lc $a cmp lc $b;
16384ac1
KW
1462 }
1463 elsif ($b =~ /^lib/) {
1464 return -1;
1465 } elsif ($a =~ /\breadme\b/i) {
1466 return 1 if $b !~ /\breadme\b/i;
e08998bf 1467 return lc $a cmp lc $b;
16384ac1
KW
1468 }
1469 elsif ($b =~ /\breadme\b/i) {
1470 return -1;
1471 }
1472 else {
1473 return lc $a cmp lc $b;
1474 }
1475 }
1476 @files;
1477
1478# Now go through all the files and parse them
c66a5b89 1479FILE:
16384ac1
KW
1480foreach my $filename (@files) {
1481 my $parsed = 0;
1482 note("parsing $filename") if DEBUG;
1483
1484 # We may have already figured out some things in the process of generating
8505a15d 1485 # the file list. If so, we have a $checker object already. But if not,
16384ac1
KW
1486 # generate one now.
1487 my $checker = $filename_to_checker{$filename};
1488 if (! $checker) {
1489 $checker = My::Pod::Checker->new($filename);
1490 $filename_to_checker{$filename} = $checker;
1491 }
1492
1493 # We have set the name in the checker object if there is a possibility
1494 # that no further parsing is necessary, but otherwise do the parsing now.
1495 if (! $checker->name) {
48b96b3d
KW
1496 if (! $checker->parse_from_file($filename, undef)) {
1497 $checker->set_skip("$filename is transitory");
1498 next FILE;
1499 }
16384ac1 1500 $parsed = 1;
48b96b3d 1501
16384ac1
KW
1502 }
1503
1504 if ($checker->num_errors() < 0) { # Returns negative if not a pod
1505 $checker->set_skip("$filename is not a pod");
1506 }
1507 else {
1508
1509 # Here, is a pod. See if it is one that has already been tested,
1510 # or should be tested under another directory. Use either its NAME
1511 # if it has one, or a checksum if not.
1512 my $name = $checker->name;
1513 my $id;
1514
1515 if ($name) {
1516 $id = $name;
1517 }
1518 else {
1519 my $digest = Digest->new($digest_type);
84d2ce66
KW
1520 my $contents = extract_pod($filename);
1521
1522 # If the return is undef, it means that $filename was a transitory
1523 # file; skip it.
1524 next FILE unless defined $contents;
1525 $digest->add($contents);
16384ac1
KW
1526 $id = $digest->digest;
1527 }
1528
1529 # If there is a match for this pod with something that we've already
1530 # processed, don't process it, and output why.
1531 my $prior_checker;
1532 if (defined ($prior_checker = $id_to_checker{$id})
1533 && $prior_checker != $checker) # Could have defined the checker
1534 # earlier without pursuing it
1535 {
1536
1537 # If the pods are identical, then it's just a copy, and isn't an
1538 # error. First use the checksums we have already computed to see
1539 # if the entire files are identical, which means that the pods are
1540 # identical too.
1541 my $prior_filename = $prior_checker->get_filename;
1542 my $same = (! $name
1543 || ($digests{$prior_filename}
1544 && $digests{$filename}
1545 && $digests{$prior_filename} eq $digests{$filename}));
1546
1547 # If they differ, it could be that the files differ for some
1548 # reason, but the pods they contain are identical. Extract the
1549 # pods and do the comparisons on just those.
1550 if (! $same && $name) {
84d2ce66
KW
1551 my $contents = extract_pod($filename);
1552
1553 # If return is <undef>, it means that $filename no longer
1554 # exists. This means it was a transitory file, and should not
1555 # be tested.
1556 next FILE unless defined $contents;
1557
1558 my $prior_contents = extract_pod($prior_filename);
1559
1560 # If return is <undef>, it means that $prior_filename no
1561 # longer exists. This means it was a transitory file, and
1562 # should not have been tested, but we already did process it.
1563 # What we should do now is to back-out its records, and
1564 # process $filename in its stead. But backing out is not so
1565 # simple, and so I'm (khw) skipping that unless and until
1566 # experience shows that it is needed. We do go process
1567 # $filename, and there are potential false positive conflicts
1568 # with the transitory $prior_contents, and rerunning the test
1569 # should cause it to succeed.
1570 goto process_this_pod unless defined $prior_contents;
1571
1572 $same = $prior_contents eq $contents;
16384ac1
KW
1573 }
1574
1575 if ($same) {
1576 $checker->set_skip("The pod of $filename is a duplicate of "
1577 . "the pod for $prior_filename");
1578 } elsif ($prior_filename =~ /\breadme\b/i) {
1579 $checker->set_skip("$prior_filename is a README apparently for $filename");
1580 } elsif ($filename =~ /\breadme\b/i) {
1581 $checker->set_skip("$filename is a README apparently for $prior_filename");
44b8cd40
KW
1582 } elsif (! $do_upstream_cpan
1583 && $filename =~ /^cpan/
1584 && $prior_filename =~ /^cpan/)
1585 {
ef906498 1586 $checker->set_skip("CPAN is upstream for $filename");
16384ac1
KW
1587 } else { # Here have two pods with identical names that differ
1588 $prior_checker->poderror(
1589 { -msg => $duplicate_name,
1590 -line => "???",
1591 parameter => "'$filename' also has NAME '$name'"
1592 });
1593 $checker->poderror(
1594 { -msg => $duplicate_name,
1595 -line => "???",
1596 parameter => "'$prior_filename' also has NAME '$name'"
1597 });
1598
1599 # Changing the names helps later.
1600 $prior_checker->name("$name version arbitrarily numbered 1");
1601 $checker->name("$name version arbitrarily numbered 2");
1602 }
1603
1604 # In any event, don't process this pod that has the same name as
1605 # another.
c66a5b89 1606 next FILE;
16384ac1
KW
1607 }
1608
84d2ce66
KW
1609 process_this_pod:
1610
16384ac1
KW
1611 # A unique pod.
1612 $id_to_checker{$id} = $checker;
1613
1614 my $parsed_for_links = ", but parsed for its interior links";
1615 if ((! $do_upstream_cpan && $filename =~ /^cpan/)
1616 || $filename =~ $only_for_interior_links_re)
1617 {
1618 if ($filename =~ /^cpan/) {
1619 $checker->set_skip("CPAN is upstream for $filename");
1620 }
35c86e19
KW
1621 elsif ($filename =~ /perl\d+delta/) {
1622 if (! $do_deltas) {
1623 $checker->set_skip("$filename is a stable perldelta");
1624 }
16384ac1 1625 }
0496e0bb
KW
1626 elsif ($filename =~ /perltoc/) {
1627 $checker->set_skip("$filename dependent on component pods");
1628 }
16384ac1
KW
1629 else {
1630 croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
1631 }
1632
1633 if ($name && $has_referred_to_node{$name}) {
1634 $checker->set_skip($checker->get_skip() . $parsed_for_links);
1635 }
1636 }
1637
1638 # Need a name in order to process it, because not meaningful
1639 # otherwise, and also can't test links to this without a name.
1640 if (!defined $name) {
1641 $checker->poderror( { -msg => $no_name,
1642 -line => '???'
1643 });
c66a5b89 1644 next FILE;
16384ac1
KW
1645 }
1646
1647 # For skipped files, just get its NAME
1648 my $skip;
1649 if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
1650 {
1651 $checker->node($name) if $name;
1652 }
48b96b3d
KW
1653 elsif (! $parsed) {
1654 if (! $checker->parse_from_file($filename, undef)) {
1655 $checker->set_skip("$filename is transitory");
1656 next FILE;
1657 }
16384ac1
KW
1658 }
1659
1660 # Go through everything in the file that could be an anchor that
1661 # could be a link target. Count how many there are of the same name.
1662 foreach my $node ($checker->linkable_nodes) {
c66a5b89 1663 next FILE if ! $node; # Can be empty is like '=item *'
16384ac1
KW
1664 if (exists $nodes{$name}{$node}) {
1665 $nodes{$name}{$node}++;
1666 }
1667 else {
1668 $nodes{$name}{$node} = 1;
1669 }
1670
1671 # Experiments have shown that cpan search can figure out the
1672 # target of a link even if the exact wording is incorrect, as long
1673 # as the first word is. This happens frequently in perlfunc.pod,
1674 # where the link will be just to the function, but the target
1675 # entry also includes parameters to the function.
1676 my $first_word = $node;
1677 if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
1678 $nodes_first_word{$name}{$first_word} = $node;
1679 }
1680 }
1681 $filename_to_pod{$filename} = $name;
1682 }
1683}
1684
1685# Here, all files have been parsed, and all links and link targets are stored.
1686# Now go through the files again and see which don't have matches.
1687if (! $has_input_files) {
1688 foreach my $filename (@files) {
1689 next if $filename_to_checker{$filename}->get_skip;
1690 my $checker = $filename_to_checker{$filename};
1691 foreach my $link ($checker->hyperlink) {
1692 my $linked_to_page = $link->[1]->page;
1693 next unless $linked_to_page; # intra-file checks are handled by std
1694 # Pod::Checker
1695
1696 # Initialize the potential message.
1697 my %problem = ( -msg => $broken_link,
1698 -line => $link->[0],
1699 parameter => "to \"$linked_to_page\"",
1700 );
1701
1702 # See if we have found the linked-to_file in our parse
1703 if (exists $nodes{$linked_to_page}) {
1704 my $node = $link->[1]->node;
1705
1706 # If link is only to the page-level, already have it
1707 next if ! $node;
1708
1709 # Transform pod language to what we are expecting
1710 $node =~ s,E<sol>,/,g;
1711 $node =~ s/E<verbar>/|/g;
1712
1713 # If link is to a node that exists in the file, is ok
1714 if ($nodes{$linked_to_page}{$node}) {
1715
1716 # But if the page has multiple targets with the same name,
1717 # it's ambiguous which one this should be to.
1718 if ($nodes{$linked_to_page}{$node} > 1) {
1719 $problem{-msg} = $multiple_targets;
1720 $problem{parameter} = "in $linked_to_page that $node could be pointing to";
1721 $checker->poderror(\%problem);
1722 }
1723 } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
1724
1725 # Here the link target was not found, either exactly or to
1726 # the first word. Is an error.
1727 $problem{parameter} =~ s,"$,/$node",;
1728 $checker->poderror(\%problem);
1729 }
1730
1731 } # Linked-to-file not in parse; maybe is in exception list
1732 elsif (! exists $valid_modules{$link->[1]->page}) {
1733
1734 # Here, is a link to a target that we can't find. Check if
1735 # there is an internal link on the page with the target name.
1736 # If so, it could be that they just forgot the initial '/'
1c01047d
KW
1737 # But perldelta is handled specially: only do this if the
1738 # broken link isn't one of the known bad ones (that are
1739 # placemarkers and should be removed for the final)
1740 my $NAME = $filename_to_pod{$filename};
1741 if (! defined $NAME) {
1742 $checker->poderror(\%problem);
1743 }
02987562 1744 else {
1c01047d
KW
1745 if ($nodes{$NAME}{$linked_to_page}) {
1746 $problem{-msg} = $broken_internal_link;
1747 }
1748 $checker->poderror(\%problem);
16384ac1 1749 }
16384ac1
KW
1750 }
1751 }
1752 }
1753}
1754
1755# If regenerating the data file, start with the modules for which we don't
de37f83f
KW
1756# check targets. If you change the sort order, you need to run --regen before
1757# committing so that future commits that do run regen don't show irrelevant
1758# changes.
16384ac1
KW
1759if ($regen) {
1760 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1761 my_safer_print($copy_fh, $_, "\n");
1762 }
1763}
1764
1765# Now ready to output the messages.
1766foreach my $filename (@files) {
b3fdb838 1767 my $canonical = canonicalize($filename);
16384ac1
KW
1768 SKIP: {
1769 my $skip = $filename_to_checker{$filename}->get_skip // "";
1770
1771 if ($regen) {
1772 foreach my $message ( sort keys %{$problems{$filename}}) {
1773 my $count;
1774
1775 # Preserve a negative setting.
b3fdb838
KW
1776 if ($known_problems{$canonical}{$message}
1777 && $known_problems{$canonical}{$message} < 0)
16384ac1 1778 {
b3fdb838 1779 $count = $known_problems{$canonical}{$message};
16384ac1
KW
1780 }
1781 else {
1782 $count = @{$problems{$filename}{$message}};
1783 }
24df3027 1784 my_safer_print($copy_fh, $canonical . "\t$message\t$count\n");
16384ac1
KW
1785 }
1786 next;
1787 }
1788
1789 skip($skip, 1) if $skip;
1790 my @diagnostics;
1791 my $indent = ' ';
1792
16384ac1
KW
1793 my $total_known = 0;
1794 foreach my $message ( sort keys %{$problems{$filename}}) {
b3fdb838
KW
1795 $known_problems{$canonical}{$message} = 0
1796 if ! $known_problems{$canonical}{$message};
16384ac1
KW
1797 my $diagnostic = "";
1798 my $problem_count = scalar @{$problems{$filename}{$message}};
1799 $total_known += $problem_count;
b3fdb838
KW
1800 next if $known_problems{$canonical}{$message} < 0;
1801 if ($problem_count > $known_problems{$canonical}{$message}) {
16384ac1
KW
1802
1803 # Here we are about to output all the messages for this type,
1804 # subtract back this number we previously added in.
1805 $total_known -= $problem_count;
1806
b2bf5aea 1807 $diagnostic .= $indent . qq{"$message"};
16384ac1 1808 if ($problem_count > 2) {
b2bf5aea
DM
1809 $diagnostic .= " ($problem_count occurrences,"
1810 . " expected $known_problems{$canonical}{$message})";
16384ac1
KW
1811 }
1812 foreach my $problem (@{$problems{$filename}{$message}}) {
1813 $diagnostic .= " " if $problem_count == 1;
1814 $diagnostic .= "\n$indent$indent";
1815 $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
1816 $diagnostic .= " near line $problem->{-line}";
1817 $diagnostic .= " $problem->{comment}" if $problem->{comment};
1818 }
1819 $diagnostic .= "\n";
1820 $files_with_unknown_issues{$filename} = 1;
b3fdb838
KW
1821 } elsif ($problem_count < $known_problems{$canonical}{$message}) {
1822 $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
16384ac1
KW
1823 }
1824 push @diagnostics, $diagnostic if $diagnostic;
1825 }
1826
09ea063a
KW
1827 # The above loop has output messages where there are current potential
1828 # issues. But it misses where there were some that have been entirely
1829 # fixed. For those, we need to look through the old issues
b3fdb838 1830 foreach my $message ( sort keys %{$known_problems{$canonical}}) {
09ea063a 1831 next if $problems{$filename}{$message};
b3fdb838
KW
1832 next if ! $known_problems{$canonical}{$message};
1833 next if $known_problems{$canonical}{$message} < 0; # Preserve negs
1834 my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
09ea063a
KW
1835 push @diagnostics, $diagnostic if $diagnostic;
1836 }
1837
16384ac1
KW
1838 my $output = "POD of $filename";
1839 $output .= ", excluding $total_known not shown known potential problems"
1840 if $total_known;
1841 ok(@diagnostics == 0, $output);
1842 if (@diagnostics) {
1843 note(join "", @diagnostics,
477100f8 1844 "See end of this test output for your options on silencing this");
16384ac1 1845 }
da33abaf
KW
1846
1847 delete $known_problems{$canonical};
16384ac1
KW
1848 }
1849}
1850
ac93cf5d
KW
1851if (! $regen
1852 && ! ok (keys %known_problems == 0, "The known problems data base includes no references to non-existent files"))
1853{
da33abaf
KW
1854 note("The following files were not found: "
1855 . join ", ", keys %known_problems);
1856 note("They will automatically be removed from the db the next time");
1857 note(" cd t; ./perl -I../lib porting/podcheck.t --regen");
1858 note("is run");
1859}
1860
16384ac1
KW
1861my $how_to = <<EOF;
1862 run this test script by hand, using the following formula (on
1863 Un*x-like machines):
1864 cd t
1865 ./perl -I../lib porting/podcheck.t --regen
1866EOF
1867
1868if (%files_with_unknown_issues) {
1869 my $were_count_files = scalar keys %files_with_unknown_issues;
1870 $were_count_files = ($were_count_files == 1)
1871 ? "was $were_count_files file"
1872 : "were $were_count_files files";
1873 my $message = <<EOF;
1874
1875HOW TO GET THIS .t TO PASS
1876
477100f8 1877There $were_count_files that had new potential problems identified.
bc20e6b8 1878Some of them may be real, and some of them may be false positives because
968d3762
KW
1879this program isn't as smart as it likes to think it is. You can teach this
1880program to ignore the issues it has identified, and hence pass, by doing the
477100f8 1881following:
16384ac1 1882
477100f8
KW
18831) If a problem is about a link to an unknown module or man page that
1884 you know exists, re-run the command something like:
1885 ./perl -I../lib porting/podcheck.t --add_link MODULE man_page ...
1886 (MODULEs should look like Foo::Bar, and man_pages should look like
1887 bar(3c); don't do this for a module or man page that you aren't sure
1888 about; instead treat as another type of issue and follow the
1889 instructions below.)
16384ac1
KW
1890
18912) For other issues, decide if each should be fixed now or not. Fix the
1892 ones you decided to, and rerun this test to verify that the fixes
1893 worked.
1894
968d3762
KW
18953) If there remain false positive or problems that you don't plan to fix right
1896 now,
16384ac1 1897$how_to
477100f8
KW
1898 That should cause all current potential problems to be accepted by
1899 the program, so that the next time it runs, they won't be flagged.
16384ac1
KW
1900EOF
1901 if (%files_with_fixes) {
1902 $message .= " This step will also take care of the files that have fixes in them\n";
1903 }
1904
1905 $message .= <<EOF;
1906 For a few files, such as perltoc, certain issues will always be
1907 expected, and more of the same will be added over time. For those,
1908 before you do the regen, you can edit
1909 $known_issues
1910 and find the entry for the module's file and specific error message,
1911 and change the count of known potential problems to -1.
1912EOF
1913
1914 note($message);
1915} elsif (%files_with_fixes) {
1916 note(<<EOF
1917To teach this test script that the potential problems have been fixed,
1918$how_to
1919EOF
1920 );
1921}
1922
1923if ($regen) {
1924 chdir $original_dir || die "Can't change directories to $original_dir";
1925 close_and_rename($copy_fh);
1926}