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