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