#line 1 package Test::Pod; use strict; #line 13 use vars qw( $VERSION ); $VERSION = '1.26'; #line 63 use 5.004; use Pod::Simple; use Test::Builder; use File::Spec; my $Test = Test::Builder->new; sub import { my $self = shift; my $caller = caller; for my $func ( qw( pod_file_ok all_pod_files all_pod_files_ok ) ) { no strict 'refs'; *{$caller."::".$func} = \&$func; } $Test->exported_to($caller); $Test->plan(@_); } #line 100 sub pod_file_ok { my $file = shift; my $name = @_ ? shift : "POD test for $file"; if ( !-f $file ) { $Test->ok( 0, $name ); $Test->diag( "$file does not exist" ); return; } my $checker = Pod::Simple->new; $checker->output_string( \my $trash ); # Ignore any output $checker->parse_file( $file ); my $ok = !$checker->any_errata_seen; $Test->ok( $ok, $name ); if ( !$ok ) { my $lines = $checker->{errata}; for my $line ( sort { $a<=>$b } keys %$lines ) { my $errors = $lines->{$line}; $Test->diag( "$file ($line): $_" ) for @$errors; } } return $ok; } # pod_file_ok #line 150 sub all_pod_files_ok { my @files = @_ ? @_ : all_pod_files(); $Test->plan( tests => scalar @files ); my $ok = 1; foreach my $file ( @files ) { pod_file_ok( $file, $file ) or undef $ok; } return $ok; } #line 183 sub all_pod_files { my @queue = @_ ? @_ : _starting_points(); my @pod = (); while ( @queue ) { my $file = shift @queue; if ( -d $file ) { local *DH; opendir DH, $file or next; my @newfiles = readdir DH; closedir DH; @newfiles = File::Spec->no_upwards( @newfiles ); @newfiles = grep { $_ ne "CVS" && $_ ne ".svn" } @newfiles; foreach my $newfile (@newfiles) { my $filename = File::Spec->catfile( $file, $newfile ); if ( -f $filename ) { push @queue, $filename; } else { push @queue, File::Spec->catdir( $file, $newfile ); } } } if ( -f $file ) { push @pod, $file if _is_perl( $file ); } } # while return @pod; } sub _starting_points { return 'blib' if -e 'blib'; return 'lib'; } sub _is_perl { my $file = shift; return 1 if $file =~ /\.PL$/; return 1 if $file =~ /\.p(l|m|od)$/; return 1 if $file =~ /\.t$/; local *FH; open FH, $file or return; my $first = ; close FH; return 1 if defined $first && ($first =~ /^#!.*perl/); return; } #line 268 1;