t/porting/podcheck.t

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