X-Git-Url: http://vcs.maemo.org/git/?a=blobdiff_plain;f=dev%2Fi386%2Flibpod-coverage-perl%2Flibpod-coverage-perl-0.19%2Flib%2FPod%2FCoverage.pm;fp=dev%2Fi386%2Flibpod-coverage-perl%2Flibpod-coverage-perl-0.19%2Flib%2FPod%2FCoverage.pm;h=64b7ae380807111d7a6c5e7062e3da1583bc5ba2;hb=8977e561d8a9eae6959218b0306c9df2056a38a9;hp=0000000000000000000000000000000000000000;hpb=df794b845212301ea0d267c919232538bfef356a;p=dh-make-perl diff --git a/dev/i386/libpod-coverage-perl/libpod-coverage-perl-0.19/lib/Pod/Coverage.pm b/dev/i386/libpod-coverage-perl/libpod-coverage-perl-0.19/lib/Pod/Coverage.pm new file mode 100644 index 0000000..64b7ae3 --- /dev/null +++ b/dev/i386/libpod-coverage-perl/libpod-coverage-perl-0.19/lib/Pod/Coverage.pm @@ -0,0 +1,486 @@ +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.19'; + +=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/^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)$/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/^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)$/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); + + 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 }; + print "require failed with $@\n" if TRACE_ALL and $@; + return if $@; + + 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 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