vcs.maemo.org Git - dh-make-perl/blob - dev/arm/libpod-coverage-perl/libpod-coverage-perl-0.19/lib/Pod/Coverage.pm

   1 use strict;
   2
   3 package Pod::Coverage;
   4 use Devel::Symdump;
   5 use B;
   6 use Pod::Find qw(pod_where);
   7
   8 BEGIN { defined &TRACE_ALL or eval 'sub TRACE_ALL () { 0 }' }
   9
  10 use vars qw/ $VERSION /;
  11 $VERSION = '0.19';
  12
  13 =head1 NAME
  14
  15 Pod::Coverage - Checks if the documentation of a module is comprehensive
  16
  17 =head1 SYNOPSIS
  18
  19   # in the beginnning...
  20   perl -MPod::Coverage=Pod::Coverage -e666
  21
  22   # all in one invocation
  23   use Pod::Coverage package => 'Fishy';
  24
  25   # straight OO
  26   use Pod::Coverage;
  27   my $pc = Pod::Coverage->new(package => 'Pod::Coverage');
  28   print "We rock!" if $pc->coverage == 1;
  29
  30
  31 =head1 DESCRIPTION
  32
  33 Developers hate writing documentation.  They'd hate it even more if
  34 their computer tattled on them, but maybe they'll be even more
  35 thankful in the long run.  Even if not, F<perlmodstyle> tells you to, so
  36 you must obey.
  37
  38 This module provides a mechanism for determining if the pod for a
  39 given module is comprehensive.
  40
  41 It expects to find either a C<< =head(n>1) >> or an C<=item> block documenting a
  42 subroutine.
  43
  44 Consider:
  45  # an imaginary Foo.pm
  46  package Foo;
  47
  48  =item foo
  49
  50  The foo sub
  51
  52  = cut
  53
  54  sub foo {}
  55  sub bar {}
  56
  57  1;
  58  __END__
  59
  60 In this example C<Foo::foo> is covered, but C<Foo::bar> is not, so the C<Foo>
  61 package is only 50% (0.5) covered
  62
  63 =head2 Methods
  64
  65 =over
  66
  67 =item Pod::Coverage->new(package => $package)
  68
  69 Creates a new Pod::Coverage object.
  70
  71 C<package> the name of the package to analyse
  72
  73 C<private> an array of regexen which define what symbols are regarded
  74 as private (and so need not be documented) defaults to [ qr/^_/,
  75 qr/^import$/, qr/^DESTROY$/, qr/^AUTOLOAD$/, qr/^bootstrap$/,
  76         qr/^(TIE( SCALAR | ARRAY | HASH | HANDLE ) |
  77              FETCH | STORE | UNTIE | FETCHSIZE | STORESIZE |
  78              POP | PUSH | SHIFT | UNSHIFT | SPLICE | DELETE |
  79              EXISTS | EXTEND | CLEAR | FIRSTKEY | NEXTKEY | PRINT | PRINTF |
  80              WRITE | READLINE | GETC | READ | CLOSE | BINMODE | OPEN |
  81              EOF | FILENO | SEEK | TELL)$/x,
  82         qr/^( MODIFY | FETCH )_( REF | SCALAR | ARRAY | HASH | CODE |
  83                                  GLOB | FORMAT | IO)_ATTRIBUTES$/x,
  84         qr/^CLONE(_SKIP)?$/,
  85 ]
  86
  87 This should cover all the usual magical methods for tie()d objects,
  88 attributes, generally all the methods that are typically not called by
  89 a user, but instead being used internally by perl.
  90
  91 C<also_private> items are appended to the private list
  92
  93 C<trustme> an array of regexen which define what symbols you just want
  94 us to assume are properly documented even if we can't find any docs
  95 for them
  96
  97 If C<pod_from> is supplied, that file is parsed for the documentation,
  98 rather than using Pod::Find
  99
 100 If C<nonwhitespace> is supplied, then only POD sections which have
 101 non-whitespace characters will count towards being documented.
 102
 103 =cut
 104
 105 sub new {
 106     my $referent = shift;
 107     my %args     = @_;
 108     my $class    = ref $referent || $referent;
 109
 110     my $private = $args{private} || [
 111         qr/^_/,
 112         qr/^import$/,
 113         qr/^DESTROY$/,
 114         qr/^AUTOLOAD$/,
 115         qr/^bootstrap$/,
 116         qr/^\(/,
 117         qr/^(TIE( SCALAR | ARRAY | HASH | HANDLE ) |
 118              FETCH | STORE | UNTIE | FETCHSIZE | STORESIZE |
 119              POP | PUSH | SHIFT | UNSHIFT | SPLICE | DELETE |
 120              EXISTS | EXTEND | CLEAR | FIRSTKEY | NEXTKEY | PRINT | PRINTF |
 121              WRITE | READLINE | GETC | READ | CLOSE | BINMODE | OPEN |
 122              EOF | FILENO | SEEK | TELL)$/x,
 123         qr/^( MODIFY | FETCH )_( REF | SCALAR | ARRAY | HASH | CODE |
 124                                  GLOB | FORMAT | IO)_ATTRIBUTES $/x,
 125         qr/^CLONE(_SKIP)?$/,
 126     ];
 127     push @$private, @{ $args{also_private} || [] };
 128     my $trustme       = $args{trustme}       || [];
 129     my $nonwhitespace = $args{nonwhitespace} || undef;
 130
 131     my $self = bless {
 132         @_,
 133         private       => $private,
 134         trustme       => $trustme,
 135         nonwhitespace => $nonwhitespace
 136     }, $class;
 137 }
 138
 139 =item $object->coverage
 140
 141 Gives the coverage as a value in the range 0 to 1
 142
 143 =cut
 144
 145 sub coverage {
 146     my $self = shift;
 147
 148     my $package = $self->{package};
 149     my $pods    = $self->_get_pods;
 150     return unless $pods;
 151
 152     my %symbols = map { $_ => 0 } $self->_get_syms($package);
 153
 154     print "tying shoelaces\n" if TRACE_ALL;
 155     for my $pod (@$pods) {
 156         $symbols{$pod} = 1 if exists $symbols{$pod};
 157     }
 158
 159     foreach my $sym ( keys %symbols ) {
 160         $symbols{$sym} = 1 if $self->_trustme_check($sym);
 161     }
 162
 163     # stash the results for later
 164     $self->{symbols} = \%symbols;
 165
 166     if (TRACE_ALL) {
 167         require Data::Dumper;
 168         print Data::Dumper::Dumper($self);
 169     }
 170
 171     my $symbols = scalar keys %symbols;
 172     my $documented = scalar grep {$_} values %symbols;
 173     unless ($symbols) {
 174         $self->{why_unrated} = "no public symbols defined";
 175         return;
 176     }
 177     return $documented / $symbols;
 178 }
 179
 180 =item $object->why_unrated
 181
 182 C<< $object->coverage >> may return C<undef>, to indicate that it was
 183 unable to deduce coverage for a package.  If this happens you should
 184 be able to check C<why_unrated> to get a useful excuse.
 185
 186 =cut
 187
 188 sub why_unrated {
 189     my $self = shift;
 190     $self->{why_unrated};
 191 }
 192
 193 =item $object->naked/$object->uncovered
 194
 195 Returns a list of uncovered routines, will implicitly call coverage if
 196 it's not already been called.
 197
 198 Note, private and 'trustme' identifiers will be skipped.
 199
 200 =cut
 201
 202 sub naked {
 203     my $self = shift;
 204     $self->{symbols} or $self->coverage;
 205     return unless $self->{symbols};
 206     return grep { !$self->{symbols}{$_} } keys %{ $self->{symbols} };
 207 }
 208
 209 *uncovered = \&naked;
 210
 211 =item $object->covered
 212
 213 Returns a list of covered routines, will implicitly call coverage if
 214 it's not previously been called.
 215
 216 As with C<naked>, private and 'trustme' identifiers will be skipped.
 217
 218 =cut
 219
 220 sub covered {
 221     my $self = shift;
 222     $self->{symbols} or $self->coverage;
 223     return unless $self->{symbols};
 224     return grep { $self->{symbols}{$_} } keys %{ $self->{symbols} };
 225 }
 226
 227 sub import {
 228     my $self = shift;
 229     return unless @_;
 230
 231     # one argument - just a package
 232     scalar @_ == 1 and unshift @_, 'package';
 233
 234     # we were called with arguments
 235     my $pc     = $self->new(@_);
 236     my $rating = $pc->coverage;
 237     $rating = 'unrated (' . $pc->why_unrated . ')'
 238         unless defined $rating;
 239     print $pc->{package}, " has a $self rating of $rating\n";
 240     my @looky_here = $pc->naked;
 241     if ( @looky_here > 1 ) {
 242         print "The following are uncovered: ", join( ", ", sort @looky_here ),
 243             "\n";
 244     } elsif (@looky_here) {
 245         print "'$looky_here[0]' is uncovered\n";
 246     }
 247 }
 248
 249 =back
 250
 251 =head2 Debugging support
 252
 253 In order to allow internals debugging, while allowing the optimiser to
 254 do its thang, C<Pod::Coverage> uses constant subs to define how it traces.
 255
 256 Use them like so
 257
 258  sub Pod::Coverage::TRACE_ALL () { 1 }
 259  use Pod::Coverage;
 260
 261 Supported constants are:
 262
 263 =over
 264
 265 =item TRACE_ALL
 266
 267 Trace everything.
 268
 269 Well that's all there is so far, are you glad you came?
 270
 271 =back
 272
 273 =head2 Inheritance interface
 274
 275 These abstract methods while functional in C<Pod::Coverage> may make
 276 your life easier if you want to extend C<Pod::Coverage> to fit your
 277 house style more closely.
 278
 279 B<NOTE> Please consider this interface as in a state of flux until
 280 this comment goes away.
 281
 282 =over
 283
 284 =item $object->_CvGV($symbol)
 285
 286 Return the GV for the coderef supplied.  Used by C<_get_syms> to identify
 287 locally defined code.
 288
 289 You probably won't need to override this one.
 290
 291 =item $object->_get_syms($package)
 292
 293 return a list of symbols to check for from the specified packahe
 294
 295 =cut
 296
 297 # this one walks the symbol tree
 298 sub _get_syms {
 299     my $self    = shift;
 300     my $package = shift;
 301
 302     print "requiring '$package'\n" if TRACE_ALL;
 303     eval qq{ require $package };
 304     print "require failed with $@\n" if TRACE_ALL and $@;
 305     return if $@;
 306
 307     print "walking symbols\n" if TRACE_ALL;
 308     my $syms = Devel::Symdump->new($package);
 309
 310     my @symbols;
 311     for my $sym ( $syms->functions ) {
 312
 313         # see if said method wasn't just imported from elsewhere
 314         my $glob = do { no strict 'refs'; \*{$sym} };
 315         my $o = B::svref_2object($glob);
 316
 317         # in 5.005 this flag is not exposed via B, though it exists
 318         my $imported_cv = eval { B::GVf_IMPORTED_CV() } || 0x80;
 319         next if $o->GvFLAGS & $imported_cv;
 320
 321         # check if it's on the whitelist
 322         $sym =~ s/$self->{package}:://;
 323         next if $self->_private_check($sym);
 324
 325         push @symbols, $sym;
 326     }
 327     return @symbols;
 328 }
 329
 330 =item _get_pods
 331
 332 Extract pod markers from the currently active package.
 333
 334 Return an arrayref or undef on fail.
 335
 336 =cut
 337
 338 sub _get_pods {
 339     my $self = shift;
 340
 341     my $package = $self->{package};
 342
 343     print "getting pod location for '$package'\n" if TRACE_ALL;
 344     $self->{pod_from} ||= pod_where( { -inc => 1 }, $package );
 345
 346     my $pod_from = $self->{pod_from};
 347     unless ($pod_from) {
 348         $self->{why_unrated} = "couldn't find pod";
 349         return;
 350     }
 351
 352     print "parsing '$pod_from'\n" if TRACE_ALL;
 353     my $pod = Pod::Coverage::Extractor->new;
 354     $pod->{nonwhitespace} = $self->{nonwhitespace};
 355     $pod->parse_from_file( $pod_from, '/dev/null' );
 356
 357     return $pod->{identifiers} || [];
 358 }
 359
 360 =item _private_check($symbol)
 361
 362 return true if the symbol should be considered private
 363
 364 =cut
 365
 366 sub _private_check {
 367     my $self = shift;
 368     my $sym  = shift;
 369     return grep { $sym =~ /$_/ } @{ $self->{private} };
 370 }
 371
 372 =item _trustme_check($symbol)
 373
 374 return true if the symbol is a 'trustme' symbol
 375
 376 =cut
 377
 378 sub _trustme_check {
 379     my ( $self, $sym ) = @_;
 380     return grep { $sym =~ /$_/ } @{ $self->{trustme} };
 381 }
 382
 383 sub _CvGV {
 384     my $self = shift;
 385     my $cv   = shift;
 386     my $b_cv = B::svref_2object($cv);
 387
 388     # perl 5.6.2's B doesn't have an object_2svref.  in 5.8 you can
 389     # just do this:
 390     # return *{ $b_cv->GV->object_2svref };
 391     # but for backcompat we're forced into this uglyness:
 392     no strict 'refs';
 393     return *{ $b_cv->GV->STASH->NAME . "::" . $b_cv->GV->NAME };
 394 }
 395
 396 package Pod::Coverage::Extractor;
 397 use Pod::Parser;
 398 use base 'Pod::Parser';
 399
 400 use constant debug => 0;
 401
 402 # extract subnames from a pod stream
 403 sub command {
 404     my $self = shift;
 405     my ( $command, $text, $line_num ) = @_;
 406     if ( $command eq 'item' || $command =~ /^head(?:2|3|4)/ ) {
 407
 408         # take a closer look
 409         my @pods = ( $text =~ /\s*([^\s\|,\/]+)/g );
 410         $self->{recent} = [];
 411
 412         foreach my $pod (@pods) {
 413             print "Considering: '$pod'\n" if debug;
 414
 415             # it's dressed up like a method cal
 416             $pod =~ /-E<\s*gt\s*>(.*)/ and $pod = $1;
 417             $pod =~ /->(.*)/           and $pod = $1;
 418
 419             # it's used as a (bare) fully qualified name
 420             $pod =~ /\w+(?:::\w+)*::(\w+)/ and $pod = $1;
 421
 422             # it's wrapped in a pod style B<>
 423             $pod =~ s/[A-Z]<//g;
 424             $pod =~ s/>//g;
 425
 426             # has arguments, or a semicolon
 427             $pod =~ /(\w+)\s*[;\(]/ and $pod = $1;
 428
 429             print "Adding: '$pod'\n" if debug;
 430             push @{ $self->{ $self->{nonwhitespace}
 431                     ? "recent"
 432                     : "identifiers" } }, $pod;
 433         }
 434     }
 435 }
 436
 437 sub textblock {
 438     my $self = shift;
 439     my ( $text, $line_num ) = shift;
 440     if ( $self->{nonwhitespace} and $text =~ /\S/ and $self->{recent} ) {
 441         push @{ $self->{identifiers} }, @{ $self->{recent} };
 442         $self->{recent} = [];
 443     }
 444 }
 445
 446 1;
 447
 448 __END__
 449
 450 =back
 451
 452 =head1 BUGS
 453
 454 Due to the method used to identify documented subroutines
 455 C<Pod::Coverage> may completely miss your house style and declare your
 456 code undocumented.  Patches and/or failing tests welcome.
 457
 458 =head1 TODO
 459
 460 =over
 461
 462 =item Widen the rules for identifying documentation
 463
 464 =item Improve the code coverage of the test suite.  C<Devel::Cover> rocks so hard.
 465
 466 =back
 467
 468 =head1 SEE ALSO
 469
 470 L<Test::More>, L<Devel::Cover>
 471
 472 =head1 AUTHORS
 473
 474 Richard Clamp <richardc@unixbeard.net>
 475
 476 Michael Stevens <mstevens@etla.org>
 477
 478 some contributions from David Cantrell <david@cantrell.org.uk>
 479
 480 =head1 COPYRIGHT
 481
 482 Copyright (c) 2001, 2003, 2004, 2006, 2007 Richard Clamp, Michael
 483 Stevens. All rights reserved.  This program is free software; you can
 484 redistribute it and/or modify it under the same terms as Perl itself.
 485
 486 =cut