lib/App/Project/Doctor.pm

        start → end → jump
        

    1: package 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: use strict;
    8: use warnings;
    9: use autodie qw(:all);
   10: 
   11: # croak dies with the caller's file/line; carp warns at the caller's location.
   12: use Carp qw(croak carp);
   13: # Readonly makes constants truly immutable at runtime.
   14: use Readonly;
   15: # File::Spec builds OS-portable paths (handles Windows backslashes, etc.).
   16: use File::Spec;
   17: # dirname() extracts the parent directory from a path when walking up the tree.
   18: use File::Basename qw(dirname);
   19: # Params::Get normalises @_ so both hash and hashref calling styles work.
   20: use Params::Get;
   21: # validate_strict enforces parameter schemas and throws immediately on failure.
   22: use Params::Validate::Strict qw(validate_strict);
   23: use Object::Configure;	# Allow the object to be configured at runtime
   24: 
   25: our $VERSION = '0.02';
   26: 
   27: =head1 NAME
   28: 
   29: App::Project::Doctor - Unified pre-release health check for Perl CPAN distributions
   30: 
   31: =head1 VERSION
   32: 
   33: 0.02
   34: 
   35: =head1 SYNOPSIS
   36: 
   37:   # Command line
   38:   project-doctor [--check=Tests,CI] [--skip=Meta] [--fix] [PATH]
   39: 
   40:   # Programmatic
   41:   use App::Project::Doctor;
   42: 
   43:   my $doctor = App::Project::Doctor->new(path => '/path/to/my-dist');
   44:   my $report = $doctor->run;
   45:   print $report->render_text;
   46:   exit $report->exit_code;
   47: 
   48: =head1 DESCRIPTION
   49: 
   50: Orchestrates a suite of diagnostic checks against a Perl CPAN distribution,
   51: combining L<App::Workflow::Lint>, L<App::GHGen::Generator>, L<App::makefilepl2cpanfile>
   52: into a single interactive pre-upload tool.
   53: 
   54: Each enabled C<App::Project::Doctor::Check::*> plugin receives an
   55: L<App::Project::Doctor::Context> and returns a list of
   56: L<App::Project::Doctor::Finding> objects which are collected into an
   57: L<App::Project::Doctor::Report>.
   58: 
   59: =head1 CONSTRUCTOR
   60: 
   61: =head2 new( %args )
   62: 
   63: =head3 API SPECIFICATION
   64: 
   65: =head4 Input
   66: 
   67:   path    : String    -- start path for root detection    default '.'
   68:   checks  : ArrayRef  -- check name suffixes to run       default all
   69:   skip    : ArrayRef  -- check names to exclude           default []
   70:   verbose : Bool                                          default 0
   71: 
   72: =head4 Output
   73: 
   74: Blessed hashref of type C<App::Project::Doctor>.
   75: 
   76: =head1 ACCESSORS
   77: 
   78: C<path>, C<checks>, C<skip>, C<verbose> -- read-only.
   79: 
   80: =head1 METHODS
   81: 
   82: =head2 run
   83: 
   84: =head3 API SPECIFICATION
   85: 
   86: =head4 Input
   87: 
   88: None.
   89: 
   90: =head4 Output
   91: 
   92: L<App::Project::Doctor::Report>.
   93: 
   94: =head3 MESSAGES
   95: 
   96:   Code | Trigger                         | Resolution
   97:   -----|----------------------------------|----------------------------------------
   98:   DR01 | Cannot detect distribution root  | Run from within a distribution directory
   99:   DR02 | A check class cannot be loaded   | Install the check's prerequisites
  100: 
  101: =head1 CHECKS
  102: 
  103: In default execution order:
  104: 
  105:   Tests           t/ exists, .t files present, prove passes
  106:   CI              At least one CI configuration present
  107:   GitHubActions   Workflow YAML validates via App::Workflow::Lint
  108:   Meta            META.yml/json parsed and complete
  109:   Pod             All .pm files have valid POD
  110:   Dependencies    Used modules declared as prerequisites
  111:   License         LICENSE file present and consistent with META
  112:   Security        strict/warnings everywhere; no hardcoded secrets
  113:   CpanReadiness   Version format, Changes, MANIFEST, README
  114: 
  115: =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).
  123: Readonly::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.
  137: Readonly::Array my @ROOT_MARKERS => qw(
  138: 	Makefile.PL
  139: 	Build.PL
  140: 	dist.ini
  141: 	cpanfile
  142: );
  143: 
  144: # ---------------------------------------------------------------------------
  145: # Constructor
  146: # ---------------------------------------------------------------------------
  147: 
  148: sub new {
  149: 	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: 	local $@;
  153: 	# validate_strict parses arguments, applies defaults, and throws on bad input.
  154: 	# It never returns undef -- failure always throws.
  155: 	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: 	$args = Object::Configure::configure($class, $args);
  168: 	# Wrap the validated args in a blessed reference and return it.
  169: 	return bless $args, $class;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  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: sub path    { $_[0]->{path}    }
  178: # Arrayref of check names to run (short names like 'Tests', not full class names).
  179: sub checks  { $_[0]->{checks}  }
  180: # Arrayref of check names to skip.
  181: sub skip    { $_[0]->{skip}    }
  182: # When true, print "Running: <name>..." to STDOUT as each check starts.
  183: sub verbose { $_[0]->{verbose} }
  184: 
  185: # ---------------------------------------------------------------------------
  186: # Public interface
  187: # ---------------------------------------------------------------------------
  188: 
  189: =head2 run
  190: 
  191: Detects the distro root, instantiates all enabled checks, runs them in order,
  192: and returns an L<App::Project::Doctor::Report>.
  193: 
  194: =cut
  195: 
  196: sub run {
●197 → 210 → 229  197: 	my $self = shift;
  198: 	# Protect the caller's $@ from being clobbered by our internal eval blocks.
  199: 	local $@;
  200: 
  201: 	# Walk up from the user-supplied path to find the distribution root.
  202: 	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: 	my $ctx    = $self->_build_context($root);
  207: 	my $report = $self->_build_report;
  208: 
  209: 	# Run each check plugin in order and collect its findings.
  210: 	for my $check ($self->_build_checks) {
  211: 		# Show progress to the user when --verbose is on.
  212: 		printf "  Running: %s ...\n", $check->name if $self->verbose;
  213: 		my @findings;
  214: 		{
  215: 			# Isolate $@ so a check that dies doesn't corrupt the outer $@.
  216: 			local $@;
  217: 			@findings = eval { $check->check($ctx) };
  218: 			if ($@) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  219: 				# A check that throws is carped and skipped; the run continues.
  220: 				carp sprintf("Check '%s' threw: %s", $check->name, $@);
  221: 				next;
  222: 			}
  223: 		}
  224: 		# Add whatever findings this check produced to the accumulating report.
  225: 		$report->add_findings(@findings);
  226: 	}
  227: 
  228: 	# Return the completed report; the caller decides how to render/exit.
  229: 	return $report;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  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).
  240: sub _detect_root {
●241 → 244 → 254  241: 	my ($self, $start) = @_;
  242: 	# Convert to an absolute path so dirname() terminates at the filesystem root.
  243: 	my $dir = File::Spec->rel2abs($start);
  244: 	while (1) {
  245: 		# Check each marker in the current directory.
  246: 		for my $marker (@ROOT_MARKERS) {
  247: 			return $dir if -e File::Spec->catfile($dir, $marker);
  Mutants (Total: 2, Killed: 2, Survived: 0)
  248: 		}
  249: 		# Move one level up; stop when we reach the filesystem root (parent == dir).
  250: 		my $parent = dirname($dir);
  251: 		last if $parent eq $dir;
  252: 		$dir = $parent;
  253: 	}
  254: 	return undef;    # Searched all the way to the filesystem root, found nothing.
  Mutants (Total: 2, Killed: 2, Survived: 0)
  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.
  261: sub _build_context {
  262: 	my ($self, $root) = @_;
  263: 	require App::Project::Doctor::Context;
  264: 	return App::Project::Doctor::Context->new(root => $root, verbose => $self->verbose);
  Mutants (Total: 2, Killed: 2, Survived: 0)
  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.
  271: sub _build_report {
  272: 	require App::Project::Doctor::Report;
  273: 	return App::Project::Doctor::Report->new;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  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.
  280: sub _build_checks {
●281 → 290 → 311  281: 	my $self  = shift;
  282: 	# Build a set of lower-cased names to skip for case-insensitive matching.
  283: 	my %skip  = map { lc($_) => 1 } @{ $self->skip };
  284: 	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: 	require App::Project::Doctor::Check::Base;
  289: 
  290: 	for my $name (@{ $self->checks }) {
  291: 		# Honour the skip list before doing any expensive loading.
  292: 		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: 		unless ($name =~ /\A[A-Za-z][A-Za-z0-9]*\z/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  296: 			carp "Check name '$name' contains invalid characters -- skipping";
  297: 			next;
  298: 		}
  299: 		# Build the full class name from the short name and load it dynamically.
  300: 		my $class = "App::Project::Doctor::Check::$name";
  301: 		eval "require $class";    ## no critic (ProhibitStringyEval)
  302: 		if ($@) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  303: 			# Missing or broken check module: warn and skip rather than aborting the run.
  304: 			carp "Could not load '$class': $@";
  305: 			next;
  306: 		}
  307: 		push @built, $class->new;
  308: 	}
  309: 
  310: 	# Sort by the numeric 'order' value so checks run in the intended sequence.
  311: 	return sort { $a->order <=> $b->order } @built;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  312: }
  313: 
  314: 1;
  315: 
  316: __END__
  317: 
  318: =head1 LIMITATIONS
  319: 
  320: Checks run sequentially; no parallelism.
  321: 
  322: =head1 AUTHOR
  323: 
  324: Nigel Horne C<< <njh@nigelhorne.com> >>
  325: 
  326: =head1 SEE ALSO
  327: 
  328: =over 4
  329: 
  330: =item * L<Configure an Object at Runtime|Object::Configure>
  331: 
  332: =item * L<Test Dashboard|https://nigelhorne.github.io/App-Project-Doctor/coverage/>
  333: 
  334: =back
  335: 
  336: =head1 REPOSITORY
  337: 
  338: L<https://github.com/nigelhorne/App-Project-Doctor>
  339: 
  340: =head1 SUPPORT
  341: 
  342: This module is provided as-is without any warranty.
  343: 
  344: Please report any bugs or feature requests to C<bug-cgi-info at rt.cpan.org>,
  345: or through the web interface at
  346: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=App-Project-Doctor>.
  347: I will be notified, and then you'll
  348: automatically be notified of progress on your bug as I make changes.
  349: 
  350: You can find documentation for this module with the perldoc command.
  351: 
  352:     perldoc App::Project::Doctor
  353: 
  354: You can also look for information at:
  355: 
  356: =over 4
  357: 
  358: =item * MetaCPAN
  359: 
  360: L<https://metacpan.org/dist/App-Project-Doctor>
  361: 
  362: =item * RT: CPAN's request tracker
  363: 
  364: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Project-Doctor>
  365: 
  366: =item * CPAN Testers' Matrix
  367: 
  368: L<http://matrix.cpantesters.org/?dist=App-Project-Doctor>
  369: 
  370: =item * CPAN Testers Dependencies
  371: 
  372: L<http://deps.cpantesters.org/?module=App::Project::Doctor>
  373: 
  374: =back
  375: 
  376: =head1 FORMAL SPECIFICATION
  377: 
  378: =head2 doctor
  379: 
  380:   Doctor == { path : Path, checks : [Name], skip : [Name], verbose : Bool }
  381: 
  382:   run : Doctor -> Report
  383:   run d ==
  384:     let root    = detect_root (path d)
  385:         ctx     = Context { root, verbose = verbose d }
  386:         enabled = sort_by_order (checks d \\ skip d)
  387:     in  Report { concat [ check c ctx | c <- enabled ] }
  388: 
  389:   detect_root : Path -> Path | undefined
  390:   detect_root p == nearest ancestor of p containing a ROOT_MARKER
  391: 
  392: =head1 LICENSE
  393: 
  394: Usage is subject to the GPL2 licence terms.
  395: If you use it,
  396: please let me know.
  397: 
  398: =cut