File Coverage

File:blib/lib/App/Project/Doctor/Check/Security.pm
Coverage:97.0%

linestmtbrancondsubtimecode
1package App::Project::Doctor::Check::Security;
2
3
5
5
5
5
2061
6
80
use strict;
4
5
5
5
5
10
5
146
use warnings;
5
5
5
5
5
12
6
20
use autodie qw(:all);
6
7
5
5
5
5
10818
5
18
use parent -norequire, 'App::Project::Doctor::Check::Base';
8
9
5
5
5
5
161
5
129
use Carp qw(croak carp);
10
5
5
5
5
10
5
2522
use Readonly;
11
12our $VERSION = '0.02';
13
14Readonly::Array my @SECRET_PATTERNS => (
15        qr/(?:password|passwd|secret|api_?key|token)\s*=\s*['"][^'"]{4,}['"]/i,
16        qr/-----BEGIN (?:RSA |EC )?PRIVATE KEY-----/,
17        qr/(?:AKIA|ASIA)[A-Z0-9]{16}/,
18);
19
20
4
4
307
sub name        { 'Security' }
21
1
1
2
sub description { 'All modules declare strict/warnings; no hardcoded credentials.' }
22
2
2
5
sub can_fix     { 1 }
23
5
5
14
sub order       { 60 }
24
25sub check {
26
23
23
28
        my ($self, $ctx) = @_;
27
23
50
29
        croak 'check requires an App::Project::Doctor::Context' unless ref $ctx;
28
29
23
19
        my @findings;
30
23
36
        my $files = $ctx->perl_files('lib', 'script', 'bin');
31
32
23
23
53
27
        for my $rel (@{$files}) {
33
22
22
1
1
67
21
26
13
129
                my $content = eval { $ctx->slurp($rel) } // do { carp "Cannot slurp $rel"; next };
34
35                # strict / warnings -- skip .t files (they inherit from test harness).
36
21
100
76
                unless ($rel =~ /\.t$/) {
37
20
100
81
                        unless ($content =~ /^\s*use\s+strict\b/m) {
38
3
9
                                push @findings, _f(
39                                        severity => 'error',
40                                        message  => "Missing 'use strict' in $rel.",
41                                        file     => $rel,
42                                        fix      => _fix_pragma($ctx, $rel, 'strict'),
43                                );
44                        }
45
20
100
53
                        unless ($content =~ /^\s*use\s+warnings\b/m) {
46
2
6
                                push @findings, _f(
47                                        severity => 'error',
48                                        message  => "Missing 'use warnings' in $rel.",
49                                        file     => $rel,
50                                        fix      => _fix_pragma($ctx, $rel, 'warnings'),
51                                );
52                        }
53                }
54
55                # Credential scan.
56
21
49
                my @lines = split /\n/, $content;
57
21
34
                for my $i (0 .. $#lines) {
58
90
285
                        for my $pat (@SECRET_PATTERNS) {
59
261
100
1035
                                if ($lines[$i] =~ $pat) {
60
8
66
                                        push @findings, _f(
61                                                severity => 'error',
62                                                message  => "Possible hardcoded credential in $rel at line " . ($i + 1) . '.',
63                                                file     => $rel,
64                                                line     => $i + 1,
65                                                detail   => 'Move secrets to environment variables or a config file.',
66                                        );
67
8
13
                                        last;
68                                }
69                        }
70                }
71        }
72
73
23
100
104
        unless (@findings) {
74
11
18
                push @findings, _f(
75                        severity => 'pass',
76                        message  => 'All checked files use strict/warnings; no credential patterns found.',
77                );
78        }
79
80
23
46
        return @findings;
81}
82
83# ---------------------------------------------------------------------------
84# Private helpers
85# ---------------------------------------------------------------------------
86
87sub _f {
88
24
24
55
        require App::Project::Doctor::Finding;
89
24
67
        return App::Project::Doctor::Finding->new(check_name => 'Security', @_);
90}
91
92sub _fix_pragma {
93
8
8
15
        my ($ctx, $rel, $pragma) = @_;
94        return sub {
95
4
4
10
                my $abs = $ctx->abs_path($rel);
96
4
11
                open my $fh, '<', $abs;
97
4
1704
                my @lines = <$fh>;
98
4
9
                close $fh;
99
100                # A shebang must remain the very first line of a script so the OS
101                # can recognise it; preserve it by starting the search one line in.
102
4
100
67
747
                my $insert_at = (@lines && $lines[0] =~ /^#!/) ? 1 : 0;
103
4
8
                for my $i ($insert_at .. $#lines) {
104
5
100
9
                        if ($lines[$i] =~ /^\s*package\s+\S+/) {
105
1
2
                                $insert_at = $i + 1;
106
1
1
                                last;
107                        }
108                }
109
4
6
                splice @lines, $insert_at, 0, "use $pragma;\n";
110
111
4
7
                open my $out, '>', $abs;
112
4
4
286
11
                print {$out} @lines;
113
4
6
                close $out;
114
8
26
        };
115}
116
1171;
118