dffa59428f35e3d3d3b95c8247fca12e2b99735a
[imager.git] / 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