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