File Coverage

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

linestmtbrancondsubtimecode
1package 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
5
5
5
5
162852
6
88
use strict;
9
5
5
5
5
11
4
164
use warnings;
10
5
5
5
5
204
5826
20
use autodie qw(:all);
11
12# croak dies with the caller's file/line so errors point at the plugin, not here.
13
5
5
5
5
15964
10
151
use Carp qw(croak carp);
14# Readonly makes constants truly immutable; mutation throws at runtime.
15
5
5
5
5
10
2
93
use Readonly;
16# File::Spec builds cross-platform paths (handles Windows backslashes).
17
5
5
5
5
10
4
62
use File::Spec;
18# File::Find is loaded without importing its 'find' function to avoid namespace pollution.
19
5
5
5
5
11
3
39
use File::Find ();
20# validate_strict enforces parameter schemas and throws immediately on failure.
21
5
5
5
5
350
11221
114
use Params::Validate::Strict qw(validate_strict);
22# Params::Get normalises @_ so both hash and hashref calling styles work.
23
5
5
5
5
224
3262
2591
use Params::Get;
24
25our $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().
33Readonly::Array my @PERL_EXTENSIONS => qw(.pm .pl .t .PL);
34
35# Standard build-system files; the first one found is returned by builder_file().
36Readonly::Array my @BUILDER_FILES   => qw(Makefile.PL Build.PL dist.ini cpanfile);
37
38# ---------------------------------------------------------------------------
39# Constructor
40# ---------------------------------------------------------------------------
41
42sub new {
43
225
225
210513
        my $class = shift;
44        # validate_strict normalises args, applies defaults, and throws on bad input.
45
225
100
438
        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
225
100
22529
                unless -d $args->{root};
58
59        # Convert root to an absolute path so all downstream operations are stable.
60        return bless {
61                root    => File::Spec->rel2abs($args->{root}),
62                verbose => $args->{verbose},
63
219
1691
        }, $class;
64}
65
66# ---------------------------------------------------------------------------
67# Accessors  (read-only after construction)
68# ---------------------------------------------------------------------------
69
70# The absolute path to the distribution root directory.
71
930
930
7627
sub root    { $_[0]->{root}    }
72# Whether verbose progress messages should be emitted.
73
4
4
11
sub verbose { $_[0]->{verbose} }
74
75# ---------------------------------------------------------------------------
76# Public methods
77# ---------------------------------------------------------------------------
78
79 - 83
=head2 has_file( $rel_path )

Returns true when C<$rel_path> (relative to root) exists on disk.

=cut
84
85sub has_file {
86
460
460
503
        my ($self, $rel_path) = @_;
87
460
100
1093
        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
457
373
        return -e $self->abs_path($rel_path);
90}
91
92 - 97
=head2 abs_path( $rel_path )

Returns the absolute filesystem path for C<$rel_path>.
Croaks if C<$rel_path> contains C<..> as a path component (path traversal).

=cut
98
99sub abs_path {
100
804
804
1184
        my ($self, $rel_path) = @_;
101
804
100
662
        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
801
959
100
1146
1004
                if grep { $_ eq '..' } File::Spec->splitdir($rel_path);
106
797
741
        return File::Spec->catfile($self->root, $rel_path);
107}
108
109 - 114
=head2 slurp( $rel_path )

Reads and returns the entire UTF-8 content of C<$rel_path>.
Croaks if the file does not exist.

=cut
115
116sub slurp {
117
108
108
542
        my ($self, $rel_path) = @_;
118        # autodie wraps open() in an eval internally; 'local $@' protects the caller's $@.
119
108
77
        local $@;
120
108
100
119
        croak 'slurp requires a relative path' unless defined $rel_path;
121
105
113
        my $abs = $self->abs_path($rel_path);
122        # Provide a clear error if the caller asks for a file that isn't there.
123
104
100
432
        croak "File not found: $abs" unless -f $abs;
124
101
174
        open my $fh, '<:encoding(UTF-8)', $abs;
125        # Undefine $/ to enable slurp mode (read the entire file in one operation).
126
101
14237
        local $/;
127
101
1035
        my $content = <$fh>;
128
101
590
        close $fh;
129
101
4618
        return $content;
130}
131
132 - 138
=head2 perl_files( @dirs )

Returns an arrayref of paths (relative to root) for all Perl source files
(.pm .pl .t .PL) found recursively under the given directories.
Defaults to lib/, script/, bin/, t/.

=cut
139
140sub perl_files {
141
40
40
78
        my ($self, @dirs) = @_;
142        # Default to the standard Perl source directories when none are specified.
143
40
100
53
        @dirs = qw(lib script bin t) unless @dirs;
144        return $self->_collect_files(\@dirs, sub {
145
50
50
33
                my $file = shift;
146                # Extract the file extension and check it against our known Perl extensions.
147
50
110
                my ($ext) = $file =~ /(\.[^.]+)$/;
148
50
67
129
                return defined $ext && grep { $ext eq $_ } @PERL_EXTENSIONS;
149
40
114
        });
150}
151
152 - 156
=head2 lib_modules

Returns an arrayref of .pm paths (relative to root) found under lib/.

=cut
157
158sub lib_modules {
159
54
54
56
        my $self = shift;
160        # Delegate to find_files with a suffix filter for .pm files.
161
54
77
        return $self->find_files('lib', '.pm');
162}
163
164 - 168
=head2 test_files

Returns an arrayref of .t paths (relative to root) found under t/.

=cut
169
170sub test_files {
171
5
5
14
        my $self = shift;
172        # Delegate to find_files with a suffix filter for .t files.
173
5
11
        return $self->find_files('t', '.t');
174}
175
176 - 180
=head2 git_root

Returns the git repository root, or undef if not in a git repo.

=cut
181
182sub git_root {
183
1
1
2
        my $self = shift;
184
1
2
        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
1
4104
        my $out  = qx{git -C \Q$root\E rev-parse --show-toplevel 2>/dev/null};
188
1
8
        chomp $out;
189        # Return undef rather than an empty string when outside a git repo.
190
1
50
20
        return (length $out) ? $out : undef;
191}
192
193 - 197
=head2 builder_file

Returns the name (relative to root) of the first found builder file, or undef.

=cut
198
199sub builder_file {
200
15
15
24
        my $self = shift;
201        # Return the first builder file that actually exists in the distro root.
202
15
32
        for my $f (@BUILDER_FILES) {
203
36
100
94
                return $f if $self->has_file($f);
204        }
205        # None of the known builder files were found.
206
3
15
        return undef;
207}
208
209 - 214
=head2 find_files( $dir, $pattern )

Returns an arrayref of all files under C<$dir> matching C<$pattern>
(a string suffix or a compiled regexp).

=cut
215
216sub find_files {
217
75
75
107
        my ($self, $dir, $pattern) = @_;
218
75
100
115
        croak 'find_files requires a directory' unless defined $dir;
219        return $self->_collect_files([$dir], sub {
220
75
75
84
                my $rel = shift;
221                # No pattern means "match everything".
222
75
100
102
                return 1 unless defined $pattern;
223                # Accept either a compiled regexp or a plain string suffix.
224
71
100
862
                return ref $pattern eq 'Regexp' ? $rel =~ $pattern : $rel =~ /\Q$pattern\E$/;
225
72
207
        });
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).
237sub _collect_files {
238
114
114
355
        my ($self, $dirs, $accept) = @_;
239
114
132
        my @found;
240
114
114
79
118
        for my $dir (@{$dirs}) {
241
196
600
                my $abs_dir = $self->abs_path($dir);
242                # Skip directories that don't exist rather than croaking.
243
196
100
943
                next unless -d $abs_dir;
244                File::Find::find({
245                        no_chdir => 1,    # Stay in one place; $_ is always absolute.
246                        wanted   => sub {
247
240
100
240
4530
                                return unless -f $_;    # Skip directories and symlinks.
248
125
166
                                my $rel = File::Spec->abs2rel($_, $self->root);
249                                # Normalize to forward slashes on Windows where abs2rel uses backslashes.
250
125
129
                                $rel =~ s{\\}{/}g;
251
125
100
130
                                push @found, $rel if $accept->($rel);
252                        },
253
102
3379
                }, $abs_dir);
254        }
255
114
322
        return \@found;
256}
257
2581;
259