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
2226
4
71
use strict;
4
5
5
5
5
7
4
162
use warnings;
5
5
5
5
5
8
5
19
use autodie qw(:all);
6
7
5
5
5
5
10634
5
20
use parent -norequire, 'App::Project::Doctor::Check::Base';
8
9
5
5
5
5
164
6
132
use Carp qw(croak carp);
10
5
5
5
5
10
5
2648
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
238
sub name        { 'Security' }
21
1
1
3
sub description { 'All modules declare strict/warnings; no hardcoded credentials.' }
22
2
2
4
sub can_fix     { 1 }
23
5
5
13
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
20
        my @findings;
30
23
42
        my $files = $ctx->perl_files('lib', 'script', 'bin');
31
32
23
23
56
26
        for my $rel (@{$files}) {
33
22
22
1
1
67
22
29
15
153
                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
80
                unless ($rel =~ /\.t$/) {
37
20
100
83
                        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
58
                        unless ($content =~ /^\s*use\s+warnings\b/m) {
46
2
7
                                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
56
                my @lines = split /\n/, $content;
57
21
30
                for my $i (0 .. $#lines) {
58
90
283
                        for my $pat (@SECRET_PATTERNS) {
59
261
100
981
                                if ($lines[$i] =~ $pat) {
60
8
69
                                        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
14
                                        last;
68                                }
69                        }
70                }
71        }
72
73
23
100
130
        unless (@findings) {
74
11
15
                push @findings, _f(
75                        severity => 'pass',
76                        message  => 'All checked files use strict/warnings; no credential patterns found.',
77                );
78        }
79
80
23
47
        return @findings;
81}
82
83# ---------------------------------------------------------------------------
84# Private helpers
85# ---------------------------------------------------------------------------
86
87sub _f {
88
24
24
52
        require App::Project::Doctor::Finding;
89
24
85
        return App::Project::Doctor::Finding->new(check_name => 'Security', @_);
90}
91
92sub _fix_pragma {
93
8
8
16
        my ($ctx, $rel, $pragma) = @_;
94        return sub {
95
4
4
9
                my $abs = $ctx->abs_path($rel);
96
4
9
                open my $fh, '<', $abs;
97
4
1800
                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
751
                my $insert_at = (@lines && $lines[0] =~ /^#!/) ? 1 : 0;
103
4
6
                for my $i ($insert_at .. $#lines) {
104
5
100
13
                        if ($lines[$i] =~ /^\s*package\s+\S+/) {
105
1
1
                                $insert_at = $i + 1;
106
1
1
                                last;
107                        }
108                }
109
4
7
                splice @lines, $insert_at, 0, "use $pragma;\n";
110
111
4
7
                open my $out, '>', $abs;
112
4
4
273
9
                print {$out} @lines;
113
4
6
                close $out;
114
8
29
        };
115}
116
1171;
118