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