lib/App/Project/Doctor/Check/Security.pm

        start → end → jump
        

    1: package App::Project::Doctor::Check::Security;
    2: 
    3: use strict;
    4: use warnings;
    5: use autodie qw(:all);
    6: 
    7: use parent -norequire, 'App::Project::Doctor::Check::Base';
    8: 
    9: use Carp qw(croak carp);
   10: use Readonly;
   11: 
   12: our $VERSION = '0.02';
   13: 
   14: Readonly::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: sub name        { 'Security' }
   21: sub description { 'All modules declare strict/warnings; no hardcoded credentials.' }
   22: sub can_fix     { 1 }
   23: sub order       { 60 }
   24: 
   25: sub check {
●26 → 32 → 73   26: 	my ($self, $ctx) = @_;
   27: 	croak 'check requires an App::Project::Doctor::Context' unless ref $ctx;
   28: 
   29: 	my @findings;
   30: 	my $files = $ctx->perl_files('lib', 'script', 'bin');
   31: 
   32: 	for my $rel (@{$files}) {
   33: 		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: 		unless ($rel =~ /\.t$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
   37: 			unless ($content =~ /^\s*use\s+strict\b/m) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
   38: 				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: 			unless ($content =~ /^\s*use\s+warnings\b/m) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
   46: 				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: 		my @lines = split /\n/, $content;
   57: 		for my $i (0 .. $#lines) {
   58: 			for my $pat (@SECRET_PATTERNS) {
   59: 				if ($lines[$i] =~ $pat) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
   60: 					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: 					last;
   68: 				}
   69: 			}
   70: 		}
   71: 	}
   72: 
●73 → 73 → 80   73: 	unless (@findings) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
   74: 		push @findings, _f(
   75: 			severity => 'pass',
   76: 			message  => 'All checked files use strict/warnings; no credential patterns found.',
   77: 		);
   78: 	}
   79: 
   80: 	return @findings;
  Mutants (Total: 2, Killed: 2, Survived: 0)
   81: }
   82: 
   83: # ---------------------------------------------------------------------------
   84: # Private helpers
   85: # ---------------------------------------------------------------------------
   86: 
   87: sub _f {
   88: 	require App::Project::Doctor::Finding;
   89: 	return App::Project::Doctor::Finding->new(check_name => 'Security', @_);
  Mutants (Total: 2, Killed: 2, Survived: 0)
   90: }
   91: 
   92: sub _fix_pragma {
   93: 	my ($ctx, $rel, $pragma) = @_;
   94: 	return sub {
  Mutants (Total: 2, Killed: 2, Survived: 0)
   95: 		my $abs = $ctx->abs_path($rel);
   96: 		open my $fh, '<', $abs;
   97: 		my @lines = <$fh>;
   98: 		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: 		my $insert_at = (@lines && $lines[0] =~ /^#!/) ? 1 : 0;
  103: 		for my $i ($insert_at .. $#lines) {
  104: 			if ($lines[$i] =~ /^\s*package\s+\S+/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  105: 				$insert_at = $i + 1;
  106: 				last;
  107: 			}
  108: 		}
  109: 		splice @lines, $insert_at, 0, "use $pragma;\n";
  110: 
  111: 		open my $out, '>', $abs;
  112: 		print {$out} @lines;
  113: 		close $out;
  114: 	};
  115: }
  116: 
  117: 1;
  118: 
  119: __END__
  120: 
  121: =head1 NAME
  122: 
  123: App::Project::Doctor::Check::Security - Check for missing pragmas and hardcoded secrets
  124: 
  125: =head1 DESCRIPTION
  126: 
  127: Two security checks across all Perl source files:
  128: 
  129: =over 4
  130: 
  131: =item 1. C<use strict> and C<use warnings> present in every C<.pm> and script.
  132: 
  133: =item 2. Scan for hardcoded credential patterns (passwords, API keys, AWS
  134: key prefixes, PEM private key headers).
  135: 
  136: =back
  137: 
  138: Pragma fixes are automated; credential findings require manual resolution.
  139: 
  140: =head3 MESSAGES
  141: 
  142:   Code | Trigger                      | Resolution
  143:   -----|------------------------------|-------------------------------------------
  144:   S001 | Missing 'use strict'         | Fix inserts pragma after package declaration
  145:   S002 | Missing 'use warnings'       | Fix inserts pragma after package declaration
  146:   S003 | Possible hardcoded secret    | Move to env var / external config
  147: 
  148: =head3 FORMAL SPECIFICATION
  149: 
  150:   check : Context -> [Finding]
  151:   check ctx ==
  152:     concat [ check_file f | f <- perl_files ctx ]
  153:     where
  154:       check_file f ==
  155:         strict_check f ++ warnings_check f ++ credential_check f
  156: 
  157: =head1 AUTHOR
  158: 
  159: Nigel Horne C<< <njh@nigelhorne.com> >>
  160: 
  161: =head1 LICENSE
  162: 
  163: Copyright (C) 2026 Nigel Horne.
  164: This library is free software; you can redistribute it and/or modify
  165: it under the same terms as Perl itself.
  166: 
  167: =cut