TER1 (Statement): 100.00%
TER2 (Branch): 96.67%
TER3 (LCSAJ): 100.0% (2/2)
Approximate LCSAJ segments: 31
● Covered — this LCSAJ path was executed during testing.
● Not covered — this LCSAJ path was never executed. These are the paths to focus on.
Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows:
start → end → jump
Uncovered paths show [NOT COVERED] in the tooltip.
1: package App::Project::Doctor::Context; 2: 3: # Context is the filesystem helper that every check plugin receives. 4: # It encapsulates the distribution root path and provides safe, validated 5: # access to files underneath it. Checks must NEVER access the filesystem 6: # directly -- they must always go through Context methods. 7: 8: use strict; 9: use warnings; 10: use autodie qw(:all); 11: 12: # croak dies with the caller's file/line so errors point at the plugin, not here. 13: use Carp qw(croak carp); 14: # Readonly makes constants truly immutable; mutation throws at runtime. 15: use Readonly; 16: # File::Spec builds cross-platform paths (handles Windows backslashes). 17: use File::Spec; 18: # File::Find is loaded without importing its 'find' function to avoid namespace pollution. 19: use File::Find (); 20: # validate_strict enforces parameter schemas and throws immediately on failure. 21: use Params::Validate::Strict qw(validate_strict); 22: # Params::Get normalises @_ so both hash and hashref calling styles work. 23: use Params::Get; 24: 25: our $VERSION = '0.02'; 26: 27: # --------------------------------------------------------------------------- 28: # Constants 29: # --------------------------------------------------------------------------- 30: 31: # File extensions that identify Perl source files. 32: # Used by perl_files() to filter results from _collect_files(). 33: Readonly::Array my @PERL_EXTENSIONS => qw(.pm .pl .t .PL); 34: 35: # Standard build-system files; the first one found is returned by builder_file(). 36: Readonly::Array my @BUILDER_FILES => qw(Makefile.PL Build.PL dist.ini cpanfile); 37: 38: # --------------------------------------------------------------------------- 39: # Constructor 40: # --------------------------------------------------------------------------- 41: 42: sub new { 43: my $class = shift; 44: # validate_strict normalises args, applies defaults, and throws on bad input. 45: my $args = validate_strict( 46: args => Params::Get::get_params(undef, \@_) || {}, 47: schema => { 48: # root must be an existing directory; defaults to the current directory. 49: root => { type => 'scalar', optional => 1, default => '.' }, 50: # verbose is passed through to check plugins that want progress output. 51: verbose => { type => 'scalar', optional => 1, default => 0 }, 52: }, 53: ); 54: 55: # Confirm root is an actual directory before we store it. 56: croak "root '$args->{root}' is not a directory" 57: unless -d $args->{root}; 58: 59: # Convert root to an absolute path so all downstream operations are stable. 60: return bless {Mutants (Total: 2, Killed: 2, Survived: 0)
61: root => File::Spec->rel2abs($args->{root}), 62: verbose => $args->{verbose}, 63: }, $class; 64: } 65: 66: # --------------------------------------------------------------------------- 67: # Accessors (read-only after construction) 68: # --------------------------------------------------------------------------- 69: 70: # The absolute path to the distribution root directory. 71: sub root { $_[0]->{root} } 72: # Whether verbose progress messages should be emitted. 73: sub verbose { $_[0]->{verbose} } 74: 75: # --------------------------------------------------------------------------- 76: # Public methods 77: # --------------------------------------------------------------------------- 78: 79: =head2 has_file( $rel_path ) 80: 81: Returns true when C<$rel_path> (relative to root) exists on disk. 82: 83: =cut 84: 85: sub has_file { 86: my ($self, $rel_path) = @_; 87: croak 'has_file requires a relative path' unless defined $rel_path; 88: # Route through abs_path so the path-traversal security check is inherited. 89: return -e $self->abs_path($rel_path);
Mutants (Total: 2, Killed: 2, Survived: 0)
90: } 91: 92: =head2 abs_path( $rel_path ) 93: 94: Returns the absolute filesystem path for C<$rel_path>. 95: Croaks if C<$rel_path> contains C<..> as a path component (path traversal). 96: 97: =cut 98: 99: sub abs_path { 100: my ($self, $rel_path) = @_; 101: croak 'abs_path requires a relative path' unless defined $rel_path; 102: # Security: reject any path component that is exactly '..'. 103: # This prevents a crafted check name or filename from escaping the root. 104: croak "Path traversal detected in '$rel_path'" 105: if grep { $_ eq '..' } File::Spec->splitdir($rel_path); 106: return File::Spec->catfile($self->root, $rel_path);
Mutants (Total: 2, Killed: 2, Survived: 0)
107: } 108: 109: =head2 slurp( $rel_path ) 110: 111: Reads and returns the entire UTF-8 content of C<$rel_path>. 112: Croaks if the file does not exist. 113: 114: =cut 115: 116: sub slurp { 117: my ($self, $rel_path) = @_; 118: # autodie wraps open() in an eval internally; 'local $@' protects the caller's $@. 119: local $@; 120: croak 'slurp requires a relative path' unless defined $rel_path; 121: my $abs = $self->abs_path($rel_path); 122: # Provide a clear error if the caller asks for a file that isn't there. 123: croak "File not found: $abs" unless -f $abs; 124: open my $fh, '<:encoding(UTF-8)', $abs; 125: # Undefine $/ to enable slurp mode (read the entire file in one operation). 126: local $/; 127: my $content = <$fh>; 128: close $fh; 129: return $content;
Mutants (Total: 2, Killed: 2, Survived: 0)
130: } 131: 132: =head2 perl_files( @dirs ) 133: 134: Returns an arrayref of paths (relative to root) for all Perl source files 135: (.pm .pl .t .PL) found recursively under the given directories. 136: Defaults to lib/, script/, bin/, t/. 137: 138: =cut 139: 140: sub perl_files { 141: my ($self, @dirs) = @_; 142: # Default to the standard Perl source directories when none are specified. 143: @dirs = qw(lib script bin t) unless @dirs; 144: return $self->_collect_files(\@dirs, sub {
Mutants (Total: 2, Killed: 2, Survived: 0)
145: my $file = shift; 146: # Extract the file extension and check it against our known Perl extensions. 147: my ($ext) = $file =~ /(\.[^.]+)$/; 148: return defined $ext && grep { $ext eq $_ } @PERL_EXTENSIONS;
Mutants (Total: 2, Killed: 2, Survived: 0)
149: }); 150: } 151: 152: =head2 lib_modules 153: 154: Returns an arrayref of .pm paths (relative to root) found under lib/. 155: 156: =cut 157: 158: sub lib_modules { 159: my $self = shift; 160: # Delegate to find_files with a suffix filter for .pm files. 161: return $self->find_files('lib', '.pm');
Mutants (Total: 2, Killed: 2, Survived: 0)
162: } 163: 164: =head2 test_files 165: 166: Returns an arrayref of .t paths (relative to root) found under t/. 167: 168: =cut 169: 170: sub test_files { 171: my $self = shift; 172: # Delegate to find_files with a suffix filter for .t files. 173: return $self->find_files('t', '.t');
Mutants (Total: 2, Killed: 2, Survived: 0)
174: } 175: 176: =head2 git_root 177: 178: Returns the git repository root, or undef if not in a git repo. 179: 180: =cut 181: 182: sub git_root { 183: my $self = shift; 184: my $root = $self->root; 185: # Ask git for the repository root; 2>/dev/null suppresses the error when 186: # the directory is not inside any git repository. 187: my $out = qx{git -C \Q$root\E rev-parse --show-toplevel 2>/dev/null}; 188: chomp $out; 189: # Return undef rather than an empty string when outside a git repo. 190: return (length $out) ? $out : undef;
Mutants (Total: 2, Killed: 2, Survived: 0)
191: } 192: 193: =head2 builder_file 194: 195: Returns the name (relative to root) of the first found builder file, or undef. 196: 197: =cut 198: 199: sub builder_file { ●200 → 202 → 206 200: my $self = shift; 201: # Return the first builder file that actually exists in the distro root. 202: for my $f (@BUILDER_FILES) { 203: return $f if $self->has_file($f);
Mutants (Total: 2, Killed: 2, Survived: 0)
204: } 205: # None of the known builder files were found. 206: return undef;
Mutants (Total: 2, Killed: 2, Survived: 0)
207: } 208: 209: =head2 find_files( $dir, $pattern ) 210: 211: Returns an arrayref of all files under C<$dir> matching C<$pattern> 212: (a string suffix or a compiled regexp). 213: 214: =cut 215: 216: sub find_files { 217: my ($self, $dir, $pattern) = @_; 218: croak 'find_files requires a directory' unless defined $dir; 219: return $self->_collect_files([$dir], sub {
Mutants (Total: 2, Killed: 2, Survived: 0)
220: my $rel = shift; 221: # No pattern means "match everything". 222: return 1 unless defined $pattern;
Mutants (Total: 2, Killed: 2, Survived: 0)
223: # Accept either a compiled regexp or a plain string suffix. 224: return ref $pattern eq 'Regexp' ? $rel =~ $pattern : $rel =~ /\Q$pattern\E$/;
Mutants (Total: 2, Killed: 2, Survived: 0)
225: }); 226: } 227: 228: # --------------------------------------------------------------------------- 229: # Private helpers 230: # --------------------------------------------------------------------------- 231: 232: # Purpose: Recursively walk a list of directories, filtering files with $accept. 233: # Entry: $dirs is an arrayref of directory paths (relative to root). 234: # $accept is a coderef ($rel_path) -> bool that filters results. 235: # Exit: Arrayref of relative paths that passed the $accept filter. 236: # Side effects: Reads the filesystem (no writes). 237: sub _collect_files { ●238 → 240 → 255 238: my ($self, $dirs, $accept) = @_; 239: my @found; 240: for my $dir (@{$dirs}) { 241: my $abs_dir = $self->abs_path($dir); 242: # Skip directories that don't exist rather than croaking. 243: next unless -d $abs_dir; 244: File::Find::find({ 245: no_chdir => 1, # Stay in one place; $_ is always absolute. 246: wanted => sub { 247: return unless -f $_; # Skip directories and symlinks. 248: my $rel = File::Spec->abs2rel($_, $self->root); 249: # Normalize to forward slashes on Windows where abs2rel uses backslashes. 250: $rel =~ s{\\}{/}g; 251: push @found, $rel if $accept->($rel); 252: }, 253: }, $abs_dir); 254: } 255: return \@found;
Mutants (Total: 2, Killed: 2, Survived: 0)
256: } 257: 258: 1; 259: 260: __END__ 261: 262: =head1 NAME 263: 264: App::Project::Doctor::Context - Distro filesystem context passed to all checks 265: 266: =head1 VERSION 267: 268: 0.02 269: 270: =head1 SYNOPSIS 271: 272: use App::Project::Doctor::Context; 273: 274: my $ctx = App::Project::Doctor::Context->new( 275: root => '/path/to/my-dist', 276: verbose => 1, 277: ); 278: 279: my $modules = $ctx->lib_modules; 280: my $content = $ctx->slurp('lib/My/Module.pm') 281: if $ctx->has_file('lib/My/Module.pm'); 282: 283: =head1 DESCRIPTION 284: 285: Encapsulates the distribution root path and provides filesystem helpers. 286: All C<Check::*> plugins receive an instance; they must not access the 287: filesystem directly. 288: 289: =head1 CONSTRUCTOR 290: 291: =head2 new( %args ) 292: 293: my $ctx = App::Project::Doctor::Context->new( 294: root => '/path/to/dist', # must be an existing directory 295: verbose => 0, 296: ); 297: 298: Croaks when C<root> is not an existing directory. 299: 300: =head3 API SPECIFICATION 301: 302: =head4 Input 303: 304: root : String -- existing directory path default '.' 305: verbose : Bool default 0 306: 307: =head4 Output 308: 309: Blessed hashref of type C<App::Project::Doctor::Context>. 310: 311: =head1 ACCESSORS 312: 313: C<root>, C<verbose> -- read-only. 314: 315: =head1 METHODS 316: 317: =head2 has_file( $rel_path ) 318: 319: =head3 API SPECIFICATION 320: 321: =head4 Input 322: 323: $rel_path : String 324: 325: =head4 Output 326: 327: Bool. 328: 329: =head2 abs_path( $rel_path ) 330: 331: =head3 API SPECIFICATION 332: 333: =head4 Input 334: 335: $rel_path : String 336: 337: =head4 Output 338: 339: String -- absolute path. 340: 341: =head2 slurp( $rel_path ) 342: 343: =head3 API SPECIFICATION 344: 345: =head4 Input 346: 347: $rel_path : String 348: 349: =head4 Output 350: 351: String -- UTF-8 file content. 352: 353: =head2 perl_files( @dirs ) 354: 355: =head3 API SPECIFICATION 356: 357: =head4 Input 358: 359: @dirs : List of String (default: lib script bin t) 360: 361: =head4 Output 362: 363: ArrayRef[String] -- relative paths. 364: 365: =head2 lib_modules 366: 367: ArrayRef[String] -- .pm files under lib/. 368: 369: =head2 test_files 370: 371: ArrayRef[String] -- .t files under t/. 372: 373: =head2 git_root 374: 375: =head3 API SPECIFICATION 376: 377: =head4 Input 378: 379: None. 380: 381: =head4 Output 382: 383: String | undef. 384: 385: =head2 builder_file 386: 387: =head3 API SPECIFICATION 388: 389: =head4 Input 390: 391: None. 392: 393: =head4 Output 394: 395: String | undef -- first found of Makefile.PL Build.PL dist.ini cpanfile. 396: 397: =head2 find_files( $dir, $pattern ) 398: 399: =head3 API SPECIFICATION 400: 401: =head4 Input 402: 403: $dir : String 404: $pattern : String | Regexp | undef 405: 406: =head4 Output 407: 408: ArrayRef[String] -- relative paths. 409: 410: =head3 MESSAGES 411: 412: Code | Trigger | Resolution 413: -----|---------|---------- 414: (none currently defined) 415: 416: =head3 FORMAL SPECIFICATION 417: 418: Context == [ root : Path, verbose : Bool ] 419: 420: has_file : Context x RelPath -> Bool 421: has_file ctx p == exists (root ctx / p) 422: 423: slurp : Context x RelPath -> String 424: dom slurp == { (ctx, p) | has_file ctx p } 425: 426: =head1 LIMITATIONS 427: 428: C<git_root> shells out to C<git>; returns undef when git is not installed. 429: 430: =head1 AUTHOR 431: 432: Nigel Horne C<< <njh@nigelhorne.com> >> 433: 434: =head1 LICENSE 435: 436: Copyright (C) 2026 Nigel Horne. 437: This library is free software; you can redistribute it and/or modify 438: it under the same terms as Perl itself. 439: 440: =cut