t/porting/podcheck.t

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