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
2793
3
47
use strict;
8
3
3
3
3
5
3
83
use warnings;
9
3
3
3
3
15
32
10
use autodie qw(:all);
10
11# Inherit the standard check interface from Check::Base.
12
3
3
3
3
6496
2
10
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
95
3
1413
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
193
sub name        { 'POD' }
21# One-line description for --help and verbose output.
22
1
1
2
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
4
sub order       { 40 }
27
28sub check {
29
11
11
15
        my ($self, $ctx) = @_;
30        # Guard: require a proper Context object.
31
11
50
14
        croak 'check requires an App::Project::Doctor::Context' unless ref $ctx;
32
33
11
10
        my @findings;
34        # lib_modules() returns an arrayref of .pm paths relative to the distro root.
35
11
20
        my $modules = $ctx->lib_modules;
36
37        # If there are no .pm files at all there is nothing to check.
38
11
11
100
10
20
        unless (@{$modules}) {
39
3
6
                return _f(
40                        severity => 'info',
41                        message  => 'No .pm files under lib/ -- nothing to check.',
42                );
43        }
44
45
8
8
7
9
        for my $mod (@{$modules}) {
46                # Try to read the module source; skip it with a carp if reading fails.
47
9
9
1
1
67
16
14
21
144
                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
8
100
66
                unless ($content =~ /^=\w/m) {
52                        # No POD found -- offer to append a skeleton.
53
3
8
                        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
6
                        next;
61                }
62
63                # Validate the existing POD with Pod::Checker and collect any errors.
64
5
15
                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
4
                                defined $err->{line} ? (line => $err->{line}) : (),
71                        );
72                }
73        }
74
75        # If we collected no error findings, all modules have valid POD.
76
8
100
46
        unless (@findings) {
77                push @findings, _f(
78                        severity => 'pass',
79
4
4
2
11
                        message  => sprintf('%d module(s) checked -- all have valid POD.', scalar @{$modules}),
80                );
81        }
82
83
8
25
        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
11
11
30
        require App::Project::Doctor::Finding;
96
11
48
        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
6
6
2490
        my $abs_path = shift;
106
6
592
        require Pod::Checker;
107
108        # Capture Pod::Checker's diagnostic output into a scalar instead of STDERR.
109        # The :encoding(UTF-8) layer is required: Pod::Checker honours =encoding utf8
110        # directives and emits wide characters; without the layer Perl raises
111        # "Wide character in print" before we ever see the error text.
112
6
33934
        my $captured = '';
113
6
14
        open my $out_fh, '>:encoding(UTF-8)', \$captured;
114
6
1773
        my $checker = Pod::Checker->new;
115
6
335
        $checker->parse_from_file($abs_path, $out_fh);
116
6
4232
        close $out_fh;
117
118        # If Pod::Checker reported no errors, return an empty list immediately.
119
6
100
50
912
        return () if ($checker->num_errors // 0) == 0;
120
121        # Parse the captured text output to extract individual error messages.
122
1
3
        my @errors;
123
1
2
        for my $line (split /\n/, $captured) {
124                # Skip blank lines in the checker output.
125
1
50
2
                next unless $line =~ /\S/;
126                # Try to extract the line number from the Pod::Checker message.
127
1
2
                my ($lineno) = $line =~ /line\s+(\d+)/i;
128
1
50
3
                push @errors, {
129                        message => $line,
130                        # Only include 'line' in the hashref when we actually found one.
131                        defined $lineno ? (line => $lineno) : (),
132                };
133        }
134
1
7
        return @errors;
135}
136
137# Purpose:    Return a coderef that rewrites a module file with a POD skeleton.
138# Entry:      $ctx is the Context; $rel_path is the module path relative to root.
139# Exit:       Coderef ($ctx) -> void; rewrites the module file with POD appended.
140# Side effects: Modifies the module file on disk when the coderef is called.
141sub _fix_scaffold_pod {
142
4
4
8
        my ($ctx, $rel_path) = @_;
143        # Return the fix as a closure so it runs only when the user accepts it.
144        return sub {
145                # Protect caller's $@ from autodie's internal eval inside open().
146
3
3
4
                local $@;
147
3
5
                my $abs = $ctx->abs_path($rel_path);
148                # Convert the relative file path to a Perl package name.
149                # e.g. lib/My/Module.pm -> My::Module
150
3
3
3
8
4
8
                (my $pkg = $rel_path) =~ s{^lib/}{}; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{};
151
152                # Read the existing file so we can rewrite it (not just append).
153                # UTF-8 encoding layer matches what Pod::Checker expects and preserves
154                # any non-ASCII source characters correctly on the round-trip.
155
3
6
                open my $rfh, '<:encoding(UTF-8)', $abs;
156
3
3
3
233
4
29
                my $content = do { local $/; <$rfh> };
157
3
21
                close $rfh;
158
159                # Remove any trailing `1;` so the rewritten file has exactly one.
160                # Without this, the original `1;` and the skeleton's `1;` would both appear.
161
3
89
                $content =~ s/\s*\n?1;\s*\z//s;
162
163                # Write the existing content back followed by the POD skeleton.
164
3
5
                open my $wfh, '>:encoding(UTF-8)', $abs;
165
3
3
254
16
                print {$wfh} $content, <<"END_POD";
166
1671;
168