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
159496
6
62
use strict;
9
5
5
5
5
7
5
155
use warnings;
10
5
5
5
5
209
6028
27
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
16182
6
155
use Carp qw(croak carp);
14# Readonly makes constants truly immutable; mutation throws at runtime.
15
5
5
5
5
8
4
93
use Readonly;
16# File::Spec builds cross-platform paths (handles Windows backslashes).
17
5
5
5
5
8
5
62
use File::Spec;
18# File::Find is loaded without importing its 'find' function to avoid namespace pollution.
19
5
5
5
5
6
4
47
use File::Find ();
20# validate_strict enforces parameter schemas and throws immediately on failure.
21
5
5
5
5
362
14585
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
10
4
2515
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
223
223
196878
        my $class = shift;
44        # validate_strict normalises args, applies defaults, and throws on bad input.
45
223
100
434
        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
223
100
24552
                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
217
1572
        }, $class;
64}
65
66# ---------------------------------------------------------------------------
67# Accessors  (read-only after construction)
68# ---------------------------------------------------------------------------
69
70# The absolute path to the distribution root directory.
71
919
919
7467
sub root    { $_[0]->{root}    }
72# Whether verbose progress messages should be emitted.
73
4
4
9
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
455
455
478
        my ($self, $rel_path) = @_;
87
455
100
970
        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
452
382
        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
794
794
1115
        my ($self, $rel_path) = @_;
101
794
100
645
        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
791
947
100
1121
973
                if grep { $_ eq '..' } File::Spec->splitdir($rel_path);
106
787
1193
        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
106
106
483
        my ($self, $rel_path) = @_;
118        # autodie wraps open() in an eval internally; 'local $@' protects the caller's $@.
119
106
93
        local $@;
120
106
100
126
        croak 'slurp requires a relative path' unless defined $rel_path;
121
103
102
        my $abs = $self->abs_path($rel_path);
122        # Provide a clear error if the caller asks for a file that isn't there.
123
102
100
416
        croak "File not found: $abs" unless -f $abs;
124
99
185
        open my $fh, '<:encoding(UTF-8)', $abs;
125        # Undefine $/ to enable slurp mode (read the entire file in one operation).
126
99
13732
        local $/;
127
99
959
        my $content = <$fh>;
128
99
606
        close $fh;
129
99
4278
        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
87
        my ($self, @dirs) = @_;
142        # Default to the standard Perl source directories when none are specified.
143
40
100
54
        @dirs = qw(lib script bin t) unless @dirs;
144        return $self->_collect_files(\@dirs, sub {
145
50
50
40
                my $file = shift;
146                # Extract the file extension and check it against our known Perl extensions.
147
50
136
                my ($ext) = $file =~ /(\.[^.]+)$/;
148
50
67
133
                return defined $ext && grep { $ext eq $_ } @PERL_EXTENSIONS;
149
40
131
        });
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
53
53
48
        my $self = shift;
160        # Delegate to find_files with a suffix filter for .pm files.
161
53
87
        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
8
        my $self = shift;
172        # Delegate to find_files with a suffix filter for .t files.
173
5
18
        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
3
        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
4200
        my $out  = qx{git -C \Q$root\E rev-parse --show-toplevel 2>/dev/null};
188
1
11
        chomp $out;
189        # Return undef rather than an empty string when outside a git repo.
190
1
50
24
        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
22
        my $self = shift;
201        # Return the first builder file that actually exists in the distro root.
202
15
33
        for my $f (@BUILDER_FILES) {
203
36
100
92
                return $f if $self->has_file($f);
204        }
205        # None of the known builder files were found.
206
3
14
        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
74
74
120
        my ($self, $dir, $pattern) = @_;
218
74
100
147
        croak 'find_files requires a directory' unless defined $dir;
219        return $self->_collect_files([$dir], sub {
220
74
74
59
                my $rel = shift;
221                # No pattern means "match everything".
222
74
100
119
                return 1 unless defined $pattern;
223                # Accept either a compiled regexp or a plain string suffix.
224
70
100
961
                return ref $pattern eq 'Regexp' ? $rel =~ $pattern : $rel =~ /\Q$pattern\E$/;
225
71
227
        });
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
113
113
319
        my ($self, $dirs, $accept) = @_;
239
113
91
        my @found;
240
113
113
86
138
        for my $dir (@{$dirs}) {
241
195
684
                my $abs_dir = $self->abs_path($dir);
242                # Skip directories that don't exist rather than croaking.
243
195
100
905
                next unless -d $abs_dir;
244                File::Find::find({
245                        no_chdir => 1,    # Stay in one place; $_ is always absolute.
246                        wanted   => sub {
247
238
100
238
4490
                                return unless -f $_;    # Skip directories and symlinks.
248
124
154
                                my $rel = File::Spec->abs2rel($_, $self->root);
249                                # Normalize to forward slashes on Windows where abs2rel uses backslashes.
250
124
123
                                $rel =~ s{\\}{/}g;
251
124
100
143
                                push @found, $rel if $accept->($rel);
252                        },
253
101
3493
                }, $abs_dir);
254        }
255
113
331
        return \@found;
256}
257
2581;
259