t/x30podlinkcheck.t

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