summaryrefslogtreecommitdiffstats
path: root/chromium/third_party/cygwin/lib/perl5/vendor_perl/5.10/Pod/Coverage.pm
diff options
context:
space:
mode:
Diffstat (limited to 'chromium/third_party/cygwin/lib/perl5/vendor_perl/5.10/Pod/Coverage.pm')
-rw-r--r--chromium/third_party/cygwin/lib/perl5/vendor_perl/5.10/Pod/Coverage.pm486
1 files changed, 0 insertions, 486 deletions
diff --git a/chromium/third_party/cygwin/lib/perl5/vendor_perl/5.10/Pod/Coverage.pm b/chromium/third_party/cygwin/lib/perl5/vendor_perl/5.10/Pod/Coverage.pm
deleted file mode 100644
index 64b7ae38080..00000000000
--- a/chromium/third_party/cygwin/lib/perl5/vendor_perl/5.10/Pod/Coverage.pm
+++ /dev/null
@@ -1,486 +0,0 @@
-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<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/^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<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/^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<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 };
- 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;
- $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 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-08 02:18:56 +0000