5 use feature 'unicode_strings';
15 require '../regen/regen_lib.pl';
24 podcheck.t - Look for possible problems in the Perl pods
29 ./perl -I../lib porting/podcheck.t [--show_all] [--cpan] [--counts]
31 ./perl -I../lib porting/podcheck.t --regen
35 podcheck.t is an extension of Pod::Checker. It looks for pod errors and
36 potential errors in the files given as arguments, or if none specified, in all
37 pods in the distribution workspace, except those in the cpan directory (unless
38 C<--cpan> is specified). It does additional checking beyond that done by
39 Pod::Checker, and keeps a database of known potential problems, and will
40 fail a pod only if the number of such problems differs from that given in the
41 database. It also suppresses the C<(section) deprecated> message from
42 Pod::Checker, since specifying the man page section number is quite proper to do.
44 The additional checks it makes are:
48 =item Cross-pod link checking
50 Pod::Checker verifies that links to an internal target in a pod are not
51 broken. podcheck.t extends that (when called without FILE arguments) to
52 external links. It does this by gathering up all the possible targets in the
53 workspace, and cross-checking them. The database has a list of known targets
54 outside the workspace, so podcheck.t will not raise a warning for
55 using those. It also checks that a non-broken link points to just one target.
56 (The destination pod could have two targets with the same name.)
58 =item An internal link that isn't so specified
60 If a link is broken, but there is an existing internal target of the same
61 name, it is likely that the internal target was meant, and the C<"/"> is
62 missing from the C<LE<lt>E<gt>> pod command.
64 =item Verbatim paragraphs that wrap in an 80 column window
66 It's annoying to have lines wrap when displaying pod documentation in a
67 terminal window. This checks that all such lines fit, and for those that
68 don't, it tells you how much needs to be cut in order to fit. However,
69 if you're fixing these, keep in mind that some terminal/pager combinations
70 require really a maximum of 79 or 78 columns to display properly.
72 Often, the easiest thing to do to gain space for these is to lower the indent
75 =item Missing or duplicate NAME or missing NAME short description
77 A pod can't be linked to unless it has a unique name.
78 And a NAME should have a dash and short description after it.
80 =item =encoding statement issues
82 This indicates if an C<=encoding> statement should be present, or moved to the
85 =item Items that perhaps should be links
87 There are mentions of apparent files in the pods that perhaps should be links
88 instead, using C<LE<lt>...E<gt>>
90 =item Items that perhaps should be C<FE<lt>...E<gt>>
92 What look like path names enclosed in C<CE<lt>...E<gt>> should perhaps have
93 C<FE<lt>...E<gt>> mark-up instead.
97 A number of issues raised by podcheck.t and by the base Pod::Checker are not
98 really problems, but merely potential problems. After inspecting them and
99 deciding that they aren't real problems, it is possible to shut up this program
100 about them, unlike base Pod::Checker. To do this, call podcheck.t with the
101 C<--regen> option to regenerate the database. This tells it that all existing
102 issues are to not be mentioned again.
104 This isn't fool-proof. The database merely keeps track of the number of these
105 potential problems of each type for each pod. If a new problem of a given
106 type is introduced into the pod, podcheck.t will spit out all of them. You
107 then have to figure out which is the new one, and should it be changed or not.
108 But doing it this way insulates the database from having to keep track of line
109 numbers of problems, which may change, or the exact wording of each problem
110 which might also change without affecting whether it is a problem or not.
112 Also, if the count of potential problems of a given type for a pod decreases,
113 the database must be regenerated so that it knows the new number. The program
114 gives instructions when this happens.
116 There is currently no check that modules listed as valid in the data base
117 actually are. Thus any errors introduced there will remain there.
125 Regenerate the data base used by podcheck.t to include all the existing
126 potential problems. Future runs of the program will not then flag any of
131 Normally, all pods in the cpan directory are skipped, except to make sure that
132 any blead-upstream links to such pods are valid.
133 This option will cause cpan upstream pods to be checked.
137 Normally, if the number of potential problems of a given type found for a
138 pod matches the expected value in the database, they will not be displayed.
139 This option forces the database to be ignored during the run, so all potential
140 problems are displayed and will fail their respective pod test. Specifying
141 any particular FILES to operate on automatically selects this option.
145 Instead of testing, this just dumps the counts of the occurrences of the
146 various types of potential problems in the data base.
152 The database is stored in F<t/porting/known_pod_issues.dat>
160 #####################################################
161 # HOW IT WORKS (in general)
163 # If not called with specific files to check, the directory structure is
164 # examined for files that have pods in them. Files that might not have to be
165 # fully parsed (e.g. in cpan) are parsed enough at this time to find their
166 # pod's NAME, and to get a checksum.
168 # Those kinds of files are sorted last, but otherwise the pods are parsed with
169 # the package coded here, My::Pod::Checker, which is an extension to
170 # Pod::Checker that adds some tests and suppresses others that aren't
171 # appropriate. The latter module has no provision for capturing diagnostics,
172 # so a package, Tie_Array_to_FH, is used to force them to be placed into an
173 # array instead of printed.
175 # Parsing the files builds up a list of links. The files are gone through
176 # again, doing cross-link checking and outputting all saved-up problems with
179 # Sorting the files last that potentially don't need to be fully parsed allows
180 # us to not parse them unless there is a link to an internal anchor in them
181 # from something that we have already parsed. Keeping checksums allows us to
182 # not parse copies of other pods.
184 #####################################################
186 # 1 => Exclude low priority messages that aren't likely to be problems, and
187 # has many false positives; higher numbers give more messages.
188 my $Warnings_Level = 200;
190 # To see if two pods with the same NAME are actually copies of the same pod,
191 # which is not an error, it uses a checksum to save work.
192 my $digest_type = "SHA-1";
194 my $original_dir = File::Spec->rel2abs(File::Spec->curdir);
195 my $data_dir = File::Spec->catdir($original_dir, 'porting');
196 my $known_issues = File::Spec->catfile($data_dir, 'known_pod_issues.dat');
199 my $MAX_LINE_LENGTH = 80; # 80 columns
200 my $INDENT = 8; # default nroff indent
202 # Our warning messages. Better not have [('"] in them, as those are used as
203 # delimiters for variable parts of the messages by poderror.
204 my $line_length = "Verbatim line length including indents exceeds $MAX_LINE_LENGTH by";
205 my $broken_link = "Apparent broken link";
206 my $broken_internal_link = "Apparent internal link is missing its forward slash";
207 my $see_not_linked = "? Should you be using L<...> instead of";
208 my $C_with_slash = "? Should you be using F<...> or maybe L<...> instead of";
209 my $multiple_targets = "There is more than one target";
210 my $duplicate_name = "Pod NAME already used";
211 my $need_encoding = "Should have =encoding statement because have non-ASCII";
212 my $encoding_first = "=encoding must be first command (if present)";
213 my $no_name = "There is no NAME";
214 my $missing_name_description = "The NAME should have a dash and short description after it";
216 # objects, tests, etc can't be pods, so don't look for them. Also skip
217 # files output by the patch program. Could also ignore most of .gitignore
218 # files, but not all, so don't.
219 my $non_pods = qr/ (?: \.
220 (?: [achot] | zip | gz | bz2 | jar | tar | tgz | PL | so
221 | orig | rej | patch # Patch program output
222 | sw[op] | \#.* # Editor droppings
225 ) | ~$ # Another editor dropping
229 # Pod::Checker messages to suppress
230 my @suppressed_messages = (
231 "(section) in", # Checker is wrong to flag this
232 "multiple occurrence of link target", # We catch independently the ones
233 # that are real problems.
238 # Returns bool as to if input message is one that is to be suppressed
241 return grep { $message =~ /^\Q$_/i } @suppressed_messages;
244 { # Closure to contain a simple subset of test.pl. This is to get rid of the
245 # unnecessary 'failed at' messages that would otherwise be output pointing
246 # to a particular line in this file.
248 my $current_test = 0;
253 $planned = $plan{tests};
254 print "1..$planned\n";
265 print "not " unless $success;
266 print "ok $current_test - $message\n";
272 my $n = @_ ? shift : 1;
275 print "ok $current_test # skip $why\n";
277 no warnings 'exiting';
286 print $message =~ s/^/# /mgr;
292 if ($planned && $planned != $current_test) {
294 "# Looks like you planned $planned tests but ran $current_test.\n";
299 # This is to get this to work across multiple file systems, including those
300 # that are not case sensitive. The db is stored in lower case, Un*x style,
301 # and all file name comparisons are done that way.
302 sub canonicalize($) {
304 my ($volume, $directories, $file)
305 = File::Spec->splitpath(File::Spec->canonpath($input));
306 # Assumes $volume is constant for everything in this directory structure
307 $directories = "" if ! $directories;
308 $file = "" if ! $file;
309 my $output = lc join '/', File::Spec->splitdir($directories), $file;
310 $output =~ s! / /+ !/!gx; # Multiple slashes => single slash
315 # List of known potential problems by pod and type.
318 # Pods given by the keys contain an interior node that is referred to from
320 my %has_referred_to_node;
326 # Assume that are to skip anything in /cpan
327 my $do_upstream_cpan = 0;
329 while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
330 my $arg = shift @ARGV;
332 $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
333 if ($arg eq '-regen') {
336 elsif ($arg eq '-cpan') {
337 $do_upstream_cpan = 1;
339 elsif ($arg eq '-show_all') {
342 elsif ($arg eq '-counts') {
347 Unknown option '$arg'
349 Usage: $0 [ --regen | --cpan | --show_all ] [ FILE ... ]\n"
350 --cpan -> Include files in the cpan subdirectory.
351 --regen -> Regenerate the data file for $0
352 --show_all -> Show all known potential problems
353 --counts -> Don't test, but give summary counts of the currently
361 if (($regen + $show_all + $show_counts + $do_upstream_cpan) > 1) {
362 croak "--regen, --show_all, --cpan, and --counts are mutually exclusive";
365 my $has_input_files = @files;
367 if ($has_input_files && ($regen || $show_counts || $do_upstream_cpan)) {
368 croak "--regen, --counts and --cpan can't be used since using specific files";
371 our %problems; # potential problems found in this run
373 package My::Pod::Checker { # Extend Pod::Checker
374 use parent 'Pod::Checker';
376 # Uses inside out hash to protect from typos
377 # For new fields, remember to add to destructor DESTROY()
378 my %indents; # Stack of indents from =over's in effect for
380 my %current_indent; # Current line's indent
381 my %filename; # The pod is store in this file
382 my %skip; # is SKIP set for this pod
383 my %in_NAME; # true if within NAME section
384 my %in_begin; # true if within =begin section
385 my %linkable_item; # Bool: if the latest =item is linkable. It isn't
386 # for bullet and number lists
387 my %linkable_nodes; # Pod::Checker adds all =items to its node list,
388 # but not all =items are linkable to
389 my %seen_encoding_cmd; # true if have =encoding earlier
390 my %command_count; # Number of commands seen
391 my %seen_pod_cmd; # true if have =pod earlier
392 my %warned_encoding; # true if already have warned about =encoding
396 my $addr = Scalar::Util::refaddr $_[0];
397 delete $command_count{$addr};
398 delete $current_indent{$addr};
399 delete $filename{$addr};
400 delete $in_begin{$addr};
401 delete $indents{$addr};
402 delete $in_NAME{$addr};
403 delete $linkable_item{$addr};
404 delete $linkable_nodes{$addr};
405 delete $seen_encoding_cmd{$addr};
406 delete $seen_pod_cmd{$addr};
408 delete $warned_encoding{$addr};
414 my $filename = shift;
416 my $self = $class->SUPER::new(-quiet => 1,
417 -warnings => $Warnings_Level);
418 my $addr = Scalar::Util::refaddr $self;
419 $command_count{$addr} = 0;
420 $current_indent{$addr} = 0;
421 $filename{$addr} = $filename;
422 $in_begin{$addr} = 0;
424 $linkable_item{$addr} = 0;
425 $seen_encoding_cmd{$addr} = 0;
426 $seen_pod_cmd{$addr} = 0;
427 $warned_encoding{$addr} = 0;
431 # re's for messages that Pod::Checker outputs
432 my $location = qr/ \b (?:in|at|on|near) \s+ /xi;
433 my $optional_location = qr/ (?: $location )? /xi;
434 my $line_reference = qr/ [('"]? $optional_location \b line \s+
435 (?: \d+ | EOF | \Q???\E | - )
438 sub poderror { # Called to register a potential problem
440 # This adds an extra field to the parent hash, 'parameter'. It is
441 # used to extract the variable parts of a message leaving just the
442 # constant skeleton. This in turn allows the message to be
443 # categorized better, so that it shows up as a single type in our
444 # database, with the specifics of each occurrence not being stored with
450 my $addr = Scalar::Util::refaddr $self;
451 return if $skip{$addr};
453 # Input can be a string or hash. If a string, parse it to separate
454 # out the line number and convert to a hash for easier further
457 if (ref $opts ne 'HASH') {
458 $message = join "", $opts, @_;
460 if ($message =~ s/\s*($line_reference)//) {
461 ($line_number = $1) =~ s/\s*$optional_location//;
464 $line_number = '???';
466 $opts = { -msg => $message, -line => $line_number };
468 $message = $opts->{'-msg'};
472 $message =~ s/^\d+\s+//;
473 return if main::suppressed($message);
475 $self->SUPER::poderror($opts, @_);
477 $opts->{parameter} = "" unless $opts->{parameter};
479 # The variable parts of the message tend to be enclosed in '...',
480 # "....", or (...). Extract them and put them in an extra field,
481 # 'parameter'. This is trickier because the matching delimiter to a
482 # '(' is its mirror, and not itself. Text::Balanced could be used
484 while ($message =~ m/ \s* $optional_location ( [('"] )/xg) {
487 $delimiter = ')' if $delimiter eq '(';
489 # If there is no ending delimiter, don't consider it to be a
490 # variable part. Most likely it is a contraction like "Don't"
491 last unless $message =~ m/\G .+? \Q$delimiter/xg;
493 my $length = $+[0] - $start;
495 # Get the part up through the closing delimiter
496 my $special = substr($message, $start, $length);
497 $special =~ s/^\s+//; # No leading whitespace
499 # And add that variable part to the parameter, while removing it
500 # from the message. This isn't a foolproof way of finding the
501 # variable part. For example '(s)' can occur in e.g.,
503 if ($special ne '(s)') {
504 substr($message, $start, $length) = "";
505 pos $message = $start;
506 $opts->{-msg} = $message;
507 $opts->{parameter} .= " " if $opts->{parameter};
508 $opts->{parameter} .= $special;
512 # Extract any additional line number given. This is often the
513 # beginning location of something whereas the main line number gives
515 if ($message =~ /( $line_reference )/xi) {
517 while ($message =~ s/\s*\Q$line_ref//) {
518 $opts->{-msg} = $message;
519 $opts->{parameter} .= " " if $opts->{parameter};
520 $opts->{parameter} .= $line_ref;
524 Carp::carp("Couldn't extract line number from '$message'") if $message =~ /line \d+/;
525 push @{$problems{$filename{$addr}}{$message}}, $opts;
526 #push @{$problems{$self->get_filename}{$message}}, $opts;
529 sub check_encoding { # Does it need an =encoding statement?
530 my ($self, $paragraph, $line_num, $pod_para) = @_;
532 # Do nothing if there is an =encoding in the file, or if the line
533 # doesn't require an =encoding, or have already warned.
534 my $addr = Scalar::Util::refaddr $self;
535 return if $seen_encoding_cmd{$addr}
536 || $warned_encoding{$addr}
537 || $paragraph !~ /\P{ASCII}/;
539 $warned_encoding{$addr} = 1;
540 my ($file, $line) = $pod_para->file_line;
541 $self->poderror({ -line => $line, -file => $file,
542 -msg => $need_encoding
548 my ($self, $paragraph, $line_num, $pod_para) = @_;
549 $self->check_encoding($paragraph, $line_num, $pod_para);
551 $self->SUPER::verbatim($paragraph, $line_num, $pod_para);
553 my $addr = Scalar::Util::refaddr $self;
555 # Pick up the name, since the parent class doesn't in verbatim
556 # NAMEs; so treat as non-verbatim. The parent class only allows one
557 # paragraph in a NAME section, so if there is an extra blank line, it
558 # will trigger a message, but such a blank line is harmless, so skip
560 if ($in_NAME{$addr} && $paragraph =~ /\S/) {
561 $self->textblock($paragraph, $line_num, $pod_para);
564 my @lines = split /^/, $paragraph;
565 for my $i (0 .. @lines - 1) {
566 if ( my $encoding = $seen_encoding_cmd{$addr} ) {
568 $lines[$i] = Encode::decode($encoding, $lines[$i]);
570 $lines[$i] =~ s/\s+$//;
571 my $indent = $self->get_current_indent;
572 my $exceeds = length(Text::Tabs::expand($lines[$i]))
573 + $indent - $MAX_LINE_LENGTH;
574 next unless $exceeds > 0;
575 my ($file, $line) = $pod_para->file_line;
576 $self->poderror({ -line => $line + $i, -file => $file,
577 -msg => $line_length,
578 parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
584 my ($self, $paragraph, $line_num, $pod_para) = @_;
585 $self->check_encoding($paragraph, $line_num, $pod_para);
587 $self->SUPER::textblock($paragraph, $line_num, $pod_para);
589 my ($file, $line) = $pod_para->file_line;
590 my $addr = Scalar::Util::refaddr $self;
591 if ($in_NAME{$addr}) {
593 my $text = $self->interpolate($paragraph, $line_num);
594 if ($text =~ /^\s*(\S+?)\s*$/) {
596 $self->poderror({ -line => $line, -file => $file,
597 -msg => $missing_name_description,
602 $paragraph = join " ", split /^/, $paragraph;
604 # Matches something that looks like a file name, but is enclosed in
606 my $C_path_re = qr{ \b ( C<
607 # exclude regexes and 'OS/2'
608 (?! (?: (?: s | qr | m) / ) | OS/2 > )
609 \w+ (?: / \w+ )+ > (?: \. \w+ )? )
612 # If looks like a reference to other documentation by containing the
613 # word 'See' and then a likely pod directive, warn.
615 while ($paragraph =~ m{ \b See \s+ ( ( [^L] ) <
616 ( [^<]*? ) # The not-< excludes nested C<L<...
621 if ($interior !~ /$non_pods/
622 && $construct !~ /$C_path_re/g) {
623 $self->poderror({ -line => $line, -file => $file,
624 -msg => $see_not_linked,
625 parameter => $construct
629 while ($paragraph =~ m/$C_path_re/g) {
631 $self->poderror({ -line => $line, -file => $file,
632 -msg => $C_with_slash,
633 parameter => $construct
640 my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
641 my $addr = Scalar::Util::refaddr $self;
643 $seen_pod_cmd{$addr}++;
645 elsif ($cmd eq "encoding") {
646 my ($file, $line) = $pod_para->file_line;
647 $seen_encoding_cmd{$addr} = $paragraph; # for later decoding
648 if ($command_count{$addr} != 1 && $seen_pod_cmd{$addr}) {
649 $self->poderror({ -line => $line, -file => $file,
650 -msg => $encoding_first
654 $self->check_encoding($paragraph, $line_num, $pod_para);
656 # Pod::Check treats all =items as linkable, but the bullet and
657 # numbered lists really aren't. So keep our own list. This has to be
658 # processed before SUPER is called so that the list is started before
659 # the rest of it gets parsed.
660 if ($cmd eq 'item') { # Not linkable if item begins with * or a digit
661 $linkable_item{$addr} = ($paragraph !~ / ^ \s*
663 | \d+ \.? (?: \$ | \s+ )
669 $self->SUPER::command($cmd, $paragraph, $line_num, $pod_para);
671 $command_count{$addr}++;
673 $in_NAME{$addr} = 0; # Will change to 1 below if necessary
674 $in_begin{$addr} = 0; # ibid
675 if ($cmd eq 'over') {
676 my $text = $self->interpolate($paragraph, $line_num);
677 my $indent = 4; # default
678 $indent = $1 if $text && $text =~ /^\s*(\d+)\s*$/;
679 push @{$indents{$addr}}, $indent;
680 $current_indent{$addr} += $indent;
682 elsif ($cmd eq 'back') {
683 if (@{$indents{$addr}}) {
684 $current_indent{$addr} -= pop @{$indents{$addr}};
687 # =back without corresponding =over, but should have
689 $current_indent{$addr} = 0;
692 elsif ($cmd =~ /^head/) {
693 if (! $in_begin{$addr}) {
695 # If a particular formatter, then this command doesn't really
697 $current_indent{$addr} = 0;
698 undef @{$indents{$addr}};
701 my $text = $self->interpolate($paragraph, $line_num);
702 $in_NAME{$addr} = 1 if $cmd eq 'head1'
703 && $text && $text =~ /^NAME\b/;
705 elsif ($cmd eq 'begin') {
706 $in_begin{$addr} = 1;
715 # If the hyperlink is to an interior node of another page, save it
716 # so that we can see if we need to parse normally skipped files.
717 $has_referred_to_node{$_[0][1]{'-page'}} = 1
718 if $_[0] && $_[0][1]{'-page'} && $_[0][1]{'-node'};
719 return $self->SUPER::hyperlink($_[0]);
726 $text =~ s/\s+$//s; # strip trailing whitespace
727 $text =~ s/\s+/ /gs; # collapse whitespace
728 my $addr = Scalar::Util::refaddr $self;
729 push(@{$linkable_nodes{$addr}}, $text) if
730 ! $current_indent{$addr}
731 || $linkable_item{$addr};
733 return $self->SUPER::node($_[0]);
736 sub get_current_indent {
737 return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
741 return $filename{Scalar::Util::refaddr $_[0]};
745 my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
746 return undef unless $linkables;
751 return $skip{Scalar::Util::refaddr $_[0]} // 0;
756 $skip{Scalar::Util::refaddr $self} = shift;
758 # If skipping, no need to keep the problems for it
759 delete $problems{$self->get_filename};
764 package Tie_Array_to_FH { # So printing actually goes to an array
770 my $array_ref = shift;
772 my $self = bless \do{ my $anonymous_scalar }, $class;
773 $array{Scalar::Util::refaddr $self} = $array_ref;
780 push @{$array{Scalar::Util::refaddr $self}}, @_;
786 my %filename_to_checker; # Map a filename to it's pod checker object
787 my %id_to_checker; # Map a checksum to it's pod checker object
788 my %nodes; # key is filename, values are nodes in that file.
789 my %nodes_first_word; # same, but value is first word of each node
790 my %valid_modules; # List of modules known to exist outside us.
791 my %digests; # checksums of files, whose names are the keys
792 my %filename_to_pod; # Map a filename to its pod NAME
793 my %files_with_unknown_issues;
794 my %files_with_fixes;
797 open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
799 my %counts; # For --counts param, count of each issue type
800 my %suppressed_files; # Files with at least one issue type to suppress
802 while (<$data_fh>) { # Read the data base
804 next if /^\s*(?:#|$)/; # Skip comment and empty lines
808 # Keep track of counts of each issue type for each file
809 my ($filename, $message, $count) = split /\t/;
810 $known_problems{$filename}{$message} = $count;
813 if ($count < 0) { # -1 means to suppress this issue type
814 $suppressed_files{$filename} = $filename;
817 $counts{$message} += $count;
821 else { # Lines without a tab are modules known to be valid
822 $valid_modules{$_} = 1
829 foreach my $message (sort keys %counts) {
830 $total += $counts{$message};
831 note(Text::Tabs::expand("$counts{$message}\t$message"));
833 note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
834 if (%suppressed_files) {
835 note("\nFiles that have all messages of at least one type suppressed:");
836 note(join ",", keys %suppressed_files);
842 my %excluded_files = (
843 "lib/unicore/mktables" => 1,
844 "Porting/perldelta_template.pod" => 1,
850 # It would be nice if we didn't have to skip this,
851 # but the errors in it are too variable.
852 "pod/perltoc.pod" => 1,
855 # Convert to more generic form.
856 foreach my $file (keys %excluded_files) {
857 $excluded_files{canonicalize($excluded_files{$file})}
858 = $excluded_files{$file};
861 # re to match files that are to be parsed only if there is an internal link
862 # to them. It does not include cpan, as whether those are parsed depends
863 # on a switch. Currently, only the stable perldelta.pod's are included.
864 # These all have characters between 'perl' and 'delta'. (Actually the
865 # currently developed one matches as well, but is a duplicate of
866 # perldelta.pod, so can be skipped, so fine for it to match this.
867 my $only_for_interior_links_re = qr/ \b perl \d+ delta \. pod \b/x;
872 sub output_thanks ($$$$) { # Called when an issue has been fixed
873 my $filename = shift;
874 my $original_count = shift;
875 my $current_count = shift;
878 $files_with_fixes{$filename} = 1;
880 my $fixed_count = $original_count - $current_count;
881 my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
882 my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
886 There were $original_count occurrences (now $current_count) in this pod of type
891 There are no longer any problems found in this pod!
898 Thanks for fixing $a_problem!
900 Now you must teach $0 that this was fixed.
905 Thanks for fixing $another_problem.
914 sub my_safer_print { # print, with error checking for outputting to db
915 my ($fh, @lines) = @_;
917 if (! print $fh @lines) {
920 die "Write failure: $save_error";
924 sub extract_pod { # Extracts just the pod from a file
925 my $filename = shift;
929 # Arrange for the output of Pod::Parser to be collected in an array we can
930 # look at instead of being printed
931 tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
932 open my $in_fh, '<:bytes', $filename
934 # The file should already have been opened once to get here, so if
935 # fails, just die. It's possible that a transitory file containing a
936 # pod would get here, but not bothering to add code for that very
938 or die "Can't open '$filename': $!\n";
940 my $parser = Pod::Parser->new();
941 $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
947 my $digest = Digest->new($digest_type);
950 # If $_ is a pod file, add it to the lists and do other prep work.
953 # Don't look at files in directories that are for tests, nor those
954 # beginning with a dot
955 if ($_ eq 't' || $_ =~ /^\../) {
956 $File::Find::prune = 1;
961 return if $_ =~ /^\./; # No hidden Unix files
962 return if $_ =~ $non_pods;
964 my $filename = $File::Find::name;
966 # Assumes that the path separator is exactly one character.
967 $filename =~ s/^\..//;
969 return if $excluded_files{canonicalize($filename)};
974 if (! open $candidate, '<:bytes', $_) {
976 # If a transitory file was found earlier, the open could fail
977 # legitimately and we just skip the file; also skip it if it is a
978 # broken symbolic link, as it is probably just a build problem;
979 # certainly not a file that we would want to check the pod of.
980 # Otherwise fail it here and no reason to process it further.
981 # (But the test count will be off too)
982 ok(0, "Can't open '$filename': $!")
983 if -e $filename && ! -l $filename;
989 # If the file is a .pm or .pod, having any initial '=' on a line is
990 # grounds for testing it. Otherwise, require a head1 NAME line to view it
992 if ($filename =~ /\.(?:pm|pod)/) {
993 return unless $contents =~ /^=/m;
995 return unless $contents =~ /^=head1 +NAME/m;
998 # Here, we know that the file is a pod. Add it to the list of files
999 # to check and create a checker object for it.
1001 push @files, $filename;
1002 my $checker = My::Pod::Checker->new($filename);
1003 $filename_to_checker{$filename} = $checker;
1005 # In order to detect duplicate pods and only analyze them once, we
1006 # compute checksums for the file, so don't have to do an exact
1007 # compare. Note that if the pod is just part of the file, the
1008 # checksums can differ for the same pod. That special case is handled
1009 # later, since if the checksums of the whole file are the same, that
1010 # case won't even come up. We don't need the checksums for files that
1011 # we parse only if there is a link to its interior, but we do need its
1012 # NAME, which is also retrieved in the code below.
1014 if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
1015 | $only_for_interior_links_re
1017 $digest->add($contents);
1018 $digests{$filename} = $digest->digest;
1020 # lib files aren't analyzed if they are duplicates of files copied
1021 # there from some other directory. But to determine this, we need
1022 # to know their NAMEs. We might as well find the NAME now while
1023 # the file is open. Similarly, cpan files aren't analyzed unless
1024 # we're analyzing all of them, or this particular file is linked
1025 # to by a file we are analyzing, and thus we will want to verify
1026 # that the target exists in it. We need to know at least the NAME
1027 # to see if it's worth analyzing, or so we can determine if a lib
1028 # file is a copy of a cpan one.
1029 if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
1030 | $only_for_interior_links_re
1032 if ($contents =~ /^=head1 +NAME.*/mg) {
1033 # The NAME is the first non-spaces on the line up to a
1034 # comma, dash or end of line. Otherwise, it's invalid and
1035 # this pod doesn't have a legal name that we're smart
1036 # enough to find currently. But the parser will later
1037 # find it if it thinks there is a legal name, and set the
1039 if ($contents =~ /\G # continue from the line after =head1
1040 \s* # ignore any empty lines
1041 ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
1043 $checker->name($name);
1044 $id_to_checker{$name} = $checker
1045 if $filename =~ m{^cpan/};
1048 elsif ($filename =~ m{^cpan/}) {
1049 $id_to_checker{$digests{$filename}} = $checker;
1055 } # End of is_pod_file()
1057 # Start of real code that isn't processing the command line.
1058 # Here, @files contains list of files on the command line. If have any of
1059 # these, unconditionally test them, and show all the errors, even the known
1060 # ones, and, since not testing other pods, don't do cross-pod link tests.
1061 # (Could add extra code to do cross-pod tests for the ones in the list.)
1062 if ($has_input_files) {
1063 undef %known_problems;
1064 $do_upstream_cpan = 1; # In case one of the inputs is from cpan
1067 else { # No input files -- go find all the possibilities.
1069 $copy_fh = open_new($known_issues);
1070 note("Regenerating $known_issues, please be patient...");
1071 print $copy_fh <<END;
1072 # This file is the data file for $0.
1073 # There are three types of lines.
1074 # Comment lines are white-space only or begin with a '#', like this one. Any
1075 # changes you make to the comment lines will be lost when the file is
1077 # Lines without tab characters are simply NAMES of pods that the program knows
1078 # will have links to them and the program does not check if those links are
1080 # All other lines should have three fields, each separated by a tab. The
1081 # first field is the name of a pod; the second field is an error message
1082 # generated by this program; and the third field is a count of how many
1083 # known instances of that message there are in the pod. -1 means that the
1084 # program can expect any number of this type of message.
1088 # Move to the directory above us, but have to adjust @INC to account for
1090 s{^\.\./lib$}{lib} for @INC;
1091 chdir File::Spec->updir;
1093 # And look in this directory and all its subdirectories
1094 find( \&is_pod_file, '.');
1096 # Add ourselves to the test
1097 push @files, "t/porting/podcheck.t";
1100 # Now we know how many tests there will be.
1101 plan (tests => scalar @files) if ! $regen;
1104 # Sort file names so we get consistent results, and to put cpan last,
1105 # preceeded by the ones that we don't generally parse. This is because both
1106 # these classes are generally parsed only if there is a link to the interior
1107 # of them, and we have to parse all others first to guarantee that they don't
1108 # have such a link. 'lib' files come just before these, as some of these are
1109 # duplicates of others. We already have figured this out when gathering the
1110 # data as a special case for all such files, but this, while unnecessary,
1111 # puts the derived file last in the output. 'readme' files come before those,
1112 # as those also could be duplicates of others, which are considered the
1113 # primary ones. These currently aren't figured out when gathering data, so
1115 @files = sort { if ($a =~ /^cpan/) {
1116 return 1 if $b !~ /^cpan/;
1119 elsif ($b =~ /^cpan/) {
1122 elsif ($a =~ /$only_for_interior_links_re/) {
1123 return 1 if $b !~ /$only_for_interior_links_re/;
1126 elsif ($b =~ /$only_for_interior_links_re/) {
1129 elsif ($a =~ /^lib/) {
1130 return 1 if $b !~ /^lib/;
1133 elsif ($b =~ /^lib/) {
1135 } elsif ($a =~ /\breadme\b/i) {
1136 return 1 if $b !~ /\breadme\b/i;
1139 elsif ($b =~ /\breadme\b/i) {
1143 return lc $a cmp lc $b;
1148 # Now go through all the files and parse them
1149 foreach my $filename (@files) {
1151 note("parsing $filename") if DEBUG;
1153 # We may have already figured out some things in the process of generating
1154 # the file list. If so, have a $checker object already. But if not,
1156 my $checker = $filename_to_checker{$filename};
1158 $checker = My::Pod::Checker->new($filename);
1159 $filename_to_checker{$filename} = $checker;
1162 # We have set the name in the checker object if there is a possibility
1163 # that no further parsing is necessary, but otherwise do the parsing now.
1164 if (! $checker->name) {
1166 $checker->parse_from_file($filename, undef);
1169 if ($checker->num_errors() < 0) { # Returns negative if not a pod
1170 $checker->set_skip("$filename is not a pod");
1174 # Here, is a pod. See if it is one that has already been tested,
1175 # or should be tested under another directory. Use either its NAME
1176 # if it has one, or a checksum if not.
1177 my $name = $checker->name;
1184 my $digest = Digest->new($digest_type);
1185 $digest->add(extract_pod($filename));
1186 $id = $digest->digest;
1189 # If there is a match for this pod with something that we've already
1190 # processed, don't process it, and output why.
1192 if (defined ($prior_checker = $id_to_checker{$id})
1193 && $prior_checker != $checker) # Could have defined the checker
1194 # earlier without pursuing it
1197 # If the pods are identical, then it's just a copy, and isn't an
1198 # error. First use the checksums we have already computed to see
1199 # if the entire files are identical, which means that the pods are
1201 my $prior_filename = $prior_checker->get_filename;
1203 || ($digests{$prior_filename}
1204 && $digests{$filename}
1205 && $digests{$prior_filename} eq $digests{$filename}));
1207 # If they differ, it could be that the files differ for some
1208 # reason, but the pods they contain are identical. Extract the
1209 # pods and do the comparisons on just those.
1210 if (! $same && $name) {
1211 $same = extract_pod($prior_filename) eq extract_pod($filename);
1215 $checker->set_skip("The pod of $filename is a duplicate of "
1216 . "the pod for $prior_filename");
1217 } elsif ($prior_filename =~ /\breadme\b/i) {
1218 $checker->set_skip("$prior_filename is a README apparently for $filename");
1219 } elsif ($filename =~ /\breadme\b/i) {
1220 $checker->set_skip("$filename is a README apparently for $prior_filename");
1221 } else { # Here have two pods with identical names that differ
1222 $prior_checker->poderror(
1223 { -msg => $duplicate_name,
1225 parameter => "'$filename' also has NAME '$name'"
1228 { -msg => $duplicate_name,
1230 parameter => "'$prior_filename' also has NAME '$name'"
1233 # Changing the names helps later.
1234 $prior_checker->name("$name version arbitrarily numbered 1");
1235 $checker->name("$name version arbitrarily numbered 2");
1238 # In any event, don't process this pod that has the same name as
1244 $id_to_checker{$id} = $checker;
1246 my $parsed_for_links = ", but parsed for its interior links";
1247 if ((! $do_upstream_cpan && $filename =~ /^cpan/)
1248 || $filename =~ $only_for_interior_links_re)
1250 if ($filename =~ /^cpan/) {
1251 $checker->set_skip("CPAN is upstream for $filename");
1253 elsif ($filename =~ /perl\d+delta/) {
1254 $checker->set_skip("$filename is a stable perldelta");
1257 croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
1260 if ($name && $has_referred_to_node{$name}) {
1261 $checker->set_skip($checker->get_skip() . $parsed_for_links);
1265 # Need a name in order to process it, because not meaningful
1266 # otherwise, and also can't test links to this without a name.
1267 if (!defined $name) {
1268 $checker->poderror( { -msg => $no_name,
1274 # For skipped files, just get its NAME
1276 if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
1278 $checker->node($name) if $name;
1281 $checker->parse_from_file($filename, undef) if ! $parsed;
1284 # Go through everything in the file that could be an anchor that
1285 # could be a link target. Count how many there are of the same name.
1286 foreach my $node ($checker->linkable_nodes) {
1287 next if ! $node; # Can be empty is like '=item *'
1288 if (exists $nodes{$name}{$node}) {
1289 $nodes{$name}{$node}++;
1292 $nodes{$name}{$node} = 1;
1295 # Experiments have shown that cpan search can figure out the
1296 # target of a link even if the exact wording is incorrect, as long
1297 # as the first word is. This happens frequently in perlfunc.pod,
1298 # where the link will be just to the function, but the target
1299 # entry also includes parameters to the function.
1300 my $first_word = $node;
1301 if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
1302 $nodes_first_word{$name}{$first_word} = $node;
1305 $filename_to_pod{$filename} = $name;
1309 # Here, all files have been parsed, and all links and link targets are stored.
1310 # Now go through the files again and see which don't have matches.
1311 if (! $has_input_files) {
1312 foreach my $filename (@files) {
1313 next if $filename_to_checker{$filename}->get_skip;
1314 my $checker = $filename_to_checker{$filename};
1315 foreach my $link ($checker->hyperlink) {
1316 my $linked_to_page = $link->[1]->page;
1317 next unless $linked_to_page; # intra-file checks are handled by std
1320 # Initialize the potential message.
1321 my %problem = ( -msg => $broken_link,
1322 -line => $link->[0],
1323 parameter => "to \"$linked_to_page\"",
1326 # See if we have found the linked-to_file in our parse
1327 if (exists $nodes{$linked_to_page}) {
1328 my $node = $link->[1]->node;
1330 # If link is only to the page-level, already have it
1333 # Transform pod language to what we are expecting
1334 $node =~ s,E<sol>,/,g;
1335 $node =~ s/E<verbar>/|/g;
1337 # If link is to a node that exists in the file, is ok
1338 if ($nodes{$linked_to_page}{$node}) {
1340 # But if the page has multiple targets with the same name,
1341 # it's ambiguous which one this should be to.
1342 if ($nodes{$linked_to_page}{$node} > 1) {
1343 $problem{-msg} = $multiple_targets;
1344 $problem{parameter} = "in $linked_to_page that $node could be pointing to";
1345 $checker->poderror(\%problem);
1347 } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
1349 # Here the link target was not found, either exactly or to
1350 # the first word. Is an error.
1351 $problem{parameter} =~ s,"$,/$node",;
1352 $checker->poderror(\%problem);
1355 } # Linked-to-file not in parse; maybe is in exception list
1356 elsif (! exists $valid_modules{$link->[1]->page}) {
1358 # Here, is a link to a target that we can't find. Check if
1359 # there is an internal link on the page with the target name.
1360 # If so, it could be that they just forgot the initial '/'
1361 if ($filename_to_pod{$filename}
1362 && $nodes{$filename_to_pod{$filename}}{$linked_to_page})
1364 $problem{-msg} = $broken_internal_link;
1366 $checker->poderror(\%problem);
1372 # If regenerating the data file, start with the modules for which we don't
1375 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1376 my_safer_print($copy_fh, $_, "\n");
1380 # Now ready to output the messages.
1381 foreach my $filename (@files) {
1382 my $test_name = "POD of $filename";
1383 my $canonical = canonicalize($filename);
1385 my $skip = $filename_to_checker{$filename}->get_skip // "";
1388 foreach my $message ( sort keys %{$problems{$filename}}) {
1391 # Preserve a negative setting.
1392 if ($known_problems{$canonical}{$message}
1393 && $known_problems{$canonical}{$message} < 0)
1395 $count = $known_problems{$canonical}{$message};
1398 $count = @{$problems{$filename}{$message}};
1400 my_safer_print($copy_fh, canonicalize($filename) . "\t$message\t$count\n");
1405 skip($skip, 1) if $skip;
1409 my $total_known = 0;
1410 foreach my $message ( sort keys %{$problems{$filename}}) {
1411 $known_problems{$canonical}{$message} = 0
1412 if ! $known_problems{$canonical}{$message};
1413 my $diagnostic = "";
1414 my $problem_count = scalar @{$problems{$filename}{$message}};
1415 $total_known += $problem_count;
1416 next if $known_problems{$canonical}{$message} < 0;
1417 if ($problem_count > $known_problems{$canonical}{$message}) {
1419 # Here we are about to output all the messages for this type,
1420 # subtract back this number we previously added in.
1421 $total_known -= $problem_count;
1423 $diagnostic .= $indent . $message;
1424 if ($problem_count > 2) {
1425 $diagnostic .= " ($problem_count occurrences)";
1427 foreach my $problem (@{$problems{$filename}{$message}}) {
1428 $diagnostic .= " " if $problem_count == 1;
1429 $diagnostic .= "\n$indent$indent";
1430 $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
1431 $diagnostic .= " near line $problem->{-line}";
1432 $diagnostic .= " $problem->{comment}" if $problem->{comment};
1434 $diagnostic .= "\n";
1435 $files_with_unknown_issues{$filename} = 1;
1436 } elsif ($problem_count < $known_problems{$canonical}{$message}) {
1437 $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
1439 push @diagnostics, $diagnostic if $diagnostic;
1442 # The above loop has output messages where there are current potential
1443 # issues. But it misses where there were some that have been entirely
1444 # fixed. For those, we need to look through the old issues
1445 foreach my $message ( sort keys %{$known_problems{$canonical}}) {
1446 next if $problems{$filename}{$message};
1447 next if ! $known_problems{$canonical}{$message};
1448 next if $known_problems{$canonical}{$message} < 0; # Preserve negs
1449 my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
1450 push @diagnostics, $diagnostic if $diagnostic;
1453 my $output = "POD of $filename";
1454 $output .= ", excluding $total_known not shown known potential problems"
1456 ok(@diagnostics == 0, $output);
1458 note(join "", @diagnostics,
1459 "See end of this test output for your options");
1465 run this test script by hand, using the following formula (on
1466 Un*x-like machines):
1468 ./perl -I../lib porting/podcheck.t --regen
1471 if (%files_with_unknown_issues) {
1472 my $were_count_files = scalar keys %files_with_unknown_issues;
1473 $were_count_files = ($were_count_files == 1)
1474 ? "was $were_count_files file"
1475 : "were $were_count_files files";
1476 my $message = <<EOF;
1478 HOW TO GET THIS .t TO PASS
1480 There $were_count_files that had new potential problems identified. To get
1481 this .t to pass, do the following:
1483 1) If a problem is about a link to an unknown module that you know exists,
1484 simply edit the file,
1486 and add anywhere a line that contains just the module's name.
1487 (Don't do this for a module that you aren't sure about; instead treat
1488 as another type of issue and follow the instructions below.)
1490 2) For other issues, decide if each should be fixed now or not. Fix the
1491 ones you decided to, and rerun this test to verify that the fixes
1494 3) If there remain potential problems that you don't plan to fix right
1495 now (or aren't really problems),
1497 That should cause all current potential problems to be accepted by the
1498 program, so that the next time it runs, they won't be flagged.
1500 if (%files_with_fixes) {
1501 $message .= " This step will also take care of the files that have fixes in them\n";
1505 For a few files, such as perltoc, certain issues will always be
1506 expected, and more of the same will be added over time. For those,
1507 before you do the regen, you can edit
1509 and find the entry for the module's file and specific error message,
1510 and change the count of known potential problems to -1.
1514 } elsif (%files_with_fixes) {
1516 To teach this test script that the potential problems have been fixed,
1523 chdir $original_dir || die "Can't change directories to $original_dir";
1524 close_and_rename($copy_fh);