xt/x30podlinkcheck.t

   1 #!perl -w
   2 use strict;
   3 use Test::More;
   4 BEGIN {
   5   eval 'use Pod::Parser 1.50;';
   6   plan skip_all => "Pod::Parser 1.50 required for podlinkcheck" if $@;
   7 }
   8 use File::Find;
   9 use File::Spec::Functions qw(rel2abs abs2rel splitdir);
  10
  11 # external stuff we refer to
  12 my @known =
  13   qw(perl Affix::Infix2Postfix Parse::RecDescent GD Image::Magick Graphics::Magick CGI Image::ExifTool XSLoader DynaLoader Prima::Image IPA PDL);
  14
  15 # also known since we supply them, but we don't always install them
  16 push @known, qw(Imager::Font::FT2 Imager::Font::W32 Imager::Font::T1
  17    Imager::File::JPEG Imager::File::GIF Imager::File::PNG Imager::File::TIFF);
  18
  19 my @pod; # files with pod
  20
  21 my $base = rel2abs("blib/lib");
  22
  23 my @files;
  24 find(sub {
  25        -f && /\.(pod|pm)$/
  26          and push @files, $File::Find::name;
  27      }, $base);
  28
  29 my %targets = map { $_ => {} } @known;
  30 my %item_in;
  31
  32 for my $file (@files) {
  33   my $parser = PodPreparse->new;
  34
  35   my $link = abs2rel($file, $base);
  36   $link =~ s/\.(pod|pm|pl|PL)$//;
  37   $link = join("::", splitdir($link));
  38
  39   $parser->{'targets'} = \%targets;
  40   $parser->{'link'} = $link;
  41   $parser->{'file'} = $file;
  42   $parser->{item_in} = \%item_in;
  43   $parser->parse_from_file($file);
  44   if ($targets{$link}) {
  45     push @pod, $file;
  46   }
  47 }
  48
  49 plan tests => scalar(@pod);
  50
  51 for my $file (@pod) {
  52   my $parser = PodLinkCheck->new;
  53   $parser->{"targets"} = \%targets;
  54   my $relfile = abs2rel($file, $base);
  55   (my $link = $relfile) =~ s/\.(pod|pm|pl|PL)$//;
  56   $link = join("::", splitdir($link));
  57   $parser->{"file"} = $relfile;
  58   $parser->{"link"} = $link;
  59   my @errors;
  60   $parser->{"errors"} = \@errors;
  61   $parser->{item_in} = \%item_in;
  62   $parser->parse_from_file($file);
  63
  64   unless (ok(!@errors, "check links in $relfile")) {
  65     print STDERR "# $_\n" for @errors;
  66   }
  67 }
  68
  69 package PodPreparse;
  70 BEGIN { our @ISA = qw(Pod::Parser); }
  71
  72 sub command {
  73   my ($self, $cmd, $para) = @_;
  74
  75   my $targets = $self->{"targets"};
  76   my $link = $self->{"link"};
  77   $targets->{$link} ||= {};
  78
  79   if ($cmd =~ /^(head[1-5]|item)/) {
  80     $para =~ s/X<.*?>//g;
  81     $para =~ s/\s+$//;
  82     $targets->{$link}{$para} = 1;
  83     push @{$self->{item_in}{$para}}, $link;
  84   }
  85 }
  86
  87 sub verbatim {}
  88
  89 sub textblock {}
  90
  91 package PodLinkCheck;
  92 BEGIN { our @ISA = qw(Pod::Parser); }
  93
  94 sub command {}
  95
  96 sub verbatim {}
  97
  98 sub textblock {
  99   my ($self, $para, $line_num) = @_;
 100
 101   $self->parse_text
 102     (
 103      { -expand_seq => "sequence" },
 104      $para, $line_num,
 105     );
 106 }
 107
 108 sub sequence {
 109   my ($self, $seq) = @_;
 110
 111   if ($seq->cmd_name eq "L") {
 112     my $raw = $seq->raw_text;
 113     my $base_link = $seq->parse_tree->raw_text;
 114     (my $link = $base_link) =~ s/.*\|//s;
 115     $link =~ /^(https?|ftp|mailto):/
 116       and return '';
 117     my ($pod, $part) = split m(/), $link, 2;
 118     $pod ||= $self->{link};
 119     if ($part) {
 120       $part =~ s/^\"//;
 121       $part =~ s/"$//;
 122     }
 123     my $targets = $self->{targets};
 124     my $errors = $self->{errors};
 125     (undef, my $line) = $seq->file_line;
 126
 127     if (!$targets->{$pod}) {
 128       push @$errors, "$line: No $pod found ($raw)";
 129     }
 130     elsif ($part && !$targets{$pod}{$part}) {
 131       push @$errors, "$line: No item/section '$part' found in $pod ($raw)";
 132       if ($self->{item_in}{$part}) {
 133         push @$errors, "  $part can be found in:";
 134         push @$errors, map "     $_", @{$self->{item_in}{$part}};
 135       }
 136     }
 137   }
 138
 139   return $seq->raw_text;
 140 }
 141