File Coverage

File:lib/App/Project/Doctor/Check/Pod.pm
Coverage:94.5%

linestmtbrancondsubtimecode
1package App::Project::Doctor::Check::Pod;
2
3# This check verifies that every .pm file under lib/ contains valid POD
4# documentation.  It uses Pod::Checker to detect syntax errors.
5# Modules with no POD at all get a fixable finding that writes a skeleton.
6
7
3
3
3
3
2574
3
38
use strict;
8
3
3
3
3
5
2
115
use warnings;
9
3
3
3
3
12
36
9
use autodie qw(:all);
10
11# Inherit the standard check interface from Check::Base.
12
3
3
3
3
6562
4
11
use parent -norequire, 'App::Project::Doctor::Check::Base';
13
14# croak dies with the caller's location; carp warns there.
15
3
3
3
3
107
2
1592
use Carp qw(croak carp);
16
17our $VERSION = '0.02';
18
19# Short name used in Finding.check_name and text-report columns.
20
2
2
198
sub name        { 'POD' }
21# One-line description for --help and verbose output.
22
1
1
3
sub description { 'Every .pm file contains valid, parseable POD documentation.' }
23# This check can offer a fix (append a POD skeleton).
24
2
2
4
sub can_fix     { 1 }
25# Run after Dependencies (50) but before Security (60).
26
2
2
3
sub order       { 40 }
27
28sub check {
29
10
10
14
        my ($self, $ctx) = @_;
30        # Guard: require a proper Context object.
31
10
50
17
        croak 'check requires an App::Project::Doctor::Context' unless ref $ctx;
32
33
10
9
        my @findings;
34        # lib_modules() returns an arrayref of .pm paths relative to the distro root.
35
10
21
        my $modules = $ctx->lib_modules;
36
37        # If there are no .pm files at all there is nothing to check.
38
10
10
100
10
25
        unless (@{$modules}) {
39
3
7
                return _f(
40                        severity => 'info',
41                        message  => 'No .pm files under lib/ -- nothing to check.',
42                );
43        }
44
45
7
7
9
10
        for my $mod (@{$modules}) {
46                # Try to read the module source; skip it with a carp if reading fails.
47
8
8
1
1
67
14
15
18
174
                my $content = eval { $ctx->slurp($mod) } // do { carp "Cannot slurp $mod: $@"; next };
48
49                # Quick check: does the file contain any POD at all?
50                # A line beginning with '=' followed by a word character starts a POD block.
51
7
100
68
                unless ($content =~ /^=\w/m) {
52                        # No POD found -- offer to append a skeleton.
53
3
7
                        push @findings, _f(
54                                severity => 'error',
55                                message  => "No POD found in $mod.",
56                                file     => $mod,
57                                fix      => _fix_scaffold_pod($ctx, $mod),
58                        );
59                        # No point running Pod::Checker on a file with no POD at all.
60
3
5
                        next;
61                }
62
63                # Validate the existing POD with Pod::Checker and collect any errors.
64
4
14
                for my $err (_check_pod($ctx->abs_path($mod))) {
65                        push @findings, _f(
66                                severity => 'error',
67                                message  => "POD error in $mod: $err->{message}",
68                                file     => $mod,
69                                # Only include a line number when Pod::Checker provided one.
70
1
50
3
                                defined $err->{line} ? (line => $err->{line}) : (),
71                        );
72                }
73        }
74
75        # If we collected no error findings, all modules have valid POD.
76
7
100
39
        unless (@findings) {
77                push @findings, _f(
78                        severity => 'pass',
79
3
3
3
11
                        message  => sprintf('%d module(s) checked -- all have valid POD.', scalar @{$modules}),
80                );
81        }
82
83
7
21
        return @findings;
84}
85
86# ---------------------------------------------------------------------------
87# Private helpers
88# ---------------------------------------------------------------------------
89
90# Purpose:    Create a Finding with check_name pre-filled to 'POD'.
91# Entry:      %args is a valid Finding constructor argument list.
92# Exit:       App::Project::Doctor::Finding object.
93# Side effects: None.
94sub _f {
95
10
10
24
        require App::Project::Doctor::Finding;
96
10
40
        return App::Project::Doctor::Finding->new(check_name => 'POD', @_);
97}
98
99# Purpose:    Run Pod::Checker on a single file and return a list of errors.
100# Entry:      $abs_path is the absolute path to the .pm file to check.
101# Exit:       List of hashrefs with 'message' string and optional 'line' int.
102# Side effects: Loads Pod::Checker if not already in memory; writes to an in-memory
103#               filehandle (no disk I/O).
104sub _check_pod {
105
5
5
2363
        my $abs_path = shift;
106
5
578
        require Pod::Checker;
107
108        # Capture Pod::Checker's diagnostic output into a scalar instead of STDERR.
109
5
33655
        my $captured = '';
110
5
15
        open my $out_fh, '>', \$captured;
111
5
1809
        my $checker = Pod::Checker->new;
112
5
317
        $checker->parse_from_file($abs_path, $out_fh);
113
5
2766
        close $out_fh;
114
115        # If Pod::Checker reported no errors, return an empty list immediately.
116
5
100
50
949
        return () if ($checker->num_errors // 0) == 0;
117
118        # Parse the captured text output to extract individual error messages.
119
1
3
        my @errors;
120
1
3
        for my $line (split /\n/, $captured) {
121                # Skip blank lines in the checker output.
122
1
50
1
                next unless $line =~ /\S/;
123                # Try to extract the line number from the Pod::Checker message.
124
1
3
                my ($lineno) = $line =~ /line\s+(\d+)/i;
125
1
50
4
                push @errors, {
126                        message => $line,
127                        # Only include 'line' in the hashref when we actually found one.
128                        defined $lineno ? (line => $lineno) : (),
129                };
130        }
131
1
6
        return @errors;
132}
133
134# Purpose:    Return a coderef that rewrites a module file with a POD skeleton.
135# Entry:      $ctx is the Context; $rel_path is the module path relative to root.
136# Exit:       Coderef ($ctx) -> void; rewrites the module file with POD appended.
137# Side effects: Modifies the module file on disk when the coderef is called.
138sub _fix_scaffold_pod {
139
4
4
8
        my ($ctx, $rel_path) = @_;
140        # Return the fix as a closure so it runs only when the user accepts it.
141        return sub {
142                # Protect caller's $@ from autodie's internal eval inside open().
143
3
3
5
                local $@;
144
3
7
                my $abs = $ctx->abs_path($rel_path);
145                # Convert the relative file path to a Perl package name.
146                # e.g. lib/My/Module.pm -> My::Module
147
3
3
3
7
5
10
                (my $pkg = $rel_path) =~ s{^lib/}{}; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{};
148
149                # Read the existing file so we can rewrite it (not just append).
150
3
7
                open my $rfh, '<', $abs;
151
3
3
3
216
5
27
                my $content = do { local $/; <$rfh> };
152
3
5
                close $rfh;
153
154                # Remove any trailing `1;` so the rewritten file has exactly one.
155                # Without this, the original `1;` and the skeleton's `1;` would both appear.
156
3
74
                $content =~ s/\s*\n?1;\s*\z//s;
157
158                # Write the existing content back followed by the POD skeleton.
159
3
4
                open my $wfh, '>', $abs;
160
3
3
195
13
                print {$wfh} $content, <<"END_POD";
161
1621;
163