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