Initial Commit
This commit is contained in:
Riley Schneider
494
database/perl/lib/Pod/Coverage.pm
Normal file
494
database/perl/lib/Pod/Coverage.pm
Normal file
@@ -0,0 +1,494 @@
|
||||
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
|
||||
Reference in New Issue
Block a user