File Coverage

inc/Test/Pod/Coverage.pm
Criterion Covered Total %
statement 82 93 88.1
branch 23 44 52.2
condition 8 22 36.3
subroutine 10 10 100.0
pod 3 3 100.0
total 126 172 73.2


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Pod::Coverage;
3              
4             #line 11
5              
6             our $VERSION = "1.08";
7              
8             #line 74
9              
10             use strict;
11             use warnings;
12              
13             use Pod::Coverage;
14             use Test::Builder;
15              
16             my $Test = Test::Builder->new;
17              
18             sub import {
19             my $self = shift;
20             my $caller = caller;
21             no strict 'refs';
22             *{$caller.'::pod_coverage_ok'} = \&pod_coverage_ok;
23             *{$caller.'::all_pod_coverage_ok'} = \&all_pod_coverage_ok;
24             *{$caller.'::all_modules'} = \&all_modules;
25              
26             $Test->exported_to($caller);
27             $Test->plan(@_);
28             }
29              
30             #line 112
31              
32             sub all_pod_coverage_ok {
33             my $parms = (@_ && (ref $_[0] eq "HASH")) ? shift : {};
34             my $msg = shift;
35              
36             my $ok = 1;
37             my @modules = all_modules();
38             if ( @modules ) {
39             $Test->plan( tests => scalar @modules );
40              
41             for my $module ( @modules ) {
42             my $thismsg = defined $msg ? $msg : "Pod coverage on $module";
43              
44             my $thisok = pod_coverage_ok( $module, $parms, $thismsg );
45             $ok = 0 unless $thisok;
46             }
47             }
48             else {
49             $Test->plan( tests => 1 );
50             $Test->ok( 1, "No modules found." );
51             }
52              
53             return $ok;
54             }
55              
56              
57             #line 150
58              
59             sub pod_coverage_ok {
60             my $module = shift;
61             my %parms = (@_ && (ref $_[0] eq "HASH")) ? %{(shift)} : ();
62             my $msg = @_ ? shift : "Pod coverage on $module";
63              
64             my $pc_class = (delete $parms{coverage_class}) || 'Pod::Coverage';
65             eval "require $pc_class" or die $@;
66              
67             my $pc = $pc_class->new( package => $module, %parms );
68              
69             my $rating = $pc->coverage;
70             my $ok;
71             if ( defined $rating ) {
72             $ok = ($rating == 1);
73             $Test->ok( $ok, $msg );
74             if ( !$ok ) {
75 1     1   673 my @nakies = sort $pc->naked;
  1         3  
  1         40  
76 1     1   5 my $s = @nakies == 1 ? "" : "s";
  1         3  
  1         32  
77             $Test->diag(
78 1     1   13 sprintf( "Coverage for %s is %3.1f%%, with %d naked subroutine$s:",
  1         2  
  1         25  
79 1     1   6 $module, $rating*100, scalar @nakies ) );
  1         2  
  1         62  
80             $Test->diag( "\t$_" ) for @nakies;
81             }
82             }
83             else { # No symbols
84 1     1   27 my $why = $pc->why_unrated;
85 1         2 my $nopublics = ( $why =~ "no public symbols defined" );
86 1     1   6 my $verbose = $ENV{HARNESS_VERBOSE} || 0;
  1         2  
  1         927  
87 1         2 $ok = $nopublics;
  1         6  
88 1         2 $Test->ok( $ok, $msg );
  1         4  
89 1         2 $Test->diag( "$module: $why" ) unless ( $nopublics && !$verbose );
  1         3  
90             }
91 1         5  
92 1         11 return $ok;
93             }
94              
95             #line 199
96              
97             sub all_modules {
98             my @starters = @_ ? @_ : _starting_points();
99             my %starters = map {$_,1} @starters;
100              
101             my @queue = @starters;
102              
103             my @modules;
104             while ( @queue ) {
105             my $file = shift @queue;
106             if ( -d $file ) {
107             local *DH;
108             opendir DH, $file or next;
109             my @newfiles = readdir DH;
110             closedir DH;
111              
112             @newfiles = File::Spec->no_upwards( @newfiles );
113             @newfiles = grep { $_ ne "CVS" && $_ ne ".svn" } @newfiles;
114 1 50 33 1 1 16  
115 1         16 push @queue, map "$file/$_", @newfiles;
116             }
117 1         1 if ( -f $file ) {
118 1         2 next unless $file =~ /\.pm$/;
119 1 50       2  
120 1         5 my @parts = File::Spec->splitdir( $file );
121             shift @parts if @parts && exists $starters{$parts[0]};
122 1         535 shift @parts if @parts && $parts[0] eq "lib";
123 1 50       6 $parts[-1] =~ s/\.pm$// if @parts;
124              
125 1         3 # Untaint the parts
126 1 50       5 for ( @parts ) {
127             if ( /^([a-zA-Z0-9_\.\-]+)$/ && ($_ eq $1) ) {
128             $_ = $1; # Untaint the original
129             }
130 0         0 else {
131 0         0 die qq{Invalid and untaintable filename "$file"!};
132             }
133             }
134 1         86 my $module = join( "::", @parts );
135             push( @modules, $module );
136             }
137             } # while
138              
139             return @modules;
140             }
141              
142             sub _starting_points {
143             return 'blib' if -e 'blib';
144             return 'lib';
145             }
146              
147             #line 303
148              
149             1;