vcs.maemo.org Git - pkg-perl/blob - deb-src/libtest-pod-coverage-perl/libtest-pod-coverage-perl-1.08/Coverage.pm

   1 package Test::Pod::Coverage;
   2
   3 =head1 NAME
   4
   5 Test::Pod::Coverage - Check for pod coverage in your distribution.
   6
   7 =head1 VERSION
   8
   9 Version 1.08
  10
  11 =cut
  12
  13 our $VERSION = "1.08";
  14
  15 =head1 SYNOPSIS
  16
  17 Checks for POD coverage in files for your distribution.
  18
  19     use Test::Pod::Coverage tests=>1;
  20     pod_coverage_ok( "Foo::Bar", "Foo::Bar is covered" );
  21
  22 Can also be called with L<Pod::Coverage> parms.
  23
  24     use Test::Pod::Coverage tests=>1;
  25     pod_coverage_ok(
  26         "Foo::Bar",
  27         { also_private => [ qr/^[A-Z_]+$/ ], },
  28         "Foo::Bar, with all-caps functions as privates",
  29     );
  30
  31 The L<Pod::Coverage> parms are also useful for subclasses that don't
  32 re-document the parent class's methods.  Here's an example from
  33 L<Mail::SRS>.
  34
  35     pod_coverage_ok( "Mail::SRS" ); # No exceptions
  36
  37     # Define the three overridden methods.
  38     my $trustme = { trustme => [qr/^(new|parse|compile)$/] };
  39     pod_coverage_ok( "Mail::SRS::DB", $trustme );
  40     pod_coverage_ok( "Mail::SRS::Guarded", $trustme );
  41     pod_coverage_ok( "Mail::SRS::Reversable", $trustme );
  42     pod_coverage_ok( "Mail::SRS::Shortcut", $trustme );
  43
  44 Alternately, you could use L<Pod::Coverage::CountParents>, which always allows
  45 a subclass to reimplement its parents' methods without redocumenting them.  For
  46 example:
  47
  48     my $trustparents = { coverage_class => 'Pod::Coverage::CountParents' };
  49     pod_coverage_ok( "IO::Handle::Frayed", $trustparents );
  50
  51 (The C<coverage_class> parameter is not passed to the coverage class with other
  52 parameters.)
  53
  54 If you want POD coverage for your module, but don't want to make
  55 Test::Pod::Coverage a prerequisite for installing, create the following
  56 as your F<t/pod-coverage.t> file:
  57
  58     use Test::More;
  59     eval "use Test::Pod::Coverage";
  60     plan skip_all => "Test::Pod::Coverage required for testing pod coverage" if $@;
  61
  62     plan tests => 1;
  63     pod_coverage_ok( "Pod::Master::Html");
  64
  65 Finally, Module authors can include the following in a F<t/pod-coverage.t>
  66 file and have C<Test::Pod::Coverage> automatically find and check all
  67 modules in the module distribution:
  68
  69     use Test::More;
  70     eval "use Test::Pod::Coverage 1.00";
  71     plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@;
  72     all_pod_coverage_ok();
  73
  74 =cut
  75
  76 use strict;
  77 use warnings;
  78
  79 use Pod::Coverage;
  80 use Test::Builder;
  81
  82 my $Test = Test::Builder->new;
  83
  84 sub import {
  85     my $self = shift;
  86     my $caller = caller;
  87     no strict 'refs';
  88     *{$caller.'::pod_coverage_ok'}       = \&pod_coverage_ok;
  89     *{$caller.'::all_pod_coverage_ok'}   = \&all_pod_coverage_ok;
  90     *{$caller.'::all_modules'}           = \&all_modules;
  91
  92     $Test->exported_to($caller);
  93     $Test->plan(@_);
  94 }
  95
  96 =head1 FUNCTIONS
  97
  98 All functions listed below are exported to the calling namespace.
  99
 100 =head2 all_pod_coverage_ok( [$parms, ] $msg )
 101
 102 Checks that the POD code in all modules in the distro have proper POD
 103 coverage.
 104
 105 If the I<$parms> hashref if passed in, they're passed into the
 106 C<Pod::Coverage> object that the function uses.  Check the
 107 L<Pod::Coverage> manual for what those can be.
 108
 109 The exception is the C<coverage_class> parameter, which specifies a class to
 110 use for coverage testing.  It defaults to C<Pod::Coverage>.
 111
 112 =cut
 113
 114 sub all_pod_coverage_ok {
 115     my $parms = (@_ && (ref $_[0] eq "HASH")) ? shift : {};
 116     my $msg = shift;
 117
 118     my $ok = 1;
 119     my @modules = all_modules();
 120     if ( @modules ) {
 121         $Test->plan( tests => scalar @modules );
 122
 123         for my $module ( @modules ) {
 124             my $thismsg = defined $msg ? $msg : "Pod coverage on $module";
 125
 126             my $thisok = pod_coverage_ok( $module, $parms, $thismsg );
 127             $ok = 0 unless $thisok;
 128         }
 129     }
 130     else {
 131         $Test->plan( tests => 1 );
 132         $Test->ok( 1, "No modules found." );
 133     }
 134
 135     return $ok;
 136 }
 137
 138
 139 =head2 pod_coverage_ok( $module, [$parms, ] $msg )
 140
 141 Checks that the POD code in I<$module> has proper POD coverage.
 142
 143 If the I<$parms> hashref if passed in, they're passed into the
 144 C<Pod::Coverage> object that the function uses.  Check the
 145 L<Pod::Coverage> manual for what those can be.
 146
 147 The exception is the C<coverage_class> parameter, which specifies a class to
 148 use for coverage testing.  It defaults to C<Pod::Coverage>.
 149
 150 =cut
 151
 152 sub pod_coverage_ok {
 153     my $module = shift;
 154     my %parms = (@_ && (ref $_[0] eq "HASH")) ? %{(shift)} : ();
 155     my $msg = @_ ? shift : "Pod coverage on $module";
 156
 157     my $pc_class = (delete $parms{coverage_class}) || 'Pod::Coverage';
 158     eval "require $pc_class" or die $@;
 159
 160     my $pc = $pc_class->new( package => $module, %parms );
 161
 162     my $rating = $pc->coverage;
 163     my $ok;
 164     if ( defined $rating ) {
 165         $ok = ($rating == 1);
 166         $Test->ok( $ok, $msg );
 167         if ( !$ok ) {
 168             my @nakies = sort $pc->naked;
 169             my $s = @nakies == 1 ? "" : "s";
 170             $Test->diag(
 171                 sprintf( "Coverage for %s is %3.1f%%, with %d naked subroutine$s:",
 172                     $module, $rating*100, scalar @nakies ) );
 173             $Test->diag( "\t$_" ) for @nakies;
 174         }
 175     }
 176     else { # No symbols
 177         my $why = $pc->why_unrated;
 178         my $nopublics = ( $why =~ "no public symbols defined" );
 179         my $verbose = $ENV{HARNESS_VERBOSE} || 0;
 180         $ok = $nopublics;
 181         $Test->ok( $ok, $msg );
 182         $Test->diag( "$module: $why" ) unless ( $nopublics && !$verbose );
 183     }
 184
 185     return $ok;
 186 }
 187
 188 =head2 all_modules( [@dirs] )
 189
 190 Returns a list of all modules in I<$dir> and in directories below. If
 191 no directories are passed, it defaults to F<blib> if F<blib> exists,
 192 or F<lib> if not.
 193
 194 Note that the modules are as "Foo::Bar", not "Foo/Bar.pm".
 195
 196 The order of the files returned is machine-dependent.  If you want them
 197 sorted, you'll have to sort them yourself.
 198
 199 =cut
 200
 201 sub all_modules {
 202     my @starters = @_ ? @_ : _starting_points();
 203     my %starters = map {$_,1} @starters;
 204
 205     my @queue = @starters;
 206
 207     my @modules;
 208     while ( @queue ) {
 209         my $file = shift @queue;
 210         if ( -d $file ) {
 211             local *DH;
 212             opendir DH, $file or next;
 213             my @newfiles = readdir DH;
 214             closedir DH;
 215
 216             @newfiles = File::Spec->no_upwards( @newfiles );
 217             @newfiles = grep { $_ ne "CVS" && $_ ne ".svn" } @newfiles;
 218
 219             push @queue, map "$file/$_", @newfiles;
 220         }
 221         if ( -f $file ) {
 222             next unless $file =~ /\.pm$/;
 223
 224             my @parts = File::Spec->splitdir( $file );
 225             shift @parts if @parts && exists $starters{$parts[0]};
 226             shift @parts if @parts && $parts[0] eq "lib";
 227             $parts[-1] =~ s/\.pm$// if @parts;
 228
 229             # Untaint the parts
 230             for ( @parts ) {
 231                 if ( /^([a-zA-Z0-9_\.\-]+)$/ && ($_ eq $1) ) {
 232                     $_ = $1;  # Untaint the original
 233                 }
 234                 else {
 235                     die qq{Invalid and untaintable filename "$file"!};
 236                 }
 237             }
 238             my $module = join( "::", @parts );
 239             push( @modules, $module );
 240         }
 241     } # while
 242
 243     return @modules;
 244 }
 245
 246 sub _starting_points {
 247     return 'blib' if -e 'blib';
 248     return 'lib';
 249 }
 250
 251 =head1 BUGS
 252
 253 Please report any bugs or feature requests to
 254 C<bug-test-pod-coverage at rt.cpan.org>, or through the web interface at
 255 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Pod-Coverage>.
 256 I will be notified, and then you'll automatically be notified of progress on
 257 your bug as I make changes.
 258
 259 =head1 SUPPORT
 260
 261 You can find documentation for this module with the perldoc command.
 262
 263     perldoc Test::Pod::Coverage
 264
 265 You can also look for information at:
 266
 267 =over 4
 268
 269 =item * AnnoCPAN: Annotated CPAN documentation
 270
 271 L<http://annocpan.org/dist/Test-Pod-Coverage>
 272
 273 =item * CPAN Ratings
 274
 275 L<http://cpanratings.perl.org/d/Test-Pod-Coverage>
 276
 277 =item * RT: CPAN's request tracker
 278
 279 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Pod-Coverage>
 280
 281 =item * Search CPAN
 282
 283 L<http://search.cpan.org/dist/Test-Pod-Coverage>
 284
 285 =back
 286
 287 =head1 AUTHOR
 288
 289 Written by Andy Lester, C<< <andy at petdance.com> >>.
 290
 291 =head1 ACKNOWLEDGEMENTS
 292
 293 Thanks to Ricardo Signes for patches, and Richard Clamp for
 294 writing Pod::Coverage.
 295
 296 =head1 COPYRIGHT & LICENSE
 297
 298 Copyright 2006, Andy Lester, All Rights Reserved.
 299
 300 You may use, modify, and distribute this package under the
 301 same terms as Perl itself.
 302
 303 =cut
 304
 305 1;