Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 135 lines (107 sloc) 3.001 kb
67d441b @tonycoz [RT #65749] add pod link check test and fix the broken links
authored
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 =
92ea766 @tonycoz add to the valid links list so the previous commit passes the link check
authored
10 qw(perl Affix::Infix2Postfix Parse::RecDescent GD Image::Magick Graphics::Magick CGI Image::ExifTool XSLoader DynaLoader Prima::Image IPA PDL);
67d441b @tonycoz [RT #65749] add pod link check test and fix the broken links
authored
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")) {
92ea766 @tonycoz add to the valid links list so the previous commit passes the link check
authored
58 print STDERR "# $_\n" for @errors;
67d441b @tonycoz [RT #65749] add pod link check test and fix the broken links
authored
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
Something went wrong with that request. Please try again.