5 unshift @INC, "../lib";
10 use feature 'unicode_strings';
21 require '../regen/regen_lib.pl';
30 podcheck.t - Look for possible problems in the Perl pods
35 ./perl -I../lib porting/podcheck.t [--show_all] [--cpan] [--deltas]
36 [--counts] [ FILE ...]
37 ./perl -I../lib porting/podcheck.t --add_link MODULE ...
39 ./perl -I../lib porting/podcheck.t --regen
43 podcheck.t is an extension of Pod::Checker. It looks for pod errors and
44 potential errors in the files given as arguments, or if none specified, in all
45 pods in the distribution workspace, except certain known special ones
46 (specified below). It does additional checking beyond that done by
47 Pod::Checker, and keeps a database of known potential problems, and will
48 fail a pod only if the number of such problems differs from that given in the
49 database. It also suppresses the C<(section) deprecated> message from
50 Pod::Checker, since specifying the man page section number is quite proper to do.
52 The additional checks it makes are:
56 =item Cross-pod link checking
58 Pod::Checker verifies that links to an internal target in a pod are not
59 broken. podcheck.t extends that (when called without FILE arguments) to
60 external links. It does this by gathering up all the possible targets in the
61 workspace, and cross-checking them. It also checks that a non-broken link
62 points to just one target. (The destination pod could have two targets with
65 The way that the C<LE<lt>E<gt>> pod command works (for links outside the pod)
66 is to actually create a link to C<search.cpan.org> with an embedded query for
67 the desired pod or man page. That means that links outside the distribution
68 are valid. podcheck.t doesn't verify the validity of such links, but instead
69 keeps a data base of those known to be valid. This means that if a link to a
70 target not on the list is created, the target needs to be added to the data
71 base. This is accomplished via the L<--add_link|/--add_link MODULE ...>
72 option to podcheck.t, described below.
74 =item An internal link that isn't so specified
76 If a link is broken, but there is an existing internal target of the same
77 name, it is likely that the internal target was meant, and the C<"/"> is
78 missing from the C<LE<lt>E<gt>> pod command.
80 =item Verbatim paragraphs that wrap in an 80 (including 1 spare) column window
82 It's annoying to have lines wrap when displaying pod documentation in a
83 terminal window. This checks that all verbatim lines fit in a standard 80
84 column window, even when using a pager that reserves a column for its own use.
85 (Thus the check is for a net of 79 columns.)
86 For those lines that don't fit, it tells you how much needs to be cut in
89 Often, the easiest thing to do to gain space for these is to lower the indent
92 =item Missing or duplicate NAME or missing NAME short description
94 A pod can't be linked to unless it has a unique name.
95 And a NAME should have a dash and short description after it.
97 =item =encoding statement issues
99 This indicates if an C<=encoding> statement should be present, or moved to the
102 =item Items that perhaps should be links
104 There are mentions of apparent files in the pods that perhaps should be links
105 instead, using C<LE<lt>...E<gt>>
107 =item Items that perhaps should be C<FE<lt>...E<gt>>
109 What look like path names enclosed in C<CE<lt>...E<gt>> should perhaps have
110 C<FE<lt>...E<gt>> mark-up instead.
114 A number of issues raised by podcheck.t and by the base Pod::Checker are not
115 really problems, but merely potential problems, that is, false positives.
116 After inspecting them and
117 deciding that they aren't real problems, it is possible to shut up this program
118 about them, unlike base Pod::Checker. For a valid link to an outside module
119 or man page, call podcheck.t with the C<--add_link> option to add it to the
120 the database of known links; for other causes, call podcheck.t with the C<--regen>
121 option to regenerate the entire database. This tells it that all existing
122 issues are to not be mentioned again.
124 C<--regen> isn't fool-proof. The database merely keeps track of the number of these
125 potential problems of each type for each pod. If a new problem of a given
126 type is introduced into the pod, podcheck.t will spit out all of them. You
127 then have to figure out which is the new one, and should it be changed or not.
128 But doing it this way insulates the database from having to keep track of line
129 numbers of problems, which may change, or the exact wording of each problem
130 which might also change without affecting whether it is a problem or not.
132 Also, if the count of potential problems of a given type for a pod decreases,
133 the database must be regenerated so that it knows the new number. The program
134 gives instructions when this happens.
136 Some pods will have varying numbers of problems of a given type. This can
137 be handled by manually editing the database file (see L</FILES>), and setting
138 the number of those problems for that pod to a negative number. This will
139 cause the corresponding error to always be suppressed no matter how many there
142 Another problem is that there is currently no check that modules listed as
143 valid in the data base
144 actually are. Thus any errors introduced there will remain there.
146 =head2 Specially handled pods
152 This pod is generated by pasting bits from other pods. Errors in those bits
153 will show up as errors here, as well as for those other pods. Therefore
154 errors here are suppressed, and the pod is checked only to verify that nodes
155 within it actually exist that are externally linked to.
159 The current perldelta pod is initialized from a template that contains
160 placeholder text. Some of this text is in the form of links that don't really
161 exist. Any such links that are listed in C<@perldelta_ignore_links> will not
162 generate messages. It is presumed that these links will be cleaned up when
163 the perldelta is cleaned up for release since they should be marked with
166 =item Porting/perldelta_template.pod
168 This is not a pod, but a template for C<perldelta>. Any errors introduced
169 here will show up when C<perldelta> is created from it.
171 =item cpan-upstream pods
173 See the L</--cpan> option documentation
177 See the L</--deltas> option documentation
185 =item --add_link MODULE ...
187 Use this option to teach podcheck.t that the C<MODULE>s or man pages actually
188 exist, and to silence any messages that links to them are broken.
190 podcheck.t checks that links within the Perl core distribution are valid, but
191 it doesn't check links to man pages or external modules. When it finds
192 a broken link, it checks its data base of external modules and man pages,
193 and only if not found there does it raise a message. This option just adds
194 the list of modules and man page references that follow it on the command line
200 ./perl -I../lib porting/podcheck.t --add_link Unicode::Casing
202 causes the external module "Unicode::Casing" to be added to the data base, so
203 C<LE<lt>Unicode::Casing<gt>> will be considered valid.
207 Regenerate the data base used by podcheck.t to include all the existing
208 potential problems. Future runs of the program will not then flag any of
213 Normally, all pods in the cpan directory are skipped, except to make sure that
214 any blead-upstream links to such pods are valid.
215 This option will cause cpan upstream pods to be fully checked.
219 Normally, all old perldelta pods are skipped, except to make sure that
220 any links to such pods are valid. This is because they are considered
221 stable, and perhaps trying to fix them will cause changes that will
222 misrepresent Perl's history. But, this option will cause them to be fully
227 Normally, if the number of potential problems of a given type found for a
228 pod matches the expected value in the database, they will not be displayed.
229 This option forces the database to be ignored during the run, so all potential
230 problems are displayed and will fail their respective pod test. Specifying
231 any particular FILES to operate on automatically selects this option.
235 Instead of testing, this just dumps the counts of the occurrences of the
236 various types of potential problems in the data base.
242 The database is stored in F<t/porting/known_pod_issues.dat>
250 #####################################################
251 # HOW IT WORKS (in general)
253 # If not called with specific files to check, the directory structure is
254 # examined for files that have pods in them. Files that might not have to be
255 # fully parsed (e.g. in cpan) are parsed enough at this time to find their
256 # pod's NAME, and to get a checksum.
258 # Those kinds of files are sorted last, but otherwise the pods are parsed with
259 # the package coded here, My::Pod::Checker, which is an extension to
260 # Pod::Checker that adds some tests and suppresses others that aren't
261 # appropriate. The latter module has no provision for capturing diagnostics,
262 # so a package, Tie_Array_to_FH, is used to force them to be placed into an
263 # array instead of printed.
265 # Parsing the files builds up a list of links. The files are gone through
266 # again, doing cross-link checking and outputting all saved-up problems with
269 # Sorting the files last that potentially don't need to be fully parsed allows
270 # us to not parse them unless there is a link to an internal anchor in them
271 # from something that we have already parsed. Keeping checksums allows us to
272 # not parse copies of other pods.
274 #####################################################
276 # 1 => Exclude low priority messages that aren't likely to be problems, and
277 # has many false positives; higher numbers give more messages.
278 my $Warnings_Level = 200;
280 # perldelta during construction may have place holder links. N.B. This
281 # variable is referred to by name in release_managers_guide.pod
282 our @perldelta_ignore_links = ( "XXX", "perl5YYYdelta", "perldiag/message" );
284 # To see if two pods with the same NAME are actually copies of the same pod,
285 # which is not an error, it uses a checksum to save work.
286 my $digest_type = "SHA-1";
288 my $original_dir = File::Spec->rel2abs(File::Spec->curdir);
289 my $data_dir = File::Spec->catdir($original_dir, 'porting');
290 my $known_issues = File::Spec->catfile($data_dir, 'known_pod_issues.dat');
293 my $MAX_LINE_LENGTH = 79; # 79 columns
294 my $INDENT = 7; # default nroff indent
296 # Our warning messages. Better not have [('"] in them, as those are used as
297 # delimiters for variable parts of the messages by poderror.
298 my $line_length = "Verbatim line length including indents exceeds $MAX_LINE_LENGTH by";
299 my $broken_link = "Apparent broken link";
300 my $broken_internal_link = "Apparent internal link is missing its forward slash";
301 my $see_not_linked = "? Should you be using L<...> instead of";
302 my $C_with_slash = "? Should you be using F<...> or maybe L<...> instead of";
303 my $multiple_targets = "There is more than one target";
304 my $duplicate_name = "Pod NAME already used";
305 my $need_encoding = "Should have =encoding statement because have non-ASCII";
306 my $encoding_first = "=encoding must be first command (if present)";
307 my $no_name = "There is no NAME";
308 my $missing_name_description = "The NAME should have a dash and short description after it";
310 # objects, tests, etc can't be pods, so don't look for them. Also skip
311 # files output by the patch program. Could also ignore most of .gitignore
312 # files, but not all, so don't.
314 my $obj_ext = $Config{'obj_ext'}; $obj_ext =~ tr/.//d; # dot will be added back
315 my $lib_ext = $Config{'lib_ext'}; $lib_ext =~ tr/.//d;
316 my $lib_so = $Config{'so'}; $lib_so =~ tr/.//d;
317 my $dl_ext = $Config{'dlext'}; $dl_ext =~ tr/.//d;
319 # This list should not include anything for which case sensitivity is
320 # important, as it won't work on VMS, and won't show up until tested on VMS.
321 # Instead is_pod_file() can be used to exclude these at a finer grained
323 my $non_pods = qr/ (?: \.
324 (?: [achot] | zip | gz | bz2 | jar | tar | tgz
325 | orig | rej | patch # Patch program output
326 | sw[op] | \#.* # Editor droppings
327 | old # buildtoc output
328 | xs # pod should be in the .pm file
329 | al # autosplit files
330 | bs # bootstrap files
331 | (?i:sh) # shell scripts, hints, templates
332 | lst # assorted listing files
333 | bat # Windows,Netware,OS2 batch files
334 | cmd # Windows,Netware,OS2 command files
335 | lis # VMS compiler listings
336 | map # VMS linker maps
337 | opt # VMS linker options files
338 | mms # MM(K|S) description files
339 | ts # timestamp files generated during build
340 | $obj_ext # object files
341 | exe # $Config{'exe_ext'} might be empty string
342 | $lib_ext # object libraries
343 | $lib_so # shared libraries
344 | $dl_ext # dynamic libraries
347 ) | ~$ | \ \(Autosaved\)\.txt$ # Other editor droppings
348 | ^cxx\$demangler_db\.$ # VMS name mangler database
349 | ^typemap\.?$ # typemap files
350 | ^(?i:Makefile\.PL)$
354 # Pod::Checker messages to suppress
355 my @suppressed_messages = (
356 "(section) in", # Checker is wrong to flag this
357 "multiple occurrence of link target", # We catch independently the ones
358 # that are real problems.
360 "Entity number out of range", # Checker outputs this for anything above
361 # 255, but in fact all Unicode is valid
365 # Returns bool as to if input message is one that is to be suppressed
368 return grep { $message =~ /^\Q$_/i } @suppressed_messages;
371 { # Closure to contain a simple subset of test.pl. This is to get rid of the
372 # unnecessary 'failed at' messages that would otherwise be output pointing
373 # to a particular line in this file.
375 my $current_test = 0;
380 $planned = $plan{tests};
381 print "1..$planned\n";
392 print "not " unless $success;
393 print "ok $current_test - $message\n";
399 my $n = @_ ? shift : 1;
402 print "ok $current_test # skip $why\n";
404 no warnings 'exiting';
413 print $message =~ s/^/# /mgr;
419 if ($planned && $planned != $current_test) {
421 "# Looks like you planned $planned tests but ran $current_test.\n";
426 # This is to get this to work across multiple file systems, including those
427 # that are not case sensitive. The db is stored in lower case, Un*x style,
428 # and all file name comparisons are done that way.
429 sub canonicalize($) {
431 my ($volume, $directories, $file)
432 = File::Spec->splitpath(File::Spec->canonpath($input));
433 # Assumes $volume is constant for everything in this directory structure
434 $directories = "" if ! $directories;
435 $file = "" if ! $file;
436 $file =~ s/\.$// if $^O eq 'VMS';
437 my $output = lc join '/', File::Spec->splitdir($directories), $file;
438 $output =~ s! / /+ !/!gx; # Multiple slashes => single slash
443 # List of known potential problems by pod and type.
446 # Pods given by the keys contain an interior node that is referred to from
448 my %has_referred_to_node;
455 my $do_upstream_cpan = 0; # Assume that are to skip anything in /cpan
456 my $do_deltas = 0; # And stable perldeltas
458 while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
459 my $arg = shift @ARGV;
461 $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
462 if ($arg eq '-regen') {
465 elsif ($arg eq '-add_link') {
468 elsif ($arg eq '-cpan') {
469 $do_upstream_cpan = 1;
471 elsif ($arg eq '-deltas') {
474 elsif ($arg eq '-show_all') {
477 elsif ($arg eq '-counts') {
482 Unknown option '$arg'
484 Usage: $0 [ --regen | --cpan | --show_all | FILE ... | --add_link MODULE ... ]\n"
485 --add_link -> Add the MODULE and man page references to the data base
486 --regen -> Regenerate the data file for $0
487 --cpan -> Include files in the cpan subdirectory.
488 --deltas -> Include stable perldeltas
489 --show_all -> Show all known potential problems
490 --counts -> Don't test, but give summary counts of the currently
498 my $cpan_or_deltas = $do_upstream_cpan || $do_deltas;
499 if (($regen + $show_all + $show_counts + $add_link + $cpan_or_deltas ) > 1) {
500 croak "--regen, --show_all, --counts, and --add_link are mutually exclusive\n and none can be run with --cpan nor --deltas";
503 my $has_input_files = @files;
506 && ($regen || $show_counts || $do_upstream_cpan || $do_deltas))
508 croak "--regen, --counts, --deltas, and --cpan can't be used since using specific files";
511 if ($add_link && ! $has_input_files) {
512 croak "--add_link requires at least one module or man page reference";
515 our %problems; # potential problems found in this run
517 package My::Pod::Checker { # Extend Pod::Checker
518 use parent 'Pod::Checker';
520 # Uses inside out hash to protect from typos
521 # For new fields, remember to add to destructor DESTROY()
522 my %indents; # Stack of indents from =over's in effect for
524 my %current_indent; # Current line's indent
525 my %filename; # The pod is store in this file
526 my %skip; # is SKIP set for this pod
527 my %in_NAME; # true if within NAME section
528 my %in_begin; # true if within =begin section
529 my %linkable_item; # Bool: if the latest =item is linkable. It isn't
530 # for bullet and number lists
531 my %linkable_nodes; # Pod::Checker adds all =items to its node list,
532 # but not all =items are linkable to
533 my %seen_encoding_cmd; # true if have =encoding earlier
534 my %command_count; # Number of commands seen
535 my %seen_pod_cmd; # true if have =pod earlier
536 my %warned_encoding; # true if already have warned about =encoding
540 my $addr = Scalar::Util::refaddr $_[0];
541 delete $command_count{$addr};
542 delete $current_indent{$addr};
543 delete $filename{$addr};
544 delete $in_begin{$addr};
545 delete $indents{$addr};
546 delete $in_NAME{$addr};
547 delete $linkable_item{$addr};
548 delete $linkable_nodes{$addr};
549 delete $seen_encoding_cmd{$addr};
550 delete $seen_pod_cmd{$addr};
552 delete $warned_encoding{$addr};
558 my $filename = shift;
560 my $self = $class->SUPER::new(-quiet => 1,
561 -warnings => $Warnings_Level);
562 my $addr = Scalar::Util::refaddr $self;
563 $command_count{$addr} = 0;
564 $current_indent{$addr} = 0;
565 $filename{$addr} = $filename;
566 $in_begin{$addr} = 0;
568 $linkable_item{$addr} = 0;
569 $seen_encoding_cmd{$addr} = 0;
570 $seen_pod_cmd{$addr} = 0;
571 $warned_encoding{$addr} = 0;
575 # re's for messages that Pod::Checker outputs
576 my $location = qr/ \b (?:in|at|on|near) \s+ /xi;
577 my $optional_location = qr/ (?: $location )? /xi;
578 my $line_reference = qr/ [('"]? $optional_location \b line \s+
579 (?: \d+ | EOF | \Q???\E | - )
582 sub poderror { # Called to register a potential problem
584 # This adds an extra field to the parent hash, 'parameter'. It is
585 # used to extract the variable parts of a message leaving just the
586 # constant skeleton. This in turn allows the message to be
587 # categorized better, so that it shows up as a single type in our
588 # database, with the specifics of each occurrence not being stored with
594 my $addr = Scalar::Util::refaddr $self;
595 return if $skip{$addr};
597 # Input can be a string or hash. If a string, parse it to separate
598 # out the line number and convert to a hash for easier further
601 if (ref $opts ne 'HASH') {
602 $message = join "", $opts, @_;
604 if ($message =~ s/\s*($line_reference)//) {
605 ($line_number = $1) =~ s/\s*$optional_location//;
608 $line_number = '???';
610 $opts = { -msg => $message, -line => $line_number };
612 $message = $opts->{'-msg'};
616 $message =~ s/^\d+\s+//;
617 return if main::suppressed($message);
619 $self->SUPER::poderror($opts, @_);
621 $opts->{parameter} = "" unless $opts->{parameter};
623 # The variable parts of the message tend to be enclosed in '...',
624 # "....", or (...). Extract them and put them in an extra field,
625 # 'parameter'. This is trickier because the matching delimiter to a
626 # '(' is its mirror, and not itself. Text::Balanced could be used
628 while ($message =~ m/ \s* $optional_location ( [('"] )/xg) {
631 $delimiter = ')' if $delimiter eq '(';
633 # If there is no ending delimiter, don't consider it to be a
634 # variable part. Most likely it is a contraction like "Don't"
635 last unless $message =~ m/\G .+? \Q$delimiter/xg;
637 my $length = $+[0] - $start;
639 # Get the part up through the closing delimiter
640 my $special = substr($message, $start, $length);
641 $special =~ s/^\s+//; # No leading whitespace
643 # And add that variable part to the parameter, while removing it
644 # from the message. This isn't a foolproof way of finding the
645 # variable part. For example '(s)' can occur in e.g.,
647 if ($special ne '(s)') {
648 substr($message, $start, $length) = "";
649 pos $message = $start;
650 $opts->{-msg} = $message;
651 $opts->{parameter} .= " " if $opts->{parameter};
652 $opts->{parameter} .= $special;
656 # Extract any additional line number given. This is often the
657 # beginning location of something whereas the main line number gives
659 if ($message =~ /( $line_reference )/xi) {
661 while ($message =~ s/\s*\Q$line_ref//) {
662 $opts->{-msg} = $message;
663 $opts->{parameter} .= " " if $opts->{parameter};
664 $opts->{parameter} .= $line_ref;
668 Carp::carp("Couldn't extract line number from '$message'") if $message =~ /line \d+/;
669 push @{$problems{$filename{$addr}}{$message}}, $opts;
670 #push @{$problems{$self->get_filename}{$message}}, $opts;
673 sub check_encoding { # Does it need an =encoding statement?
674 my ($self, $paragraph, $line_num, $pod_para) = @_;
676 # Do nothing if there is an =encoding in the file, or if the line
677 # doesn't require an =encoding, or have already warned.
678 my $addr = Scalar::Util::refaddr $self;
679 return if $seen_encoding_cmd{$addr}
680 || $warned_encoding{$addr}
681 || $paragraph !~ /\P{ASCII}/;
683 $warned_encoding{$addr} = 1;
684 my ($file, $line) = $pod_para->file_line;
685 $self->poderror({ -line => $line, -file => $file,
686 -msg => $need_encoding
692 my ($self, $paragraph, $line_num, $pod_para) = @_;
693 $self->check_encoding($paragraph, $line_num, $pod_para);
695 $self->SUPER::verbatim($paragraph, $line_num, $pod_para);
697 my $addr = Scalar::Util::refaddr $self;
699 # Pick up the name, since the parent class doesn't in verbatim
700 # NAMEs; so treat as non-verbatim. The parent class only allows one
701 # paragraph in a NAME section, so if there is an extra blank line, it
702 # will trigger a message, but such a blank line is harmless, so skip
704 if ($in_NAME{$addr} && $paragraph =~ /\S/) {
705 $self->textblock($paragraph, $line_num, $pod_para);
708 my @lines = split /^/, $paragraph;
709 for my $i (0 .. @lines - 1) {
710 if ( my $encoding = $seen_encoding_cmd{$addr} ) {
712 $lines[$i] = Encode::decode($encoding, $lines[$i]);
714 $lines[$i] =~ s/\s+$//;
715 my $indent = $self->get_current_indent;
716 my $exceeds = length(Text::Tabs::expand($lines[$i]))
717 + $indent - $MAX_LINE_LENGTH;
718 next unless $exceeds > 0;
719 my ($file, $line) = $pod_para->file_line;
720 $self->poderror({ -line => $line + $i, -file => $file,
721 -msg => $line_length,
722 parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
728 my ($self, $paragraph, $line_num, $pod_para) = @_;
729 $self->check_encoding($paragraph, $line_num, $pod_para);
731 $self->SUPER::textblock($paragraph, $line_num, $pod_para);
733 my ($file, $line) = $pod_para->file_line;
734 my $addr = Scalar::Util::refaddr $self;
735 if ($in_NAME{$addr}) {
737 my $text = $self->interpolate($paragraph, $line_num);
738 if ($text =~ /^\s*(\S+?)\s*$/) {
740 $self->poderror({ -line => $line, -file => $file,
741 -msg => $missing_name_description,
746 $paragraph = join " ", split /^/, $paragraph;
748 # Matches something that looks like a file name, but is enclosed in
750 my $C_path_re = qr{ \b ( C<
751 # exclude various things that have slashes
752 # in them but aren't paths
754 (?: (?: s | qr | m) / ) # regexes
755 | \d+/\d+> # probable fractions
760 | - # File names don't begin with "-"
762 [-\w]+ (?: / [-\w]+ )+ (?: \. \w+ )? > )
765 # If looks like a reference to other documentation by containing the
766 # word 'See' and then a likely pod directive, warn.
767 while ($paragraph =~ m{
768 ( (?: \w+ \s+ )* ) # The phrase before, if any
772 ( [^<]*? ) # The not < excludes nested C<L<...
775 ( \s+ (?: under | in ) \s+ L< )?
777 my $prefix = $1 // "";
778 my $construct = $2; # The whole thing, like C<...>
781 my $trailing = $5; # After the whole thing ending in "L<"
783 # If the full phrase is something like, "you might see C<", or
784 # similar, it really isn't a reference to a link. The ones I saw
785 # all had the word "you" in them; and the "you" wasn't the
786 # beginning of a sentence.
787 if ($prefix !~ / \b you \b /x) {
789 # Now, find what the module or man page name within the
790 # construct would be if it actually has L<> syntax. If it
791 # doesn't have that syntax, will set the module to the entire
794 (?: [^|]+ \| )? # Optional arbitrary text ending
796 ( .+? ) # module, etc. name
797 (?: \/ .+ )? # target within module
801 if (! defined $trailing # not referring to something in another
803 && $interior !~ /$non_pods/
805 # C<> that look like files have their own message below, so
807 && $construct !~ /$C_path_re/g
809 # There can't be spaces (I think) in module names or man
811 && $module !~ / \s /x
813 # F<> that end in eg \.pl are almost certainly ok, as are
814 # those that look like a path with multiple "/" chars
817 && $interior !~ /\.\w+$/
818 && $interior !~ /\/.+\//)
821 $self->poderror({ -line => $line, -file => $file,
822 -msg => $see_not_linked,
823 parameter => $construct
828 while ($paragraph =~ m/$C_path_re/g) {
830 $self->poderror({ -line => $line, -file => $file,
831 -msg => $C_with_slash,
832 parameter => $construct
839 my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
840 my $addr = Scalar::Util::refaddr $self;
842 $seen_pod_cmd{$addr}++;
844 elsif ($cmd eq "encoding") {
845 my ($file, $line) = $pod_para->file_line;
846 $seen_encoding_cmd{$addr} = $paragraph; # for later decoding
847 if ($command_count{$addr} != 1 && $seen_pod_cmd{$addr}) {
848 $self->poderror({ -line => $line, -file => $file,
849 -msg => $encoding_first
853 $self->check_encoding($paragraph, $line_num, $pod_para);
855 # Pod::Check treats all =items as linkable, but the bullet and
856 # numbered lists really aren't. So keep our own list. This has to be
857 # processed before SUPER is called so that the list is started before
858 # the rest of it gets parsed.
859 if ($cmd eq 'item') { # Not linkable if item begins with * or a digit
860 $linkable_item{$addr} = ($paragraph !~ / ^ \s*
862 | \d+ \.? (?: \$ | \s+ )
868 $self->SUPER::command($cmd, $paragraph, $line_num, $pod_para);
870 $command_count{$addr}++;
872 $in_NAME{$addr} = 0; # Will change to 1 below if necessary
873 $in_begin{$addr} = 0; # ibid
874 if ($cmd eq 'over') {
875 my $text = $self->interpolate($paragraph, $line_num);
876 my $indent = 4; # default
877 $indent = $1 if $text && $text =~ /^\s*(\d+)\s*$/;
878 push @{$indents{$addr}}, $indent;
879 $current_indent{$addr} += $indent;
881 elsif ($cmd eq 'back') {
882 if (@{$indents{$addr}}) {
883 $current_indent{$addr} -= pop @{$indents{$addr}};
886 # =back without corresponding =over, but should have
888 $current_indent{$addr} = 0;
891 elsif ($cmd =~ /^head/) {
892 if (! $in_begin{$addr}) {
894 # If a particular formatter, then this command doesn't really
896 $current_indent{$addr} = 0;
897 undef @{$indents{$addr}};
900 my $text = $self->interpolate($paragraph, $line_num);
901 $in_NAME{$addr} = 1 if $cmd eq 'head1'
902 && $text && $text =~ /^NAME\b/;
904 elsif ($cmd eq 'begin') {
905 $in_begin{$addr} = 1;
915 if ($_[0] && ($page = $_[0][1]{'-page'})) {
916 my $node = $_[0][1]{'-node'};
918 # If the hyperlink is to an interior node of another page, save it
919 # so that we can see if we need to parse normally skipped files.
920 $has_referred_to_node{$page} = 1 if $node;
922 # Ignore certain placeholder links in perldelta. Check if the
923 # link is page-level, and also check if to a node within the page
924 if ($self->name && $self->name eq "perldelta"
925 && ((grep { $page eq $_ } @perldelta_ignore_links)
927 && (grep { "$page/$node" eq $_ } @perldelta_ignore_links)
932 return $self->SUPER::hyperlink($_[0]);
939 $text =~ s/\s+$//s; # strip trailing whitespace
940 $text =~ s/\s+/ /gs; # collapse whitespace
941 my $addr = Scalar::Util::refaddr $self;
942 push(@{$linkable_nodes{$addr}}, $text) if
943 ! $current_indent{$addr}
944 || $linkable_item{$addr};
946 return $self->SUPER::node($_[0]);
949 sub get_current_indent {
950 return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
954 return $filename{Scalar::Util::refaddr $_[0]};
958 my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
959 return undef unless $linkables;
964 return $skip{Scalar::Util::refaddr $_[0]} // 0;
969 $skip{Scalar::Util::refaddr $self} = shift;
971 # If skipping, no need to keep the problems for it
972 delete $problems{$self->get_filename};
977 package Tie_Array_to_FH { # So printing actually goes to an array
983 my $array_ref = shift;
985 my $self = bless \do{ my $anonymous_scalar }, $class;
986 $array{Scalar::Util::refaddr $self} = $array_ref;
993 push @{$array{Scalar::Util::refaddr $self}}, @_;
999 my %filename_to_checker; # Map a filename to it's pod checker object
1000 my %id_to_checker; # Map a checksum to it's pod checker object
1001 my %nodes; # key is filename, values are nodes in that file.
1002 my %nodes_first_word; # same, but value is first word of each node
1003 my %valid_modules; # List of modules known to exist outside us.
1004 my %digests; # checksums of files, whose names are the keys
1005 my %filename_to_pod; # Map a filename to its pod NAME
1006 my %files_with_unknown_issues;
1007 my %files_with_fixes;
1010 open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
1012 my %counts; # For --counts param, count of each issue type
1013 my %suppressed_files; # Files with at least one issue type to suppress
1015 # This file is the data file for $0.
1016 # There are three types of lines.
1017 # Comment lines are white-space only or begin with a '#', like this one. Any
1018 # changes you make to the comment lines will be lost when the file is
1020 # Lines without tab characters are simply NAMES of pods that the program knows
1021 # will have links to them and the program does not check if those links are
1023 # All other lines should have three fields, each separated by a tab. The
1024 # first field is the name of a pod; the second field is an error message
1025 # generated by this program; and the third field is a count of how many
1026 # known instances of that message there are in the pod. -1 means that the
1027 # program can expect any number of this type of message.
1030 my @existing_issues;
1033 while (<$data_fh>) { # Read the data base
1035 next if /^\s*(?:#|$)/; # Skip comment and empty lines
1038 if ($add_link) { # The issues are saved and later output unchanged
1039 push @existing_issues, $_;
1043 # Keep track of counts of each issue type for each file
1044 my ($filename, $message, $count) = split /\t/;
1045 $known_problems{$filename}{$message} = $count;
1048 if ($count < 0) { # -1 means to suppress this issue type
1049 $suppressed_files{$filename} = $filename;
1052 $counts{$message} += $count;
1056 else { # Lines without a tab are modules known to be valid
1057 $valid_modules{$_} = 1
1063 $copy_fh = open_new($known_issues);
1065 # Check for basic sanity, and add each command line argument
1066 foreach my $module (@files) {
1067 die "\"$module\" does not look like a module or man page"
1068 # Must look like (A or A::B or A::B::C ..., or foo(3C)
1069 if $module !~ /^ (?: \w+ (?: :: \w+ )* | \w+ \( \d \w* \) ) $/x;
1070 $valid_modules{$module} = 1
1072 my_safer_print($copy_fh, $HEADER);
1073 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1074 my_safer_print($copy_fh, $_, "\n");
1077 # The rest of the db file is output unchanged.
1078 my_safer_print($copy_fh, join "\n", @existing_issues, "");
1080 close_and_rename($copy_fh);
1086 foreach my $message (sort keys %counts) {
1087 $total += $counts{$message};
1088 note(Text::Tabs::expand("$counts{$message}\t$message"));
1090 note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
1091 if (%suppressed_files) {
1092 note("\nFiles that have all messages of at least one type suppressed:");
1093 note(join ",", keys %suppressed_files);
1099 # Not really pods, but can look like them.
1100 my %excluded_files = (
1101 "lib/unicore/mktables" => 1,
1102 "Porting/perldelta_template.pod" => 1,
1109 # Convert to more generic form.
1110 foreach my $file (keys %excluded_files) {
1111 delete $excluded_files{$file};
1112 $excluded_files{canonicalize($file)} = 1;
1115 # re to match files that are to be parsed only if there is an internal link
1116 # to them. It does not include cpan, as whether those are parsed depends
1117 # on a switch. Currently, only perltoc and the stable perldelta.pod's
1118 # are included. The latter all have characters between 'perl' and
1119 # 'delta'. (Actually the currently developed one matches as well, but
1120 # is a duplicate of perldelta.pod, so can be skipped, so fine for it to
1122 my $only_for_interior_links_re = qr/ ^ pod\/perltoc.pod $
1124 unless ($do_deltas) {
1125 $only_for_interior_links_re = qr/$only_for_interior_links_re |
1126 \b perl \d+ delta \. pod \b
1133 sub output_thanks ($$$$) { # Called when an issue has been fixed
1134 my $filename = shift;
1135 my $original_count = shift;
1136 my $current_count = shift;
1137 my $message = shift;
1139 $files_with_fixes{$filename} = 1;
1141 my $fixed_count = $original_count - $current_count;
1142 my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
1143 my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
1147 There were $original_count occurrences (now $current_count) in this pod of type
1152 There are no longer any problems found in this pod!
1159 Thanks for fixing $a_problem!
1161 Now you must teach $0 that this was fixed.
1166 Thanks for fixing $another_problem.
1175 sub my_safer_print { # print, with error checking for outputting to db
1176 my ($fh, @lines) = @_;
1178 if (! print $fh @lines) {
1179 my $save_error = $!;
1181 die "Write failure: $save_error";
1185 sub extract_pod { # Extracts just the pod from a file
1186 my $filename = shift;
1190 # Arrange for the output of Pod::Parser to be collected in an array we can
1191 # look at instead of being printed
1192 tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
1193 open my $in_fh, '<:bytes', $filename
1195 # The file should already have been opened once to get here, so if
1196 # fails, just die. It's possible that a transitory file containing a
1197 # pod would get here, but not bothering to add code for that very
1199 or die "Can't open '$filename': $!\n";
1201 my $parser = Pod::Parser->new();
1202 $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
1205 return join "", @pod
1208 my $digest = Digest->new($digest_type);
1211 # If $_ is a pod file, add it to the lists and do other prep work.
1214 # Don't look at files in directories that are for tests, nor those
1215 # beginning with a dot
1216 if ($_ eq 't' || $_ =~ /^\../) {
1217 $File::Find::prune = 1;
1222 if ($_ =~ /^\./ # No hidden Unix files
1223 || $_ =~ $non_pods) {
1224 note("Not considering $_") if DEBUG;
1228 my $filename = $File::Find::name;
1230 # In pod directories, skip .pl files. This is a workaround for VMS which
1231 # can't by default distnguish between .PL and .pl. We usually want to
1232 # examine .pl files but not .PL, but the one case where there is a current
1233 # conflict is in /pod, and there's only one .PL file there.
1234 if ($File::Find::dir =~ /pod$/ && $filename =~ /\.pl$/i) {
1235 note("Not considering $_") if DEBUG;
1239 # Assumes that the path separator is exactly one character.
1240 $filename =~ s/^\..//;
1242 return if $excluded_files{canonicalize($filename)};
1247 if (! open $candidate, '<:bytes', $_) {
1249 # If a transitory file was found earlier, the open could fail
1250 # legitimately and we just skip the file; also skip it if it is a
1251 # broken symbolic link, as it is probably just a build problem;
1252 # certainly not a file that we would want to check the pod of.
1253 # Otherwise fail it here and no reason to process it further.
1254 # (But the test count will be off too)
1255 ok(0, "Can't open '$filename': $!")
1256 if -e $filename && ! -l $filename;
1262 # If the file is a .pm or .pod, having any initial '=' on a line is
1263 # grounds for testing it. Otherwise, require a head1 NAME line to
1264 # consider it as a potential pod
1265 if ($filename =~ /\.(?:pm|pod)/) {
1266 return unless $contents =~ /^=/m;
1268 return unless $contents =~ /^=head1 +NAME/m;
1271 # Here, we know that the file is a pod. Add it to the list of files
1272 # to check and create a checker object for it.
1274 push @files, $filename;
1275 my $checker = My::Pod::Checker->new($filename);
1276 $filename_to_checker{$filename} = $checker;
1278 # In order to detect duplicate pods and only analyze them once, we
1279 # compute checksums for the file, so don't have to do an exact
1280 # compare. Note that if the pod is just part of the file, the
1281 # checksums can differ for the same pod. That special case is handled
1282 # later, since if the checksums of the whole file are the same, that
1283 # case won't even come up. We don't need the checksums for files that
1284 # we parse only if there is a link to its interior, but we do need its
1285 # NAME, which is also retrieved in the code below.
1287 if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
1288 | $only_for_interior_links_re
1290 $digest->add($contents);
1291 $digests{$filename} = $digest->digest;
1293 # lib files aren't analyzed if they are duplicates of files copied
1294 # there from some other directory. But to determine this, we need
1295 # to know their NAMEs. We might as well find the NAME now while
1296 # the file is open. Similarly, cpan files aren't analyzed unless
1297 # we're analyzing all of them, or this particular file is linked
1298 # to by a file we are analyzing, and thus we will want to verify
1299 # that the target exists in it. We need to know at least the NAME
1300 # to see if it's worth analyzing, or so we can determine if a lib
1301 # file is a copy of a cpan one.
1302 if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
1303 | $only_for_interior_links_re
1305 if ($contents =~ /^=head1 +NAME.*/mg) {
1306 # The NAME is the first non-spaces on the line up to a
1307 # comma, dash or end of line. Otherwise, it's invalid and
1308 # this pod doesn't have a legal name that we're smart
1309 # enough to find currently. But the parser will later
1310 # find it if it thinks there is a legal name, and set the
1312 if ($contents =~ /\G # continue from the line after =head1
1313 \s* # ignore any empty lines
1314 ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
1316 $checker->name($name);
1317 $id_to_checker{$name} = $checker
1318 if $filename =~ m{^cpan/};
1321 elsif ($filename =~ m{^cpan/}) {
1322 $id_to_checker{$digests{$filename}} = $checker;
1328 } # End of is_pod_file()
1330 # Start of real code that isn't processing the command line (except the
1331 # db is read in above, as is processing of the --add_link option).
1332 # Here, @files contains list of files on the command line. If have any of
1333 # these, unconditionally test them, and show all the errors, even the known
1334 # ones, and, since not testing other pods, don't do cross-pod link tests.
1335 # (Could add extra code to do cross-pod tests for the ones in the list.)
1337 if ($has_input_files) {
1338 undef %known_problems;
1339 $do_upstream_cpan = $do_deltas = 1; # In case one of the inputs is one
1342 else { # No input files -- go find all the possibilities.
1344 $copy_fh = open_new($known_issues);
1345 note("Regenerating $known_issues, please be patient...");
1346 print $copy_fh $HEADER;
1349 # Move to the directory above us, but have to adjust @INC to account for
1351 s{^\.\./lib$}{lib} for @INC;
1352 chdir File::Spec->updir;
1354 # And look in this directory and all its subdirectories
1355 find( \&is_pod_file, '.');
1357 # Add ourselves to the test
1358 push @files, "t/porting/podcheck.t";
1361 # Now we know how many tests there will be.
1362 plan (tests => scalar @files) if ! $regen;
1365 # Sort file names so we get consistent results, and to put cpan last,
1366 # preceeded by the ones that we don't generally parse. This is because both
1367 # these classes are generally parsed only if there is a link to the interior
1368 # of them, and we have to parse all others first to guarantee that they don't
1369 # have such a link. 'lib' files come just before these, as some of these are
1370 # duplicates of others. We already have figured this out when gathering the
1371 # data as a special case for all such files, but this, while unnecessary,
1372 # puts the derived file last in the output. 'readme' files come before those,
1373 # as those also could be duplicates of others, which are considered the
1374 # primary ones. These currently aren't figured out when gathering data, so
1376 @files = sort { if ($a =~ /^cpan/) {
1377 return 1 if $b !~ /^cpan/;
1378 return lc $a cmp lc $b;
1380 elsif ($b =~ /^cpan/) {
1383 elsif ($a =~ /$only_for_interior_links_re/) {
1384 return 1 if $b !~ /$only_for_interior_links_re/;
1385 return lc $a cmp lc $b;
1387 elsif ($b =~ /$only_for_interior_links_re/) {
1390 elsif ($a =~ /^lib/) {
1391 return 1 if $b !~ /^lib/;
1392 return lc $a cmp lc $b;
1394 elsif ($b =~ /^lib/) {
1396 } elsif ($a =~ /\breadme\b/i) {
1397 return 1 if $b !~ /\breadme\b/i;
1398 return lc $a cmp lc $b;
1400 elsif ($b =~ /\breadme\b/i) {
1404 return lc $a cmp lc $b;
1409 # Now go through all the files and parse them
1410 foreach my $filename (@files) {
1412 note("parsing $filename") if DEBUG;
1414 # We may have already figured out some things in the process of generating
1415 # the file list. If so, we have a $checker object already. But if not,
1417 my $checker = $filename_to_checker{$filename};
1419 $checker = My::Pod::Checker->new($filename);
1420 $filename_to_checker{$filename} = $checker;
1423 # We have set the name in the checker object if there is a possibility
1424 # that no further parsing is necessary, but otherwise do the parsing now.
1425 if (! $checker->name) {
1427 $checker->parse_from_file($filename, undef);
1430 if ($checker->num_errors() < 0) { # Returns negative if not a pod
1431 $checker->set_skip("$filename is not a pod");
1435 # Here, is a pod. See if it is one that has already been tested,
1436 # or should be tested under another directory. Use either its NAME
1437 # if it has one, or a checksum if not.
1438 my $name = $checker->name;
1445 my $digest = Digest->new($digest_type);
1446 $digest->add(extract_pod($filename));
1447 $id = $digest->digest;
1450 # If there is a match for this pod with something that we've already
1451 # processed, don't process it, and output why.
1453 if (defined ($prior_checker = $id_to_checker{$id})
1454 && $prior_checker != $checker) # Could have defined the checker
1455 # earlier without pursuing it
1458 # If the pods are identical, then it's just a copy, and isn't an
1459 # error. First use the checksums we have already computed to see
1460 # if the entire files are identical, which means that the pods are
1462 my $prior_filename = $prior_checker->get_filename;
1464 || ($digests{$prior_filename}
1465 && $digests{$filename}
1466 && $digests{$prior_filename} eq $digests{$filename}));
1468 # If they differ, it could be that the files differ for some
1469 # reason, but the pods they contain are identical. Extract the
1470 # pods and do the comparisons on just those.
1471 if (! $same && $name) {
1472 $same = extract_pod($prior_filename) eq extract_pod($filename);
1476 $checker->set_skip("The pod of $filename is a duplicate of "
1477 . "the pod for $prior_filename");
1478 } elsif ($prior_filename =~ /\breadme\b/i) {
1479 $checker->set_skip("$prior_filename is a README apparently for $filename");
1480 } elsif ($filename =~ /\breadme\b/i) {
1481 $checker->set_skip("$filename is a README apparently for $prior_filename");
1482 } elsif (! $do_upstream_cpan
1483 && $filename =~ /^cpan/
1484 && $prior_filename =~ /^cpan/)
1486 $checker->set_skip("CPAN is upstream for $filename");
1487 } else { # Here have two pods with identical names that differ
1488 $prior_checker->poderror(
1489 { -msg => $duplicate_name,
1491 parameter => "'$filename' also has NAME '$name'"
1494 { -msg => $duplicate_name,
1496 parameter => "'$prior_filename' also has NAME '$name'"
1499 # Changing the names helps later.
1500 $prior_checker->name("$name version arbitrarily numbered 1");
1501 $checker->name("$name version arbitrarily numbered 2");
1504 # In any event, don't process this pod that has the same name as
1510 $id_to_checker{$id} = $checker;
1512 my $parsed_for_links = ", but parsed for its interior links";
1513 if ((! $do_upstream_cpan && $filename =~ /^cpan/)
1514 || $filename =~ $only_for_interior_links_re)
1516 if ($filename =~ /^cpan/) {
1517 $checker->set_skip("CPAN is upstream for $filename");
1519 elsif ($filename =~ /perl\d+delta/ && ! $do_deltas) {
1520 $checker->set_skip("$filename is a stable perldelta");
1522 elsif ($filename =~ /perltoc/) {
1523 $checker->set_skip("$filename dependent on component pods");
1526 croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
1529 if ($name && $has_referred_to_node{$name}) {
1530 $checker->set_skip($checker->get_skip() . $parsed_for_links);
1534 # Need a name in order to process it, because not meaningful
1535 # otherwise, and also can't test links to this without a name.
1536 if (!defined $name) {
1537 $checker->poderror( { -msg => $no_name,
1543 # For skipped files, just get its NAME
1545 if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
1547 $checker->node($name) if $name;
1550 $checker->parse_from_file($filename, undef) if ! $parsed;
1553 # Go through everything in the file that could be an anchor that
1554 # could be a link target. Count how many there are of the same name.
1555 foreach my $node ($checker->linkable_nodes) {
1556 next if ! $node; # Can be empty is like '=item *'
1557 if (exists $nodes{$name}{$node}) {
1558 $nodes{$name}{$node}++;
1561 $nodes{$name}{$node} = 1;
1564 # Experiments have shown that cpan search can figure out the
1565 # target of a link even if the exact wording is incorrect, as long
1566 # as the first word is. This happens frequently in perlfunc.pod,
1567 # where the link will be just to the function, but the target
1568 # entry also includes parameters to the function.
1569 my $first_word = $node;
1570 if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
1571 $nodes_first_word{$name}{$first_word} = $node;
1574 $filename_to_pod{$filename} = $name;
1578 # Here, all files have been parsed, and all links and link targets are stored.
1579 # Now go through the files again and see which don't have matches.
1580 if (! $has_input_files) {
1581 foreach my $filename (@files) {
1582 next if $filename_to_checker{$filename}->get_skip;
1583 my $checker = $filename_to_checker{$filename};
1584 foreach my $link ($checker->hyperlink) {
1585 my $linked_to_page = $link->[1]->page;
1586 next unless $linked_to_page; # intra-file checks are handled by std
1589 # Initialize the potential message.
1590 my %problem = ( -msg => $broken_link,
1591 -line => $link->[0],
1592 parameter => "to \"$linked_to_page\"",
1595 # See if we have found the linked-to_file in our parse
1596 if (exists $nodes{$linked_to_page}) {
1597 my $node = $link->[1]->node;
1599 # If link is only to the page-level, already have it
1602 # Transform pod language to what we are expecting
1603 $node =~ s,E<sol>,/,g;
1604 $node =~ s/E<verbar>/|/g;
1606 # If link is to a node that exists in the file, is ok
1607 if ($nodes{$linked_to_page}{$node}) {
1609 # But if the page has multiple targets with the same name,
1610 # it's ambiguous which one this should be to.
1611 if ($nodes{$linked_to_page}{$node} > 1) {
1612 $problem{-msg} = $multiple_targets;
1613 $problem{parameter} = "in $linked_to_page that $node could be pointing to";
1614 $checker->poderror(\%problem);
1616 } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
1618 # Here the link target was not found, either exactly or to
1619 # the first word. Is an error.
1620 $problem{parameter} =~ s,"$,/$node",;
1621 $checker->poderror(\%problem);
1624 } # Linked-to-file not in parse; maybe is in exception list
1625 elsif (! exists $valid_modules{$link->[1]->page}) {
1627 # Here, is a link to a target that we can't find. Check if
1628 # there is an internal link on the page with the target name.
1629 # If so, it could be that they just forgot the initial '/'
1630 # But perldelta is handled specially: only do this if the
1631 # broken link isn't one of the known bad ones (that are
1632 # placemarkers and should be removed for the final)
1633 my $NAME = $filename_to_pod{$filename};
1634 if (! defined $NAME) {
1635 $checker->poderror(\%problem);
1638 if ($nodes{$NAME}{$linked_to_page}) {
1639 $problem{-msg} = $broken_internal_link;
1641 $checker->poderror(\%problem);
1648 # If regenerating the data file, start with the modules for which we don't
1651 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1652 my_safer_print($copy_fh, $_, "\n");
1656 # Now ready to output the messages.
1657 foreach my $filename (@files) {
1658 my $canonical = canonicalize($filename);
1660 my $skip = $filename_to_checker{$filename}->get_skip // "";
1663 foreach my $message ( sort keys %{$problems{$filename}}) {
1666 # Preserve a negative setting.
1667 if ($known_problems{$canonical}{$message}
1668 && $known_problems{$canonical}{$message} < 0)
1670 $count = $known_problems{$canonical}{$message};
1673 $count = @{$problems{$filename}{$message}};
1675 my_safer_print($copy_fh, $canonical . "\t$message\t$count\n");
1680 skip($skip, 1) if $skip;
1684 my $total_known = 0;
1685 foreach my $message ( sort keys %{$problems{$filename}}) {
1686 $known_problems{$canonical}{$message} = 0
1687 if ! $known_problems{$canonical}{$message};
1688 my $diagnostic = "";
1689 my $problem_count = scalar @{$problems{$filename}{$message}};
1690 $total_known += $problem_count;
1691 next if $known_problems{$canonical}{$message} < 0;
1692 if ($problem_count > $known_problems{$canonical}{$message}) {
1694 # Here we are about to output all the messages for this type,
1695 # subtract back this number we previously added in.
1696 $total_known -= $problem_count;
1698 $diagnostic .= $indent . $message;
1699 if ($problem_count > 2) {
1700 $diagnostic .= " ($problem_count occurrences)";
1702 foreach my $problem (@{$problems{$filename}{$message}}) {
1703 $diagnostic .= " " if $problem_count == 1;
1704 $diagnostic .= "\n$indent$indent";
1705 $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
1706 $diagnostic .= " near line $problem->{-line}";
1707 $diagnostic .= " $problem->{comment}" if $problem->{comment};
1709 $diagnostic .= "\n";
1710 $files_with_unknown_issues{$filename} = 1;
1711 } elsif ($problem_count < $known_problems{$canonical}{$message}) {
1712 $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
1714 push @diagnostics, $diagnostic if $diagnostic;
1717 # The above loop has output messages where there are current potential
1718 # issues. But it misses where there were some that have been entirely
1719 # fixed. For those, we need to look through the old issues
1720 foreach my $message ( sort keys %{$known_problems{$canonical}}) {
1721 next if $problems{$filename}{$message};
1722 next if ! $known_problems{$canonical}{$message};
1723 next if $known_problems{$canonical}{$message} < 0; # Preserve negs
1724 my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
1725 push @diagnostics, $diagnostic if $diagnostic;
1728 my $output = "POD of $filename";
1729 $output .= ", excluding $total_known not shown known potential problems"
1731 ok(@diagnostics == 0, $output);
1733 note(join "", @diagnostics,
1734 "See end of this test output for your options on silencing this");
1740 run this test script by hand, using the following formula (on
1741 Un*x-like machines):
1743 ./perl -I../lib porting/podcheck.t --regen
1746 if (%files_with_unknown_issues) {
1747 my $were_count_files = scalar keys %files_with_unknown_issues;
1748 $were_count_files = ($were_count_files == 1)
1749 ? "was $were_count_files file"
1750 : "were $were_count_files files";
1751 my $message = <<EOF;
1753 HOW TO GET THIS .t TO PASS
1755 There $were_count_files that had new potential problems identified.
1756 Some of them may be real, and some of them may be false positives because
1757 this program isn't as smart as it likes to think it is. You can teach this
1758 program to ignore the issues it has identified, and hence pass, by doing the
1761 1) If a problem is about a link to an unknown module or man page that
1762 you know exists, re-run the command something like:
1763 ./perl -I../lib porting/podcheck.t --add_link MODULE man_page ...
1764 (MODULEs should look like Foo::Bar, and man_pages should look like
1765 bar(3c); don't do this for a module or man page that you aren't sure
1766 about; instead treat as another type of issue and follow the
1767 instructions below.)
1769 2) For other issues, decide if each should be fixed now or not. Fix the
1770 ones you decided to, and rerun this test to verify that the fixes
1773 3) If there remain false positive or problems that you don't plan to fix right
1776 That should cause all current potential problems to be accepted by
1777 the program, so that the next time it runs, they won't be flagged.
1779 if (%files_with_fixes) {
1780 $message .= " This step will also take care of the files that have fixes in them\n";
1784 For a few files, such as perltoc, certain issues will always be
1785 expected, and more of the same will be added over time. For those,
1786 before you do the regen, you can edit
1788 and find the entry for the module's file and specific error message,
1789 and change the count of known potential problems to -1.
1793 } elsif (%files_with_fixes) {
1795 To teach this test script that the potential problems have been fixed,
1802 chdir $original_dir || die "Can't change directories to $original_dir";
1803 close_and_rename($copy_fh);