note GIF changes
[imager.git] / xt / x30podlinkcheck.t
CommitLineData
67d441b2
TC
1#!perl -w
2use strict;
3use Test::More;
17dbbf91
TC
4BEGIN {
5 eval 'use Pod::Parser 1.50;';
6 plan skip_all => "Pod::Parser 1.50 required for podlinkcheck" if $@;
7}
67d441b2
TC
8use File::Find;
9use File::Spec::Functions qw(rel2abs abs2rel splitdir);
10
11# external stuff we refer to
12my @known =
92ea766b 13 qw(perl Affix::Infix2Postfix Parse::RecDescent GD Image::Magick Graphics::Magick CGI Image::ExifTool XSLoader DynaLoader Prima::Image IPA PDL);
67d441b2 14
be4b66bb
TC
15# also known since we supply them, but we don't always install them
16push @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
67d441b2
TC
19my @pod; # files with pod
20
21my $base = rel2abs("blib/lib");
22
23my @files;
24find(sub {
25 -f && /\.(pod|pm)$/
26 and push @files, $File::Find::name;
27 }, $base);
28
29my %targets = map { $_ => {} } @known;
30my %item_in;
31
32for 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
49plan tests => scalar(@pod);
50
51for 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")) {
92ea766b 65 print STDERR "# $_\n" for @errors;
67d441b2
TC
66 }
67}
68
69package PodPreparse;
70BEGIN { our @ISA = qw(Pod::Parser); }
71
72sub 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
87sub verbatim {}
88
89sub textblock {}
90
91package PodLinkCheck;
92BEGIN { our @ISA = qw(Pod::Parser); }
93
94sub command {}
95
96sub verbatim {}
97
98sub textblock {
99 my ($self, $para, $line_num) = @_;
100
101 $self->parse_text
102 (
103 { -expand_seq => "sequence" },
104 $para, $line_num,
105 );
106}
107
108sub 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;
be4b66bb
TC
114 (my $link = $base_link) =~ s/.*\|//s;
115 $link =~ /^(https?|ftp|mailto):/
67d441b2 116 and return '';
67d441b2
TC
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