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