local-lib5/lib/perl5/Test/Pod.pm

   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;