This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
podcheck.t: Move perldelta placeholder link checks
[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
02987562
KW
829 my $page;
830 if ($_[0] && ($page = $_[0][1]{'-page'})) {
831 my $node = $_[0][1]{'-node'};
832
833 # If the hyperlink is to an interior node of another page, save it
834 # so that we can see if we need to parse normally skipped files.
835 $has_referred_to_node{$page} = 1 if $node;
836
837 # Ignore certain placeholder links in perldelta. Check if the
838 # link is page-level, and also check if to a node within the page
839 if ($self->name && $self->name eq "perldelta"
840 && ((grep { $page eq $_ } @perldelta_ignore_links)
841 || ($node
842 && (grep { "$page/$node" eq $_ } @perldelta_ignore_links)
843 ))) {
844 return;
845 }
846 }
16384ac1
KW
847 return $self->SUPER::hyperlink($_[0]);
848 }
849
850 sub node {
851 my $self = shift;
852 my $text = $_[0];
853 if($text) {
854 $text =~ s/\s+$//s; # strip trailing whitespace
855 $text =~ s/\s+/ /gs; # collapse whitespace
856 my $addr = Scalar::Util::refaddr $self;
857 push(@{$linkable_nodes{$addr}}, $text) if
858 ! $current_indent{$addr}
859 || $linkable_item{$addr};
860 }
861 return $self->SUPER::node($_[0]);
862 }
863
864 sub get_current_indent {
865 return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
866 }
867
868 sub get_filename {
869 return $filename{Scalar::Util::refaddr $_[0]};
870 }
871
872 sub linkable_nodes {
873 my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
874 return undef unless $linkables;
875 return @$linkables;
876 }
877
878 sub get_skip {
879 return $skip{Scalar::Util::refaddr $_[0]} // 0;
880 }
881
882 sub set_skip {
883 my $self = shift;
884 $skip{Scalar::Util::refaddr $self} = shift;
885
886 # If skipping, no need to keep the problems for it
887 delete $problems{$self->get_filename};
888 return;
889 }
890}
891
892package Tie_Array_to_FH { # So printing actually goes to an array
893
894 my %array;
895
896 sub TIEHANDLE {
897 my $class = shift;
898 my $array_ref = shift;
899
900 my $self = bless \do{ my $anonymous_scalar }, $class;
901 $array{Scalar::Util::refaddr $self} = $array_ref;
902
903 return $self;
904 }
905
906 sub PRINT {
a67b1afa 907 my $self = shift;
16384ac1
KW
908 push @{$array{Scalar::Util::refaddr $self}}, @_;
909 return 1;
910 }
a67b1afa
MM
911}
912
69f6a9a1 913
16384ac1
KW
914my %filename_to_checker; # Map a filename to it's pod checker object
915my %id_to_checker; # Map a checksum to it's pod checker object
916my %nodes; # key is filename, values are nodes in that file.
917my %nodes_first_word; # same, but value is first word of each node
918my %valid_modules; # List of modules known to exist outside us.
919my %digests; # checksums of files, whose names are the keys
920my %filename_to_pod; # Map a filename to its pod NAME
921my %files_with_unknown_issues;
922my %files_with_fixes;
69f6a9a1 923
16384ac1 924my $data_fh;
be39e7f8 925open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
69f6a9a1 926
16384ac1
KW
927my %counts; # For --counts param, count of each issue type
928my %suppressed_files; # Files with at least one issue type to suppress
e57d740c
KW
929my $HEADER = <<END;
930# This file is the data file for $0.
931# There are three types of lines.
932# Comment lines are white-space only or begin with a '#', like this one. Any
933# changes you make to the comment lines will be lost when the file is
934# regen'd.
935# Lines without tab characters are simply NAMES of pods that the program knows
936# will have links to them and the program does not check if those links are
937# valid.
938# All other lines should have three fields, each separated by a tab. The
939# first field is the name of a pod; the second field is an error message
940# generated by this program; and the third field is a count of how many
941# known instances of that message there are in the pod. -1 means that the
942# program can expect any number of this type of message.
943END
16384ac1 944
e57d740c 945my @existing_issues;
477100f8 946
477100f8 947
16384ac1 948while (<$data_fh>) { # Read the data base
69f6a9a1 949 chomp;
16384ac1
KW
950 next if /^\s*(?:#|$)/; # Skip comment and empty lines
951 if (/\t/) {
952 next if $show_all;
e57d740c
KW
953 if ($add_link) { # The issues are saved and later output unchanged
954 push @existing_issues, $_;
955 next;
956 }
16384ac1
KW
957
958 # Keep track of counts of each issue type for each file
959 my ($filename, $message, $count) = split /\t/;
960 $known_problems{$filename}{$message} = $count;
961
962 if ($show_counts) {
963 if ($count < 0) { # -1 means to suppress this issue type
964 $suppressed_files{$filename} = $filename;
965 }
966 else {
967 $counts{$message} += $count;
968 }
969 }
970 }
971 else { # Lines without a tab are modules known to be valid
972 $valid_modules{$_} = 1
973 }
974}
975close $data_fh;
976
e57d740c
KW
977if ($add_link) {
978 $copy_fh = open_new($known_issues);
979
980 # Check for basic sanity, and add each command line argument
981 foreach my $module (@files) {
982 die "\"$module\" does not look like a module or man page"
983 # Must look like (A or A::B or A::B::C ..., or foo(3C)
984 if $module !~ /^ (?: \w+ (?: :: \w+ )* | \w+ \( \d \w* \) ) $/x;
985 $valid_modules{$module} = 1
986 }
987 my_safer_print($copy_fh, $HEADER);
988 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
989 my_safer_print($copy_fh, $_, "\n");
990 }
991
992 # The rest of the db file is output unchanged.
63717411 993 my_safer_print($copy_fh, join "\n", @existing_issues, "");
e57d740c
KW
994
995 close_and_rename($copy_fh);
996 exit;
997}
998
16384ac1
KW
999if ($show_counts) {
1000 my $total = 0;
1001 foreach my $message (sort keys %counts) {
1002 $total += $counts{$message};
1003 note(Text::Tabs::expand("$counts{$message}\t$message"));
1004 }
1005 note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
1006 if (%suppressed_files) {
1007 note("\nFiles that have all messages of at least one type suppressed:");
1008 note(join ",", keys %suppressed_files);
1009 }
1010 exit 0;
1011}
1012
1013
1014my %excluded_files = (
1015 "lib/unicore/mktables" => 1,
1016 "Porting/perldelta_template.pod" => 1,
1017 "autodoc.pl" => 1,
1018 "configpm" => 1,
1019 "miniperl" => 1,
1020 "perl" => 1,
1021 );
1022
b3fdb838
KW
1023# Convert to more generic form.
1024foreach my $file (keys %excluded_files) {
03ca349a
KW
1025 delete $excluded_files{$file};
1026 $excluded_files{canonicalize($file)} = 1;
b3fdb838
KW
1027}
1028
16384ac1
KW
1029# re to match files that are to be parsed only if there is an internal link
1030# to them. It does not include cpan, as whether those are parsed depends
0496e0bb
KW
1031# on a switch. Currently, only perltoc and the stable perldelta.pod's
1032# are included. The latter all have characters between 'perl' and
1033# 'delta'. (Actually the currently developed one matches as well, but
1034# is a duplicate of perldelta.pod, so can be skipped, so fine for it to
1035# match this.
d9e2eb4b 1036my $only_for_interior_links_re = qr/ ^ pod\/perltoc.pod $
0496e0bb 1037 /x;
d9e2eb4b
KW
1038unless ($do_deltas) {
1039 $only_for_interior_links_re = qr/$only_for_interior_links_re |
1040 \b perl \d+ delta \. pod \b
1041 /x;
1042}
16384ac1
KW
1043
1044{ # Closure
1045 my $first_time = 1;
1046
1047 sub output_thanks ($$$$) { # Called when an issue has been fixed
1048 my $filename = shift;
1049 my $original_count = shift;
1050 my $current_count = shift;
1051 my $message = shift;
1052
1053 $files_with_fixes{$filename} = 1;
1054 my $return;
1055 my $fixed_count = $original_count - $current_count;
1056 my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
1057 my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
1058 my $diff;
1059 if ($message) {
1060 $diff = <<EOF;
1061There were $original_count occurrences (now $current_count) in this pod of type
1062"$message",
1063EOF
1064 } else {
1065 $diff = <<EOF;
1066There are no longer any problems found in this pod!
1067EOF
1068 }
1069
1070 if ($first_time) {
1071 $first_time = 0;
1072 $return = <<EOF;
1073Thanks for fixing $a_problem!
1074$diff
1075Now you must teach $0 that this was fixed.
1076EOF
1077 }
1078 else {
1079 $return = <<EOF
1080Thanks for fixing $another_problem.
1081$diff
1082EOF
1083 }
1084
1085 return $return;
1086 }
1087}
1088
1089sub my_safer_print { # print, with error checking for outputting to db
1090 my ($fh, @lines) = @_;
1091
1092 if (! print $fh @lines) {
1093 my $save_error = $!;
1094 close($fh);
1095 die "Write failure: $save_error";
1096 }
1097}
1098
1099sub extract_pod { # Extracts just the pod from a file
1100 my $filename = shift;
1101
1102 my @pod;
1103
1104 # Arrange for the output of Pod::Parser to be collected in an array we can
1105 # look at instead of being printed
1106 tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
be39e7f8 1107 open my $in_fh, '<:bytes', $filename
763df156
KW
1108
1109 # The file should already have been opened once to get here, so if
77b8b9ad
KW
1110 # fails, just die. It's possible that a transitory file containing a
1111 # pod would get here, but not bothering to add code for that very
1112 # unlikely event.
16384ac1
KW
1113 or die "Can't open '$filename': $!\n";
1114
1115 my $parser = Pod::Parser->new();
1116 $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
1117 close $in_fh;
1118
1119 return join "", @pod
1120}
1121
1122my $digest = Digest->new($digest_type);
1123
1124sub is_pod_file {
c1dcaaab
KW
1125 # If $_ is a pod file, add it to the lists and do other prep work.
1126
16384ac1
KW
1127 if (-d $_) {
1128 # Don't look at files in directories that are for tests, nor those
1129 # beginning with a dot
1130 if ($_ eq 't' || $_ =~ /^\../) {
1131 $File::Find::prune = 1;
1132 }
1133 return;
1134 }
1135
1136 return if $_ =~ /^\./; # No hidden Unix files
1137 return if $_ =~ $non_pods;
1138
1139 my $filename = $File::Find::name;
1140
1141 # Assumes that the path separator is exactly one character.
1142 $filename =~ s/^\..//;
1143
b3fdb838 1144 return if $excluded_files{canonicalize($filename)};
16384ac1 1145
144a708b
NC
1146 my $contents = do {
1147 local $/;
763df156
KW
1148 my $candidate;
1149 if (! open $candidate, '<:bytes', $_) {
1150
77b8b9ad
KW
1151 # If a transitory file was found earlier, the open could fail
1152 # legitimately and we just skip the file; also skip it if it is a
1153 # broken symbolic link, as it is probably just a build problem;
1154 # certainly not a file that we would want to check the pod of.
1155 # Otherwise fail it here and no reason to process it further.
1156 # (But the test count will be off too)
1157 ok(0, "Can't open '$filename': $!")
1158 if -e $filename && ! -l $filename;
763df156
KW
1159 return;
1160 }
144a708b
NC
1161 <$candidate>;
1162 };
16384ac1
KW
1163
1164 # If the file is a .pm or .pod, having any initial '=' on a line is
1165 # grounds for testing it. Otherwise, require a head1 NAME line to view it
1166 # as a potential pod
144a708b
NC
1167 if ($filename =~ /\.(?:pm|pod)/) {
1168 return unless $contents =~ /^=/m;
1169 } else {
1170 return unless $contents =~ /^=head1 +NAME/m;
16384ac1 1171 }
144a708b
NC
1172
1173 # Here, we know that the file is a pod. Add it to the list of files
1174 # to check and create a checker object for it.
1175
1176 push @files, $filename;
1177 my $checker = My::Pod::Checker->new($filename);
1178 $filename_to_checker{$filename} = $checker;
1179
1180 # In order to detect duplicate pods and only analyze them once, we
1181 # compute checksums for the file, so don't have to do an exact
1182 # compare. Note that if the pod is just part of the file, the
1183 # checksums can differ for the same pod. That special case is handled
1184 # later, since if the checksums of the whole file are the same, that
1185 # case won't even come up. We don't need the checksums for files that
1186 # we parse only if there is a link to its interior, but we do need its
1187 # NAME, which is also retrieved in the code below.
1188
1189 if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
1190 | $only_for_interior_links_re
1191 /x) {
1192 $digest->add($contents);
1193 $digests{$filename} = $digest->digest;
1194
1195 # lib files aren't analyzed if they are duplicates of files copied
1196 # there from some other directory. But to determine this, we need
1197 # to know their NAMEs. We might as well find the NAME now while
1198 # the file is open. Similarly, cpan files aren't analyzed unless
1199 # we're analyzing all of them, or this particular file is linked
1200 # to by a file we are analyzing, and thus we will want to verify
1201 # that the target exists in it. We need to know at least the NAME
1202 # to see if it's worth analyzing, or so we can determine if a lib
1203 # file is a copy of a cpan one.
1204 if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
16384ac1 1205 | $only_for_interior_links_re
144a708b
NC
1206 }x) {
1207 if ($contents =~ /^=head1 +NAME.*/mg) {
1208 # The NAME is the first non-spaces on the line up to a
1209 # comma, dash or end of line. Otherwise, it's invalid and
1210 # this pod doesn't have a legal name that we're smart
1211 # enough to find currently. But the parser will later
1212 # find it if it thinks there is a legal name, and set the
1213 # name
1214 if ($contents =~ /\G # continue from the line after =head1
1215 \s* # ignore any empty lines
1216 ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
1217 my $name = $1;
1218 $checker->name($name);
1219 $id_to_checker{$name} = $checker
1220 if $filename =~ m{^cpan/};
16384ac1
KW
1221 }
1222 }
144a708b
NC
1223 elsif ($filename =~ m{^cpan/}) {
1224 $id_to_checker{$digests{$filename}} = $checker;
1225 }
16384ac1
KW
1226 }
1227 }
c1dcaaab
KW
1228
1229 return;
16384ac1
KW
1230} # End of is_pod_file()
1231
477100f8
KW
1232# Start of real code that isn't processing the command line (except the
1233# db is read in above, as is processing of the --add_link option).
16384ac1
KW
1234# Here, @files contains list of files on the command line. If have any of
1235# these, unconditionally test them, and show all the errors, even the known
1236# ones, and, since not testing other pods, don't do cross-pod link tests.
1237# (Could add extra code to do cross-pod tests for the ones in the list.)
477100f8 1238
16384ac1
KW
1239if ($has_input_files) {
1240 undef %known_problems;
d9e2eb4b
KW
1241 $do_upstream_cpan = $do_deltas = 1; # In case one of the inputs is one
1242 # of these types
16384ac1
KW
1243}
1244else { # No input files -- go find all the possibilities.
1245 if ($regen) {
1246 $copy_fh = open_new($known_issues);
1247 note("Regenerating $known_issues, please be patient...");
e57d740c 1248 print $copy_fh $HEADER;
16384ac1
KW
1249 }
1250
1251 # Move to the directory above us, but have to adjust @INC to account for
1252 # that.
1253 s{^\.\./lib$}{lib} for @INC;
1254 chdir File::Spec->updir;
1255
1256 # And look in this directory and all its subdirectories
1257 find( \&is_pod_file, '.');
1258
1259 # Add ourselves to the test
b3fdb838 1260 push @files, "t/porting/podcheck.t";
16384ac1
KW
1261}
1262
1263# Now we know how many tests there will be.
1264plan (tests => scalar @files) if ! $regen;
1265
1266
1267 # Sort file names so we get consistent results, and to put cpan last,
1268 # preceeded by the ones that we don't generally parse. This is because both
1269 # these classes are generally parsed only if there is a link to the interior
1270 # of them, and we have to parse all others first to guarantee that they don't
1271 # have such a link. 'lib' files come just before these, as some of these are
1272 # duplicates of others. We already have figured this out when gathering the
1273 # data as a special case for all such files, but this, while unnecessary,
1274 # puts the derived file last in the output. 'readme' files come before those,
1275 # as those also could be duplicates of others, which are considered the
1276 # primary ones. These currently aren't figured out when gathering data, so
1277 # are done here.
1278 @files = sort { if ($a =~ /^cpan/) {
1279 return 1 if $b !~ /^cpan/;
1280 return $a cmp $b;
1281 }
1282 elsif ($b =~ /^cpan/) {
1283 return -1;
1284 }
1285 elsif ($a =~ /$only_for_interior_links_re/) {
1286 return 1 if $b !~ /$only_for_interior_links_re/;
1287 return $a cmp $b;
1288 }
1289 elsif ($b =~ /$only_for_interior_links_re/) {
1290 return -1;
1291 }
1292 elsif ($a =~ /^lib/) {
1293 return 1 if $b !~ /^lib/;
1294 return $a cmp $b;
1295 }
1296 elsif ($b =~ /^lib/) {
1297 return -1;
1298 } elsif ($a =~ /\breadme\b/i) {
1299 return 1 if $b !~ /\breadme\b/i;
1300 return $a cmp $b;
1301 }
1302 elsif ($b =~ /\breadme\b/i) {
1303 return -1;
1304 }
1305 else {
1306 return lc $a cmp lc $b;
1307 }
1308 }
1309 @files;
1310
1311# Now go through all the files and parse them
1312foreach my $filename (@files) {
1313 my $parsed = 0;
1314 note("parsing $filename") if DEBUG;
1315
1316 # We may have already figured out some things in the process of generating
1317 # the file list. If so, have a $checker object already. But if not,
1318 # generate one now.
1319 my $checker = $filename_to_checker{$filename};
1320 if (! $checker) {
1321 $checker = My::Pod::Checker->new($filename);
1322 $filename_to_checker{$filename} = $checker;
1323 }
1324
1325 # We have set the name in the checker object if there is a possibility
1326 # that no further parsing is necessary, but otherwise do the parsing now.
1327 if (! $checker->name) {
1328 $parsed = 1;
1329 $checker->parse_from_file($filename, undef);
1330 }
1331
1332 if ($checker->num_errors() < 0) { # Returns negative if not a pod
1333 $checker->set_skip("$filename is not a pod");
1334 }
1335 else {
1336
1337 # Here, is a pod. See if it is one that has already been tested,
1338 # or should be tested under another directory. Use either its NAME
1339 # if it has one, or a checksum if not.
1340 my $name = $checker->name;
1341 my $id;
1342
1343 if ($name) {
1344 $id = $name;
1345 }
1346 else {
1347 my $digest = Digest->new($digest_type);
1348 $digest->add(extract_pod($filename));
1349 $id = $digest->digest;
1350 }
1351
1352 # If there is a match for this pod with something that we've already
1353 # processed, don't process it, and output why.
1354 my $prior_checker;
1355 if (defined ($prior_checker = $id_to_checker{$id})
1356 && $prior_checker != $checker) # Could have defined the checker
1357 # earlier without pursuing it
1358 {
1359
1360 # If the pods are identical, then it's just a copy, and isn't an
1361 # error. First use the checksums we have already computed to see
1362 # if the entire files are identical, which means that the pods are
1363 # identical too.
1364 my $prior_filename = $prior_checker->get_filename;
1365 my $same = (! $name
1366 || ($digests{$prior_filename}
1367 && $digests{$filename}
1368 && $digests{$prior_filename} eq $digests{$filename}));
1369
1370 # If they differ, it could be that the files differ for some
1371 # reason, but the pods they contain are identical. Extract the
1372 # pods and do the comparisons on just those.
1373 if (! $same && $name) {
1374 $same = extract_pod($prior_filename) eq extract_pod($filename);
1375 }
1376
1377 if ($same) {
1378 $checker->set_skip("The pod of $filename is a duplicate of "
1379 . "the pod for $prior_filename");
1380 } elsif ($prior_filename =~ /\breadme\b/i) {
1381 $checker->set_skip("$prior_filename is a README apparently for $filename");
1382 } elsif ($filename =~ /\breadme\b/i) {
1383 $checker->set_skip("$filename is a README apparently for $prior_filename");
ef906498
KW
1384 } elsif (! $do_upstream_cpan && $filename =~ /^cpan/) {
1385 $checker->set_skip("CPAN is upstream for $filename");
16384ac1
KW
1386 } else { # Here have two pods with identical names that differ
1387 $prior_checker->poderror(
1388 { -msg => $duplicate_name,
1389 -line => "???",
1390 parameter => "'$filename' also has NAME '$name'"
1391 });
1392 $checker->poderror(
1393 { -msg => $duplicate_name,
1394 -line => "???",
1395 parameter => "'$prior_filename' also has NAME '$name'"
1396 });
1397
1398 # Changing the names helps later.
1399 $prior_checker->name("$name version arbitrarily numbered 1");
1400 $checker->name("$name version arbitrarily numbered 2");
1401 }
1402
1403 # In any event, don't process this pod that has the same name as
1404 # another.
1405 next;
1406 }
1407
1408 # A unique pod.
1409 $id_to_checker{$id} = $checker;
1410
1411 my $parsed_for_links = ", but parsed for its interior links";
1412 if ((! $do_upstream_cpan && $filename =~ /^cpan/)
1413 || $filename =~ $only_for_interior_links_re)
1414 {
1415 if ($filename =~ /^cpan/) {
1416 $checker->set_skip("CPAN is upstream for $filename");
1417 }
d9e2eb4b 1418 elsif ($filename =~ /perl\d+delta/ && ! $do_deltas) {
16384ac1
KW
1419 $checker->set_skip("$filename is a stable perldelta");
1420 }
0496e0bb
KW
1421 elsif ($filename =~ /perltoc/) {
1422 $checker->set_skip("$filename dependent on component pods");
1423 }
16384ac1
KW
1424 else {
1425 croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
1426 }
1427
1428 if ($name && $has_referred_to_node{$name}) {
1429 $checker->set_skip($checker->get_skip() . $parsed_for_links);
1430 }
1431 }
1432
1433 # Need a name in order to process it, because not meaningful
1434 # otherwise, and also can't test links to this without a name.
1435 if (!defined $name) {
1436 $checker->poderror( { -msg => $no_name,
1437 -line => '???'
1438 });
1439 next;
1440 }
1441
1442 # For skipped files, just get its NAME
1443 my $skip;
1444 if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
1445 {
1446 $checker->node($name) if $name;
1447 }
1448 else {
1449 $checker->parse_from_file($filename, undef) if ! $parsed;
1450 }
1451
1452 # Go through everything in the file that could be an anchor that
1453 # could be a link target. Count how many there are of the same name.
1454 foreach my $node ($checker->linkable_nodes) {
1455 next if ! $node; # Can be empty is like '=item *'
1456 if (exists $nodes{$name}{$node}) {
1457 $nodes{$name}{$node}++;
1458 }
1459 else {
1460 $nodes{$name}{$node} = 1;
1461 }
1462
1463 # Experiments have shown that cpan search can figure out the
1464 # target of a link even if the exact wording is incorrect, as long
1465 # as the first word is. This happens frequently in perlfunc.pod,
1466 # where the link will be just to the function, but the target
1467 # entry also includes parameters to the function.
1468 my $first_word = $node;
1469 if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
1470 $nodes_first_word{$name}{$first_word} = $node;
1471 }
1472 }
1473 $filename_to_pod{$filename} = $name;
1474 }
1475}
1476
1477# Here, all files have been parsed, and all links and link targets are stored.
1478# Now go through the files again and see which don't have matches.
1479if (! $has_input_files) {
1480 foreach my $filename (@files) {
1481 next if $filename_to_checker{$filename}->get_skip;
1482 my $checker = $filename_to_checker{$filename};
1483 foreach my $link ($checker->hyperlink) {
1484 my $linked_to_page = $link->[1]->page;
1485 next unless $linked_to_page; # intra-file checks are handled by std
1486 # Pod::Checker
1487
1488 # Initialize the potential message.
1489 my %problem = ( -msg => $broken_link,
1490 -line => $link->[0],
1491 parameter => "to \"$linked_to_page\"",
1492 );
1493
1494 # See if we have found the linked-to_file in our parse
1495 if (exists $nodes{$linked_to_page}) {
1496 my $node = $link->[1]->node;
1497
1498 # If link is only to the page-level, already have it
1499 next if ! $node;
1500
1501 # Transform pod language to what we are expecting
1502 $node =~ s,E<sol>,/,g;
1503 $node =~ s/E<verbar>/|/g;
1504
1505 # If link is to a node that exists in the file, is ok
1506 if ($nodes{$linked_to_page}{$node}) {
1507
1508 # But if the page has multiple targets with the same name,
1509 # it's ambiguous which one this should be to.
1510 if ($nodes{$linked_to_page}{$node} > 1) {
1511 $problem{-msg} = $multiple_targets;
1512 $problem{parameter} = "in $linked_to_page that $node could be pointing to";
1513 $checker->poderror(\%problem);
1514 }
1515 } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
1516
1517 # Here the link target was not found, either exactly or to
1518 # the first word. Is an error.
1519 $problem{parameter} =~ s,"$,/$node",;
1520 $checker->poderror(\%problem);
1521 }
1522
1523 } # Linked-to-file not in parse; maybe is in exception list
1524 elsif (! exists $valid_modules{$link->[1]->page}) {
1525
1526 # Here, is a link to a target that we can't find. Check if
1527 # there is an internal link on the page with the target name.
1528 # If so, it could be that they just forgot the initial '/'
1c01047d
KW
1529 # But perldelta is handled specially: only do this if the
1530 # broken link isn't one of the known bad ones (that are
1531 # placemarkers and should be removed for the final)
1532 my $NAME = $filename_to_pod{$filename};
1533 if (! defined $NAME) {
1534 $checker->poderror(\%problem);
1535 }
02987562 1536 else {
1c01047d
KW
1537 if ($nodes{$NAME}{$linked_to_page}) {
1538 $problem{-msg} = $broken_internal_link;
1539 }
1540 $checker->poderror(\%problem);
16384ac1 1541 }
16384ac1
KW
1542 }
1543 }
1544 }
1545}
1546
1547# If regenerating the data file, start with the modules for which we don't
1548# check targets
1549if ($regen) {
1550 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1551 my_safer_print($copy_fh, $_, "\n");
1552 }
1553}
1554
1555# Now ready to output the messages.
1556foreach my $filename (@files) {
1557 my $test_name = "POD of $filename";
b3fdb838 1558 my $canonical = canonicalize($filename);
16384ac1
KW
1559 SKIP: {
1560 my $skip = $filename_to_checker{$filename}->get_skip // "";
1561
1562 if ($regen) {
1563 foreach my $message ( sort keys %{$problems{$filename}}) {
1564 my $count;
1565
1566 # Preserve a negative setting.
b3fdb838
KW
1567 if ($known_problems{$canonical}{$message}
1568 && $known_problems{$canonical}{$message} < 0)
16384ac1 1569 {
b3fdb838 1570 $count = $known_problems{$canonical}{$message};
16384ac1
KW
1571 }
1572 else {
1573 $count = @{$problems{$filename}{$message}};
1574 }
b3fdb838 1575 my_safer_print($copy_fh, canonicalize($filename) . "\t$message\t$count\n");
16384ac1
KW
1576 }
1577 next;
1578 }
1579
1580 skip($skip, 1) if $skip;
1581 my @diagnostics;
1582 my $indent = ' ';
1583
16384ac1
KW
1584 my $total_known = 0;
1585 foreach my $message ( sort keys %{$problems{$filename}}) {
b3fdb838
KW
1586 $known_problems{$canonical}{$message} = 0
1587 if ! $known_problems{$canonical}{$message};
16384ac1
KW
1588 my $diagnostic = "";
1589 my $problem_count = scalar @{$problems{$filename}{$message}};
1590 $total_known += $problem_count;
b3fdb838
KW
1591 next if $known_problems{$canonical}{$message} < 0;
1592 if ($problem_count > $known_problems{$canonical}{$message}) {
16384ac1
KW
1593
1594 # Here we are about to output all the messages for this type,
1595 # subtract back this number we previously added in.
1596 $total_known -= $problem_count;
1597
1598 $diagnostic .= $indent . $message;
1599 if ($problem_count > 2) {
1600 $diagnostic .= " ($problem_count occurrences)";
1601 }
1602 foreach my $problem (@{$problems{$filename}{$message}}) {
1603 $diagnostic .= " " if $problem_count == 1;
1604 $diagnostic .= "\n$indent$indent";
1605 $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
1606 $diagnostic .= " near line $problem->{-line}";
1607 $diagnostic .= " $problem->{comment}" if $problem->{comment};
1608 }
1609 $diagnostic .= "\n";
1610 $files_with_unknown_issues{$filename} = 1;
b3fdb838
KW
1611 } elsif ($problem_count < $known_problems{$canonical}{$message}) {
1612 $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
16384ac1
KW
1613 }
1614 push @diagnostics, $diagnostic if $diagnostic;
1615 }
1616
09ea063a
KW
1617 # The above loop has output messages where there are current potential
1618 # issues. But it misses where there were some that have been entirely
1619 # fixed. For those, we need to look through the old issues
b3fdb838 1620 foreach my $message ( sort keys %{$known_problems{$canonical}}) {
09ea063a 1621 next if $problems{$filename}{$message};
b3fdb838
KW
1622 next if ! $known_problems{$canonical}{$message};
1623 next if $known_problems{$canonical}{$message} < 0; # Preserve negs
1624 my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
09ea063a
KW
1625 push @diagnostics, $diagnostic if $diagnostic;
1626 }
1627
16384ac1
KW
1628 my $output = "POD of $filename";
1629 $output .= ", excluding $total_known not shown known potential problems"
1630 if $total_known;
1631 ok(@diagnostics == 0, $output);
1632 if (@diagnostics) {
1633 note(join "", @diagnostics,
477100f8 1634 "See end of this test output for your options on silencing this");
16384ac1
KW
1635 }
1636 }
1637}
1638
1639my $how_to = <<EOF;
1640 run this test script by hand, using the following formula (on
1641 Un*x-like machines):
1642 cd t
1643 ./perl -I../lib porting/podcheck.t --regen
1644EOF
1645
1646if (%files_with_unknown_issues) {
1647 my $were_count_files = scalar keys %files_with_unknown_issues;
1648 $were_count_files = ($were_count_files == 1)
1649 ? "was $were_count_files file"
1650 : "were $were_count_files files";
1651 my $message = <<EOF;
1652
1653HOW TO GET THIS .t TO PASS
1654
477100f8 1655There $were_count_files that had new potential problems identified.
968d3762
KW
1656Some of them may be real, and some of them may be false positives, because
1657this program isn't as smart as it likes to think it is. You can teach this
1658program to ignore the issues it has identified, and hence pass, by doing the
477100f8 1659following:
16384ac1 1660
477100f8
KW
16611) If a problem is about a link to an unknown module or man page that
1662 you know exists, re-run the command something like:
1663 ./perl -I../lib porting/podcheck.t --add_link MODULE man_page ...
1664 (MODULEs should look like Foo::Bar, and man_pages should look like
1665 bar(3c); don't do this for a module or man page that you aren't sure
1666 about; instead treat as another type of issue and follow the
1667 instructions below.)
16384ac1
KW
1668
16692) For other issues, decide if each should be fixed now or not. Fix the
1670 ones you decided to, and rerun this test to verify that the fixes
1671 worked.
1672
968d3762
KW
16733) If there remain false positive or problems that you don't plan to fix right
1674 now,
16384ac1 1675$how_to
477100f8
KW
1676 That should cause all current potential problems to be accepted by
1677 the program, so that the next time it runs, they won't be flagged.
16384ac1
KW
1678EOF
1679 if (%files_with_fixes) {
1680 $message .= " This step will also take care of the files that have fixes in them\n";
1681 }
1682
1683 $message .= <<EOF;
1684 For a few files, such as perltoc, certain issues will always be
1685 expected, and more of the same will be added over time. For those,
1686 before you do the regen, you can edit
1687 $known_issues
1688 and find the entry for the module's file and specific error message,
1689 and change the count of known potential problems to -1.
1690EOF
1691
1692 note($message);
1693} elsif (%files_with_fixes) {
1694 note(<<EOF
1695To teach this test script that the potential problems have been fixed,
1696$how_to
1697EOF
1698 );
1699}
1700
1701if ($regen) {
1702 chdir $original_dir || die "Can't change directories to $original_dir";
1703 close_and_rename($copy_fh);
1704}