This file is indexed.

/usr/share/perl5/Pod/Coverage.pm is in libpod-coverage-perl 0.23-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
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