File Coverage

File:blib/lib/App/Project/Doctor.pm
Coverage:100.0%

linestmtbrancondsubtimecode
1package App::Project::Doctor;
2
3# This is the top-level orchestrator for the project health-check tool.
4# It finds the distribution root, loads check plugins, runs them in order,
5# and returns a Report containing all of the resulting findings.
6
7
5
5
5
5
188760
5
68
use strict;
8
5
5
5
5
6
4
157
use warnings;
9
5
5
5
5
9
4
20
use autodie qw(:all);
10
11# croak dies with the caller's file/line; carp warns at the caller's location.
12
5
5
5
5
10476
5
175
use Carp qw(croak carp);
13# Readonly makes constants truly immutable at runtime.
14
5
5
5
5
7
6
81
use Readonly;
15# File::Spec builds OS-portable paths (handles Windows backslashes, etc.).
16
5
5
5
5
11
3
72
use File::Spec;
17# dirname() extracts the parent directory from a path when walking up the tree.
18
5
5
5
5
9
4
111
use File::Basename qw(dirname);
19# Params::Get normalises @_ so both hash and hashref calling styles work.
20
5
5
5
5
9
3
64
use Params::Get;
21# validate_strict enforces parameter schemas and throws immediately on failure.
22
5
5
5
5
14
4
76
use Params::Validate::Strict qw(validate_strict);
23
5
5
5
5
1562
121183
2210
use Object::Configure;  # Allow the object to be configured at runtime
24
25our $VERSION = '0.02';
26
27 - 115
=head1 NAME

App::Project::Doctor - Unified pre-release health check for Perl CPAN distributions

=head1 VERSION

0.02

=head1 SYNOPSIS

  # Command line
  project-doctor [--check=Tests,CI] [--skip=Meta] [--fix] [PATH]

  # Programmatic
  use App::Project::Doctor;

  my $doctor = App::Project::Doctor->new(path => '/path/to/my-dist');
  my $report = $doctor->run;
  print $report->render_text;
  exit $report->exit_code;

=head1 DESCRIPTION

Orchestrates a suite of diagnostic checks against a Perl CPAN distribution,
combining L<App::Workflow::Lint>, L<App::GHGen::Generator>, L<App::makefilepl2cpanfile>
into a single interactive pre-upload tool.

Each enabled C<App::Project::Doctor::Check::*> plugin receives an
L<App::Project::Doctor::Context> and returns a list of
L<App::Project::Doctor::Finding> objects which are collected into an
L<App::Project::Doctor::Report>.

=head1 CONSTRUCTOR

=head2 new( %args )

=head3 API SPECIFICATION

=head4 Input

  path    : String    -- start path for root detection    default '.'
  checks  : ArrayRef  -- check name suffixes to run       default all
  skip    : ArrayRef  -- check names to exclude           default []
  verbose : Bool                                          default 0

=head4 Output

Blessed hashref of type C<App::Project::Doctor>.

=head1 ACCESSORS

C<path>, C<checks>, C<skip>, C<verbose> -- read-only.

=head1 METHODS

=head2 run

=head3 API SPECIFICATION

=head4 Input

None.

=head4 Output

L<App::Project::Doctor::Report>.

=head3 MESSAGES

  Code | Trigger                         | Resolution
  -----|----------------------------------|----------------------------------------
  DR01 | Cannot detect distribution root  | Run from within a distribution directory
  DR02 | A check class cannot be loaded   | Install the check's prerequisites

=head1 CHECKS

In default execution order:

  Tests           t/ exists, .t files present, prove passes
  CI              At least one CI configuration present
  GitHubActions   Workflow YAML validates via App::Workflow::Lint
  Meta            META.yml/json parsed and complete
  Pod             All .pm files have valid POD
  Dependencies    Used modules declared as prerequisites
  License         LICENSE file present and consistent with META
  Security        strict/warnings everywhere; no hardcoded secrets
  CpanReadiness   Version format, Changes, MANIFEST, README

=cut
116
117# ---------------------------------------------------------------------------
118# Constants
119# ---------------------------------------------------------------------------
120
121# The default set of checks run when the user does not pass --check=...
122# Listed in the order they run (each check has an 'order' method too).
123Readonly::Array my @DEFAULT_CHECKS => qw(
124        Tests
125        CI
126        GitHubActions
127        Meta
128        Pod
129        Dependencies
130        License
131        Security
132        CpanReadiness
133);
134
135# Files whose presence marks the root directory of a Perl distribution.
136# Doctor walks up the directory tree looking for any of these.
137Readonly::Array my @ROOT_MARKERS => qw(
138        Makefile.PL
139        Build.PL
140        dist.ini
141        cpanfile
142);
143
144# ---------------------------------------------------------------------------
145# Constructor
146# ---------------------------------------------------------------------------
147
148sub new {
149
41
41
63614
        my $class = shift;
150        # Protect the caller's $@ from Object::Configure::configure and validate_strict,
151        # both of which use eval internally and set $@ = '' on success.
152
41
39
        local $@;
153        # validate_strict parses arguments, applies defaults, and throws on bad input.
154        # It never returns undef -- failure always throws.
155
41
100
81
        my $args = validate_strict(
156                args => Params::Get::get_params(undef, \@_) || {},
157                schema => {
158                        # path: the directory to start searching from (need not be the root).
159                        path    => { type => 'scalar',   optional => 1, default => '.'               },
160                        # checks: which check plugins to run; defaults to all nine.
161                        checks  => { type => 'arrayref', optional => 1, default => [@DEFAULT_CHECKS] },
162                        # skip: check names to exclude from the run.
163                        skip    => { type => 'arrayref', optional => 1, default => []                },
164                        verbose => { type => 'scalar',   optional => 1, default => 0                 },
165                },
166        );
167
40
7121
        $args = Object::Configure::configure($class, $args);
168        # Wrap the validated args in a blessed reference and return it.
169
40
170370
        return bless $args, $class;
170}
171
172# ---------------------------------------------------------------------------
173# Accessors  (all read-only after construction)
174# ---------------------------------------------------------------------------
175
176# The start path passed by the caller; used by _detect_root to walk upward.
177
35
35
169
sub path    { $_[0]->{path}    }
178# Arrayref of check names to run (short names like 'Tests', not full class names).
179
34
34
54
sub checks  { $_[0]->{checks}  }
180# Arrayref of check names to skip.
181
28
28
47
sub skip    { $_[0]->{skip}    }
182# When true, print "Running: <name>..." to STDOUT as each check starts.
183
41
41
123
sub verbose { $_[0]->{verbose} }
184
185# ---------------------------------------------------------------------------
186# Public interface
187# ---------------------------------------------------------------------------
188
189 - 194
=head2 run

Detects the distro root, instantiates all enabled checks, runs them in order,
and returns an L<App::Project::Doctor::Report>.

=cut
195
196sub run {
197
25
25
352
        my $self = shift;
198        # Protect the caller's $@ from being clobbered by our internal eval blocks.
199
25
22
        local $@;
200
201        # Walk up from the user-supplied path to find the distribution root.
202
25
100
43
        my $root = $self->_detect_root($self->path)
203                or croak "Cannot detect a distribution root from '" . $self->path . "'";
204
205        # Build the Context (filesystem helper) and an empty Report to fill.
206
21
269
        my $ctx    = $self->_build_context($root);
207
21
31
        my $report = $self->_build_report;
208
209        # Run each check plugin in order and collect its findings.
210
21
30
        for my $check ($self->_build_checks) {
211                # Show progress to the user when --verbose is on.
212
16
100
19
                printf "  Running: %s ...\n", $check->name if $self->verbose;
213
16
16
                my @findings;
214                {
215                        # Isolate $@ so a check that dies doesn't corrupt the outer $@.
216
16
16
14
16
                        local $@;
217
16
16
17
21
                        @findings = eval { $check->check($ctx) };
218
16
100
27
                        if ($@) {
219                                # A check that throws is carped and skipped; the run continues.
220
1
2
                                carp sprintf("Check '%s' threw: %s", $check->name, $@);
221
1
102
                                next;
222                        }
223                }
224                # Add whatever findings this check produced to the accumulating report.
225
16
35
                $report->add_findings(@findings);
226        }
227
228        # Return the completed report; the caller decides how to render/exit.
229
21
108
        return $report;
230}
231
232# ---------------------------------------------------------------------------
233# Private helpers
234# ---------------------------------------------------------------------------
235
236# Purpose:    Walk up from $start until a distribution root marker is found.
237# Entry:      $start is any path (relative or absolute) inside the distribution.
238# Exit:       Absolute path string of the root directory, or undef if not found.
239# Side effects: None (read-only filesystem checks).
240sub _detect_root {
241
30
30
41
        my ($self, $start) = @_;
242        # Convert to an absolute path so dirname() terminates at the filesystem root.
243
30
179
        my $dir = File::Spec->rel2abs($start);
244
30
26
        while (1) {
245                # Check each marker in the current directory.
246
41
74
                for my $marker (@ROOT_MARKERS) {
247
92
100
646
                        return $dir if -e File::Spec->catfile($dir, $marker);
248                }
249                # Move one level up; stop when we reach the filesystem root (parent == dir).
250
15
318
                my $parent = dirname($dir);
251
15
100
22
                last if $parent eq $dir;
252
11
11
                $dir = $parent;
253        }
254
4
9
        return undef;    # Searched all the way to the filesystem root, found nothing.
255}
256
257# Purpose:    Create the Context object that check plugins use for file I/O.
258# Entry:      $root is the absolute path to the distribution root directory.
259# Exit:       App::Project::Doctor::Context object.
260# Side effects: Loads Context module if not already in memory.
261sub _build_context {
262
21
21
25
        my ($self, $root) = @_;
263
21
61
        require App::Project::Doctor::Context;
264
21
44
        return App::Project::Doctor::Context->new(root => $root, verbose => $self->verbose);
265}
266
267# Purpose:    Create an empty Report to accumulate findings into.
268# Entry:      None.
269# Exit:       App::Project::Doctor::Report object.
270# Side effects: Loads Report module if not already in memory.
271sub _build_report {
272
21
21
32
        require App::Project::Doctor::Report;
273
21
74
        return App::Project::Doctor::Report->new;
274}
275
276# Purpose:    Load, instantiate, and sort the enabled check plugins.
277# Entry:      self->checks and self->skip are already validated lists.
278# Exit:       List of check objects sorted ascending by their ->order value.
279# Side effects: Loads Check::Base and each check module; carps on load failure.
280sub _build_checks {
281
24
24
66
        my $self  = shift;
282        # Build a set of lower-cased names to skip for case-insensitive matching.
283
24
4
24
26
10
30
        my %skip  = map { lc($_) => 1 } @{ $self->skip };
284
24
604
        my @built;
285
286        # Check::Base must be loaded before calling ->new on any check subclass
287        # because the subclasses use 'use parent -norequire' which suppresses auto-load.
288
24
412
        require App::Project::Doctor::Check::Base;
289
290
24
24
22
46
        for my $name (@{ $self->checks }) {
291                # Honour the skip list before doing any expensive loading.
292
29
100
46
                next if $skip{ lc($name) };
293                # Security guard: only allow names matching the safe identifier pattern.
294                # This prevents check names like '../Exploit' from reaching the string eval.
295
25
100
90
                unless ($name =~ /\A[A-Za-z][A-Za-z0-9]*\z/) {
296
2
27
                        carp "Check name '$name' contains invalid characters -- skipping";
297
2
231
                        next;
298                }
299                # Build the full class name from the short name and load it dynamically.
300
23
24
                my $class = "App::Project::Doctor::Check::$name";
301
23
788
                eval "require $class";    ## no critic (ProhibitStringyEval)
302
23
100
70
                if ($@) {
303                        # Missing or broken check module: warn and skip rather than aborting the run.
304
3
56
                        carp "Could not load '$class': $@";
305
3
676
                        next;
306                }
307
20
68
                push @built, $class->new;
308        }
309
310        # Sort by the numeric 'order' value so checks run in the intended sequence.
311
24
3
49
3
        return sort { $a->order <=> $b->order } @built;
312}
313
3141;
315