Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

file 133 lines (107 sloc) 3.001 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
#!perl -w
use strict;
use Test::More;
use Pod::Parser;
use File::Find;
use File::Spec::Functions qw(rel2abs abs2rel splitdir);

# external stuff we refer to
my @known =
  qw(perl Affix::Infix2Postfix Parse::RecDescent GD Image::Magick Graphics::Magick CGI Image::ExifTool XSLoader DynaLoader Prima::Image IPA PDL);

my @pod; # files with pod

my $base = rel2abs("blib/lib");

my @files;
find(sub {
       -f && /\.(pod|pm)$/
and push @files, $File::Find::name;
     }, $base);

my %targets = map { $_ => {} } @known;
my %item_in;

for my $file (@files) {
  my $parser = PodPreparse->new;

  my $link = abs2rel($file, $base);
  $link =~ s/\.(pod|pm|pl|PL)$//;
  $link = join("::", splitdir($link));

  $parser->{'targets'} = \%targets;
  $parser->{'link'} = $link;
  $parser->{'file'} = $file;
  $parser->{item_in} = \%item_in;
  $parser->parse_from_file($file);
  if ($targets{$link}) {
    push @pod, $file;
  }
}

plan tests => scalar(@pod);

for my $file (@pod) {
  my $parser = PodLinkCheck->new;
  $parser->{"targets"} = \%targets;
  my $relfile = abs2rel($file, $base);
  (my $link = $relfile) =~ s/\.(pod|pm|pl|PL)$//;
  $link = join("::", splitdir($link));
  $parser->{"file"} = $relfile;
  $parser->{"link"} = $link;
  my @errors;
  $parser->{"errors"} = \@errors;
  $parser->{item_in} = \%item_in;
  $parser->parse_from_file($file);

  unless (ok(!@errors, "check links in $relfile")) {
    print STDERR "# $_\n" for @errors;
  }
}

package PodPreparse;
BEGIN { our @ISA = qw(Pod::Parser); }

sub command {
  my ($self, $cmd, $para) = @_;

  my $targets = $self->{"targets"};
  my $link = $self->{"link"};
  $targets->{$link} ||= {};

  if ($cmd =~ /^(head[1-5]|item)/) {
    $para =~ s/X<.*?>//g;
    $para =~ s/\s+$//;
    $targets->{$link}{$para} = 1;
    push @{$self->{item_in}{$para}}, $link;
  }
}

sub verbatim {}

sub textblock {}

package PodLinkCheck;
BEGIN { our @ISA = qw(Pod::Parser); }

sub command {}

sub verbatim {}

sub textblock {
  my ($self, $para, $line_num) = @_;

  $self->parse_text
    (
     { -expand_seq => "sequence" },
     $para, $line_num,
    );
}

sub sequence {
  my ($self, $seq) = @_;

  if ($seq->cmd_name eq "L") {
    my $raw = $seq->raw_text;
    my $base_link = $seq->parse_tree->raw_text;
    $base_link =~ /^(https?|ftp|mailto):/
      and return '';
    (my $link = $base_link) =~ s/.*\|//;
    my ($pod, $part) = split m(/), $link, 2;
    $pod ||= $self->{link};
    if ($part) {
      $part =~ s/^\"//;
      $part =~ s/"$//;
    }
    my $targets = $self->{targets};
    my $errors = $self->{errors};
    (undef, my $line) = $seq->file_line;

    if (!$targets->{$pod}) {
      push @$errors, "$line: No $pod found ($raw)";
    }
    elsif ($part && !$targets{$pod}{$part}) {
      push @$errors, "$line: No item/section '$part' found in $pod ($raw)";
      if ($self->{item_in}{$part}) {
push @$errors, " $part can be found in:";
push @$errors, map " $_", @{$self->{item_in}{$part}};
      }
    }
  }

  return $seq->raw_text;
}
Something went wrong with that request. Please try again.