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