t/porting/podcheck.t

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