1package Test::Pod::Coverage::Permissive; 2 3use warnings; 4use strict; 5use 5.008009; 6use Test::More 0.88; 7use File::Spec; 8use Pod::Coverage; 9use YAML::Syck qw(LoadFile DumpFile); 10 11my $Test = Test::Builder->new; 12 13sub import { 14 my $self = shift; 15 my $caller = caller; 16 no strict 'refs'; 17 *{$caller.'::pod_coverage_ok'} = \&pod_coverage_ok; 18 *{$caller.'::all_pod_coverage_ok'} = \&all_pod_coverage_ok; 19 *{$caller.'::all_modules'} = \&all_modules; 20 21 $Test->exported_to($caller); 22 $Test->plan(@_); 23} 24 25=head1 NAME 26 27Test::Pod::Coverage::Permissive - Checks for pod coverage regression. 28 29=head1 VERSION 30 31Version 0.05 32 33=cut 34 35our $VERSION = '0.05'; 36 37=head1 SYNOPSIS 38 39Checks for POD coverage regressions in your code. This module is for large projects, which can't be covered by POD for a 405 minutes. If you have small module or your project is fully covered - use L<Test::Pod::Coverage> instead. 41 42After first run, this module creates data file, where saves all uncovered subroutines. If you create new uncovered 43subroutine, it will fail. If you create new package with uncovered subroutines, it will fail. Otherwise it will show 44diagnostic messages like these: 45 46 t/03podcoverage.t .. 2/? # YourProject::Controller::Root: naked 4 subroutine(s) 47 # YourProject::Controller::NotRoot: naked 8 subroutine(s) 48 # YorProject::Controller::AlsoNotRoot: naked 3 subroutine(s) 49 ... 50 51This module will help you to cover your project step-by-step. And your new code will be covered by POD. 52 53Interface is like L<Test::Pod::Coverage>: 54 55 use Test::Pod::Coverage::Permissive; 56 57 use Test::More; 58 eval "use Test::Pod::Coverage::Permissive"; 59 plan skip_all => "Test::Pod::Coverage::Permissive required for testing POD coverage" if $@; 60 all_pod_coverage_ok(); 61 62=head1 FUNCTIONS 63 64=head2 all_pod_coverage_ok( [$parms] ) 65 66Checks that the POD code in all modules in the distro have proper POD 67coverage. 68 69If the I<$parms> hashref if passed in, they're passed into the 70C<Pod::Coverage> object that the function uses. Check the 71L<Pod::Coverage> manual for what those can be. 72 73The exception is the C<coverage_class> parameter, which specifies a class to 74use for coverage testing. It defaults to C<Pod::Coverage>. 75 76=cut 77 78sub all_pod_coverage_ok { 79 my $parms = ( @_ && ( ref $_[0] eq "HASH" ) ) ? shift : {}; 80 my $msg = shift; 81 82 my $ok = 1; 83 my @modules = all_modules(); 84 if (@modules) { 85 for my $module (@modules) { 86 pod_coverage_ok($module, $parms, $msg); 87 } 88 } 89 else { 90 ok( 1, "No modules found." ); 91 } 92 93 return $ok; 94} 95 96=head2 pod_coverage_ok( $module, [$parms,] $msg ) 97 98Checks that the POD code in I<$module> has proper POD coverage. 99 100If the I<$parms> hashref if passed in, they're passed into the 101C<Pod::Coverage> object that the function uses. Check the 102L<Pod::Coverage> manual for what those can be. 103 104The exception is the C<coverage_class> parameter, which specifies a class to 105use for coverage testing. It defaults to C<Pod::Coverage>. 106 107=cut 108 109sub pod_coverage_ok { 110 my $module = shift; 111 my %parms = (@_ && (ref $_[0] eq "HASH")) ? %{(shift)} : (); 112 my $msg = @_ ? shift : "Pod coverage on $module"; 113 my $first_time = !-e 't/pod_correct.yaml'; 114 my $correct = eval { LoadFile('t/pod_correct.yaml') } || {}; 115 my $coverage = Pod::Coverage->new( package => $module, %parms ); 116 my $v = $coverage->naked || 0; 117 my $ok = 1; 118 if ( defined $coverage->coverage ) { 119 $correct->{$module} = $v if $first_time; 120 if ( $ok = $Test->ok($v <= ($correct->{$module}||0), $msg) ) { 121 $correct->{$module} = $v; 122 } 123 if ( my $count = $coverage->naked ) { 124 $Test->diag("${module}: naked $count subroutine(s)"); 125 } 126 } 127 else { # No symbols 128 my $why = $coverage->why_unrated; 129 my $nopublics = ( $why =~ "no public symbols defined" ); 130 my $verbose = $ENV{HARNESS_VERBOSE} || 0; 131 $correct->{$module} = undef if $first_time; 132 $ok = $nopublics || exists $coverage->{$module}; 133 $Test->ok( $ok, $msg ); 134 $Test->diag( "$module: $why" ) unless ( $nopublics && !$verbose ); 135 } 136 137 DumpFile( 't/pod_correct.yaml', $correct ); 138} 139 140=head2 all_modules( [@dirs] ) 141 142Returns a list of all modules in I<$dir> and in directories below. If 143no directories are passed, it defaults to F<blib> if F<blib> exists, 144or F<lib> if not. 145 146Note that the modules are as "Foo::Bar", not "Foo/Bar.pm". 147 148The order of the files returned is machine-dependent. If you want them 149sorted, you'll have to sort them yourself. 150 151=cut 152 153sub all_modules { 154 my @starters = @_ ? @_ : _starting_points(); 155 my %starters = map { $_, 1 } @starters; 156 157 my @queue = @starters; 158 159 my @modules; 160 while (@queue) { 161 my $file = shift @queue; 162 if ( -d $file ) { 163 local *DH; 164 opendir DH, $file or next; 165 my @newfiles = readdir DH; 166 closedir DH; 167 168 @newfiles = File::Spec->no_upwards(@newfiles); 169 @newfiles = grep { $_ ne "CVS" && $_ ne ".svn" } @newfiles; 170 171 push @queue, map "$file/$_", @newfiles; 172 } 173 if ( -f $file ) { 174 next unless $file =~ /\.pm$/; 175 176 my @parts = File::Spec->splitdir($file); 177 shift @parts if @parts && exists $starters{ $parts[0] }; 178 shift @parts if @parts && $parts[0] eq "lib"; 179 $parts[-1] =~ s/\.pm$// if @parts; 180 181 # Untaint the parts 182 for (@parts) { 183 if ( /^([a-zA-Z0-9_\.\-]+)$/ && ( $_ eq $1 ) ) { 184 $_ = $1; # Untaint the original 185 } 186 else { 187 die qq{Invalid and untaintable filename "$file"!}; 188 } 189 } 190 my $module = join( "::", @parts ); 191 push( @modules, $module ); 192 } 193 } # while 194 195 return @modules; 196} 197 198sub _starting_points { 199 return 'blib' if -e 'blib'; 200 return 'lib'; 201} 202 203=head1 AUTHOR 204 205Andrey Kostenko, C<< <andrey at kostenko.name> >> 206 207=head1 BUGS 208 209Please report any bugs or feature requests to C<bug-test-pod-coverage-permissive at rt.cpan.org>, or through 210the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Pod-Coverage-Permissive>. I will be notified, and then you'll 211automatically be notified of progress on your bug as I make changes. 212 213 214 215 216=head1 SUPPORT 217 218You can find documentation for this module with the perldoc command. 219 220 perldoc Test::Pod::Coverage::Permissive 221 222 223You can also look for information at: 224 225=over 4 226 227=item * RT: CPAN's request tracker 228 229L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Pod-Coverage-Permissive> 230 231=item * AnnoCPAN: Annotated CPAN documentation 232 233L<http://annocpan.org/dist/Test-Pod-Coverage-Permissive> 234 235=item * CPAN Ratings 236 237L<http://cpanratings.perl.org/d/Test-Pod-Coverage-Permissive> 238 239=item * Search CPAN 240 241L<http://search.cpan.org/dist/Test-Pod-Coverage-Permissive/> 242 243=back 244 245 246=head1 ACKNOWLEDGEMENTS 247 248Thanks to author of L<Test::Pod::Coverage>. 90% of this module is a copy-paste from L<Test::Pod::Coverage>. 249 250=head1 LICENSE AND COPYRIGHT 251 252Copyright 2010 Andrey Kostenko, based on Andy Lester's L<Test::Pod::Coverage> 253 254This program is free software; you can redistribute it and/or modify it 255under the terms of either: the GNU General Public License as published 256by the Free Software Foundation; or the Artistic License. 257 258See http://dev.perl.org/licenses/ for more information. 259 260 261=cut 262 2631; # End of Test::Pod::Coverage::Permissive 264