File Coverage

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

linestmtbrancondsubtimecode
1package App::Project::Doctor::Check::Tests;
2
3# This check verifies that the distribution has a working test suite.
4# It runs in three stages: (1) does t/ exist? (2) are there .t files?
5# (3) does 'prove -l' exit 0?  The first two failures are auto-fixable.
6
7
4
4
4
4
1398
4
66
use strict;
8
4
4
4
4
7
3
126
use warnings;
9
4
4
4
4
7
3
11
use autodie qw(:all);
10
11# Inherit the standard interface from Check::Base.
12
4
4
4
4
8282
4
14
use parent -norequire, 'App::Project::Doctor::Check::Base';
13
14# croak reports errors at the caller's location, not inside this module.
15
4
4
4
4
120
4
97
use Carp qw(croak carp);
16# File::Path::make_path creates directory trees in the fix closure.
17
4
4
4
4
5
4
25
use File::Path ();
18# File::Spec builds cross-platform file paths (forward slashes on Windows too).
19
4
4
4
4
5
3
38
use File::Spec;
20# Readonly makes constants truly immutable at runtime.
21
4
4
4
4
6
3
936
use Readonly;
22
23our $VERSION = '0.02';
24
25# The prove command to run.  --nocolor avoids ANSI codes in the captured output.
26Readonly::Scalar my $PROVE_CMD => 'prove -l --nocolor 2>&1';
27
28# Short name used in Finding.check_name and report column headings.
29
3
3
188
sub name        { 'Tests' }
30# One-line description shown in verbose / help output.
31
1
1
2
sub description { 'Test suite exists, contains .t files, and passes cleanly.' }
32# This check can offer an automated fix (scaffold a smoke test).
33
2
2
5
sub can_fix     { 1 }
34# Run first; everything else depends on a working test suite.
35
5
5
9
sub order       { 10 }
36
37sub check {
38
7
7
13
        my ($self, $ctx) = @_;
39        # Require a Context object so we can use its filesystem helpers.
40
7
100
33
        croak 'check requires an App::Project::Doctor::Context' unless ref $ctx;
41
42        # -----------------------------------------------------------------------
43        # Stage 1: the t/ directory must exist.
44        # -----------------------------------------------------------------------
45
6
100
21
        unless ($ctx->has_file('t')) {
46                # No t/ at all -- return immediately with a fixable error.
47
3
12
                return _f(
48                        severity => 'error',
49                        message  => 'No t/ directory -- distribution has no test suite.',
50                        fix      => _fix_scaffold($ctx),
51                );
52        }
53
54        # -----------------------------------------------------------------------
55        # Stage 2: at least one .t file must be in t/.
56        # -----------------------------------------------------------------------
57
3
8
        my $test_files = $ctx->test_files;
58
3
3
100
4
7
        unless (@{$test_files}) {
59                # The directory exists but is empty of test files.
60
1
5
                return _f(
61                        severity => 'error',
62                        message  => 't/ directory exists but contains no .t files.',
63                        fix      => _fix_scaffold($ctx),
64                );
65        }
66
67        # -----------------------------------------------------------------------
68        # Stage 3: run prove and check the exit status.
69        # -----------------------------------------------------------------------
70        # We use Perl's chdir instead of shell 'cd && prove' because quotemeta
71        # on a Windows path (C:\Tmp) produces C\:\\Tmp which cmd.exe rejects.
72
2
5
        my $root = $ctx->root;
73
2
8
        require Cwd;
74
2
7852
        my $orig   = Cwd::cwd();    # Save the current directory so we can restore it.
75
2
46
        chdir $root;
76
2
830033
        my $output = qx{$PROVE_CMD};    # Capture all prove output for the detail field.
77
2
36
        my $status = $?;                # $? holds the child process exit status.
78
2
58
        chdir $orig;                    # Always restore the working directory.
79
80
2
100
297
        if ($status != 0) {
81                # prove reported failures; include the captured output as detail.
82                return _f(
83                        severity => 'error',
84
1
1
8
18
                        message  => sprintf('Test suite FAILED (%d file(s) with failures).', scalar @{$test_files}),
85                        detail   => $output,
86                );
87        }
88
89        # All stages passed -- report success with the file count.
90        return _f(
91                severity => 'pass',
92
1
1
6
15
                message  => sprintf('%d test file(s) found -- all pass.', scalar @{$test_files}),
93        );
94}
95
96# ---------------------------------------------------------------------------
97# Private helpers
98# ---------------------------------------------------------------------------
99
100# Purpose:    Build a Finding with check_name pre-filled to 'Tests'.
101# Entry:      %args is a valid Finding constructor argument list.
102# Exit:       App::Project::Doctor::Finding object.
103# Side effects: None.
104sub _f {
105
7
7
30
        require App::Project::Doctor::Finding;
106
7
55
        return App::Project::Doctor::Finding->new(check_name => 'Tests', @_);
107}
108
109# Purpose:    Return a coderef that creates a minimal t/00-smoke.t scaffold.
110# Entry:      $ctx is the current App::Project::Doctor::Context.
111# Exit:       Coderef ($ctx) -> void; creates t/ and t/00-smoke.t on disk.
112# Side effects: Creates directories and files under $ctx->root.
113sub _fix_scaffold {
114
5
5
5
        my $ctx = shift;
115        # Return the fix as a closure so it captures $ctx without running now.
116        return sub {
117                # Build the absolute path to the t/ directory.
118
1
1
2
                my $t_dir = File::Spec->catdir($ctx->root, 't');
119                # make_path creates the directory and any missing parent directories.
120
1
98
                File::Path::make_path($t_dir);
121                # The smoke test file that will be written.
122
1
4
                my $smoke = File::Spec->catfile($t_dir, '00-smoke.t');
123
1
5
                open my $fh, '>', $smoke;
124                # Write a minimal but valid Test::More script that always passes.
125
1
1
834
7
                print {$fh} <<'END_SMOKE';
126use strict;
127use warnings;
128use Test::More;
129
130ok(1, 'module loads');
131done_testing;
132END_SMOKE
133
1
3
                close $fh;
134
5
37
        };
135}
136
1371;
138