495 lines
12 KiB
Perl
495 lines
12 KiB
Perl
use strict;
|
|
|
|
package Pod::Coverage;
|
|
use Devel::Symdump;
|
|
use B;
|
|
use Pod::Find qw(pod_where);
|
|
|
|
BEGIN { defined &TRACE_ALL or eval 'sub TRACE_ALL () { 0 }' }
|
|
|
|
use vars qw/ $VERSION /;
|
|
$VERSION = '0.23';
|
|
|
|
=head1 NAME
|
|
|
|
Pod::Coverage - Checks if the documentation of a module is comprehensive
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
# in the beginnning...
|
|
perl -MPod::Coverage=Pod::Coverage -e666
|
|
|
|
# all in one invocation
|
|
use Pod::Coverage package => 'Fishy';
|
|
|
|
# straight OO
|
|
use Pod::Coverage;
|
|
my $pc = Pod::Coverage->new(package => 'Pod::Coverage');
|
|
print "We rock!" if $pc->coverage == 1;
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Developers hate writing documentation. They'd hate it even more if
|
|
their computer tattled on them, but maybe they'll be even more
|
|
thankful in the long run. Even if not, F<perlmodstyle> tells you to, so
|
|
you must obey.
|
|
|
|
This module provides a mechanism for determining if the pod for a
|
|
given module is comprehensive.
|
|
|
|
It expects to find either a C<< =head(n>1) >> or an C<=item> block documenting a
|
|
subroutine.
|
|
|
|
Consider:
|
|
# an imaginary Foo.pm
|
|
package Foo;
|
|
|
|
=item foo
|
|
|
|
The foo sub
|
|
|
|
= cut
|
|
|
|
sub foo {}
|
|
sub bar {}
|
|
|
|
1;
|
|
__END__
|
|
|
|
In this example C<Foo::foo> is covered, but C<Foo::bar> is not, so the C<Foo>
|
|
package is only 50% (0.5) covered
|
|
|
|
=head2 Methods
|
|
|
|
=over
|
|
|
|
=item Pod::Coverage->new(package => $package)
|
|
|
|
Creates a new Pod::Coverage object.
|
|
|
|
C<package> the name of the package to analyse
|
|
|
|
C<private> an array of regexen which define what symbols are regarded
|
|
as private (and so need not be documented) defaults to [ qr/^_/,
|
|
qr/^(un)?import$/, qr/^DESTROY$/, qr/^AUTOLOAD$/, qr/^bootstrap$/,
|
|
qr/^(TIE( SCALAR | ARRAY | HASH | HANDLE ) |
|
|
FETCH | STORE | UNTIE | FETCHSIZE | STORESIZE |
|
|
POP | PUSH | SHIFT | UNSHIFT | SPLICE | DELETE |
|
|
EXISTS | EXTEND | CLEAR | FIRSTKEY | NEXTKEY | PRINT | PRINTF |
|
|
WRITE | READLINE | GETC | READ | CLOSE | BINMODE | OPEN |
|
|
EOF | FILENO | SEEK | TELL | SCALAR )$/x,
|
|
qr/^( MODIFY | FETCH )_( REF | SCALAR | ARRAY | HASH | CODE |
|
|
GLOB | FORMAT | IO )_ATTRIBUTES$/x,
|
|
qr/^CLONE(_SKIP)?$/,
|
|
]
|
|
|
|
This should cover all the usual magical methods for tie()d objects,
|
|
attributes, generally all the methods that are typically not called by
|
|
a user, but instead being used internally by perl.
|
|
|
|
C<also_private> items are appended to the private list
|
|
|
|
C<trustme> an array of regexen which define what symbols you just want
|
|
us to assume are properly documented even if we can't find any docs
|
|
for them
|
|
|
|
If C<pod_from> is supplied, that file is parsed for the documentation,
|
|
rather than using Pod::Find
|
|
|
|
If C<nonwhitespace> is supplied, then only POD sections which have
|
|
non-whitespace characters will count towards being documented.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $referent = shift;
|
|
my %args = @_;
|
|
my $class = ref $referent || $referent;
|
|
|
|
my $private = $args{private} || [
|
|
qr/^_/,
|
|
qr/^(un)?import$/,
|
|
qr/^DESTROY$/,
|
|
qr/^AUTOLOAD$/,
|
|
qr/^bootstrap$/,
|
|
qr/^\(/,
|
|
qr/^(TIE( SCALAR | ARRAY | HASH | HANDLE ) |
|
|
FETCH | STORE | UNTIE | FETCHSIZE | STORESIZE |
|
|
POP | PUSH | SHIFT | UNSHIFT | SPLICE | DELETE |
|
|
EXISTS | EXTEND | CLEAR | FIRSTKEY | NEXTKEY | PRINT | PRINTF |
|
|
WRITE | READLINE | GETC | READ | CLOSE | BINMODE | OPEN |
|
|
EOF | FILENO | SEEK | TELL | SCALAR )$/x,
|
|
qr/^( MODIFY | FETCH )_( REF | SCALAR | ARRAY | HASH | CODE |
|
|
GLOB | FORMAT | IO)_ATTRIBUTES $/x,
|
|
qr/^CLONE(_SKIP)?$/,
|
|
];
|
|
push @$private, @{ $args{also_private} || [] };
|
|
my $trustme = $args{trustme} || [];
|
|
my $nonwhitespace = $args{nonwhitespace} || undef;
|
|
|
|
my $self = bless {
|
|
@_,
|
|
private => $private,
|
|
trustme => $trustme,
|
|
nonwhitespace => $nonwhitespace
|
|
}, $class;
|
|
}
|
|
|
|
=item $object->coverage
|
|
|
|
Gives the coverage as a value in the range 0 to 1
|
|
|
|
=cut
|
|
|
|
sub coverage {
|
|
my $self = shift;
|
|
|
|
my $package = $self->{package};
|
|
my $pods = $self->_get_pods;
|
|
return unless $pods;
|
|
|
|
my %symbols = map { $_ => 0 } $self->_get_syms($package);
|
|
|
|
if (!%symbols && $self->{why_unrated}) {
|
|
# _get_syms failed violently
|
|
return;
|
|
}
|
|
|
|
print "tying shoelaces\n" if TRACE_ALL;
|
|
for my $pod (@$pods) {
|
|
$symbols{$pod} = 1 if exists $symbols{$pod};
|
|
}
|
|
|
|
foreach my $sym ( keys %symbols ) {
|
|
$symbols{$sym} = 1 if $self->_trustme_check($sym);
|
|
}
|
|
|
|
# stash the results for later
|
|
$self->{symbols} = \%symbols;
|
|
|
|
if (TRACE_ALL) {
|
|
require Data::Dumper;
|
|
print Data::Dumper::Dumper($self);
|
|
}
|
|
|
|
my $symbols = scalar keys %symbols;
|
|
my $documented = scalar grep {$_} values %symbols;
|
|
unless ($symbols) {
|
|
$self->{why_unrated} = "no public symbols defined";
|
|
return;
|
|
}
|
|
return $documented / $symbols;
|
|
}
|
|
|
|
=item $object->why_unrated
|
|
|
|
C<< $object->coverage >> may return C<undef>, to indicate that it was
|
|
unable to deduce coverage for a package. If this happens you should
|
|
be able to check C<why_unrated> to get a useful excuse.
|
|
|
|
=cut
|
|
|
|
sub why_unrated {
|
|
my $self = shift;
|
|
$self->{why_unrated};
|
|
}
|
|
|
|
=item $object->naked/$object->uncovered
|
|
|
|
Returns a list of uncovered routines, will implicitly call coverage if
|
|
it's not already been called.
|
|
|
|
Note, private and 'trustme' identifiers will be skipped.
|
|
|
|
=cut
|
|
|
|
sub naked {
|
|
my $self = shift;
|
|
$self->{symbols} or $self->coverage;
|
|
return unless $self->{symbols};
|
|
return grep { !$self->{symbols}{$_} } keys %{ $self->{symbols} };
|
|
}
|
|
|
|
*uncovered = \&naked;
|
|
|
|
=item $object->covered
|
|
|
|
Returns a list of covered routines, will implicitly call coverage if
|
|
it's not previously been called.
|
|
|
|
As with C<naked>, private and 'trustme' identifiers will be skipped.
|
|
|
|
=cut
|
|
|
|
sub covered {
|
|
my $self = shift;
|
|
$self->{symbols} or $self->coverage;
|
|
return unless $self->{symbols};
|
|
return grep { $self->{symbols}{$_} } keys %{ $self->{symbols} };
|
|
}
|
|
|
|
sub import {
|
|
my $self = shift;
|
|
return unless @_;
|
|
|
|
# one argument - just a package
|
|
scalar @_ == 1 and unshift @_, 'package';
|
|
|
|
# we were called with arguments
|
|
my $pc = $self->new(@_);
|
|
my $rating = $pc->coverage;
|
|
$rating = 'unrated (' . $pc->why_unrated . ')'
|
|
unless defined $rating;
|
|
print $pc->{package}, " has a $self rating of $rating\n";
|
|
my @looky_here = $pc->naked;
|
|
if ( @looky_here > 1 ) {
|
|
print "The following are uncovered: ", join( ", ", sort @looky_here ),
|
|
"\n";
|
|
} elsif (@looky_here) {
|
|
print "'$looky_here[0]' is uncovered\n";
|
|
}
|
|
}
|
|
|
|
=back
|
|
|
|
=head2 Debugging support
|
|
|
|
In order to allow internals debugging, while allowing the optimiser to
|
|
do its thang, C<Pod::Coverage> uses constant subs to define how it traces.
|
|
|
|
Use them like so
|
|
|
|
sub Pod::Coverage::TRACE_ALL () { 1 }
|
|
use Pod::Coverage;
|
|
|
|
Supported constants are:
|
|
|
|
=over
|
|
|
|
=item TRACE_ALL
|
|
|
|
Trace everything.
|
|
|
|
Well that's all there is so far, are you glad you came?
|
|
|
|
=back
|
|
|
|
=head2 Inheritance interface
|
|
|
|
These abstract methods while functional in C<Pod::Coverage> may make
|
|
your life easier if you want to extend C<Pod::Coverage> to fit your
|
|
house style more closely.
|
|
|
|
B<NOTE> Please consider this interface as in a state of flux until
|
|
this comment goes away.
|
|
|
|
=over
|
|
|
|
=item $object->_CvGV($symbol)
|
|
|
|
Return the GV for the coderef supplied. Used by C<_get_syms> to identify
|
|
locally defined code.
|
|
|
|
You probably won't need to override this one.
|
|
|
|
=item $object->_get_syms($package)
|
|
|
|
return a list of symbols to check for from the specified packahe
|
|
|
|
=cut
|
|
|
|
# this one walks the symbol tree
|
|
sub _get_syms {
|
|
my $self = shift;
|
|
my $package = shift;
|
|
|
|
print "requiring '$package'\n" if TRACE_ALL;
|
|
eval qq{ require $package };
|
|
if ($@) {
|
|
print "require failed with $@\n" if TRACE_ALL;
|
|
$self->{why_unrated} = "requiring '$package' failed";
|
|
return;
|
|
}
|
|
|
|
print "walking symbols\n" if TRACE_ALL;
|
|
my $syms = Devel::Symdump->new($package);
|
|
|
|
my @symbols;
|
|
for my $sym ( $syms->functions ) {
|
|
|
|
# see if said method wasn't just imported from elsewhere
|
|
my $glob = do { no strict 'refs'; \*{$sym} };
|
|
my $o = B::svref_2object($glob);
|
|
|
|
# in 5.005 this flag is not exposed via B, though it exists
|
|
my $imported_cv = eval { B::GVf_IMPORTED_CV() } || 0x80;
|
|
next if $o->GvFLAGS & $imported_cv;
|
|
|
|
# check if it's on the whitelist
|
|
$sym =~ s/$self->{package}:://;
|
|
next if $self->_private_check($sym);
|
|
|
|
push @symbols, $sym;
|
|
}
|
|
return @symbols;
|
|
}
|
|
|
|
=item _get_pods
|
|
|
|
Extract pod markers from the currently active package.
|
|
|
|
Return an arrayref or undef on fail.
|
|
|
|
=cut
|
|
|
|
sub _get_pods {
|
|
my $self = shift;
|
|
|
|
my $package = $self->{package};
|
|
|
|
print "getting pod location for '$package'\n" if TRACE_ALL;
|
|
$self->{pod_from} ||= pod_where( { -inc => 1 }, $package );
|
|
|
|
my $pod_from = $self->{pod_from};
|
|
unless ($pod_from) {
|
|
$self->{why_unrated} = "couldn't find pod";
|
|
return;
|
|
}
|
|
|
|
print "parsing '$pod_from'\n" if TRACE_ALL;
|
|
my $pod = Pod::Coverage::Extractor->new;
|
|
$pod->{nonwhitespace} = $self->{nonwhitespace};
|
|
$pod->parse_from_file( $pod_from, '/dev/null' );
|
|
|
|
return $pod->{identifiers} || [];
|
|
}
|
|
|
|
=item _private_check($symbol)
|
|
|
|
return true if the symbol should be considered private
|
|
|
|
=cut
|
|
|
|
sub _private_check {
|
|
my $self = shift;
|
|
my $sym = shift;
|
|
return grep { $sym =~ /$_/ } @{ $self->{private} };
|
|
}
|
|
|
|
=item _trustme_check($symbol)
|
|
|
|
return true if the symbol is a 'trustme' symbol
|
|
|
|
=cut
|
|
|
|
sub _trustme_check {
|
|
my ( $self, $sym ) = @_;
|
|
return grep { $sym =~ /$_/ } @{ $self->{trustme} };
|
|
}
|
|
|
|
sub _CvGV {
|
|
my $self = shift;
|
|
my $cv = shift;
|
|
my $b_cv = B::svref_2object($cv);
|
|
|
|
# perl 5.6.2's B doesn't have an object_2svref. in 5.8 you can
|
|
# just do this:
|
|
# return *{ $b_cv->GV->object_2svref };
|
|
# but for backcompat we're forced into this uglyness:
|
|
no strict 'refs';
|
|
return *{ $b_cv->GV->STASH->NAME . "::" . $b_cv->GV->NAME };
|
|
}
|
|
|
|
package Pod::Coverage::Extractor;
|
|
use Pod::Parser;
|
|
use base 'Pod::Parser';
|
|
|
|
use constant debug => 0;
|
|
|
|
# extract subnames from a pod stream
|
|
sub command {
|
|
my $self = shift;
|
|
my ( $command, $text, $line_num ) = @_;
|
|
if ( $command eq 'item' || $command =~ /^head(?:2|3|4)/ ) {
|
|
|
|
# take a closer look
|
|
my @pods = ( $text =~ /\s*([^\s\|,\/]+)/g );
|
|
$self->{recent} = [];
|
|
|
|
foreach my $pod (@pods) {
|
|
print "Considering: '$pod'\n" if debug;
|
|
|
|
# it's dressed up like a method cal
|
|
$pod =~ /-E<\s*gt\s*>(.*)/ and $pod = $1;
|
|
$pod =~ /->(.*)/ and $pod = $1;
|
|
|
|
# it's used as a (bare) fully qualified name
|
|
$pod =~ /\w+(?:::\w+)*::(\w+)/ and $pod = $1;
|
|
|
|
# it's wrapped in a pod style B<>
|
|
$pod =~ s/[A-Z]<//g;
|
|
$pod =~ s/>//g;
|
|
|
|
# has arguments, or a semicolon
|
|
$pod =~ /(\w+)\s*[;\(]/ and $pod = $1;
|
|
|
|
print "Adding: '$pod'\n" if debug;
|
|
push @{ $self->{ $self->{nonwhitespace}
|
|
? "recent"
|
|
: "identifiers" } }, $pod;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub textblock {
|
|
my $self = shift;
|
|
my ( $text, $line_num ) = shift;
|
|
if ( $self->{nonwhitespace} and $text =~ /\S/ and $self->{recent} ) {
|
|
push @{ $self->{identifiers} }, @{ $self->{recent} };
|
|
$self->{recent} = [];
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=back
|
|
|
|
=head1 BUGS
|
|
|
|
Due to the method used to identify documented subroutines
|
|
C<Pod::Coverage> may completely miss your house style and declare your
|
|
code undocumented. Patches and/or failing tests welcome.
|
|
|
|
=head1 TODO
|
|
|
|
=over
|
|
|
|
=item Widen the rules for identifying documentation
|
|
|
|
=item Improve the code coverage of the test suite. C<Devel::Cover> rocks so hard.
|
|
|
|
=back
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Test::More>, L<Devel::Cover>
|
|
|
|
=head1 AUTHORS
|
|
|
|
Richard Clamp <richardc@unixbeard.net>
|
|
|
|
Michael Stevens <mstevens@etla.org>
|
|
|
|
some contributions from David Cantrell <david@cantrell.org.uk>
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2001, 2003, 2004, 2006, 2007, 2009 Richard Clamp, Michael
|
|
Stevens. All rights reserved. This program is free software; you can
|
|
redistribute it and/or modify it under the same terms as Perl itself.
|
|
|
|
=cut
|