Commit | Line | Data |
3fea05b9 |
1 | package Test::Pod::_parser; |
2 | use base 'Pod::Simple'; |
3 | use strict; |
4 | |
5 | sub _handle_element_start { |
6 | my($parser, $element_name, $attr_hash_r) = @_; |
7 | |
8 | # Curiously, Pod::Simple supports L<text|scheme:...> rather well. |
9 | |
10 | if( $element_name eq "L" and $attr_hash_r->{type} eq "url") { |
11 | $parser->{_state_of_concern}{'Lurl'} = $attr_hash_r->{to}; |
12 | } |
13 | |
14 | return $parser->SUPER::_handle_element_start(@_); |
15 | } |
16 | |
17 | sub _handle_element_end { |
18 | my($parser, $element_name) = @_; |
19 | |
20 | delete $parser->{_state_of_concern}{'Lurl'} |
21 | if $element_name eq "L" and exists $parser->{_state_of_concern}{'Lurl'}; |
22 | |
23 | return $parser->SUPER::_handle_element_end(@_); |
24 | } |
25 | |
26 | sub _handle_text { |
27 | my($parser, $text) = @_; |
28 | if( my $href = $parser->{_state_of_concern}{'Lurl'} ) { |
29 | if( $href ne $text ) { |
30 | my $line = $parser->line_count() -2; # XXX: -2, WHY WHY WHY?? |
31 | |
32 | $parser->whine($line, "L<text|scheme:...> is invalid according to perlpod"); |
33 | } |
34 | } |
35 | |
36 | return $parser->SUPER::_handle_text(@_); |
37 | } |
38 | |
39 | 1; |
40 | |
41 | package Test::Pod; |
42 | |
43 | use strict; |
44 | |
45 | =head1 NAME |
46 | |
47 | Test::Pod - check for POD errors in files |
48 | |
49 | =head1 VERSION |
50 | |
51 | Version 1.40 |
52 | |
53 | =cut |
54 | |
55 | our $VERSION = '1.40'; |
56 | |
57 | =head1 SYNOPSIS |
58 | |
59 | C<Test::Pod> lets you check the validity of a POD file, and report |
60 | its results in standard C<Test::Simple> fashion. |
61 | |
62 | use Test::Pod tests => $num_tests; |
63 | pod_file_ok( $file, "Valid POD file" ); |
64 | |
65 | Module authors can include the following in a F<t/pod.t> file and |
66 | have C<Test::Pod> automatically find and check all POD files in a |
67 | module distribution: |
68 | |
69 | use Test::More; |
70 | eval "use Test::Pod 1.00"; |
71 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; |
72 | all_pod_files_ok(); |
73 | |
74 | You can also specify a list of files to check, using the |
75 | C<all_pod_files()> function supplied: |
76 | |
77 | use strict; |
78 | use Test::More; |
79 | eval "use Test::Pod 1.00"; |
80 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; |
81 | my @poddirs = qw( blib script ); |
82 | all_pod_files_ok( all_pod_files( @poddirs ) ); |
83 | |
84 | Or even (if you're running under L<Apache::Test>): |
85 | |
86 | use strict; |
87 | use Test::More; |
88 | eval "use Test::Pod 1.00"; |
89 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; |
90 | |
91 | my @poddirs = qw( blib script ); |
92 | use File::Spec::Functions qw( catdir updir ); |
93 | all_pod_files_ok( |
94 | all_pod_files( map { catdir updir, $_ } @poddirs ) |
95 | ); |
96 | |
97 | =head1 DESCRIPTION |
98 | |
99 | Check POD files for errors or warnings in a test file, using |
100 | C<Pod::Simple> to do the heavy lifting. |
101 | |
102 | =cut |
103 | |
104 | use 5.008; |
105 | |
106 | use Test::Builder; |
107 | use File::Spec; |
108 | |
109 | our %ignore_dirs = ( |
110 | '.bzr' => 'Bazaar', |
111 | '.git' => 'Git', |
112 | '.hg' => 'Mercurial', |
113 | '.pc' => 'quilt', |
114 | '.svn' => 'Subversion', |
115 | CVS => 'CVS', |
116 | RCS => 'RCS', |
117 | SCCS => 'SCCS', |
118 | _darcs => 'darcs', |
119 | _sgbak => 'Vault/Fortress', |
120 | ); |
121 | |
122 | my $Test = Test::Builder->new; |
123 | |
124 | sub import { |
125 | my $self = shift; |
126 | my $caller = caller; |
127 | |
128 | for my $func ( qw( pod_file_ok all_pod_files all_pod_files_ok ) ) { |
129 | no strict 'refs'; |
130 | *{$caller."::".$func} = \&$func; |
131 | } |
132 | |
133 | $Test->exported_to($caller); |
134 | $Test->plan(@_); |
135 | } |
136 | |
137 | sub _additional_test_pod_specific_checks { |
138 | my ($ok, $errata, $file) = @_; |
139 | |
140 | return $ok; |
141 | } |
142 | |
143 | =head1 FUNCTIONS |
144 | |
145 | =head2 pod_file_ok( FILENAME[, TESTNAME ] ) |
146 | |
147 | C<pod_file_ok()> will okay the test if the POD parses correctly. Certain |
148 | conditions are not reported yet, such as a file with no pod in it at all. |
149 | |
150 | When it fails, C<pod_file_ok()> will show any pod checking errors as |
151 | diagnostics. |
152 | |
153 | The optional second argument TESTNAME is the name of the test. If it |
154 | is omitted, C<pod_file_ok()> chooses a default test name "POD test |
155 | for FILENAME". |
156 | |
157 | =cut |
158 | |
159 | sub pod_file_ok { |
160 | my $file = shift; |
161 | my $name = @_ ? shift : "POD test for $file"; |
162 | |
163 | if ( !-f $file ) { |
164 | $Test->ok( 0, $name ); |
165 | $Test->diag( "$file does not exist" ); |
166 | return; |
167 | } |
168 | |
169 | my $checker = Test::Pod::_parser->new; |
170 | |
171 | $checker->output_string( \my $trash ); # Ignore any output |
172 | $checker->parse_file( $file ); |
173 | |
174 | my $ok = !$checker->any_errata_seen; |
175 | $ok = _additional_test_pod_specific_checks( $ok, ($checker->{errata}||={}), $file ); |
176 | |
177 | $Test->ok( $ok, $name ); |
178 | if ( !$ok ) { |
179 | my $lines = $checker->{errata}; |
180 | for my $line ( sort { $a<=>$b } keys %$lines ) { |
181 | my $errors = $lines->{$line}; |
182 | $Test->diag( "$file ($line): $_" ) for @$errors; |
183 | } |
184 | } |
185 | |
186 | return $ok; |
187 | } # pod_file_ok |
188 | |
189 | =head2 all_pod_files_ok( [@files/@directories] ) |
190 | |
191 | Checks all the files in C<@files> for valid POD. It runs |
192 | L<all_pod_files()> on each file/directory, and calls the C<plan()> |
193 | function for you (one test for each function), so you can't have |
194 | already called C<plan>. |
195 | |
196 | If C<@files> is empty or not passed, the function finds all POD |
197 | files in the F<blib> directory if it exists, or the F<lib> directory |
198 | if not. A POD file is one that ends with F<.pod>, F<.pl> and F<.pm>, |
199 | or any file where the first line looks like a shebang line. |
200 | |
201 | If you're testing a module, just make a F<t/pod.t>: |
202 | |
203 | use Test::More; |
204 | eval "use Test::Pod 1.00"; |
205 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; |
206 | all_pod_files_ok(); |
207 | |
208 | Returns true if all pod files are ok, or false if any fail. |
209 | |
210 | =cut |
211 | |
212 | sub all_pod_files_ok { |
213 | my @files = @_ ? @_ : all_pod_files(); |
214 | |
215 | $Test->plan( tests => scalar @files ); |
216 | |
217 | my $ok = 1; |
218 | foreach my $file ( @files ) { |
219 | pod_file_ok( $file, $file ) or undef $ok; |
220 | } |
221 | return $ok; |
222 | } |
223 | |
224 | =head2 all_pod_files( [@dirs] ) |
225 | |
226 | Returns a list of all the Perl files in I<$dir> and in directories |
227 | below. If no directories are passed, it defaults to F<blib> if |
228 | F<blib> exists, or else F<lib> if not. Skips any files in CVS, |
229 | .svn, .git and similar directories. See C<%Test::Pod::ignore_dirs> |
230 | for a list of them. |
231 | |
232 | A Perl file is: |
233 | |
234 | =over 4 |
235 | |
236 | =item * Any file that ends in F<.PL>, F<.pl>, F<.pm>, F<.pod> or F<.t>. |
237 | |
238 | =item * Any file that has a first line with a shebang and "perl" on it. |
239 | |
240 | =back |
241 | |
242 | The order of the files returned is machine-dependent. If you want them |
243 | sorted, you'll have to sort them yourself. |
244 | |
245 | =cut |
246 | |
247 | sub all_pod_files { |
248 | my @queue = @_ ? @_ : _starting_points(); |
249 | my @pod = (); |
250 | |
251 | while ( @queue ) { |
252 | my $file = shift @queue; |
253 | if ( -d $file ) { |
254 | local *DH; |
255 | opendir DH, $file or next; |
256 | my @newfiles = readdir DH; |
257 | closedir DH; |
258 | |
259 | @newfiles = File::Spec->no_upwards( @newfiles ); |
260 | @newfiles = grep { not exists $ignore_dirs{ $_ } } @newfiles; |
261 | |
262 | foreach my $newfile (@newfiles) { |
263 | my $filename = File::Spec->catfile( $file, $newfile ); |
264 | if ( -f $filename ) { |
265 | push @queue, $filename; |
266 | } |
267 | else { |
268 | push @queue, File::Spec->catdir( $file, $newfile ); |
269 | } |
270 | } |
271 | } |
272 | if ( -f $file ) { |
273 | push @pod, $file if _is_perl( $file ); |
274 | } |
275 | } # while |
276 | return @pod; |
277 | } |
278 | |
279 | sub _starting_points { |
280 | return 'blib' if -e 'blib'; |
281 | return 'lib'; |
282 | } |
283 | |
284 | sub _is_perl { |
285 | my $file = shift; |
286 | |
287 | return 1 if $file =~ /\.PL$/; |
288 | return 1 if $file =~ /\.p(?:l|m|od)$/; |
289 | return 1 if $file =~ /\.t$/; |
290 | |
291 | open my $fh, '<', $file or return; |
292 | my $first = <$fh>; |
293 | close $fh; |
294 | |
295 | return 1 if defined $first && ($first =~ /^#!.*perl/); |
296 | |
297 | return; |
298 | } |
299 | |
300 | =head1 TODO |
301 | |
302 | STUFF TO DO |
303 | |
304 | Note the changes that are being made. |
305 | |
306 | Note that you no longer can test for "no pod". |
307 | |
308 | =head1 AUTHOR |
309 | |
310 | Currently maintained by Andy Lester, C<< <andy at petdance.com> >>. |
311 | |
312 | Originally by brian d foy. |
313 | |
314 | =head1 ACKNOWLEDGEMENTS |
315 | |
316 | Thanks to |
317 | David Wheeler, |
318 | Paul Miller |
319 | and |
320 | Peter Edwards |
321 | for contributions and to C<brian d foy> for the original code. |
322 | |
323 | =head1 COPYRIGHT |
324 | |
325 | Copyright 2006-2009, Andy Lester, All Rights Reserved. |
326 | |
327 | You may use, modify, and distribute this package under the terms |
328 | as the Artistic License v2.0 or GNU Public License v2.0. |
329 | |
330 | =cut |
331 | |
332 | 1; |