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