t/porting/podcheck.t

   1 #!/usr/bin/perl -w
   2
   3 package main;
   4
   5 BEGIN {
   6     chdir 't';
   7     @INC = "../lib";
   8     # Do not require test.pl, this file has its own framework.
   9 }
  10
  11 use strict;
  12 use warnings;
  13 use feature 'unicode_strings';
  14
  15 use Carp;
  16 use Config;
  17 use Digest;
  18 use File::Find;
  19 use File::Spec;
  20 use Scalar::Util;
  21 use Text::Tabs;
  22
  23 BEGIN {
  24     if ( $Config{usecrosscompile} ) {
  25         print "1..0 # Not all files are available during cross-compilation\n";
  26         exit 0;
  27     }
  28     if ($^O eq 'dec_osf') {
  29         print "1..0 # $^O cannot handle this test\n";
  30         exit(0);
  31     }
  32     if ( $ENV{'PERL_BUILD_PACKAGING'} ) {
  33         print "1..0 # This distro may have modified some files in cpan/. Skipping validation. \n";
  34         exit 0;
  35     }
  36     require '../regen/regen_lib.pl';
  37 }
  38
  39 sub DEBUG { 0 };
  40
  41 =pod
  42
  43 =head1 NAME
  44
  45 podcheck.t - Look for possible problems in the Perl pods
  46
  47 =head1 SYNOPSIS
  48
  49  cd t
  50  ./perl -I../lib porting/podcheck.t [--show_all] [--cpan] [--deltas]
  51                                     [--counts] [--pedantic] [FILE ...]
  52
  53  ./perl -I../lib porting/podcheck.t --add_link MODULE ...
  54
  55  ./perl -I../lib porting/podcheck.t --regen
  56
  57 =head1 DESCRIPTION
  58
  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
  65 database.
  66
  67 The additional checks it always makes are:
  68
  69 =over
  70
  71 =item Cross-pod link checking
  72
  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
  78 the same name.)
  79
  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.
  88
  89 =item An internal link that isn't so specified
  90
  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.
  94
  95 =item Missing or duplicate NAME or missing NAME short description
  96
  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.
  99
 100 =item Occurrences of the Unicode replacement character
 101
 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}>.
 104
 105 =back
 106
 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:
 110
 111 =over
 112
 113 =item Verbatim paragraphs that wrap in an 80 (including 1 spare) column window
 114
 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
 120 order to fit.
 121
 122 Often, the easiest thing to do to gain space for these is to lower the indent
 123 to just one space.
 124
 125 =item Items that perhaps should be links
 126
 127 There are mentions of apparent files in the pods that perhaps should be links
 128 instead, using C<LE<lt>...E<gt>>
 129
 130 =item Items that perhaps should be C<FE<lt>...E<gt>>
 131
 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.
 134
 135 =back
 136
 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.
 146
 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.
 154
 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.
 158
 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
 163 actually are.
 164
 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.
 168
 169 =head2 Specially handled pods
 170
 171 =over
 172
 173 =item perltoc
 174
 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.
 179
 180 =item perldelta
 181
 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
 187 C<XXX>.
 188
 189 =item Porting/perldelta_template.pod
 190
 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.
 193
 194 =item cpan-upstream pods
 195
 196 See the L</--cpan> option documentation
 197
 198 =item old perldeltas
 199
 200 See the L</--deltas> option documentation
 201
 202 =back
 203
 204 =head1 OPTIONS
 205
 206 =over
 207
 208 =item --add_link MODULE ...
 209
 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.
 212
 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
 218 to that database.
 219
 220 For example,
 221
 222     cd t
 223     ./perl -I../lib porting/podcheck.t --add_link Unicode::Casing
 224
 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.
 227
 228 =item --regen
 229
 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>.
 233
 234 =item --cpan
 235
 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.
 239
 240 =item --deltas
 241
 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
 246 checked.
 247
 248 =item --show_all
 249
 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.
 255
 256 =item --counts
 257
 258 Instead of testing, this just dumps the counts of the occurrences of the
 259 various types of potential problems in the database.
 260
 261 =item --pedantic
 262
 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.
 267
 268 =back
 269
 270 =head1 FILES
 271
 272 The database is stored in F<t/porting/known_pod_issues.dat>
 273
 274 =head1 SEE ALSO
 275
 276 L<Pod::Checker>
 277
 278 =cut
 279
 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;
 286
 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;
 290
 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($) {
 295     my $input = shift;
 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
 303
 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.
 309     if ($^O eq 'VMS'
 310         && $file =~ / ( $vms_re ) $ /x
 311         && ! exists $special_vms_files{$file})
 312     {
 313         $file =~ s/ $1 $ //x;
 314     }
 315     return $file;
 316 }
 317
 318 #####################################################
 319 # HOW IT WORKS (in general)
 320 #
 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.
 325 #
 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.
 332 #
 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
 335 # each pod.
 336 #
 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.
 341 #
 342 #####################################################
 343
 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;
 347
 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" );
 351
 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";
 355
 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');
 360 my $copy_fh;
 361
 362 my $MAX_LINE_LENGTH = 79;   # 79 columns
 363 my $INDENT = 7;             # default nroff indent
 364
 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";
 378
 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.
 382
 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;
 387
 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,
 403                     );
 404
 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
 435                            | core
 436                        )
 437                        $
 438                     ) | ~$ | \ \(Autosaved\)\.txt$ # Other editor droppings
 439                            | ^cxx\$demangler_db\.$ # VMS name mangler database
 440                            | ^typemap\.?$          # typemap files
 441                            | ^(?i:Makefile\.PL)$
 442                 /x;
 443
 444 # Matches something that looks like a file name, but is enclosed in C<...>
 445 my $C_path_re = qr{ ^
 446                         # exclude various things that have slashes
 447                         # in them but aren't paths
 448                         (?!
 449                             (?: (?: s | qr | m | tr | y ) / ) # regexes
 450                             | \d+/\d+ \b       # probable fractions
 451                             | (?: [LF] < )+
 452                             | OS/2 \b
 453                             | Perl/Tk \b
 454                             | origin/blead \b
 455                             | origin/maint \b
 456
 457                         )
 458                         /?  # Optional initial slash
 459                         \w+ # First component of path, doesn't begin with
 460                             # a minus
 461                         (?: / [-\w]+ )+ # Subsequent path components
 462                         (?: \. \w+ )?   # Optional trailing dot and suffix
 463                         >*  # Any enclosed L< F< have matching closing >
 464                         $
 465                     }x;
 466
 467 # '.PL' files should be excluded, as they aren't final pods, but often contain
 468 # material used in generating pods, and so can look like a pod.  We can't use
 469 # the regexp above because case sensisitivity is important for these, as some
 470 # '.pl' files should be examined for pods.  Instead look through the MANIFEST
 471 # for .PL files and get their full path names, so we can exclude each such
 472 # file explicitly.  This works because other porting tests prohibit having two
 473 # files with the same names except for case.
 474 open my $manifest_fh, '<:bytes', $MANIFEST or die "Can't open $MANIFEST";
 475 while (<$manifest_fh>) {
 476
 477     # While we have MANIFEST open, on VMS platforms, look for files that match
 478     # the magic VMS file names that have to be handled specially.  Add these
 479     # to the list of them.
 480     if ($^O eq 'VMS' && / ^ ( [^\t]* $vms_re ) \t /x) {
 481         $special_vms_files{$1} = 1;
 482     }
 483     if (/ ^ ( [^\t]* \. PL ) \t /x) {
 484         $excluded_files{canonicalize($1)} = 1;
 485     }
 486 }
 487 close $manifest_fh, or die "Can't close $MANIFEST";
 488
 489
 490 # Pod::Checker messages to suppress
 491 my @suppressed_messages = (
 492     # We catch independently the ones that are real problems.
 493     qr/multiple occurrences \(\d+\) of link target/,
 494
 495     "unescaped <>",                 # Not every '<' or '>' need be escaped
 496     qr/No items in =over/,          # i.e., a blockquote, which we consider legal
 497 );
 498
 499 sub suppressed {
 500     # Returns bool as to if input message is one that is to be suppressed
 501
 502     my $message = shift;
 503
 504     return grep { $message =~ /^$_/i } @suppressed_messages;
 505 }
 506
 507 {   # Closure to contain a simple subset of test.pl.  This is to get rid of the
 508     # unnecessary 'failed at' messages that would otherwise be output pointing
 509     # to a particular line in this file.
 510
 511     my $current_test = 0;
 512     my $planned;
 513
 514     sub plan {
 515         my %plan = @_;
 516         $planned = $plan{tests} + 1;    # +1 for final test that files haven't
 517                                         # been removed
 518         print "1..$planned\n";
 519         return;
 520     }
 521
 522     sub ok {
 523         my $success = shift;
 524         my $message = shift;
 525
 526         chomp $message;
 527
 528         $current_test++;
 529         print "not " unless $success;
 530         print "ok $current_test - $message\n";
 531         return $success;
 532     }
 533
 534     sub skip {
 535         my $why = shift;
 536         my $n    = @_ ? shift : 1;
 537         for (1..$n) {
 538             $current_test++;
 539             print "ok $current_test # skip $why\n";
 540         }
 541         no warnings 'exiting';
 542         last SKIP;
 543     }
 544
 545     sub _note {
 546         my ($andle, $message) = @_;
 547
 548         chomp $message;
 549
 550         print $andle $message =~ s/^/# /mgr;
 551         print $andle "\n";
 552         return;
 553     }
 554
 555     sub note { unshift @_, \*STDOUT; goto &_note }
 556
 557     sub diag { unshift @_, \*STDERR; goto &_note }
 558
 559     END {
 560         if ($planned && $planned != $current_test) {
 561             print STDERR
 562             "# Looks like you planned $planned tests but ran $current_test.\n";
 563         }
 564     }
 565 }
 566
 567 # List of known potential problems by pod and type.
 568 my %known_problems;
 569
 570 # Pods given by the keys contain an interior node that is referred to from
 571 # outside it.
 572 my %has_referred_to_node;
 573
 574 my $show_counts = 0;
 575 my $regen = 0;
 576 my $add_link = 0;
 577 my $show_all = 0;
 578 my $pedantic = 0;
 579
 580 my $do_upstream_cpan = 0; # Assume that are to skip anything in /cpan
 581 my $do_deltas = 0;        # And stable perldeltas
 582
 583 while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
 584     my $arg = shift @ARGV;
 585
 586     $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
 587     if ($arg eq '-regen') {
 588         $regen = 1;
 589         $pedantic = 1;
 590     }
 591     elsif ($arg eq '-add_link') {
 592         $add_link = 1;
 593     }
 594     elsif ($arg eq '-cpan') {
 595         $do_upstream_cpan = 1;
 596     }
 597     elsif ($arg eq '-deltas') {
 598         $do_deltas = 1;
 599     }
 600     elsif ($arg eq '-show_all') {
 601         $show_all = 1;
 602     }
 603     elsif ($arg eq '-counts') {
 604         $show_counts = 1;
 605     }
 606     elsif ($arg eq '-pedantic') {
 607         $pedantic = 1;
 608     }
 609     else {
 610         die <<EOF;
 611 Unknown option '$arg'
 612
 613 Usage: $0 [ --regen | --cpan | --show_all | FILE ... | --add_link MODULE ... ]\n"
 614     --add_link -> Add the MODULE and man page references to the database
 615     --regen    -> Regenerate the data file for $0
 616     --cpan     -> Include files in the cpan subdirectory.
 617     --deltas   -> Include stable perldeltas
 618     --show_all -> Show all known potential problems
 619     --counts   -> Don't test, but give summary counts of the currently
 620                   existing database
 621     --pedantic -> Check for overly long lines in verbatim blocks
 622 EOF
 623     }
 624 }
 625
 626 $pedantic = 1 if exists $ENV{PERL_POD_PEDANTIC} and $ENV{PERL_POD_PEDANTIC};
 627 my @files = @ARGV;
 628
 629 my $cpan_or_deltas = $do_upstream_cpan || $do_deltas;
 630 if (($regen + $show_all + $show_counts + $add_link + $cpan_or_deltas ) > 1) {
 631     croak "--regen, --show_all, --counts, and --add_link are mutually exclusive\n and none can be run with --cpan nor --deltas";
 632 }
 633
 634 my $has_input_files = @files;
 635
 636
 637 if ($add_link) {
 638     if (! $has_input_files) {
 639         croak "--add_link requires at least one module or man page reference";
 640     }
 641 }
 642 elsif ($has_input_files) {
 643     if ($regen || $show_counts || $do_upstream_cpan || $do_deltas) {
 644         croak "--regen, --counts, --deltas, and --cpan can't be used since using specific files";
 645     }
 646     foreach my $file (@files) {
 647         croak "Can't read file '$file'" if ! -r $file;
 648     }
 649 }
 650
 651 our %problems;  # potential problems found in this run
 652
 653 package My::Pod::Checker {      # Extend Pod::Checker
 654     use parent 'Pod::Checker';
 655
 656     # Uses inside out hash to protect from typos
 657     # For new fields, remember to add to destructor DESTROY()
 658     my %CFL_text;           # The text comprising the current C<>, F<>, or L<>
 659     my %C_text;             # If defined, are in a C<> section, and includes
 660                             # the accumulated text from that
 661     my %current_indent;     # Current line's indent
 662     my %filename;           # The pod is store in this file
 663     my %in_CFL;             # count of stacked C<>, F<>, L<> directives
 664     my %indents;            # Stack of indents from =over's in effect for
 665                             # current line
 666     my %in_for;             # true if in a =for or =begin
 667     my %in_NAME;            # true if within NAME section
 668     my %in_begin;           # true if within =begin section
 669     my %in_X;               # true if in a X<>
 670     my %linkable_item;      # Bool: if the latest =item is linkable.  It isn't
 671                             # for bullet and number lists
 672     my %linkable_nodes;     # Pod::Checker adds all =items to its node list,
 673                             # but not all =items are linkable to
 674     my %running_CFL_text;   # The current text that is being accumulated until
 675                             # an end_FOO is found, and this includes any C<>,
 676                             # F<>, or L<> directives.
 677     my %running_simple_text; # The currentt text that is being accumulated
 678                             # until an end_FOO is found, and all directives
 679                             # have been expanded into plain text
 680     my %command_count;      # Number of commands seen
 681     my %seen_pod_cmd;       # true if have =pod earlier
 682     my %skip;               # is SKIP set for this pod
 683     my %start_line;         # the first input line number in the the thing
 684                             # currently being worked on
 685
 686     sub DESTROY {
 687         my $addr = Scalar::Util::refaddr $_[0];
 688         delete $CFL_text{$addr};
 689         delete $C_text{$addr};
 690         delete $command_count{$addr};
 691         delete $current_indent{$addr};
 692         delete $filename{$addr};
 693         delete $in_begin{$addr};
 694         delete $in_CFL{$addr};
 695         delete $indents{$addr};
 696         delete $in_for{$addr};
 697         delete $in_NAME{$addr};
 698         delete $in_X{$addr};
 699         delete $linkable_item{$addr};
 700         delete $linkable_nodes{$addr};
 701         delete $running_CFL_text{$addr};
 702         delete $running_simple_text{$addr};
 703         delete $seen_pod_cmd{$addr};
 704         delete $skip{$addr};
 705         delete $start_line{$addr};
 706         return;
 707     }
 708
 709     sub new {
 710         my $class = shift;
 711         my $filename = shift;
 712
 713         my $self = $class->SUPER::new(-quiet => 1,
 714                                      -warnings => $Warnings_Level);
 715         my $addr = Scalar::Util::refaddr $self;
 716         $command_count{$addr} = 0;
 717         $current_indent{$addr} = 0;
 718         $filename{$addr} = $filename;
 719         $in_begin{$addr} = 0;
 720         $in_X{$addr} = 0;
 721         $in_CFL{$addr} = 0;
 722         $in_NAME{$addr} = 0;
 723         $linkable_item{$addr} = 0;
 724         $seen_pod_cmd{$addr} = 0;
 725         return $self;
 726     }
 727
 728     # re's for messages that Pod::Checker outputs
 729     my $location = qr/ \b (?:in|at|on|near) \s+ /xi;
 730     my $optional_location = qr/ (?: $location )? /xi;
 731     my $line_reference = qr/ [('"]? $optional_location \b line \s+
 732                              (?: \d+ | EOF | \Q???\E | - )
 733                              [)'"]? /xi;
 734
 735     sub poderror {  # Called to register a potential problem
 736
 737         # This adds an extra field to the parent hash, 'parameter'.  It is
 738         # used to extract the variable parts of a message leaving just the
 739         # constant skeleton.  This in turn allows the message to be
 740         # categorized better, so that it shows up as a single type in our
 741         # database, with the specifics of each occurrence not being stored with
 742         # it.
 743
 744         my $self = shift;
 745         my $opts = shift;
 746
 747         my $addr = Scalar::Util::refaddr $self;
 748         return if $skip{$addr};
 749
 750         # Input can be a string or hash.  If a string, parse it to separate
 751         # out the line number and convert to a hash for easier further
 752         # processing
 753         my $message;
 754         if (ref $opts ne 'HASH') {
 755             $message = join "", $opts, @_;
 756             my $line_number;
 757             if ($message =~ s/\s*($line_reference)//) {
 758                 ($line_number = $1) =~ s/\s*$optional_location//;
 759             }
 760             else {
 761                 $line_number = '???';
 762             }
 763             $opts = { -msg => $message, -line => $line_number };
 764         } else {
 765             $message = $opts->{'-msg'};
 766
 767         }
 768
 769         $message =~ s/^\d+\s+//;
 770         return if main::suppressed($message);
 771
 772         $self->SUPER::poderror($opts, @_);
 773
 774         $opts->{parameter} = "" unless $opts->{parameter};
 775
 776         # The variable parts of the message tend to be enclosed in '...',
 777         # "....", or (...).  Extract them and put them in an extra field,
 778         # 'parameter'.  This is trickier because the matching delimiter to a
 779         # '(' is its mirror, and not itself.  Text::Balanced could be used
 780         # instead.
 781         while ($message =~ m/ \s* $optional_location ( [('"] )/xg) {
 782             my $delimiter = $1;
 783             my $start = $-[0];
 784             $delimiter = ')' if $delimiter eq '(';
 785
 786             # If there is no ending delimiter, don't consider it to be a
 787             # variable part.  Most likely it is a contraction like "Don't"
 788             last unless $message =~ m/\G .+? \Q$delimiter/xg;
 789
 790             my $length = $+[0] - $start;
 791
 792             # Get the part up through the closing delimiter
 793             my $special = substr($message, $start, $length);
 794             $special =~ s/^\s+//;   # No leading whitespace
 795
 796             # And add that variable part to the parameter, while removing it
 797             # from the message.  This isn't a foolproof way of finding the
 798             # variable part.  For example '(s)' can occur in e.g.,
 799             # 'paragraph(s)'
 800             if ($special ne '(s)') {
 801                 substr($message, $start, $length) = "";
 802                 pos $message = $start;
 803                 $opts->{-msg} = $message;
 804                 $opts->{parameter} .= " " if $opts->{parameter};
 805                 $opts->{parameter} .= $special;
 806             }
 807         }
 808
 809         # Extract any additional line number given.  This is often the
 810         # beginning location of something whereas the main line number gives
 811         # the ending one.
 812         if ($message =~ /( $line_reference )/xi) {
 813             my $line_ref = $1;
 814             while ($message =~ s/\s*\Q$line_ref//) {
 815                 $opts->{-msg} = $message;
 816                 $opts->{parameter} .= " " if $opts->{parameter};
 817                 $opts->{parameter} .= $line_ref;
 818             }
 819         }
 820
 821         Carp::carp("Couldn't extract line number from '$message'") if $message =~ /line \d+/;
 822         push @{$problems{$filename{$addr}}{$message}}, $opts;
 823         #push @{$problems{$self->get_filename}{$message}}, $opts;
 824     }
 825
 826     # In the next subroutines, we keep track of the text of the current
 827     # innermost thing, like F<fooC<bar>baz>.  The things we care about raising
 828     # messages about in this program all come from a single sequence of
 829     # characters uninterrupted by other pod commands.  Therefore we don't have
 830     # to worry about recursion, and we can just set the string we care about
 831     # to empty on entrance to each command.
 832
 833     sub handle_text {
 834         # This is called by the parent class to deal with any straight text.
 835         # We mostly just append this to the running current value which will
 836         # be dealt with upon the end of the current construct, like a
 837         # paragraph.  But certain things don't contribute to checking the pod
 838         # and are ignored.  We also have set flags to indicate this text is
 839         # going towards constructing certain constructs, and handle those
 840         # specially.
 841
 842         my $self = shift;
 843         my $addr = Scalar::Util::refaddr $self;
 844
 845         my $return = $self->SUPER::handle_text(@_);
 846
 847         if ($in_X{$addr} || $in_for{$addr}) { # ignore
 848             return $return;
 849         }
 850
 851         my $text = join "\n", @_;
 852         $running_simple_text{$addr} .= $text;
 853
 854         # Keep separate tabs on C<>, F<>, and L<> directives, and one
 855         # especially for C<> ones.
 856         if ($in_CFL{$addr}) {
 857             $CFL_text{$addr} .= $text;
 858             $C_text{$addr} .= $text if defined $C_text{$addr};
 859         }
 860         else {
 861             # This variable is updated instead in the corresponding C, F, or L
 862             # handler.
 863             $running_CFL_text{$addr} .= $text;
 864         }
 865
 866         # do this line-by-line so we can get the right line number
 867         my @lines = split /^/, $running_simple_text{$addr};
 868         for my $i (0..$#lines) {
 869             if ($lines[$i] =~ m/\N{REPLACEMENT CHARACTER}/) {
 870                 $self->poderror({ -line => $start_line{$addr} + $i,
 871                     -msg => $replacement_character,
 872                     parameter => "possibly invalid ". $self->encoding . " input at character " . pos $lines[$i],
 873                 });
 874             }
 875         }
 876         return $return;
 877     }
 878
 879     # The start_FOO routines check that somehow a C<> construct hasn't escaped
 880     # without being checked, and initialize things, and call the parent
 881     # class's equivalent routine.
 882
 883     # The end_FOO routines close things off, and check the text that has been
 884     # accumulated for FOO, then call the parent's corresponding routine.
 885
 886     sub start_Para {
 887         my $self = shift;
 888         check_see_but_not_link($self);
 889
 890         my $addr = Scalar::Util::refaddr $self;
 891         $start_line{$addr} = $_[0]->{start_line};
 892         $running_CFL_text{$addr} = "";
 893         $running_simple_text{$addr} = "";
 894         return $self->SUPER::start_Para(@_);
 895     }
 896
 897     sub start_item_text {
 898         my $self = shift;
 899         check_see_but_not_link($self);
 900
 901         my $addr = Scalar::Util::refaddr $self;
 902         $start_line{$addr} = $_[0]->{start_line};
 903         $running_CFL_text{$addr} = "";
 904         $running_simple_text{$addr} = "";
 905
 906         # This is the only =item that is linkable
 907         $linkable_item{$addr} = 1;
 908
 909         return $self->SUPER::start_item_text(@_);
 910     }
 911
 912     sub start_item_number {
 913         my $self = shift;
 914         check_see_but_not_link($self);
 915
 916         my $addr = Scalar::Util::refaddr $self;
 917         $start_line{$addr} = $_[0]->{start_line};
 918         $running_CFL_text{$addr} = "";
 919         $running_simple_text{$addr} = "";
 920
 921         return $self->SUPER::start_item_number(@_);
 922     }
 923
 924     sub start_item_bullet {
 925         my $self = shift;
 926         check_see_but_not_link($self);
 927
 928         my $addr = Scalar::Util::refaddr $self;
 929         $start_line{$addr} = $_[0]->{start_line};
 930         $running_CFL_text{$addr} = "";
 931         $running_simple_text{$addr} = "";
 932
 933         return $self->SUPER::start_item_bullet(@_);
 934     }
 935
 936     sub end_item {  # No difference in =item types endings
 937         my $self = shift;
 938         check_see_but_not_link($self);
 939         return $self->SUPER::end_item(@_);
 940     }
 941
 942     sub start_over {
 943         my $self = shift;
 944         check_see_but_not_link($self);
 945
 946         my $addr = Scalar::Util::refaddr $self;
 947         $start_line{$addr} = $_[0]->{start_line};
 948         $running_CFL_text{$addr} = "";
 949         $running_simple_text{$addr} = "";
 950
 951         # Save this indent on a stack, and keep track of total indent
 952         my $indent =  $_[0]{'indent'};
 953         push @{$indents{$addr}}, $indent;
 954         $current_indent{$addr} += $indent;
 955
 956         return $self->SUPER::start_over(@_);
 957     }
 958
 959     sub end_over_bullet { shift->end_over(@_) }
 960     sub end_over_number { shift->end_over(@_) }
 961     sub end_over_text   { shift->end_over(@_) }
 962     sub end_over_block  { shift->end_over(@_) }
 963     sub end_over_empty  { shift->end_over(@_) }
 964     sub end_over {
 965         my $self = shift;
 966         check_see_but_not_link($self);
 967
 968         my $addr = Scalar::Util::refaddr $self;
 969
 970         # Pop current indent
 971         if (@{$indents{$addr}}) {
 972             $current_indent{$addr} -= pop @{$indents{$addr}};
 973         }
 974         else {
 975             # =back without corresponding =over, but should have
 976             # warned already
 977             $current_indent{$addr} = 0;
 978         }
 979     }
 980
 981     sub check_see_but_not_link {
 982
 983         # Looks through accumulated text for current element that includes the
 984         # C<>, F<>, and L<> directives for ones that look like they are
 985         # C<link> instead of L<link>.
 986
 987         my $self = shift;
 988         my $addr = Scalar::Util::refaddr $self;
 989
 990         return unless defined $running_CFL_text{$addr};
 991
 992         while ($running_CFL_text{$addr} =~ m{
 993                                 ( (?: \w+ \s+ )* )  # The phrase before, if any
 994                                 \b [Ss]ee \s+
 995                                 ( ( [^L] )
 996                                   <
 997                                   ( [^<]*? )  # The not < excludes nested C<L<...
 998                                   >
 999                                 )
1000                                 ( \s+ (?: under | in ) \s+ L< )?
1001                             }xg)
1002         {
1003             my $prefix = $1 // "";
1004             my $construct = $2;     # The whole thing, like C<...>
1005             my $type = $3;
1006             my $interior = $4;
1007             my $trailing = $5;      # After the whole thing ending in "L<"
1008
1009             # If the full phrase is something like, "you might see C<", or
1010             # similar, it really isn't a reference to a link.  The ones I saw
1011             # all had the word "you" in them; and the "you" wasn't the
1012             # beginning of a sentence.
1013             if ($prefix !~ / \b you \b /x) {
1014
1015                 # Now, find what the module or man page name within the
1016                 # construct would be if it actually has L<> syntax.  If it
1017                 # doesn't have that syntax, will set the module to the entire
1018                 # interior.
1019                 if (! defined $trailing # not referring to something in another
1020                                         # section
1021                     && $interior !~ /$non_pods/
1022
1023                     # There can't be spaces (I think) in module names or man
1024                     # pages
1025                     && $interior !~ / \s /x
1026
1027                     # F<> that end in eg \.pl are almost certainly ok, as are
1028                     # those that look like a path with multiple "/" chars
1029                     && ($type ne "F"
1030                         || (! -e $interior
1031                             && $interior !~ /\.\w+$/
1032                             && $interior !~ /\/.+\//)
1033                     )
1034                 ) {
1035                     # TODO: move the checking of $pedantic higher up
1036                     $self->poderror({ -line => $start_line{$addr},
1037                         -msg => $C_not_linked,
1038                         parameter => $construct
1039                     });
1040                 }
1041             }
1042         }
1043
1044         undef $running_CFL_text{$addr};
1045     }
1046
1047     sub end_Para {
1048         my $self = shift;
1049         check_see_but_not_link($self);
1050
1051         my $addr = Scalar::Util::refaddr $self;
1052         if ($in_NAME{$addr}) {
1053             if ($running_simple_text{$addr} =~ /^\s*(\S+?)\s*$/) {
1054                 $self->poderror({ -line => $start_line{$addr},
1055                     -msg => $missing_name_description,
1056                     parameter => $1});
1057             }
1058             $in_NAME{$addr} = 0;
1059         }
1060         $self->SUPER::end_Para(@_);
1061     }
1062
1063     sub start_head1 {
1064         my $self = shift;
1065         check_see_but_not_link($self);
1066
1067         my $addr = Scalar::Util::refaddr $self;
1068         $start_line{$addr} = $_[0]->{start_line};
1069         $running_CFL_text{$addr} = "";
1070         $running_simple_text{$addr} = "";
1071
1072         return $self->SUPER::start_head1(@_);
1073     }
1074
1075     sub end_head1 {  # This is called at the end of the =head line.
1076         my $self = shift;
1077         check_see_but_not_link($self);
1078
1079         my $addr = Scalar::Util::refaddr $self;
1080
1081         $in_NAME{$addr} = 1 if $running_simple_text{$addr} eq 'NAME';
1082         return $self->SUPER::end_head(@_);
1083     }
1084
1085     sub start_Verbatim {
1086         my $self = shift;
1087         check_see_but_not_link($self);
1088
1089         my $addr = Scalar::Util::refaddr $self;
1090         $running_simple_text{$addr} = "";
1091         $start_line{$addr} = $_[0]->{start_line};
1092         return $self->SUPER::start_Verbatim(@_);
1093     }
1094
1095     sub end_Verbatim {
1096         my $self = shift;
1097         my $addr = Scalar::Util::refaddr $self;
1098
1099         # Pick up the name if it looks like one, since the parent class
1100         # doesn't handle verbatim NAMEs
1101         if ($in_NAME{$addr}
1102             && $running_simple_text{$addr} =~ /^\s*(\S+?)\s*[,-]/)
1103         {
1104             $self->name($1);
1105         }
1106
1107         my $indent = $self->get_current_indent;
1108
1109         # Look at each line to verify it is short enough
1110         my @lines = split /^/, $running_simple_text{$addr};
1111         for my $i (0 .. @lines - 1) {
1112             $lines[$i] =~ s/\s+$//;
1113             my $exceeds = length(Text::Tabs::expand($lines[$i]))
1114                         + $indent - $MAX_LINE_LENGTH;
1115             next unless $exceeds > 0;
1116
1117             $self->poderror({ -line => $start_line{$addr} + $i,
1118                 -msg => $line_length,
1119                 parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
1120             });
1121         }
1122
1123         undef $running_simple_text{$addr};
1124
1125         # Parent class didn't bother to define this
1126         #return $self->SUPER::SUPER::end_Verbatim(@_);
1127     }
1128
1129     sub start_C {
1130         my $self = shift;
1131         my $addr = Scalar::Util::refaddr $self;
1132
1133         $C_text{$addr} = "";
1134
1135         # If not in a stacked set of C<>, F<> and L<>, initialize the text for
1136         # them.
1137         $CFL_text{$addr} = "" if ! $in_CFL{$addr};
1138         $in_CFL{$addr}++;
1139
1140         return $self->SUPER::start_C(@_);
1141     }
1142
1143     sub start_F {
1144         my $self = shift;
1145         my $addr = Scalar::Util::refaddr $self;
1146
1147         $CFL_text{$addr} = "" if ! $in_CFL{$addr};
1148         $in_CFL{$addr}++;
1149         return $self->SUPER::start_F(@_);
1150     }
1151
1152     sub start_L {
1153         my $self = shift;
1154         my $addr = Scalar::Util::refaddr $self;
1155
1156         $CFL_text{$addr} = "" if ! $in_CFL{$addr};
1157         $in_CFL{$addr}++;
1158         return $self->SUPER::start_L(@_);
1159     }
1160
1161     sub end_C {
1162         my $self = shift;
1163         my $addr = Scalar::Util::refaddr $self;
1164
1165         # Warn if looks like a file or link enclosed instead by this C<>
1166         if ($C_text{$addr} =~ qr/^ $C_path_re $/x) {
1167             # Here it does look like it could be be a file path or a link.
1168             # But some varieties of regex patterns could also fit with what we
1169             # have so far.  Weed those out as best we can.  '/foo/' is almost
1170             # certainly meant to be a pattern, as is '/foo/g'.
1171             my $is_pattern;
1172             if ($C_text{$addr} !~ qr| ^ / [^/]* / ( [msixpodualngcr]* ) $ |x) {
1173                 $is_pattern = 0;
1174             }
1175             else {
1176
1177                 # Here, it looks like a pattern potentially followed by some
1178                 # modifiers.  To make doubly sure, don't count as patterns
1179                 # those constructs which have more occurrences (generally 1)
1180                 # of a modifier than is legal.
1181                 my %counts;
1182                 map { $counts{$_}++ } split "", $1;
1183                 foreach my $modifier (keys %counts) {
1184                     if ($counts{$modifier} > (($modifier eq 'a')
1185                                               ? 2
1186                                               : 1))
1187                     {
1188                         $is_pattern = 0;
1189                         last;
1190                     }
1191                 }
1192                 $is_pattern = 1 unless defined $is_pattern;
1193             }
1194
1195             unless ($is_pattern) {
1196                 $self->poderror({ -line => $start_line{$addr},
1197                     -msg => $C_with_slash,
1198                     parameter => "C<$C_text{$addr}>"
1199                 });
1200             }
1201         }
1202         undef $C_text{$addr};
1203
1204         # Add the current text to the running total.  This was not done in
1205         # handle_text(), because it just sees the plain text of the innermost
1206         # stacked directive.  We want to keep all the directive names
1207         # enclosing the text.  Otherwise the fact that C<L<foobar>> is to a
1208         # link would be lost, as the L<> would be gone.
1209         $CFL_text{$addr} = "C<$CFL_text{$addr}>";
1210
1211         # Add this text to the the whole running total only if popping this
1212         # directive off the stack leaves it empty.  As long as something is on
1213         # the stack, it gets added to $CFL_text (just above).  It is only
1214         # entirely constructed when the stack is empty.
1215         $in_CFL{$addr}--;
1216         $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
1217
1218         return $self->SUPER::end_C(@_);
1219     }
1220
1221     sub end_F {
1222         my $self = shift;
1223         my $addr = Scalar::Util::refaddr $self;
1224
1225         $CFL_text{$addr} = "F<$CFL_text{$addr}>";
1226         $in_CFL{$addr}--;
1227         $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
1228         return $self->SUPER::end_F(@_);
1229     }
1230
1231     sub end_L {
1232         my $self = shift;
1233         my $addr = Scalar::Util::refaddr $self;
1234
1235         $CFL_text{$addr} = "L<$CFL_text{$addr}>";
1236         $in_CFL{$addr}--;
1237         $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
1238         return $self->SUPER::end_L(@_);
1239     }
1240
1241     sub start_X {
1242         my $self = shift;
1243         my $addr = Scalar::Util::refaddr $self;
1244
1245         $in_X{$addr} = 1;
1246         return $self->SUPER::start_X(@_);
1247     }
1248
1249     sub end_X {
1250         my $self = shift;
1251         my $addr = Scalar::Util::refaddr $self;
1252
1253         $in_X{$addr} = 0;
1254         return $self->SUPER::end_X(@_);
1255     }
1256
1257     sub start_for {
1258         my $self = shift;
1259         my $addr = Scalar::Util::refaddr $self;
1260
1261         $in_for{$addr} = 1;
1262         return $self->SUPER::start_for(@_);
1263     }
1264
1265     sub end_for {
1266         my $self = shift;
1267         my $addr = Scalar::Util::refaddr $self;
1268
1269         $in_for{$addr} = 0;
1270         return $self->SUPER::end_for(@_);
1271     }
1272
1273     sub hyperlink {
1274         my ($self, $link) = @_;
1275
1276         if ($link && $link->type eq 'pod') {
1277             my $page = $link->page;
1278             my $node = $link->node;
1279
1280             # If the hyperlink is to an interior node of another page, save it
1281             # so that we can see if we need to parse normally skipped files.
1282             $has_referred_to_node{$page} = 1 if $node;
1283
1284             # Ignore certain placeholder links in perldelta.  Check if the
1285             # link is page-level, and also check if to a node within the page
1286             if (   $self->name && $self->name eq "perldelta"
1287                 && ((  grep { $page eq $_ } @perldelta_ignore_links)
1288                     || (   $node
1289                         && (grep { "$page/$node" eq $_ } @perldelta_ignore_links)
1290             ))) {
1291                 return;
1292             }
1293         }
1294
1295         return $self->SUPER::hyperlink($link);
1296     }
1297
1298     sub node {
1299         my $self = shift;
1300         my $text = $_[0];
1301         if($text) {
1302             $text =~ s/\s+$//s; # strip trailing whitespace
1303             $text =~ s/\s+/ /gs; # collapse whitespace
1304             my $addr = Scalar::Util::refaddr $self;
1305             push(@{$linkable_nodes{$addr}}, $text) if
1306                                     ! $current_indent{$addr}
1307                                     || $linkable_item{$addr};
1308         }
1309         return $self->SUPER::node($_[0]);
1310     }
1311
1312     sub get_current_indent {
1313         return $INDENT + $current_indent{Scalar::Util::refaddr $_[0]};
1314     }
1315
1316     sub get_filename {
1317         return $filename{Scalar::Util::refaddr $_[0]};
1318     }
1319
1320     sub linkable_nodes {
1321         my $linkables = $linkable_nodes{Scalar::Util::refaddr $_[0]};
1322         return undef unless $linkables;
1323         return @$linkables;
1324     }
1325
1326     sub get_skip {
1327         return $skip{Scalar::Util::refaddr $_[0]} // 0;
1328     }
1329
1330     sub set_skip {
1331         my $self = shift;
1332         $skip{Scalar::Util::refaddr $self} = shift;
1333
1334         # If skipping, no need to keep the problems for it
1335         delete $problems{$self->get_filename};
1336         return;
1337     }
1338
1339     sub parse_from_file {
1340         # This overrides the super class method so that if an open fails on a
1341         # transitory file, it doesn't croak.  It returns 1 if it did find the
1342         # file, 0 if it didn't
1343
1344         my $self = shift;
1345         my $filename = shift;
1346         # ignores 2nd param, which is output file.  Always uses undef
1347
1348         if (open my $in_fh, '<:bytes', $filename) {
1349             $self->SUPER::parse_from_file($in_fh, undef);
1350             close $in_fh;
1351             return 1;
1352         }
1353
1354         # If couldn't open file, perhaps it was transitory, and hence not an error
1355         return 0 unless -e $filename;
1356
1357         die "Can't open '$filename': $!\n";
1358     }
1359 }
1360
1361 package Tie_Array_to_FH {  # So printing actually goes to an array
1362
1363     my %array;
1364
1365     sub TIEHANDLE {
1366         my $class = shift;
1367         my $array_ref = shift;
1368
1369         my $self = bless \do{ my $anonymous_scalar }, $class;
1370         $array{Scalar::Util::refaddr $self} = $array_ref;
1371
1372         return $self;
1373     }
1374
1375     sub PRINT {
1376         my $self = shift;
1377         push @{$array{Scalar::Util::refaddr $self}}, @_;
1378         return 1;
1379     }
1380 }
1381
1382
1383 my %filename_to_checker; # Map a filename to its pod checker object
1384 my %id_to_checker;       # Map a checksum to its pod checker object
1385 my %nodes;               # key is filename, values are nodes in that file.
1386 my %nodes_first_word;    # same, but value is first word of each node
1387 my %valid_modules;       # List of modules known to exist outside us.
1388 my %digests;             # checksums of files, whose names are the keys
1389 my %filename_to_pod;     # Map a filename to its pod NAME
1390 my %files_with_unknown_issues;
1391 my %files_with_fixes;
1392
1393 my $data_fh;
1394 open $data_fh, '<:bytes', $known_issues or die "Can't open $known_issues";
1395
1396 my %counts; # For --counts param, count of each issue type
1397 my %suppressed_files;   # Files with at least one issue type to suppress
1398 my $HEADER = <<END;
1399 # This file is the data file for $0.
1400 # There are three types of lines.
1401 # Comment lines are white-space only or begin with a '#', like this one.  Any
1402 #   changes you make to the comment lines will be lost when the file is
1403 #   regen'd.
1404 # Lines without tab characters are simply NAMES of pods that the program knows
1405 #   will have links to them and the program does not check if those links are
1406 #   valid.
1407 # All other lines should have three fields, each separated by a tab.  The
1408 #   first field is the name of a pod; the second field is an error message
1409 #   generated by this program; and the third field is a count of how many
1410 #   known instances of that message there are in the pod.  -1 means that the
1411 #   program can expect any number of this type of message.
1412 END
1413
1414 my @existing_issues;
1415
1416
1417 while (<$data_fh>) {    # Read the database
1418     chomp;
1419     next if /^\s*(?:#|$)/;  # Skip comment and empty lines
1420     if (/\t/) {
1421         next if $show_all;
1422         if ($add_link) {    # The issues are saved and later output unchanged
1423             push @existing_issues, $_;
1424             next;
1425         }
1426
1427         # Keep track of counts of each issue type for each file
1428         my ($filename, $message, $count) = split /\t/;
1429         $known_problems{$filename}{$message} = $count;
1430
1431         if ($show_counts) {
1432             if ($count < 0) {   # -1 means to suppress this issue type
1433                 $suppressed_files{$filename} = $filename;
1434             }
1435             else {
1436                 $counts{$message} += $count;
1437             }
1438         }
1439     }
1440     else {  # Lines without a tab are modules known to be valid
1441         $valid_modules{$_} = 1
1442     }
1443 }
1444 close $data_fh;
1445
1446 if ($add_link) {
1447     $copy_fh = open_new($known_issues);
1448
1449     # Check for basic sanity, and add each command line argument
1450     foreach my $module (@files) {
1451         die "\"$module\" does not look like a module or man page"
1452             # Must look like (A or A::B or A::B::C ..., or foo(3C)
1453             if $module !~ /^ (?: \w+ (?: :: \w+ )* | \w+ \( \d \w* \) ) $/x;
1454         $valid_modules{$module} = 1
1455     }
1456     my_safer_print($copy_fh, $HEADER);
1457     foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
1458         my_safer_print($copy_fh, $_, "\n");
1459     }
1460
1461     # The rest of the db file is output unchanged.
1462     my_safer_print($copy_fh, join "\n", @existing_issues, "");
1463
1464     close_and_rename($copy_fh);
1465     exit;
1466 }
1467
1468 if ($show_counts) {
1469     my $total = 0;
1470     foreach my $message (sort keys %counts) {
1471         $total += $counts{$message};
1472         note(Text::Tabs::expand("$counts{$message}\t$message"));
1473     }
1474     note("-----\n" . Text::Tabs::expand("$total\tknown potential issues"));
1475     if (%suppressed_files) {
1476         note("\nFiles that have all messages of at least one type suppressed:");
1477         note(join ",", keys %suppressed_files);
1478     }
1479     exit 0;
1480 }
1481
1482 # re to match files that are to be parsed only if there is an internal link
1483 # to them.  It does not include cpan, as whether those are parsed depends
1484 # on a switch.  Currently, only perltoc and the stable perldelta.pod's
1485 # are included.  The latter all have characters between 'perl' and
1486 # 'delta'.  (Actually the currently developed one matches as well, but
1487 # is a duplicate of perldelta.pod, so can be skipped, so fine for it to
1488 # match this.
1489 my $only_for_interior_links_re = qr/ ^ pod\/perltoc.pod $
1490                                    /x;
1491 unless ($do_deltas) {
1492     $only_for_interior_links_re = qr/$only_for_interior_links_re |
1493                                     \b perl \d+ delta \. pod \b
1494                                 /x;
1495 }
1496
1497 { # Closure
1498     my $first_time = 1;
1499
1500     sub output_thanks ($$$$) {  # Called when an issue has been fixed
1501         my $filename = shift;
1502         my $original_count = shift;
1503         my $current_count = shift;
1504         my $message = shift;
1505
1506         $files_with_fixes{$filename} = 1;
1507         my $return;
1508         my $fixed_count = $original_count - $current_count;
1509         my $a_problem = ($fixed_count == 1) ? "a problem" : "multiple problems";
1510         my $another_problem = ($fixed_count == 1) ? "another problem" : "another set of problems";
1511         my $diff;
1512         if ($message) {
1513             $diff = <<EOF;
1514 There were $original_count occurrences (now $current_count) in this pod of type
1515 "$message",
1516 EOF
1517         } else {
1518             $diff = <<EOF;
1519 There are no longer any problems found in this pod!
1520 EOF
1521         }
1522
1523         if ($first_time) {
1524             $first_time = 0;
1525             $return = <<EOF;
1526 Thanks for fixing $a_problem!
1527 $diff
1528 Now you must teach $0 that this was fixed.
1529 EOF
1530         }
1531         else {
1532             $return = <<EOF
1533 Thanks for fixing $another_problem.
1534 $diff
1535 EOF
1536         }
1537
1538         return $return;
1539     }
1540 }
1541
1542 sub my_safer_print {    # print, with error checking for outputting to db
1543     my ($fh, @lines) = @_;
1544
1545     if (! print $fh @lines) {
1546         my $save_error = $!;
1547         close($fh);
1548         die "Write failure: $save_error";
1549     }
1550 }
1551
1552 sub extract_pod {   # Extracts just the pod from a file; returns undef if file
1553                     # doesn't exist
1554     my $filename = shift;
1555     use Pod::Parser;
1556
1557     my @pod;
1558
1559     # Arrange for the output of Pod::Parser to be collected in an array we can
1560     # look at instead of being printed
1561     tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
1562     if (open my $in_fh, '<:bytes', $filename) {
1563         my $parser = Pod::Parser->new();
1564         $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
1565         close $in_fh;
1566
1567         return join "", @pod
1568     }
1569
1570     # The file should already have been opened once to get here, so if that
1571     # fails, something is wrong.  It's possible that a transitory file
1572     # containing a pod would get here, so if the file no longer exists just
1573     # return undef.
1574     return unless -e $filename;
1575     die "Can't open '$filename': $!\n";
1576 }
1577
1578 my $digest = Digest->new($digest_type);
1579
1580 # This is used as a callback from File::Find::find(), which always constructs
1581 # pathnames using Unix separators
1582 sub is_pod_file {
1583     # If $_ is a pod file, add it to the lists and do other prep work.
1584
1585     if (-d) {
1586         # Don't look at files in directories that are for tests, nor those
1587         # beginning with a dot
1588         if (m!/t\z! || m!/\.!) {
1589             $File::Find::prune = 1;
1590         }
1591         return;
1592     }
1593
1594     return unless -r && -s;    # Can't check it if can't read it; no need to
1595                                # check if 0 length
1596     return unless -f || -l;    # Weird file types won't be pods
1597
1598     my ($leaf) = m!([^/]+)\z!;
1599     if (m!/\.!                 # No hidden Unix files
1600         || $leaf =~ $non_pods) {
1601         note("Not considering $_") if DEBUG;
1602         return;
1603     }
1604
1605     my $filename = $File::Find::name;
1606
1607     # $filename is relative, like './path'.  Strip that initial part away.
1608     $filename =~ s!^\./!! or die 'Unexpected pathname "$filename"';
1609
1610     return if $excluded_files{canonicalize($filename)};
1611
1612     my $contents = do {
1613         local $/;
1614         my $candidate;
1615         if (! open $candidate, '<:bytes', $_) {
1616
1617             # If a transitory file was found earlier, the open could fail
1618             # legitimately and we just skip the file; also skip it if it is a
1619             # broken symbolic link, as it is probably just a build problem;
1620             # certainly not a file that we would want to check the pod of.
1621             # Otherwise fail it here and no reason to process it further.
1622             # (But the test count will be off too)
1623             ok(0, "Can't open '$filename': $!")
1624                                             if -r $filename && ! -l $filename;
1625             return;
1626         }
1627         <$candidate>;
1628     };
1629
1630     # If the file is a .pm or .pod, having any initial '=' on a line is
1631     # grounds for testing it.  Otherwise, require a head1 NAME line to
1632     # consider it as a potential pod
1633     if ($filename =~ /\.(?:pm|pod)/) {
1634         return unless $contents =~ /^=/m;
1635     } else {
1636         return unless $contents =~ /^=head1 +NAME/m;
1637     }
1638
1639     # Here, we know that the file is a pod.  Add it to the list of files
1640     # to check and create a checker object for it.
1641
1642     push @files, $filename;
1643     my $checker = My::Pod::Checker->new($filename);
1644     $filename_to_checker{$filename} = $checker;
1645
1646     # In order to detect duplicate pods and only analyze them once, we
1647     # compute checksums for the file, so don't have to do an exact
1648     # compare.  Note that if the pod is just part of the file, the
1649     # checksums can differ for the same pod.  That special case is handled
1650     # later, since if the checksums of the whole file are the same, that
1651     # case won't even come up.  We don't need the checksums for files that
1652     # we parse only if there is a link to its interior, but we do need its
1653     # NAME, which is also retrieved in the code below.
1654
1655     if ($filename =~ / (?: ^(cpan|lib|ext|dist)\/ )
1656                         | $only_for_interior_links_re
1657                     /x) {
1658         $digest->add($contents);
1659         $digests{$filename} = $digest->digest;
1660
1661         # lib files aren't analyzed if they are duplicates of files copied
1662         # there from some other directory.  But to determine this, we need
1663         # to know their NAMEs.  We might as well find the NAME now while
1664         # the file is open.  Similarly, cpan files aren't analyzed unless
1665         # we're analyzing all of them, or this particular file is linked
1666         # to by a file we are analyzing, and thus we will want to verify
1667         # that the target exists in it.  We need to know at least the NAME
1668         # to see if it's worth analyzing, or so we can determine if a lib
1669         # file is a copy of a cpan one.
1670         if ($filename =~ m{ (?: ^ (?: cpan | lib ) / )
1671                             | $only_for_interior_links_re
1672                             }x) {
1673             if ($contents =~ /^=head1 +NAME.*/mg) {
1674                 # The NAME is the first non-spaces on the line up to a
1675                 # comma, dash or end of line.  Otherwise, it's invalid and
1676                 # this pod doesn't have a legal name that we're smart
1677                 # enough to find currently.  But the  parser will later
1678                 # find it if it thinks there is a legal name, and set the
1679                 # name
1680                 if ($contents =~ /\G    # continue from the line after =head1
1681                                   \s*   # ignore any empty lines
1682
1683                                   # ignore =for paragraphs followed by empty
1684                                   # lines
1685                                   (?: ^ =for .*? \n (?: [^\s]*? \n )* \s* )*
1686
1687                                   ^ \s* ( \S+?) \s* (?: [,-] | $ )/mx) {
1688                     my $name = $1;
1689                     $checker->name($name);
1690                     $id_to_checker{$name} = $checker
1691                         if $filename =~ m{^cpan/};
1692                 }
1693             }
1694             elsif ($filename =~ m{^cpan/}) {
1695                 $id_to_checker{$digests{$filename}} = $checker;
1696             }
1697         }
1698     }
1699
1700     return;
1701 } # End of is_pod_file()
1702
1703 # Start of real code that isn't processing the command line (except the
1704 # db is read in above, as is processing of the --add_link option).
1705 # Here, @files contains list of files on the command line.  If have any of
1706 # these, unconditionally test them, and show all the errors, even the known
1707 # ones, and, since not testing other pods, don't do cross-pod link tests.
1708 # (Could add extra code to do cross-pod tests for the ones in the list.)
1709
1710 if ($has_input_files) {
1711     undef %known_problems;
1712     $do_upstream_cpan = $do_deltas = 1;  # In case one of the inputs is one
1713                                          # of these types
1714 }
1715 else { # No input files -- go find all the possibilities.
1716     if ($regen) {
1717         $copy_fh = open_new($known_issues);
1718         note("Regenerating $known_issues, please be patient...");
1719         print $copy_fh $HEADER;
1720     }
1721
1722     # Move to the directory above us, but have to adjust @INC to account for
1723     # that.
1724     s{^\.\./lib$}{lib} for @INC;
1725     chdir File::Spec->updir;
1726
1727     # And look in this directory and all its subdirectories
1728     find( {wanted => \&is_pod_file, no_chdir => 1}, '.');
1729
1730     # Add ourselves to the test
1731     push @files, "t/porting/podcheck.t";
1732 }
1733
1734 # Now we know how many tests there will be.
1735 plan (tests => scalar @files) if ! $regen;
1736
1737
1738 # Sort file names so we get consistent results, and to put cpan last,
1739 # preceded by the ones that we don't generally parse.  This is because both
1740 # these classes are generally parsed only if there is a link to the interior
1741 # of them, and we have to parse all others first to guarantee that they don't
1742 # have such a link. 'lib' files come just before these, as some of these are
1743 # duplicates of others.  We already have figured this out when gathering the
1744 # data as a special case for all such files, but this, while unnecessary,
1745 # puts the derived file last in the output.  'readme' files come before those,
1746 # as those also could be duplicates of others, which are considered the
1747 # primary ones.  These currently aren't figured out when gathering data, so
1748 # are done here.
1749 @files = sort { if ($a =~ /^cpan/) {
1750                    return 1 if $b !~ /^cpan/;
1751                    return lc $a cmp lc $b;
1752                }
1753                elsif ($b =~ /^cpan/) {
1754                    return -1;
1755                }
1756                elsif ($a =~ /$only_for_interior_links_re/) {
1757                    return 1 if $b !~ /$only_for_interior_links_re/;
1758                    return lc $a cmp lc $b;
1759                }
1760                elsif ($b =~ /$only_for_interior_links_re/) {
1761                    return -1;
1762                }
1763                elsif ($a =~ /^lib/) {
1764                    return 1 if $b !~ /^lib/;
1765                    return lc $a cmp lc $b;
1766                }
1767                elsif ($b =~ /^lib/) {
1768                    return -1;
1769                } elsif ($a =~ /\breadme\b/i) {
1770                    return 1 if $b !~ /\breadme\b/i;
1771                    return lc $a cmp lc $b;
1772                }
1773                elsif ($b =~ /\breadme\b/i) {
1774                    return -1;
1775                }
1776                else {
1777                    return lc $a cmp lc $b;
1778                }
1779            }
1780            @files;
1781
1782 # Now go through all the files and parse them
1783 FILE:
1784 foreach my $filename (@files) {
1785     my $parsed = 0;
1786     note("parsing $filename") if DEBUG;
1787
1788     # We may have already figured out some things in the process of generating
1789     # the file list.  If so, we have a $checker object already.  But if not,
1790     # generate one now.
1791     my $checker = $filename_to_checker{$filename};
1792     if (! $checker) {
1793         $checker = My::Pod::Checker->new($filename);
1794         $filename_to_checker{$filename} = $checker;
1795     }
1796
1797     # We have set the name in the checker object if there is a possibility
1798     # that no further parsing is necessary, but otherwise do the parsing now.
1799     if (! $checker->name) {
1800         if (! $checker->parse_from_file($filename, undef)) {
1801             $checker->set_skip("$filename is transitory");
1802             next FILE;
1803         }
1804         $parsed = 1;
1805
1806     }
1807
1808     if ($checker->num_errors() < 0) {   # Returns negative if not a pod
1809         $checker->set_skip("$filename is not a pod");
1810     }
1811     else {
1812
1813         # Here, is a pod.  See if it is one that has already been tested,
1814         # or should be tested under another directory.  Use either its NAME
1815         # if it has one, or a checksum if not.
1816         my $name = $checker->name;
1817         my $id;
1818
1819         if ($name) {
1820             $id = $name;
1821         }
1822         else {
1823             my $digest = Digest->new($digest_type);
1824             my $contents = extract_pod($filename);
1825
1826             # If the return is undef, it means that $filename was a transitory
1827             # file; skip it.
1828             next FILE unless defined $contents;
1829             $digest->add($contents);
1830             $id = $digest->digest;
1831         }
1832
1833         # If there is a match for this pod with something that we've already
1834         # processed, don't process it, and output why.
1835         my $prior_checker;
1836         if (defined ($prior_checker = $id_to_checker{$id})
1837             && $prior_checker != $checker)  # Could have defined the checker
1838                                             # earlier without pursuing it
1839         {
1840
1841             # If the pods are identical, then it's just a copy, and isn't an
1842             # error.  First use the checksums we have already computed to see
1843             # if the entire files are identical, which means that the pods are
1844             # identical too.
1845             my $prior_filename = $prior_checker->get_filename;
1846             my $same = (! $name
1847                         || ($digests{$prior_filename}
1848                             && $digests{$filename}
1849                             && $digests{$prior_filename} eq $digests{$filename}));
1850
1851             # If they differ, it could be that the files differ for some
1852             # reason, but the pods they contain are identical.  Extract the
1853             # pods and do the comparisons on just those.
1854             if (! $same && $name) {
1855                 my $contents = extract_pod($filename);
1856
1857                 # If return is <undef>, it means that $filename no longer
1858                 # exists.  This means it was a transitory file, and should not
1859                 # be tested.
1860                 next FILE unless defined $contents;
1861
1862                 my $prior_contents = extract_pod($prior_filename);
1863
1864                 # If return is <undef>, it means that $prior_filename no
1865                 # longer exists.  This means it was a transitory file, and
1866                 # should not have been tested, but we already did process it.
1867                 # What we should do now is to back-out its records, and
1868                 # process $filename in its stead.  But backing out is not so
1869                 # simple, and so I'm (khw) skipping that unless and until
1870                 # experience shows that it is needed.  We do go process
1871                 # $filename, and there are potential false positive conflicts
1872                 # with the transitory $prior_contents, and rerunning the test
1873                 # should cause it to succeed.
1874                 goto process_this_pod unless defined $prior_contents;
1875
1876                 $same = $prior_contents eq $contents;
1877             }
1878
1879             use File::Basename 'basename';
1880             if ($same) {
1881                 $checker->set_skip("The pod of $filename is a duplicate of "
1882                                     . "the pod for $prior_filename");
1883             } elsif ($prior_filename =~ /\breadme\b/i) {
1884                 $checker->set_skip("$prior_filename is a README apparently for $filename");
1885             } elsif ($filename =~ /\breadme\b/i) {
1886                 $checker->set_skip("$filename is a README apparently for $prior_filename");
1887             } elsif (! $do_upstream_cpan
1888                      && $filename =~ /^cpan/
1889                      && $prior_filename =~ /^cpan/)
1890             {
1891                 $checker->set_skip("CPAN is upstream for $filename");
1892             } elsif ( $filename =~ /^utils/ or $prior_filename =~ /^utils/ ) {
1893                 $checker->set_skip("$filename copy is in utils/");
1894             } elsif ($prior_filename =~ /^(?:cpan|ext|dist)/
1895                      && $filename !~ /^(?:cpan|ext|dist)/
1896                      && basename($prior_filename) eq basename($filename))
1897             {
1898                 $checker->set_skip("$filename: Need to run make?");
1899             } else { # Here have two pods with identical names that differ
1900                 $prior_checker->poderror(
1901                         { -msg => $duplicate_name,
1902                             -line => "???",
1903                             parameter => "'$filename' also has NAME '$name'"
1904                         });
1905                 $checker->poderror(
1906                     { -msg => $duplicate_name,
1907                         -line => "???",
1908                         parameter => "'$prior_filename' also has NAME '$name'"
1909                     });
1910
1911                 # Changing the names helps later.
1912                 $prior_checker->name("$name version arbitrarily numbered 1");
1913                 $checker->name("$name version arbitrarily numbered 2");
1914             }
1915
1916             # In any event, don't process this pod that has the same name as
1917             # another.
1918             next FILE;
1919         }
1920
1921     process_this_pod:
1922
1923         # A unique pod.
1924         $id_to_checker{$id} = $checker;
1925
1926         my $parsed_for_links = ", but parsed for its interior links";
1927         if ((! $do_upstream_cpan && $filename =~ /^cpan/)
1928              || $filename =~ $only_for_interior_links_re)
1929         {
1930             if ($filename =~ /^cpan/) {
1931                 $checker->set_skip("CPAN is upstream for $filename");
1932             }
1933             elsif ($filename =~ /perl\d+delta/) {
1934                 if (! $do_deltas) {
1935                     $checker->set_skip("$filename is a stable perldelta");
1936                 }
1937             }
1938             elsif ($filename =~ /perltoc/) {
1939                 $checker->set_skip("$filename dependent on component pods");
1940             }
1941             else {
1942                 croak("Unexpected file '$filename' encountered that has parsing for interior-linking only");
1943             }
1944
1945             if ($name && $has_referred_to_node{$name}) {
1946                 $checker->set_skip($checker->get_skip() . $parsed_for_links);
1947             }
1948         }
1949
1950         # Need a name in order to process it, because not meaningful
1951         # otherwise, and also can't test links to this without a name.
1952         if (!defined $name) {
1953             $checker->poderror( { -msg => $no_name,
1954                                   -line => '???'
1955                                 });
1956             next FILE;
1957         }
1958
1959         # For skipped files, just get its NAME
1960         my $skip;
1961         if (($skip = $checker->get_skip()) && $skip !~ /$parsed_for_links/)
1962         {
1963             $checker->node($name) if $name;
1964         }
1965         elsif (! $parsed) {
1966             if (! $checker->parse_from_file($filename, undef)) {
1967                 $checker->set_skip("$filename is transitory");
1968                 next FILE;
1969             }
1970         }
1971
1972         # Go through everything in the file that could be an anchor that
1973         # could be a link target.  Count how many there are of the same name.
1974         foreach my $node ($checker->linkable_nodes) {
1975             next FILE if ! $node;        # Can be empty is like '=item *'
1976             $nodes{$name}{$node}++;
1977
1978             # Experiments have shown that cpan search can figure out the
1979             # target of a link even if the exact wording is incorrect, as long
1980             # as the first word is.  This happens frequently in perlfunc.pod,
1981             # where the link will be just to the function, but the target
1982             # entry also includes parameters to the function.
1983             my $first_word = $node;
1984             if ($first_word =~ s/^(\S+)\s+\S.*/$1/) {
1985                 $nodes_first_word{$name}{$first_word} = $node;
1986             }
1987         }
1988         $filename_to_pod{$filename} = $name;
1989     }
1990 }
1991
1992 # Here, all files have been parsed, and all links and link targets are stored.
1993 # Now go through the files again and see which don't have matches.
1994 if (! $has_input_files) {
1995     foreach my $filename (@files) {
1996         next if $filename_to_checker{$filename}->get_skip;
1997
1998         my $checker = $filename_to_checker{$filename};
1999         foreach my $link ($checker->hyperlinks()) {
2000             my $linked_to_page = $link->page;
2001             next unless $linked_to_page;   # intra-file checks are handled by std
2002                                            # Pod::Checker
2003             # Currently, we assume all external links are valid
2004             next if $link->type eq 'url';
2005
2006             # Initialize the potential message.
2007             my %problem = ( -msg => $broken_link,
2008                             -line => $link->line,
2009                             parameter => "to \"$linked_to_page\"",
2010                         );
2011
2012             # See if we have found the linked-to_file in our parse
2013             if (exists $nodes{$linked_to_page}) {
2014                 my $node = $link->node;
2015
2016                 # If link is only to the page-level, already have it
2017                 next if ! $node;
2018
2019                 # If link is to a node that exists in the file, is ok
2020                 if ($nodes{$linked_to_page}{$node}) {
2021
2022                     # But if the page has multiple targets with the same name,
2023                     # it's ambiguous which one this should be to.
2024                     if ($nodes{$linked_to_page}{$node} > 1) {
2025                         $problem{-msg} = $multiple_targets;
2026                         $problem{parameter} = "in $linked_to_page that $node could be pointing to";
2027                         $checker->poderror(\%problem);
2028                     }
2029                 } elsif (! $nodes_first_word{$linked_to_page}{$node}) {
2030
2031                     # Here the link target was not found, either exactly or to
2032                     # the first word.  Is an error.
2033                     $problem{parameter} =~ s,"$,/$node",;
2034                     $checker->poderror(\%problem);
2035                 }
2036
2037             } # Linked-to-file not in parse; maybe is in exception list
2038             elsif (! exists $valid_modules{$link->page}) {
2039
2040                 # Here, is a link to a target that we can't find.  Check if
2041                 # there is an internal link on the page with the target name.
2042                 # If so, it could be that they just forgot the initial '/'
2043                 # But perldelta is handled specially: only do this if the
2044                 # broken link isn't one of the known bad ones (that are
2045                 # placemarkers and should be removed for the final)
2046                 my $NAME = $filename_to_pod{$filename};
2047                 if (! defined $NAME) {
2048                     $checker->poderror(\%problem);
2049                 }
2050                 else {
2051                     if ($nodes{$NAME}{$linked_to_page}) {
2052                         $problem{-msg} =  $broken_internal_link;
2053                     }
2054                     $checker->poderror(\%problem);
2055                 }
2056             }
2057         }
2058     }
2059 }
2060
2061 # If regenerating the data file, start with the modules for which we don't
2062 # check targets.  If you change the sort order, you need to run --regen before
2063 # committing so that future commits that do run regen don't show irrelevant
2064 # changes.
2065 if ($regen) {
2066     foreach (sort { lc $a cmp lc $b } keys %valid_modules) {
2067         my_safer_print($copy_fh, $_, "\n");
2068     }
2069 }
2070
2071 # Now ready to output the messages.
2072 foreach my $filename (@files) {
2073     my $canonical = canonicalize($filename);
2074     SKIP: {
2075         my $skip = $filename_to_checker{$filename}->get_skip // "";
2076
2077         if ($regen) {
2078             foreach my $message ( sort keys %{$problems{$filename}}) {
2079                 my $count;
2080
2081                 # Preserve a negative setting.
2082                 if ($known_problems{$canonical}{$message}
2083                     && $known_problems{$canonical}{$message} < 0)
2084                 {
2085                     $count = $known_problems{$canonical}{$message};
2086                 }
2087                 else {
2088                     $count = @{$problems{$filename}{$message}};
2089                 }
2090                 my_safer_print($copy_fh, $canonical . "\t$message\t$count\n");
2091             }
2092             next;
2093         }
2094
2095         skip($skip, 1) if $skip;
2096         my @diagnostics;
2097         my $thankful_diagnostics = 0;
2098         my $indent = '  ';
2099
2100         my $total_known = 0;
2101         foreach my $message ( sort keys %{$problems{$filename}}) {
2102             $known_problems{$canonical}{$message} = 0
2103                                     if ! $known_problems{$canonical}{$message};
2104             my $diagnostic = "";
2105             my $problem_count = scalar @{$problems{$filename}{$message}};
2106             $total_known += $problem_count;
2107             next if $known_problems{$canonical}{$message} < 0;
2108             if ($problem_count > $known_problems{$canonical}{$message}) {
2109
2110                 # Here we are about to output all the messages for this type,
2111                 # subtract back this number we previously added in.
2112                 $total_known -= $problem_count;
2113
2114                 $diagnostic .= $indent . qq{"$message"};
2115                 if ($problem_count > 2) {
2116                     $diagnostic .= "  ($problem_count occurrences,"
2117                         . " expected $known_problems{$canonical}{$message})";
2118                 }
2119                 foreach my $problem (@{$problems{$filename}{$message}}) {
2120                     $diagnostic .= " " if $problem_count == 1;
2121                     $diagnostic .= "\n$indent$indent";
2122                     $diagnostic .= "$problem->{parameter}" if $problem->{parameter};
2123                     $diagnostic .= " near line $problem->{-line} of "
2124                                    . $filename;
2125                     $diagnostic .= " $problem->{comment}" if $problem->{comment};
2126                 }
2127                 $diagnostic .= "\n";
2128                 $files_with_unknown_issues{$filename} = 1;
2129             } elsif ($problem_count < $known_problems{$canonical}{$message}) {
2130                $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, $problem_count, $message);
2131                $thankful_diagnostics++;
2132             }
2133             push @diagnostics, $diagnostic if $diagnostic;
2134         }
2135
2136         # The above loop has output messages where there are current potential
2137         # issues.  But it misses where there were some that have been entirely
2138         # fixed.  For those, we need to look through the old issues
2139         foreach my $message ( sort keys %{$known_problems{$canonical}}) {
2140             next if $problems{$filename}{$message};
2141             next if ! $known_problems{$canonical}{$message};
2142             next if $known_problems{$canonical}{$message} < 0; # Preserve negs
2143
2144             next if !$pedantic and $message =~
2145                 /^(?:\Q$line_length\E|\Q$C_not_linked\E|\Q$C_with_slash\E)/;
2146
2147             my $diagnostic = output_thanks($filename, $known_problems{$canonical}{$message}, 0, $message);
2148             push @diagnostics, $diagnostic if $diagnostic;
2149             $thankful_diagnostics++ if $diagnostic;
2150         }
2151
2152         my $output = "POD of $filename";
2153         $output .= ", excluding $total_known not shown known potential problems"
2154                                                                 if $total_known;
2155         if (@diagnostics && @diagnostics == $thankful_diagnostics) {
2156             # Output fixed issues as passing to-do tests, so they do not
2157             # cause failures, but t/harness still flags them.
2158             $output .= " # TODO"
2159         }
2160         ok(@diagnostics == $thankful_diagnostics, $output);
2161         if (@diagnostics) {
2162             diag(join "", @diagnostics,
2163             "See end of this test output for your options on silencing this");
2164         }
2165
2166         delete $known_problems{$canonical};
2167     }
2168 }
2169
2170 if (! $regen
2171     && ! ok (keys %known_problems == 0, "The known problems database ($data_dir/known_pod_issues.dat) includes no references to non-existent files"))
2172 {
2173     note("The following files were not found: "
2174          . join ", ", keys %known_problems);
2175     note("They will automatically be removed from the db the next time");
2176     note("  cd t; ./perl -I../lib porting/podcheck.t --regen");
2177     note("is run");
2178 }
2179
2180 my $how_to = <<EOF;
2181    run this test script by hand, using the following formula (on
2182    Un*x-like machines):
2183         cd t
2184         ./perl -I../lib porting/podcheck.t --regen
2185 EOF
2186
2187 if (%files_with_unknown_issues) {
2188     my $were_count_files = scalar keys %files_with_unknown_issues;
2189     $were_count_files = ($were_count_files == 1)
2190                         ? "was $were_count_files file"
2191                         : "were $were_count_files files";
2192     my $message = <<EOF;
2193
2194 HOW TO GET ${\__FILE__} TO PASS
2195
2196 There $were_count_files that had new potential problems identified.
2197 Some of them may be real, and some of them may be false positives because
2198 this program isn't as smart as it likes to think it is.  You can teach this
2199 program to ignore the issues it has identified, and hence pass, by doing the
2200 following:
2201
2202 1) If a problem is about a link to an unknown module or man page that
2203    you know exists, re-run the command something like:
2204       ./perl -I../lib porting/podcheck.t --add_link MODULE man_page ...
2205    (MODULEs should look like Foo::Bar, and man_pages should look like
2206    bar(3c); don't do this for a module or man page that you aren't sure
2207    about; instead treat as another type of issue and follow the
2208    instructions below.)
2209
2210 2) For other issues, decide if each should be fixed now or not.  Fix the
2211    ones you decided to, and rerun this test to verify that the fixes
2212    worked.
2213
2214 3) If there remain false positive or problems that you don't plan to fix right
2215    now,
2216 $how_to
2217    That should cause all current potential problems to be accepted by
2218    the program, so that the next time it runs, they won't be flagged.
2219 EOF
2220     if (%files_with_fixes) {
2221         $message .= "   This step will also take care of the files that have fixes in them\n";
2222     }
2223
2224     $message .= <<EOF;
2225    For a few files, such as perltoc, certain issues will always be
2226    expected, and more of the same will be added over time.  For those,
2227    before you do the regen, you can edit
2228    $known_issues
2229    and find the entry for the module's file and specific error message,
2230    and change the count of known potential problems to -1.
2231 EOF
2232
2233     diag($message);
2234 } elsif (%files_with_fixes) {
2235     diag(<<EOF
2236 To teach this test script that the potential problems have been fixed,
2237 $how_to
2238 EOF
2239     );
2240 }
2241
2242 if ($regen) {
2243     chdir $original_dir || die "Can't change directories to $original_dir";
2244     close_and_rename($copy_fh);
2245 }
2246
2247 1;