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