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 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 is covered, but C is not, so the C package is only 50% (0.5) covered =head2 Methods =over =item Pod::Coverage->new(package => $package) Creates a new Pod::Coverage object. C the name of the package to analyse C 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 items are appended to the private list C 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 is supplied, that file is parsed for the documentation, rather than using Pod::Find If C 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, to indicate that it was unable to deduce coverage for a package. If this happens you should be able to check C 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, 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 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 may make your life easier if you want to extend C to fit your house style more closely. B 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; # 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 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 rocks so hard. =back =head1 SEE ALSO L, L =head1 AUTHORS Richard Clamp Michael Stevens some contributions from David Cantrell =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