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