t/950-kwalitee/060-podstruct.t

   1 #!perl -w
   2 use strict;
   3 use Test::More;
   4 $ENV{AUTOMATED_TESTING} || $ENV{IMAGER_AUTHOR_TESTING}
   5   or plan skip_all => "POD only tested under automated or author testing";
   6 BEGIN {
   7   eval 'use Pod::Parser 1.50;';
   8   plan skip_all => "Pod::Parser 1.50 required for podlinkcheck" if $@;
   9 }
  10 use File::Spec::Functions qw(rel2abs abs2rel splitdir);
  11 use ExtUtils::Manifest qw(maniread);
  12
  13 # this test is intended to catch errors like in
  14 # https://rt.cpan.org/Ticket/Display.html?id=85413
  15
  16 my @pod; # files with pod
  17
  18 my $base = rel2abs(".");
  19
  20 my $manifest = maniread();
  21
  22 my @files = sort grep /\.(pod|pm)$/ && !/^inc/, keys %$manifest;
  23
  24 my %item_in;
  25
  26 for my $file (@files) {
  27   my $parser = PodPreparse->new;
  28
  29   $parser->parse_from_file($file);
  30   if ($parser->{is_pod}) {
  31     push @pod, $file;
  32   }
  33 }
  34
  35 plan tests =>  3 * scalar(@pod);
  36
  37 my @req_head1s = qw(NAME DESCRIPTION AUTHOR);
  38
  39 for my $file (@pod) {
  40   my $parser = PodStructCheck->new;
  41   my $relfile = abs2rel($file, $base);
  42   $parser->{bad_quotes} = [];
  43   $parser->{dup_words} = [];
  44   $parser->parse_from_file($file);
  45
  46   my @missing;
  47   for my $head (@req_head1s) {
  48     push @missing, $head unless $parser->{head1s}{$head};
  49   }
  50
  51   unless (ok(!@missing, "$relfile: check missing headers")) {
  52     diag "$relfile: missing head1s @missing\n";
  53   }
  54   unless (ok(!@{$parser->{bad_quotes}}, "$relfile: check for bad quotes")) {
  55     diag "$relfile:$_->[1]: bad quote in: $_->[0]"
  56       for @{$parser->{bad_quotes}};
  57   }
  58   unless (ok(!@{$parser->{dup_words}}, "$relfile: check for duplicate words")) {
  59     diag "$relfile:$_->[1]: dup word '$_->[0]' in: $_->[2]"
  60       for @{$parser->{dup_words}};
  61   }
  62 }
  63
  64 package PodPreparse;
  65 BEGIN { our @ISA = qw(Pod::Parser); }
  66
  67 sub command {
  68   my ($self, $cmd, $para) = @_;
  69
  70   $self->{is_pod} = 1;
  71 }
  72
  73 sub verbatim {}
  74
  75 sub textblock {}
  76
  77 package PodStructCheck;
  78 BEGIN { our @ISA = qw(Pod::Parser); }
  79
  80 sub command {
  81   my ($self, $command, $paragraph, $line_num) = @_;
  82
  83   if ($command eq "head1") {
  84     $paragraph =~ s/\s+\z//;
  85     $self->{head1s}{$paragraph} = 1;
  86
  87     if ($paragraph =~ /\A[^']*'\z/
  88         || $paragraph =~ /\A[^"]*"\z/
  89         || $paragraph =~ /\A'[^']*\z/
  90         || $paragraph =~ /\A"[^"]*\z/) {
  91       push @{$self->{bad_quotes}}, [ $paragraph, $line_num ];
  92     }
  93   }
  94 }
  95
  96 sub verbatim {}
  97
  98 sub textblock {
  99   my ($self, $text, $line_num) = @_;
 100
 101   if (my ($sample, $word) = $text =~ /(.{0,10}\b(\w+)\s+\2\b.{0,10})/s) {
 102     # avoid catching "C C<something to do with C>"
 103     if ($word ne "C") {
 104       push @{$self->{dup_words}}, [ $word, $line_num, $sample ];
 105     }
 106   }
 107 }
 108
 109 sub sequence {
 110 }
 111
 112