8 # Do not require test.pl, this file has its own framework.
13 use feature 'unicode_strings';
24 if ( $Config{usecrosscompile} ) {
25 print "1..0 # Not all files are available during cross-compilation\n";
28 if ($^O eq 'dec_osf') {
29 print "1..0 # $^O cannot handle this test\n";
32 if ( $ENV{'PERL_BUILD_PACKAGING'} ) {
33 print "1..0 # This distro may have modified some files in cpan/. Skipping validation. \n";
36 require '../regen/regen_lib.pl';
45 podcheck.t - Look for possible problems in the Perl pods
50 ./perl -I../lib porting/podcheck.t [--show_all] [--cpan] [--deltas]
51 [--counts] [--pedantic] [FILE ...]
53 ./perl -I../lib porting/podcheck.t --add_link MODULE ...
55 ./perl -I../lib porting/podcheck.t --regen
59 podcheck.t is an extension of Pod::Checker. It looks for pod errors and
60 potential errors in the files given as arguments, or if none specified, in all
61 pods in the distribution workspace, except certain known special ones
62 (specified below). It does additional checking beyond that done by
63 Pod::Checker, and keeps a database of known potential problems, and will
64 fail a pod only if the number of such problems differs from that given in the
67 The additional checks it always makes are:
71 =item Cross-pod link checking
73 Pod::Checker verifies that links to an internal target in a pod are not
74 broken. podcheck.t extends that (when called without FILE arguments) to
75 external links. It does this by gathering up all the possible targets in the
76 workspace, and cross-checking them. It also checks that a non-broken link
77 points to just one target. (The destination pod could have two targets with
80 The way that the C<LE<lt>E<gt>> pod command works (for links outside the pod)
81 is to actually create a link to C<search.cpan.org> with an embedded query for
82 the desired pod or man page. That means that links outside the distribution
83 are valid. podcheck.t doesn't verify the validity of such links, but instead
84 keeps a database of those known to be valid. This means that if a link to a
85 target not on the list is created, the target needs to be added to the data
86 base. This is accomplished via the L<--add_link|/--add_link MODULE ...>
87 option to podcheck.t, described below.
89 =item An internal link that isn't so specified
91 If a link is broken, but there is an existing internal target of the same
92 name, it is likely that the internal target was meant, and the C<"/"> is
93 missing from the C<LE<lt>E<gt>> pod command.
95 =item Missing or duplicate NAME or missing NAME short description
97 A pod can't be linked to unless it has a unique name.
98 And a NAME should have a dash and short description after it.
100 =item Occurrences of the Unicode replacement character
102 L<Pod::Simple> replaces bytes that aren't valid according to the document's
103 encoding (declared or auto-detected) with C<\N{REPLACEMENT CHARACTER}>.
107 If the C<PERL_POD_PEDANTIC> environment variable is set or the C<--pedantic>
108 command line argument is provided, then a few more checks are made.
109 The pedantic checks are:
113 =item Verbatim paragraphs that wrap in an 80 (including 1 spare) column window
115 It's annoying to have lines wrap when displaying pod documentation in a
116 terminal window. This checks that all verbatim lines fit in a standard 80
117 column window, even when using a pager that reserves a column for its own use.
118 (Thus the check is for a net of 79 columns.)
119 For those lines that don't fit, it tells you how much needs to be cut in
122 Often, the easiest thing to do to gain space for these is to lower the indent
125 =item Items that perhaps should be links
127 There are mentions of apparent files in the pods that perhaps should be links
128 instead, using C<LE<lt>...E<gt>>
130 =item Items that perhaps should be C<FE<lt>...E<gt>>
132 What look like path names enclosed in C<CE<lt>...E<gt>> should perhaps have
133 C<FE<lt>...E<gt>> mark-up instead.
137 A number of issues raised by podcheck.t and by the base Pod::Checker are not
138 really problems, but merely potential problems, that is, false positives.
139 After inspecting them and
140 deciding that they aren't real problems, it is possible to shut up this program
141 about them, unlike base Pod::Checker. For a valid link to an outside module
142 or man page, call podcheck.t with the C<--add_link> option to add it to the
143 the database of known links; for other causes, call podcheck.t with the C<--regen>
144 option to regenerate the entire database. This tells it that all existing
145 issues are to not be mentioned again.
147 C<--regen> isn't fool-proof. The database merely keeps track of the number of these
148 potential problems of each type for each pod. If a new problem of a given
149 type is introduced into the pod, podcheck.t will spit out all of them. You
150 then have to figure out which is the new one, and should it be changed or not.
151 But doing it this way insulates the database from having to keep track of line
152 numbers of problems, which may change, or the exact wording of each problem
153 which might also change without affecting whether it is a problem or not.
155 Also, if the count of potential problems of a given type for a pod decreases,
156 the database must be regenerated so that it knows the new number. The program
157 gives instructions when this happens.
159 Some pods will have varying numbers of problems of a given type. This can
160 be handled by manually editing the database file (see L</FILES>), and setting
161 the number of those problems for that pod to a negative number. This will
162 cause the corresponding error to always be suppressed no matter how many there
165 Another problem is that there is currently no check that modules listed as
166 valid in the database
167 actually are. Thus any errors introduced there will remain there.
169 =head2 Specially handled pods
175 This pod is generated by pasting bits from other pods. Errors in those bits
176 will show up as errors here, as well as for those other pods. Therefore
177 errors here are suppressed, and the pod is checked only to verify that nodes
178 within it actually exist that are externally linked to.
182 The current perldelta pod is initialized from a template that contains
183 placeholder text. Some of this text is in the form of links that don't really
184 exist. Any such links that are listed in C<@perldelta_ignore_links> will not
185 generate messages. It is presumed that these links will be cleaned up when
186 the perldelta is cleaned up for release since they should be marked with
189 =item Porting/perldelta_template.pod
191 This is not a pod, but a template for C<perldelta>. Any errors introduced
192 here will show up when C<perldelta> is created from it.
194 =item cpan-upstream pods
196 See the L</--cpan> option documentation
200 See the L</--deltas> option documentation
208 =item --add_link MODULE ...
210 Use this option to teach podcheck.t that the C<MODULE>s or man pages actually
211 exist, and to silence any messages that links to them are broken.
213 podcheck.t checks that links within the Perl core distribution are valid, but
214 it doesn't check links to man pages or external modules. When it finds
215 a broken link, it checks its database of external modules and man pages,
216 and only if not found there does it raise a message. This option just adds
217 the list of modules and man page references that follow it on the command line
223 ./perl -I../lib porting/podcheck.t --add_link Unicode::Casing
225 causes the external module "Unicode::Casing" to be added to the database, so
226 C<LE<lt>Unicode::CasingE<gt>> will be considered valid.
230 Regenerate the database used by podcheck.t to include all the existing
231 potential problems. Future runs of the program will not then flag any of
232 these. Setting this option also sets C<--pedantic>.
236 Normally, all pods in the cpan directory are skipped, except to make sure that
237 any blead-upstream links to such pods are valid.
238 This option will cause cpan upstream pods to be fully checked.
242 Normally, all old perldelta pods are skipped, except to make sure that
243 any links to such pods are valid. This is because they are considered
244 stable, and perhaps trying to fix them will cause changes that will
245 misrepresent Perl's history. But, this option will cause them to be fully
250 Normally, if the number of potential problems of a given type found for a
251 pod matches the expected value in the database, they will not be displayed.
252 This option forces the database to be ignored during the run, so all potential
253 problems are displayed and will fail their respective pod test. Specifying
254 any particular FILES to operate on automatically selects this option.
258 Instead of testing, this just dumps the counts of the occurrences of the
259 various types of potential problems in the database.
263 There are three potential problems that are not checked for by default.
264 This options enables them. The environment variable C<PERL_POD_PEDANTIC>
265 can be set to 1 to enable this option also.
266 This option is set when C<--regen> is used.
272 The database is stored in F<t/porting/known_pod_issues.dat>
280 # VMS builds have a '.com' appended to utility and script names, and it adds a
281 # trailing dot for any other file name that doesn't have a dot in it. The db
282 # is stored without those things. This regex allows for these special file
283 # names to be dealt with. It needs to be interpolated into a larger regex
284 # that furnishes the closing boundary.
285 my $vms_re = qr/ \. (?: com )? /x;
287 # Some filenames in the MANIFEST match $vms_re, and so must not be handled the
288 # same way that that the special vms ones are. This hash lists those.
289 my %special_vms_files;
291 # This is to get this to work across multiple file systems, including those
292 # that are not case sensitive. The db is stored in lower case, Un*x style,
293 # and all file name comparisons are done that way.
294 sub canonicalize($) {
296 my ($volume, $directories, $file)
297 = File::Spec->splitpath(File::Spec->canonpath($input));
298 # Assumes $volume is constant for everything in this directory structure
299 $directories = "" if ! $directories;
300 $file = "" if ! $file;
301 $file = lc join '/', File::Spec->splitdir($directories), $file;
302 $file =~ s! / /+ !/!gx; # Multiple slashes => single slash
304 # The db is stored without the special suffixes that are there in VMS, so
305 # strip them off to get the comparable name. But some files on all
306 # platforms have these suffixes, so this shouldn't happen for them, as any
307 # of their db entries will have the suffixes in them. The hash has been
308 # populated with these files.
310 && $file =~ / ( $vms_re ) $ /x
311 && ! exists $special_vms_files{$file})
313 $file =~ s/ $1 $ //x;
318 #####################################################
319 # HOW IT WORKS (in general)
321 # If not called with specific files to check, the directory structure is
322 # examined for files that have pods in them. Files that might not have to be
323 # fully parsed (e.g. in cpan) are parsed enough at this time to find their
324 # pod's NAME, and to get a checksum.
326 # Those kinds of files are sorted last, but otherwise the pods are parsed with
327 # the package coded here, My::Pod::Checker, which is an extension to
328 # Pod::Checker that adds some tests and suppresses others that aren't
329 # appropriate. The latter module has no provision for capturing diagnostics,
330 # so a package, Tie_Array_to_FH, is used to force them to be placed into an
331 # array instead of printed.
333 # Parsing the files builds up a list of links. The files are gone through
334 # again, doing cross-link checking and outputting all saved-up problems with
337 # Sorting the files last that potentially don't need to be fully parsed allows
338 # us to not parse them unless there is a link to an internal anchor in them
339 # from something that we have already parsed. Keeping checksums allows us to
340 # not parse copies of other pods.
342 #####################################################
344 # 1 => Exclude low priority messages that aren't likely to be problems, and
345 # has many false positives; higher numbers give more messages.
346 my $Warnings_Level = 200;
348 # perldelta during construction may have place holder links. N.B. This
349 # variable is referred to by name in release_managers_guide.pod
350 our @perldelta_ignore_links = ( "XXX", "perl5YYYdelta", "perldiag/message" );
352 # To see if two pods with the same NAME are actually copies of the same pod,
353 # which is not an error, it uses a checksum to save work.
354 my $digest_type = "SHA-1";
356 my $original_dir = File::Spec->rel2abs(File::Spec->curdir);
357 my $data_dir = File::Spec->catdir($original_dir, 'porting');
358 my $known_issues = File::Spec->catfile($data_dir, 'known_pod_issues.dat');
359 my $MANIFEST = File::Spec->catfile(File::Spec->updir($original_dir), 'MANIFEST');
362 my $MAX_LINE_LENGTH = 79; # 79 columns
363 my $INDENT = 7; # default nroff indent
365 # Our warning messages. Better not have [('"] in them, as those are used as
366 # delimiters for variable parts of the messages by poderror.
367 my $broken_link = "Apparent broken link";
368 my $broken_internal_link = "Apparent internal link is missing its forward slash";
369 my $multiple_targets = "There is more than one target";
370 my $duplicate_name = "Pod NAME already used";
371 my $no_name = "There is no NAME";
372 my $missing_name_description = "The NAME should have a dash and short description after it";
373 my $replacement_character = "Unicode replacement character found";
374 # the pedantic warnings messages
375 my $line_length = "Verbatim line length including indents exceeds $MAX_LINE_LENGTH by";
376 my $C_not_linked = "? Should you be using L<...> instead of";
377 my $C_with_slash = "? Should you be using F<...> or maybe L<...> instead of";
379 # objects, tests, etc can't be pods, so don't look for them. Also skip
380 # files output by the patch program. Could also ignore most of .gitignore
381 # files, but not all, so don't.
383 my $obj_ext = $Config{'obj_ext'}; $obj_ext =~ tr/.//d; # dot will be added back
384 my $lib_ext = $Config{'lib_ext'}; $lib_ext =~ tr/.//d;
385 my $lib_so = $Config{'so'}; $lib_so =~ tr/.//d;
386 my $dl_ext = $Config{'dlext'}; $dl_ext =~ tr/.//d;
388 # Not really pods, but can look like them.
389 my %excluded_files = (
390 canonicalize("lib/unicore/mktables") => 1,
391 canonicalize("Porting/make-rmg-checklist") => 1,
392 canonicalize("Porting/perldelta_template.pod") => 1,
393 canonicalize("regen/feature.pl") => 1,
394 canonicalize("regen/warnings.pl") => 1,
395 canonicalize("autodoc.pl") => 1,
396 canonicalize("configpm") => 1,
397 canonicalize("miniperl") => 1,
398 canonicalize("perl") => 1,
399 canonicalize('cpan/Pod-Perldoc/corpus/no-head.pod') => 1,
400 canonicalize('cpan/Pod-Perldoc/corpus/perlfunc.pod') => 1,
401 canonicalize('cpan/Pod-Perldoc/corpus/utf8.pod') => 1,
402 canonicalize("lib/unicore/mktables") => 1,
405 # This list should not include anything for which case sensitivity is
406 # important, as it won't work on VMS, and won't show up until tested on VMS.
407 # All or almost all such files should be listed in the MANIFEST, so that can
408 # be examined for them, and each such file explicitly excluded, as is done for
409 # .PL files in the loop just below this. For files not catchable this way,
410 # is_pod_file() can be used to exclude these at a finer grained level.
411 my $non_pods = qr/ (?: \.
412 (?: [achot] | zip | gz | bz2 | jar | tar | tgz
413 | orig | rej | patch # Patch program output
414 | sw[op] | \#.* # Editor droppings
415 | old # buildtoc output
416 | xs # pod should be in the .pm file
417 | al # autosplit files
418 | bs # bootstrap files
419 | (?i:sh) # shell scripts, hints, templates
420 | lst # assorted listing files
421 | bat # Windows,Netware,OS2 batch files
422 | cmd # Windows,Netware,OS2 command files
423 | lis # VMS compiler listings
424 | map # VMS linker maps
425 | opt # VMS linker options files
426 | mms # MM(K|S) description files
427 | ts # timestamp files generated during build
428 | $obj_ext # object files
429 | exe # $Config{'exe_ext'} might be empty string
430 | $lib_ext # object libraries
431 | $lib_so # shared libraries
432 | $dl_ext # dynamic libraries
433 | gif # GIF images (example files from CGI.pm)
434 | eg # examples from libnet
438 ) | ~$ | \ \(Autosaved\)\.txt$ # Other editor droppings
439 | ^cxx\$demangler_db\.$ # VMS name mangler database
440 | ^typemap\.?$ # typemap files
441 | ^(?i:Makefile\.PL)$
442 | ^core (?: $ | \. .* )
445 # Matches something that looks like a file name, but is enclosed in C<...>
446 my $C_path_re = qr{ ^
447 # exclude various things that have slashes
448 # in them but aren't paths
450 (?: (?: s | qr | m | tr | y ) / ) # regexes
451 | \d+/\d+ \b # probable fractions
459 /? # Optional initial slash
460 \w+ # First component of path, doesn't begin with
462 (?: / [-\w]+ )+ # Subsequent path components
463 (?: \. \w+ )? # Optional trailing dot and suffix
464 >* # Any enclosed L< F< have matching closing >
468 # '.PL' files should be excluded, as they aren't final pods, but often contain
469 # material used in generating pods, and so can look like a pod. We can't use
470 # the regexp above because case sensitivity is important for these, as some
471 # '.pl' files should be examined for pods. Instead look through the MANIFEST
472 # for .PL files and get their full path names, so we can exclude each such
473 # file explicitly. This works because other porting tests prohibit having two
474 # files with the same names except for case.
475 open my $manifest_fh, '<:bytes', $MANIFEST or die "Can't open $MANIFEST";
476 while (<$manifest_fh>) {
478 # While we have MANIFEST open, on VMS platforms, look for files that match
479 # the magic VMS file names that have to be handled specially. Add these
480 # to the list of them.
481 if ($^O eq 'VMS' && / ^ ( [^\t]* $vms_re ) \t /x) {
482 $special_vms_files{$1} = 1;
484 if (/ ^ ( [^\t]* \. PL ) \t /x) {
485 $excluded_files{canonicalize($1)} = 1;
488 close $manifest_fh, or die "Can't close $MANIFEST";
491 # Pod::Checker messages to suppress
492 my @suppressed_messages = (
493 # We catch independently the ones that are real problems.
494 qr/multiple occurrences \(\d+\) of link target/,
496 "unescaped <>", # Not every '<' or '>' need be escaped
497 qr/No items in =over/, # i.e., a blockquote, which we consider legal
501 # Returns bool as to if input message is one that is to be suppressed
505 return grep { $message =~ /^$_/i } @suppressed_messages;
508 { # Closure to contain a simple subset of test.pl. This is to get rid of the
509 # unnecessary 'failed at' messages that would otherwise be output pointing
510 # to a particular line in this file.
512 my $current_test = 0;
517 $planned = $plan{tests} + 1; # +1 for final test that files haven't
519 print "1..$planned\n";
530 print "not " unless $success;
531 print "ok $current_test - $message\n";
537 my $n = @_ ? shift : 1;
540 print "ok $current_test # skip $why\n";
542 no warnings 'exiting';
547 my ($andle, $message) = @_;
551 print $andle $message =~ s/^/# /mgr;
556 sub note { unshift @_, \*STDOUT; goto &_note }
558 sub diag { unshift @_, \*STDERR; goto &_note }
561 if ($planned && $planned != $current_test) {
563 "# Looks like you planned $planned tests but ran $current_test.\n";
568 # List of known potential problems by pod and type.
571 # Pods given by the keys contain an interior node that is referred to from
573 my %has_referred_to_node;
581 my $do_upstream_cpan = 0; # Assume that are to skip anything in /cpan
582 my $do_deltas = 0; # And stable perldeltas
584 while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
585 my $arg = shift @ARGV;
587 $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
588 if ($arg eq '-regen') {
592 elsif ($arg eq '-add_link') {
595 elsif ($arg eq '-cpan') {
596 $do_upstream_cpan = 1;
598 elsif ($arg eq '-deltas') {
601 elsif ($arg eq '-show_all') {
604 elsif ($arg eq '-counts') {
607 elsif ($arg eq '-pedantic') {
612 Unknown option '$arg'
614 Usage: $0 [ --regen | --cpan | --show_all | FILE ... | --add_link MODULE ... ]\n"
615 --add_link -> Add the MODULE and man page references to the database
616 --regen -> Regenerate the data file for $0
617 --cpan -> Include files in the cpan subdirectory.
618 --deltas -> Include stable perldeltas
619 --show_all -> Show all known potential problems
620 --counts -> Don't test, but give summary counts of the currently
622 --pedantic -> Check for overly long lines in verbatim blocks
627 $pedantic = 1 if exists $ENV{PERL_POD_PEDANTIC} and $ENV{PERL_POD_PEDANTIC};
630 my $cpan_or_deltas = $do_upstream_cpan || $do_deltas;
631 if (($regen + $show_all + $show_counts + $add_link + $cpan_or_deltas ) > 1) {
632 croak "--regen, --show_all, --counts, and --add_link are mutually exclusive\n and none can be run with --cpan nor --deltas";
635 my $has_input_files = @files;
639 if (! $has_input_files) {
640 croak "--add_link requires at least one module or man page reference";
643 elsif ($has_input_files) {
644 if ($regen || $show_counts || $do_upstream_cpan || $do_deltas) {
645 croak "--regen, --counts, --deltas, and --cpan can't be used since using specific files";
647 foreach my $file (@files) {
648 croak "Can't read file '$file'" if ! -r $file;
652 our %problems; # potential problems found in this run
654 package My::Pod::Checker { # Extend Pod::Checker
655 use parent 'Pod::Checker';
657 # Uses inside out hash to protect from typos
658 # For new fields, remember to add to destructor DESTROY()
659 my %CFL_text; # The text comprising the current C<>, F<>, or L<>
660 my %C_text; # If defined, are in a C<> section, and includes
661 # the accumulated text from that
662 my %current_indent; # Current line's indent
663 my %filename; # The pod is store in this file
664 my %in_CFL; # count of stacked C<>, F<>, L<> directives
665 my %indents; # Stack of indents from =over's in effect for
667 my %in_for; # true if in a =for or =begin
668 my %in_NAME; # true if within NAME section
669 my %in_begin; # true if within =begin section
670 my %in_X; # true if in a X<>
671 my %linkable_item; # Bool: if the latest =item is linkable. It isn't
672 # for bullet and number lists
673 my %linkable_nodes; # Pod::Checker adds all =items to its node list,
674 # but not all =items are linkable-to
675 my %running_CFL_text; # The current text that is being accumulated until
676 # an end_FOO is found, and this includes any C<>,
677 # F<>, or L<> directives.
678 my %running_simple_text; # The currentt text that is being accumulated
679 # until an end_FOO is found, and all directives
680 # have been expanded into plain text
681 my %command_count; # Number of commands seen
682 my %seen_pod_cmd; # true if have =pod earlier
683 my %skip; # is SKIP set for this pod
684 my %start_line; # the first input line number in the the thing
685 # currently being worked on
688 my $addr = Scalar::Util::refaddr $_[0];
689 delete $CFL_text{$addr};
690 delete $C_text{$addr};
691 delete $command_count{$addr};
692 delete $current_indent{$addr};
693 delete $filename{$addr};
694 delete $in_begin{$addr};
695 delete $in_CFL{$addr};
696 delete $indents{$addr};
697 delete $in_for{$addr};
698 delete $in_NAME{$addr};
700 delete $linkable_item{$addr};
701 delete $linkable_nodes{$addr};
702 delete $running_CFL_text{$addr};
703 delete $running_simple_text{$addr};
704 delete $seen_pod_cmd{$addr};
706 delete $start_line{$addr};
712 my $filename = shift;
714 my $self = $class->SUPER::new(-quiet => 1,
715 -warnings => $Warnings_Level);
716 my $addr = Scalar::Util::refaddr $self;
717 $command_count{$addr} = 0;
718 $current_indent{$addr} = 0;
719 $filename{$addr} = $filename;
720 $in_begin{$addr} = 0;
724 $linkable_item{$addr} = 0;
725 $seen_pod_cmd{$addr} = 0;
729 # re's for messages that Pod::Checker outputs
730 my $location = qr/ \b (?:in|at|on|near) \s+ /xi;
731 my $optional_location = qr/ (?: $location )? /xi;
732 my $line_reference = qr/ [('"]? $optional_location \b line \s+
733 (?: \d+ | EOF | \Q???\E | - )
736 sub poderror { # Called to register a potential problem
738 # This adds an extra field to the parent hash, 'parameter'. It is
739 # used to extract the variable parts of a message leaving just the
740 # constant skeleton. This in turn allows the message to be
741 # categorized better, so that it shows up as a single type in our
742 # database, with the specifics of each occurrence not being stored with
748 my $addr = Scalar::Util::refaddr $self;
749 return if $skip{$addr};
751 # Input can be a string or hash. If a string, parse it to separate
752 # out the line number and convert to a hash for easier further
755 if (ref $opts ne 'HASH') {
756 $message = join "", $opts, @_;
758 if ($message =~ s/\s*($line_reference)//) {
759 ($line_number = $1) =~ s/\s*$optional_location//;
762 $line_number = '???';
764 $opts = { -msg => $message, -line => $line_number };
766 $message = $opts->{'-msg'};
770 $message =~ s/^\d+\s+//;
771 return if main::suppressed($message);
773 $self->SUPER::poderror($opts, @_);
775 $opts->{parameter} = "" unless $opts->{parameter};
777 # The variable parts of the message tend to be enclosed in '...',
778 # "....", or (...). Extract them and put them in an extra field,
779 # 'parameter'. This is trickier because the matching delimiter to a
780 # '(' is its mirror, and not itself. Text::Balanced could be used
782 while ($message =~ m/ \s* $optional_location ( [('"] )/xg) {
785 $delimiter = ')' if $delimiter eq '(';
787 # If there is no ending delimiter, don't consider it to be a
788 # variable part. Most likely it is a contraction like "Don't"
789 last unless $message =~ m/\G .+? \Q$delimiter/xg;
791 my $length = $+[0] - $start;
793 # Get the part up through the closing delimiter
794 my $special = substr($message, $start, $length);
795 $special =~ s/^\s+//; # No leading whitespace
797 # And add that variable part to the parameter, while removing it
798 # from the message. This isn't a foolproof way of finding the
799 # variable part. For example '(s)' can occur in e.g.,
801 if ($special ne '(s)') {
802 substr($message, $start, $length) = "";
803 pos $message = $start;
804 $opts->{-msg} = $message;
805 $opts->{parameter} .= " " if $opts->{parameter};
806 $opts->{parameter} .= $special;
810 # Extract any additional line number given. This is often the
811 # beginning location of something whereas the main line number gives
813 if ($message =~ /( $line_reference )/xi) {
815 while ($message =~ s/\s*\Q$line_ref//) {
816 $opts->{-msg} = $message;
817 $opts->{parameter} .= " " if $opts->{parameter};
818 $opts->{parameter} .= $line_ref;
822 Carp::carp("Couldn't extract line number from '$message'") if $message =~ /line \d+/;
823 push @{$problems{$filename{$addr}}{$message}}, $opts;
824 #push @{$problems{$self->get_filename}{$message}}, $opts;
827 # In the next subroutines, we keep track of the text of the current
828 # innermost thing, like F<fooC<bar>baz>. The things we care about raising
829 # messages about in this program all come from a single sequence of
830 # characters uninterrupted by other pod commands. Therefore we don't have
831 # to worry about recursion, and we can just set the string we care about
832 # to empty on entrance to each command.
835 # This is called by the parent class to deal with any straight text.
836 # We mostly just append this to the running current value which will
837 # be dealt with upon the end of the current construct, like a
838 # paragraph. But certain things don't contribute to checking the pod
839 # and are ignored. We also have set flags to indicate this text is
840 # going towards constructing certain constructs, and handle those
844 my $addr = Scalar::Util::refaddr $self;
846 my $return = $self->SUPER::handle_text(@_);
848 if ($in_X{$addr} || $in_for{$addr}) { # ignore
852 my $text = join "\n", @_;
853 $running_simple_text{$addr} .= $text;
855 # Keep separate tabs on C<>, F<>, and L<> directives, and one
856 # especially for C<> ones.
857 if ($in_CFL{$addr}) {
858 $CFL_text{$addr} .= $text;
859 $C_text{$addr} .= $text if defined $C_text{$addr};
862 # This variable is updated instead in the corresponding C, F, or L
864 $running_CFL_text{$addr} .= $text;
867 # do this line-by-line so we can get the right line number
868 my @lines = split /^/, $running_simple_text{$addr};
869 for my $i (0..$#lines) {
870 if ($lines[$i] =~ m/\N{REPLACEMENT CHARACTER}/) {
871 $self->poderror({ -line => $start_line{$addr} + $i,
872 -msg => $replacement_character,
873 parameter => "possibly invalid ". $self->encoding . " input at character " . pos $lines[$i],
880 # The start_FOO routines check that somehow a C<> construct hasn't escaped
881 # without being checked, and initialize things, and call the parent
882 # class's equivalent routine.
884 # The end_FOO routines close things off, and check the text that has been
885 # accumulated for FOO, then call the parent's corresponding routine.
889 check_see_but_not_link($self);
891 my $addr = Scalar::Util::refaddr $self;
892 $start_line{$addr} = $_[0]->{start_line};
893 $running_CFL_text{$addr} = "";
894 $running_simple_text{$addr} = "";
895 return $self->SUPER::start_Para(@_);
898 sub start_item_text {
900 check_see_but_not_link($self);
902 my $addr = Scalar::Util::refaddr $self;
903 $start_line{$addr} = $_[0]->{start_line};
904 $running_CFL_text{$addr} = "";
905 $running_simple_text{$addr} = "";
907 # This is the only =item that is linkable
908 $linkable_item{$addr} = 1;
910 return $self->SUPER::start_item_text(@_);
913 sub start_item_number {
915 check_see_but_not_link($self);
917 my $addr = Scalar::Util::refaddr $self;
918 $start_line{$addr} = $_[0]->{start_line};
919 $running_CFL_text{$addr} = "";
920 $running_simple_text{$addr} = "";
922 return $self->SUPER::start_item_number(@_);
925 sub start_item_bullet {
927 check_see_but_not_link($self);
929 my $addr = Scalar::Util::refaddr $self;
930 $start_line{$addr} = $_[0]->{start_line};
931 $running_CFL_text{$addr} = "";
932 $running_simple_text{$addr} = "";
934 return $self->SUPER::start_item_bullet(@_);
937 sub end_item { # No difference in =item types endings
939 check_see_but_not_link($self);
940 return $self->SUPER::end_item(@_);
945 check_see_but_not_link($self);
947 my $addr = Scalar::Util::refaddr $self;
948 $start_line{$addr} = $_[0]->{start_line};
949 $running_CFL_text{$addr} = "";
950 $running_simple_text{$addr} = "";
952 # Save this indent on a stack, and keep track of total indent
953 my $indent = $_[0]{'indent'};
954 push @{$indents{$addr}}, $indent;
955 $current_indent{$addr} += $indent;
957 return $self->SUPER::start_over(@_);
960 sub end_over_bullet { shift->end_over(@_) }
961 sub end_over_number { shift->end_over(@_) }
962 sub end_over_text { shift->end_over(@_) }
963 sub end_over_block { shift->end_over(@_) }
964 sub end_over_empty { shift->end_over(@_) }
967 check_see_but_not_link($self);
969 my $addr = Scalar::Util::refaddr $self;
972 if (@{$indents{$addr}}) {
973 $current_indent{$addr} -= pop @{$indents{$addr}};
976 # =back without corresponding =over, but should have
978 $current_indent{$addr} = 0;
982 sub check_see_but_not_link {
984 # Looks through accumulated text for current element that includes the
985 # C<>, F<>, and L<> directives for ones that look like they are
986 # C<link> instead of L<link>.
989 my $addr = Scalar::Util::refaddr $self;
991 return unless defined $running_CFL_text{$addr};
993 while ($running_CFL_text{$addr} =~ m{
994 ( (?: \w+ \s+ )* ) # The phrase before, if any
998 ( [^<]*? ) # The not < excludes nested C<L<...
1001 ( \s+ (?: under | in ) \s+ L< )?
1004 my $prefix = $1 // "";
1005 my $construct = $2; # The whole thing, like C<...>
1008 my $trailing = $5; # After the whole thing ending in "L<"
1010 # If the full phrase is something like, "you might see C<", or
1011 # similar, it really isn't a reference to a link. The ones I saw
1012 # all had the word "you" in them; and the "you" wasn't the
1013 # beginning of a sentence.
1014 if ($prefix !~ / \b you \b /x) {
1016 # Now, find what the module or man page name within the
1017 # construct would be if it actually has L<> syntax. If it
1018 # doesn't have that syntax, will set the module to the entire
1020 if (! defined $trailing # not referring to something in another
1022 && $interior !~ /$non_pods/
1024 # There can't be spaces (I think) in module names or man
1026 && $interior !~ / \s /x
1028 # F<> that end in eg \.pl are almost certainly ok, as are
1029 # those that look like a path with multiple "/" chars
1032 && $interior !~ /\.\w+$/
1033 && $interior !~ /\/.+\//)
1036 # TODO: move the checking of $pedantic higher up
1037 $self->poderror({ -line => $start_line{$addr},
1038 -msg => $C_not_linked,
1039 parameter => $construct
1045 undef $running_CFL_text{$addr};
1050 check_see_but_not_link($self);
1052 my $addr = Scalar::Util::refaddr $self;
1053 if ($in_NAME{$addr}) {
1054 if ($running_simple_text{$addr} =~ /^\s*(\S+?)\s*$/) {
1055 $self->poderror({ -line => $start_line{$addr},
1056 -msg => $missing_name_description,
1059 $in_NAME{$addr} = 0;
1061 $self->SUPER::end_Para(@_);
1066 check_see_but_not_link($self);
1068 my $addr = Scalar::Util::refaddr $self;
1069 $start_line{$addr} = $_[0]->{start_line};
1070 $running_CFL_text{$addr} = "";
1071 $running_simple_text{$addr} = "";
1073 return $self->SUPER::start_head1(@_);
1076 sub end_head1 { # This is called at the end of the =head line.
1078 check_see_but_not_link($self);
1080 my $addr = Scalar::Util::refaddr $self;
1082 $in_NAME{$addr} = 1 if $running_simple_text{$addr} eq 'NAME';
1083 return $self->SUPER::end_head(@_);
1086 sub start_Verbatim {
1088 check_see_but_not_link($self);
1090 my $addr = Scalar::Util::refaddr $self;
1091 $running_simple_text{$addr} = "";
1092 $start_line{$addr} = $_[0]->{start_line};
1093 return $self->SUPER::start_Verbatim(@_);
1098 my $addr = Scalar::Util::refaddr $self;
1100 # Pick up the name if it looks like one, since the parent class
1101 # doesn't handle verbatim NAMEs
1103 && $running_simple_text{$addr} =~ /^\s*(\S+?)\s*[,-]/)
1108 my $indent = $self->get_current_indent;
1110 # Look at each line to verify it is short enough
1111 my @lines = split /^/, $running_simple_text{$addr};
1112 for my $i (0 .. @lines - 1) {
1113 $lines[$i] =~ s/\s+$//;
1114 my $exceeds = length(Text::Tabs::expand($lines[$i]))
1115 + $indent - $MAX_LINE_LENGTH;
1116 next unless $exceeds > 0;
1118 $self->poderror({ -line => $start_line{$addr} + $i,
1119 -msg => $line_length,
1120 parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
1124 undef $running_simple_text{$addr};
1126 # Parent class didn't bother to define this
1127 #return $self->SUPER::SUPER::end_Verbatim(@_);
1132 my $addr = Scalar::Util::refaddr $self;
1134 $C_text{$addr} = "";
1136 # If not in a stacked set of C<>, F<> and L<>, initialize the text for
1138 $CFL_text{$addr} = "" if ! $in_CFL{$addr};
1141 return $self->SUPER::start_C(@_);
1146 my $addr = Scalar::Util::refaddr $self;
1148 $CFL_text{$addr} = "" if ! $in_CFL{$addr};
1150 return $self->SUPER::start_F(@_);
1155 my $addr = Scalar::Util::refaddr $self;
1157 $CFL_text{$addr} = "" if ! $in_CFL{$addr};
1159 return $self->SUPER::start_L(@_);
1164 my $addr = Scalar::Util::refaddr $self;
1166 # Warn if looks like a file or link enclosed instead by this C<>
1167 if ($C_text{$addr} =~ qr/^ $C_path_re $/x) {
1168 # Here it does look like it could be be a file path or a link.
1169 # But some varieties of regex patterns could also fit with what we
1170 # have so far. Weed those out as best we can. '/foo/' is almost
1171 # certainly meant to be a pattern, as is '/foo/g'.
1173 if ($C_text{$addr} !~ qr| ^ / [^/]* / ( [msixpodualngcr]* ) $ |x) {
1178 # Here, it looks like a pattern potentially followed by some
1179 # modifiers. To make doubly sure, don't count as patterns
1180 # those constructs which have more occurrences (generally 1)
1181 # of a modifier than is legal.
1183 map { $counts{$_}++ } split "", $1;
1184 foreach my $modifier (keys %counts) {
1185 if ($counts{$modifier} > (($modifier eq 'a')
1193 $is_pattern = 1 unless defined $is_pattern;
1196 unless ($is_pattern) {
1197 $self->poderror({ -line => $start_line{$addr},
1198 -msg => $C_with_slash,
1199 parameter => "C<$C_text{$addr}>"
1203 undef $C_text{$addr};
1205 # Add the current text to the running total. This was not done in
1206 # handle_text(), because it just sees the plain text of the innermost
1207 # stacked directive. We want to keep all the directive names
1208 # enclosing the text. Otherwise the fact that C<L<foobar>> is to a
1209 # link would be lost, as the L<> would be gone.
1210 $CFL_text{$addr} = "C<$CFL_text{$addr}>";
1212 # Add this text to the the whole running total only if popping this
1213 # directive off the stack leaves it empty. As long as something is on
1214 # the stack, it gets added to $CFL_text (just above). It is only
1215 # entirely constructed when the stack is empty.
1217 $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
1219 return $self->SUPER::end_C(@_);
1224 my $addr = Scalar::Util::refaddr $self;
1226 $CFL_text{$addr} = "F<$CFL_text{$addr}>";
1228 $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
1229 return $self->SUPER::end_F(@_);
1234 my $addr = Scalar::Util::refaddr $self;
1236 $CFL_text{$addr} = "L<$CFL_text{$addr}>";
1238 $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
1239 return $self->SUPER::end_L(@_);
1244 my $addr = Scalar::Util::refaddr $self;
1247 return $self->SUPER::start_X(@_);
1252 my $addr = Scalar::Util::refaddr $self;
1255 return $self->SUPER::end_X(@_);
1260 my $addr = Scalar::Util::refaddr $self;
1263 return $self->SUPER::start_for(@_);
1268 my $addr = Scalar::Util::refaddr $self;
1271 return $self->SUPER::end_for(@_);
1275 my ($self, $link) = @_;
1277 if ($link && $link->type eq 'pod') {
1278 my $page = $link->page;
1279 my $node = $link->node;
1281 # If the hyperlink is to an interior node of another page, save it
1282 # so that we can see if we need to parse normally skipped files.
1283 $has_referred_to_node{$page} = 1 if $node;
1285 # Ignore certain placeholder links in perldelta. Check if the
1286 # link is page-level, and also check if to a node within the page
1287 if ( $self->name && $self->name eq "perldelta"
1288 && (( grep { $page eq $_ } @perldelta_ignore_links)
1290 && (grep { "$page/$node" eq $_ } @perldelta_ignore_links)
1296 return $self->SUPER::hyperlink($link);
1303 $text =~ s/\s+$//s; # strip trailing whitespace
1304 $text =~ s/\s+/ /gs; # collapse whitespace
1305 my $addr = Scalar::Util::refaddr $self;
1306 push(@{$linkable_nodes{$addr}}, $text) if
1307 ! $current_indent{$addr}
1308 || $linkable_item{$addr};
1310 return $self->SUPER::node($_[0]);
1313 sub get_current_indent {
1314 return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
1318 return $filename{Scalar::Util::refaddr $_[0]};
1321 sub linkable_nodes {
1322 my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
1323 return undef unless $linkables;
1328 return $skip{Scalar::Util::refaddr $_[0]} // 0;
1333 $skip{Scalar::Util::refaddr $self} = shift;
1335 # If skipping, no need to keep the problems for it
1336 delete $problems{$self->get_filename};
1340 sub parse_from_file {
1341 # This overrides the super class method so that if an open fails on a
1342 # transitory file, it doesn't croak. It returns 1 if it did find the
1343 # file, 0 if it didn't
1346 my $filename = shift;
1347 # ignores 2nd param, which is output file. Always uses undef
1349 if (open my $in_fh, '<:bytes', $filename) {
1350 $self->SUPER::parse_from_file($in_fh, undef);
1355 # If couldn't open file, perhaps it was transitory, and hence not an error
1356 return 0 unless -e $filename;
1358 die "Can't open '$filename': $!\n";
1362 my %filename_to_checker; # Map a filename to its pod checker object
1363 my %id_to_checker; # Map a checksum to its pod checker object
1364 my %nodes; # key is filename, values are nodes in that file.
1365 my %nodes_first_word; # same, but value is first word of each node
1366 my %valid_modules; # List of modules known to exist outside us.
1367 my %digests; # checksums of files, whose names are the keys
1368 my %filename_to_pod; # Map a filename to its pod NAME
1369 my %files_with_unknown_issues;
1370 my %files_with_fixes;
1373 open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
1375 my %counts; # For --counts param, count of each issue type
1376 my %suppressed_files; # Files with at least one issue type to suppress
1378 # This file is the data file for $0.
1379 # There are three types of lines.
1380 # Comment lines are white-space only or begin with a '#', like this one. Any
1381 # changes you make to the comment lines will be lost when the file is
1383 # Lines without tab characters are simply NAMES of pods that the program knows
1384 # will have links to them and the program does not check if those links are
1386 # All other lines should have three fields, each separated by a tab. The
1387 # first field is the name of a pod; the second field is an error message
1388 # generated by this program; and the third field is a count of how many
1389 # known instances of that message there are in the pod. -1 means that the
1390 # program can expect any number of this type of message.
1393 my @existing_issues;
1396 while (<$data_fh>) { # Read the database
1398 next if /^\s*(?:#|$)/; # Skip comment and empty lines
1401 if ($add_link) { # The issues are saved and later output unchanged
1402 push @existing_issues, $_;
1406 # Keep track of counts of each issue type for each file
1407 my ($filename, $message, $count) = split /\t/;
1408 $known_problems{$filename}{$message} = $count;
1411 if ($count < 0) { # -1 means to suppress this issue type
1412 $suppressed_files{$filename} = $filename;
1415 $counts{$message} += $count;
1419 else { # Lines without a tab are modules known to be valid
1420 $valid_modules{$_} = 1
1426 $copy_fh = open_new($known_issues);
1428 # Check for basic sanity, and add each command line argument
1429 foreach my $module (@files) {
1430 die "\"$module\" does not look like a module or man page"
1431 # Must look like (A or A::B or A::B::C ..., or foo(3C)
1432 if $module !~ /^ (?: \w+ (?: :: \w+ )* | \w+ \( \d \w* \) ) $/x;
1433 $valid_modules{$module} = 1
1435 my_safer_print($copy_fh, $HEADER);
1436 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1437 my_safer_print($copy_fh, $_, "\n");
1440 # The rest of the db file is output unchanged.
1441 my_safer_print($copy_fh, join "\n", @existing_issues, "");
1443 close_and_rename($copy_fh);
1449 foreach my $message (sort keys %counts) {
1450 $total += $counts{$message};
1451 note(Text::Tabs::expand("$counts{$message}\t$message"));
1453 note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
1454 if (%suppressed_files) {
1455 note("\nFiles that have all messages of at least one type suppressed:");
1456 note(join ",", sort keys %suppressed_files);
1461 # re to match files that are to be parsed only if there is an internal link
1462 # to them. It does not include cpan, as whether those are parsed depends
1463 # on a switch. Currently, only perltoc and the stable perldelta.pod's
1464 # are included. The latter all have characters between 'perl' and
1465 # 'delta'. (Actually the currently developed one matches as well, but
1466 # is a duplicate of perldelta.pod, so can be skipped, so fine for it to
1468 my $only_for_interior_links_re = qr/ ^ pod\/perltoc.pod $
1470 unless ($do_deltas) {
1471 $only_for_interior_links_re = qr/$only_for_interior_links_re |
1472 \b perl \d+ delta \. pod \b
1479 sub output_thanks ($$$$) { # Called when an issue has been fixed
1480 my $filename = shift;
1481 my $original_count = shift;
1482 my $current_count = shift;
1483 my $message = shift;
1485 $files_with_fixes{$filename} = 1;
1487 my $fixed_count = $original_count - $current_count;
1488 my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
1489 my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
1493 There were $original_count occurrences (now $current_count) in this pod of type
1498 There are no longer any problems found in this pod!
1505 Thanks for fixing $a_problem!
1507 Now you must teach $0 that this was fixed.
1512 Thanks for fixing $another_problem.
1521 sub my_safer_print { # print, with error checking for outputting to db
1522 my ($fh, @lines) = @_;
1524 if (! print $fh @lines) {
1525 my $save_error = $!;
1527 die "Write failure: $save_error";
1531 sub extract_pod { # Extracts just the pod from a file; returns undef if file
1533 my $filename = shift;
1535 if (open my $in_fh, '<:bytes', $filename) {
1536 use Pod::Simple::JustPod;
1537 my $parser = Pod::Simple::JustPod->new();
1538 $parser->no_errata_section(1);
1539 $parser->no_whining(1);
1540 $parser->source_filename($filename);
1542 $parser->output_string( \$output );
1543 $parser->parse_lines( <$in_fh>, undef );
1549 # The file should already have been opened once to get here, so if that
1550 # fails, something is wrong. It's possible that a transitory file
1551 # containing a pod would get here, so if the file no longer exists just
1553 return unless -e $filename;
1554 die "Can't open '$filename': $!\n";
1557 my $digest = Digest->new($digest_type);
1559 # This is used as a callback from File::Find::find(), which always constructs
1560 # pathnames using Unix separators
1562 # If $_ is a pod file, add it to the lists and do other prep work.
1565 # Don't look at files in directories that are for tests, nor those
1566 # beginning with a dot
1567 if (m!/t\z! || m!/\.!) {
1568 $File::Find::prune = 1;
1573 return unless -r && -s; # Can't check it if can't read it; no need to
1575 return unless -f || -l; # Weird file types won't be pods
1577 my ($leaf) = m!([^/]+)\z!;
1578 if (m!/\.! # No hidden Unix files
1579 || $leaf =~ $non_pods) {
1580 note("Not considering $_") if DEBUG;
1584 my $filename = $File::Find::name;
1586 # $filename is relative, like './path'. Strip that initial part away.
1587 $filename =~ s!^\./!! or die 'Unexpected pathname "$filename"';
1589 return if $excluded_files{canonicalize($filename)};
1594 if (! open $candidate, '<:bytes', $_) {
1596 # If a transitory file was found earlier, the open could fail
1597 # legitimately and we just skip the file; also skip it if it is a
1598 # broken symbolic link, as it is probably just a build problem;
1599 # certainly not a file that we would want to check the pod of.
1600 # Otherwise fail it here and no reason to process it further.
1601 # (But the test count will be off too)
1602 ok(0, "Can't open '$filename': $!")
1603 if -r $filename && ! -l $filename;
1609 # If the file is a .pm or .pod, having any initial '=' on a line is
1610 # grounds for testing it. Otherwise, require a head1 NAME line to
1611 # consider it as a potential pod
1612 if ($filename =~ /\.(?:pm|pod)/) {
1613 return unless $contents =~ /^=/m;
1615 return unless $contents =~ /^=head1 +NAME/m;
1618 # Here, we know that the file is a pod. Add it to the list of files
1619 # to check and create a checker object for it.
1621 push @files, $filename;
1622 my $checker = My::Pod::Checker->new($filename);
1623 $filename_to_checker{$filename} = $checker;
1625 # In order to detect duplicate pods and only analyze them once, we
1626 # compute checksums for the file, so don't have to do an exact
1627 # compare. Note that if the pod is just part of the file, the
1628 # checksums can differ for the same pod. That special case is handled
1629 # later, since if the checksums of the whole file are the same, that
1630 # case won't even come up. We don't need the checksums for files that
1631 # we parse only if there is a link to its interior, but we do need its
1632 # NAME, which is also retrieved in the code below.
1634 if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
1635 | $only_for_interior_links_re
1638 $digest->add($contents);
1639 $digests{$filename} = $digest->digest;
1641 # lib files aren't analyzed if they are duplicates of files copied
1642 # there from some other directory. But to determine this, we need
1643 # to know their NAMEs. We might as well find the NAME now while
1644 # the file is open. Similarly, cpan files aren't analyzed unless
1645 # we're analyzing all of them, or this particular file is linked
1646 # to by a file we are analyzing, and thus we will want to verify
1647 # that the target exists in it. We need to know at least the NAME
1648 # to see if it's worth analyzing, or so we can determine if a lib
1649 # file is a copy of a cpan one.
1650 if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
1651 | $only_for_interior_links_re
1653 if ($contents =~ /^=head1 +NAME.*/mg) {
1654 # The NAME is the first non-spaces on the line up to a
1655 # comma, dash or end of line. Otherwise, it's invalid and
1656 # this pod doesn't have a legal name that we're smart
1657 # enough to find currently. But the parser will later
1658 # find it if it thinks there is a legal name, and set the
1660 if ($contents =~ /\G # continue from the line after =head1
1661 \s* # ignore any empty lines
1663 # ignore =for paragraphs followed by empty
1665 (?: ^ =for .*? \n (?: [^\s]*? \n )* \s* )*
1667 ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
1669 $checker->name($name);
1670 $id_to_checker{$name} = $checker
1671 if $filename =~ m{^cpan/};
1674 elsif ($filename =~ m{^cpan/}) {
1675 $id_to_checker{$digests{$filename}} = $checker;
1681 } # End of is_pod_file()
1683 # Start of real code that isn't processing the command line (except the
1684 # db is read in above, as is processing of the --add_link option).
1685 # Here, @files contains list of files on the command line. If have any of
1686 # these, unconditionally test them, and show all the errors, even the known
1687 # ones, and, since not testing other pods, don't do cross-pod link tests.
1688 # (Could add extra code to do cross-pod tests for the ones in the list.)
1690 if ($has_input_files) {
1691 undef %known_problems;
1692 $do_upstream_cpan = $do_deltas = 1; # In case one of the inputs is one
1695 else { # No input files -- go find all the possibilities.
1697 $copy_fh = open_new($known_issues);
1698 note("Regenerating $known_issues, please be patient...");
1699 print $copy_fh $HEADER;
1702 # Move to the directory above us, but have to adjust @INC to account for
1704 s{^\.\./lib$}{lib} for @INC;
1705 chdir File::Spec->updir;
1707 # And look in this directory and all its subdirectories
1708 find( {wanted => \&is_pod_file, no_chdir => 1}, '.');
1710 # Add ourselves to the test
1711 push @files, "t/porting/podcheck.t";
1714 # Now we know how many tests there will be.
1715 plan (tests => scalar @files) if ! $regen;
1718 # Sort file names so we get consistent results, and to put cpan last,
1719 # preceded by the ones that we don't generally parse. This is because both
1720 # these classes are generally parsed only if there is a link to the interior
1721 # of them, and we have to parse all others first to guarantee that they don't
1722 # have such a link. 'lib' files come just before these, as some of these are
1723 # duplicates of others. We already have figured this out when gathering the
1724 # data as a special case for all such files, but this, while unnecessary,
1725 # puts the derived file last in the output. 'readme' files come before those,
1726 # as those also could be duplicates of others, which are considered the
1727 # primary ones. These currently aren't figured out when gathering data, so
1729 @files = sort { if ($a =~ /^cpan/) {
1730 return 1 if $b !~ /^cpan/;
1731 return lc $a cmp lc $b;
1733 elsif ($b =~ /^cpan/) {
1736 elsif ($a =~ /$only_for_interior_links_re/) {
1737 return 1 if $b !~ /$only_for_interior_links_re/;
1738 return lc $a cmp lc $b;
1740 elsif ($b =~ /$only_for_interior_links_re/) {
1743 elsif ($a =~ /^lib/) {
1744 return 1 if $b !~ /^lib/;
1745 return lc $a cmp lc $b;
1747 elsif ($b =~ /^lib/) {
1749 } elsif ($a =~ /\breadme\b/i) {
1750 return 1 if $b !~ /\breadme\b/i;
1751 return lc $a cmp lc $b;
1753 elsif ($b =~ /\breadme\b/i) {
1757 return lc $a cmp lc $b;
1762 # Now go through all the files and parse them
1764 foreach my $filename (@files) {
1766 note("parsing $filename") if DEBUG;
1768 # We may have already figured out some things in the process of generating
1769 # the file list. If so, we have a $checker object already. But if not,
1771 my $checker = $filename_to_checker{$filename};
1773 $checker = My::Pod::Checker->new($filename);
1774 $filename_to_checker{$filename} = $checker;
1777 # We have set the name in the checker object if there is a possibility
1778 # that no further parsing is necessary, but otherwise do the parsing now.
1779 if (! $checker->name) {
1780 if (! $checker->parse_from_file($filename, undef)) {
1781 $checker->set_skip("$filename is transitory");
1787 if ($checker->num_errors() < 0) { # Returns negative if not a pod
1788 $checker->set_skip("$filename is not a pod");
1792 # Here, is a pod. See if it is one that has already been tested,
1793 # or should be tested under another directory. Use either its NAME
1794 # if it has one, or a checksum if not.
1795 my $name = $checker->name;
1802 my $digest = Digest->new($digest_type);
1803 my $contents = extract_pod($filename);
1805 # If the return is undef, it means that $filename was a transitory
1807 next FILE unless defined $contents;
1808 $digest->add($contents);
1809 $id = $digest->digest;
1812 # If there is a match for this pod with something that we've already
1813 # processed, don't process it, and output why.
1815 if (defined ($prior_checker = $id_to_checker{$id})
1816 && $prior_checker != $checker) # Could have defined the checker
1817 # earlier without pursuing it
1820 # If the pods are identical, then it's just a copy, and isn't an
1821 # error. First use the checksums we have already computed to see
1822 # if the entire files are identical, which means that the pods are
1824 my $prior_filename = $prior_checker->get_filename;
1826 || ($digests{$prior_filename}
1827 && $digests{$filename}
1828 && $digests{$prior_filename} eq $digests{$filename}));
1830 # If they differ, it could be that the files differ for some
1831 # reason, but the pods they contain are identical. Extract the
1832 # pods and do the comparisons on just those.
1833 if (! $same && $name) {
1834 my $contents = extract_pod($filename);
1836 # If return is <undef>, it means that $filename no longer
1837 # exists. This means it was a transitory file, and should not
1839 next FILE unless defined $contents;
1841 my $prior_contents = extract_pod($prior_filename);
1843 # If return is <undef>, it means that $prior_filename no
1844 # longer exists. This means it was a transitory file, and
1845 # should not have been tested, but we already did process it.
1846 # What we should do now is to back-out its records, and
1847 # process $filename in its stead. But backing out is not so
1848 # simple, and so I'm (khw) skipping that unless and until
1849 # experience shows that it is needed. We do go process
1850 # $filename, and there are potential false positive conflicts
1851 # with the transitory $prior_contents, and rerunning the test
1852 # should cause it to succeed.
1853 goto process_this_pod unless defined $prior_contents;
1855 $same = $prior_contents eq $contents;
1858 use File::Basename 'basename';
1860 $checker->set_skip("The pod of $filename is a duplicate of "
1861 . "the pod for $prior_filename");
1862 } elsif ($prior_filename =~ /\breadme\b/i) {
1863 $checker->set_skip("$prior_filename is a README apparently for $filename");
1864 } elsif ($filename =~ /\breadme\b/i) {
1865 $checker->set_skip("$filename is a README apparently for $prior_filename");
1866 } elsif (! $do_upstream_cpan
1867 && $filename =~ /^cpan/
1868 && $prior_filename =~ /^cpan/)
1870 $checker->set_skip("CPAN is upstream for $filename");
1871 } elsif ( $filename =~ /^utils/ or $prior_filename =~ /^utils/ ) {
1872 $checker->set_skip("$filename copy is in utils/");
1873 } elsif ($prior_filename =~ /^(?:cpan|ext|dist)/
1874 && $filename !~ /^(?:cpan|ext|dist)/
1875 && basename($prior_filename) eq basename($filename))
1877 $checker->set_skip("$filename: Need to run make?");
1878 } else { # Here have two pods with identical names that differ
1879 $prior_checker->poderror(
1880 { -msg => $duplicate_name,
1882 parameter => "'$filename' also has NAME '$name'"
1885 { -msg => $duplicate_name,
1887 parameter => "'$prior_filename' also has NAME '$name'"
1890 # Changing the names helps later.
1891 $prior_checker->name("$name version arbitrarily numbered 1");
1892 $checker->name("$name version arbitrarily numbered 2");
1895 # In any event, don't process this pod that has the same name as
1903 $id_to_checker{$id} = $checker;
1905 my $parsed_for_links = ", but parsed for its interior links";
1906 if ((! $do_upstream_cpan && $filename =~ /^cpan/)
1907 || $filename =~ $only_for_interior_links_re)
1909 if ($filename =~ /^cpan/) {
1910 $checker->set_skip("CPAN is upstream for $filename");
1912 elsif ($filename =~ /perl\d+delta/) {
1914 $checker->set_skip("$filename is a stable perldelta");
1917 elsif ($filename =~ /perltoc/) {
1918 $checker->set_skip("$filename dependent on component pods");
1921 croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
1924 if ($name && $has_referred_to_node{$name}) {
1925 $checker->set_skip($checker->get_skip() . $parsed_for_links);
1929 # Need a name in order to process it, because not meaningful
1930 # otherwise, and also can't test links to this without a name.
1931 if (!defined $name) {
1932 $checker->poderror( { -msg => $no_name,
1938 # For skipped files, just get its NAME
1940 if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
1942 $checker->node($name) if $name;
1945 if (! $checker->parse_from_file($filename, undef)) {
1946 $checker->set_skip("$filename is transitory");
1951 # Go through everything in the file that could be an anchor that
1952 # could be a link target. Count how many there are of the same name.
1953 foreach my $node ($checker->linkable_nodes) {
1954 next FILE if ! $node; # Can be empty is like '=item *'
1955 $nodes{$name}{$node}++;
1957 # Experiments have shown that cpan search can figure out the
1958 # target of a link even if the exact wording is incorrect, as long
1959 # as the first word is. This happens frequently in perlfunc.pod,
1960 # where the link will be just to the function, but the target
1961 # entry also includes parameters to the function.
1962 my $first_word = $node;
1963 if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
1964 $nodes_first_word{$name}{$first_word} = $node;
1967 $filename_to_pod{$filename} = $name;
1971 # Here, all files have been parsed, and all links and link targets are stored.
1972 # Now go through the files again and see which don't have matches.
1973 if (! $has_input_files) {
1974 foreach my $filename (@files) {
1975 next if $filename_to_checker{$filename}->get_skip;
1977 my $checker = $filename_to_checker{$filename};
1978 foreach my $link ($checker->hyperlinks()) {
1979 my $linked_to_page = $link->page;
1980 next unless $linked_to_page; # intra-file checks are handled by std
1982 # Currently, we assume all external links are valid
1983 next if $link->type eq 'url';
1985 # Initialize the potential message.
1986 my %problem = ( -msg => $broken_link,
1987 -line => $link->line,
1988 parameter => "to \"$linked_to_page\"",
1991 # See if we have found the linked-to_file in our parse
1992 if (exists $nodes{$linked_to_page}) {
1993 my $node = $link->node;
1995 # If link is only to the page-level, already have it
1998 # If link is to a node that exists in the file, is ok
1999 if ($nodes{$linked_to_page}{$node}) {
2001 # But if the page has multiple targets with the same name,
2002 # it's ambiguous which one this should be to.
2003 if ($nodes{$linked_to_page}{$node} > 1) {
2004 $problem{-msg} = $multiple_targets;
2005 $problem{parameter} = "in $linked_to_page that $node could be pointing to";
2006 $checker->poderror(\%problem);
2008 } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
2010 # Here the link target was not found, either exactly or to
2011 # the first word. Is an error.
2012 $problem{parameter} =~ s,"$,/$node",;
2013 $checker->poderror(\%problem);
2016 } # Linked-to-file not in parse; maybe is in exception list
2017 elsif (! exists $valid_modules{$link->page}) {
2019 # Here, is a link to a target that we can't find. Check if
2020 # there is an internal link on the page with the target name.
2021 # If so, it could be that they just forgot the initial '/'
2022 # But perldelta is handled specially: only do this if the
2023 # broken link isn't one of the known bad ones (that are
2024 # placemarkers and should be removed for the final)
2025 my $NAME = $filename_to_pod{$filename};
2026 if (! defined $NAME) {
2027 $checker->poderror(\%problem);
2030 if ($nodes{$NAME}{$linked_to_page}) {
2031 $problem{-msg} = $broken_internal_link;
2033 $checker->poderror(\%problem);
2040 # If regenerating the data file, start with the modules for which we don't
2041 # check targets. If you change the sort order, you need to run --regen before
2042 # committing so that future commits that do run regen don't show irrelevant
2045 foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
2046 my_safer_print($copy_fh, $_, "\n");
2050 # Now ready to output the messages.
2051 foreach my $filename (@files) {
2052 my $canonical = canonicalize($filename);
2054 my $skip = $filename_to_checker{$filename}->get_skip // "";
2057 foreach my $message ( sort keys %{$problems{$filename}}) {
2060 # Preserve a negative setting.
2061 if ($known_problems{$canonical}{$message}
2062 && $known_problems{$canonical}{$message} < 0)
2064 $count = $known_problems{$canonical}{$message};
2067 $count = @{$problems{$filename}{$message}};
2069 my_safer_print($copy_fh, $canonical . "\t$message\t$count\n");
2074 skip($skip, 1) if $skip;
2076 my $thankful_diagnostics = 0;
2079 my $total_known = 0;
2080 foreach my $message ( sort keys %{$problems{$filename}}) {
2081 $known_problems{$canonical}{$message} = 0
2082 if ! $known_problems{$canonical}{$message};
2083 my $diagnostic = "";
2084 my $problem_count = scalar @{$problems{$filename}{$message}};
2085 $total_known += $problem_count;
2086 next if $known_problems{$canonical}{$message} < 0;
2088 # If we have new problems not previously known, we output all of
2089 # such problems, as we can't know which are really new and which
2091 if ($problem_count > $known_problems{$canonical}{$message}) {
2093 # Here we are about to output all the messages for this type,
2094 # subtract back this number we previously added in.
2095 $total_known -= $problem_count;
2097 $diagnostic .= $indent . qq{"$message"};
2098 if ($problem_count > 2) {
2099 $diagnostic .= " ($problem_count occurrences,"
2100 . " expected $known_problems{$canonical}{$message})";
2102 foreach my $problem (@{$problems{$filename}{$message}}) {
2103 $diagnostic .= " " if $problem_count == 1;
2104 $diagnostic .= "\n$indent$indent";
2105 $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
2106 $diagnostic .= " near line $problem->{-line} of "
2108 $diagnostic .= " $problem->{comment}" if $problem->{comment};
2110 $diagnostic .= "\n";
2111 $files_with_unknown_issues{$filename} = 1;
2112 } elsif ($problem_count < $known_problems{$canonical}{$message}) {
2113 $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
2114 $thankful_diagnostics++;
2116 push @diagnostics, $diagnostic if $diagnostic;
2119 # The above loop has output messages where there are current potential
2120 # issues. But it misses where there were some that have been entirely
2121 # fixed. For those, we need to look through the old issues
2122 foreach my $message ( sort keys %{$known_problems{$canonical}}) {
2123 next if $problems{$filename}{$message};
2124 next if ! $known_problems{$canonical}{$message};
2125 next if $known_problems{$canonical}{$message} < 0; # Preserve negs
2127 next if !$pedantic and $message =~
2128 /^(?:\Q$line_length\E|\Q$C_not_linked\E|\Q$C_with_slash\E)/;
2130 my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
2131 push @diagnostics, $diagnostic if $diagnostic;
2132 $thankful_diagnostics++ if $diagnostic;
2135 my $output = "POD of $filename";
2136 $output .= ", excluding $total_known not shown known potential problems"
2138 if (@diagnostics && @diagnostics == $thankful_diagnostics) {
2139 # Output fixed issues as passing to-do tests, so they do not
2140 # cause failures, but t/harness still flags them.
2141 $output .= " # TODO"
2143 ok(@diagnostics == $thankful_diagnostics, $output);
2145 diag(join "", @diagnostics,
2146 "See end of this test output for your options on silencing this");
2149 delete $known_problems{$canonical};
2154 && ! ok (keys %known_problems == 0, "The known problems database ($data_dir/known_pod_issues.dat) includes no references to non-existent files"))
2156 note("The following files were not found: "
2157 . join ", ", sort keys %known_problems);
2158 note("They will automatically be removed from the db the next time");
2159 note(" cd t; ./perl -I../lib porting/podcheck.t --regen");
2164 run this test script by hand, using the following formula (on
2165 Un*x-like machines):
2167 ./perl -I../lib porting/podcheck.t --regen
2170 if (%files_with_unknown_issues) {
2171 my $were_count_files = scalar keys %files_with_unknown_issues;
2172 $were_count_files = ($were_count_files == 1)
2173 ? "was $were_count_files file"
2174 : "were $were_count_files files";
2175 my $message = <<EOF;
2177 HOW TO GET ${\__FILE__} TO PASS
2179 There $were_count_files that had new potential problems identified.
2180 Some of them may be real, and some of them may be false positives because
2181 this program isn't as smart as it likes to think it is. You can teach this
2182 program to ignore the issues it has identified, and hence pass, by doing the
2185 1) If a problem is about a link to an unknown module or man page that
2186 you know exists, re-run the command something like:
2187 ./perl -I../lib porting/podcheck.t --add_link MODULE man_page ...
2188 (MODULEs should look like Foo::Bar, and man_pages should look like
2189 bar(3c); don't do this for a module or man page that you aren't sure
2190 about; instead treat as another type of issue and follow the
2191 instructions below.)
2193 2) For other issues, decide if each should be fixed now or not. Fix the
2194 ones you decided to, and rerun this test to verify that the fixes
2197 3) If there remain false positive or problems that you don't plan to fix right
2200 That should cause all current potential problems to be accepted by
2201 the program, so that the next time it runs, they won't be flagged.
2203 if (%files_with_fixes) {
2204 $message .= " This step will also take care of the files that have fixes in them\n";
2208 For a few files, such as perltoc, certain issues will always be
2209 expected, and more of the same will be added over time. For those,
2210 before you do the regen, you can edit
2212 and find the entry for the module's file and specific error message,
2213 and change the count of known potential problems to -1.
2217 } elsif (%files_with_fixes) {
2219 To teach this test script that the potential problems have been fixed,
2226 chdir $original_dir || die "Can't change directories to $original_dir";
2227 close_and_rename($copy_fh);