File Coverage

blib/lib/App/DBCritic.pm
Criterion Covered Total %
statement 61 71 85.9
branch 4 12 33.3
condition 2 3 66.6
subroutine 17 19 89.4
pod 1 1 100.0
total 85 106 80.1


line stmt bran cond sub pod time code
1             package App::DBCritic;
2              
3 7     7   1614020 use strict;
  7         50  
  7         208  
4 7     7   40 use utf8;
  7         10  
  7         54  
5 7     7   177 use Modern::Perl '2011'; ## no critic (Modules::ProhibitUseQuotedVersion)
  7         15  
  7         55  
6              
7             our $VERSION = '0.022'; # VERSION
8 7     7   1356 use Carp;
  7         33  
  7         482  
9 7     7   1853 use English '-no_match_vars';
  7         7358  
  7         55  
10 7     7   2574 use List::Util 1.33 'any';
  7         149  
  7         551  
11             use Module::Pluggable
12 7         54 search_path => [ __PACKAGE__ . '::Policy' ],
13             sub_name => 'policies',
14 7     7   4253 instantiate => 'new';
  7         78984  
15 7     7   5472 use Moo;
  7         66984  
  7         37  
16 7     7   11771 use Scalar::Util 'blessed';
  7         18  
  7         411  
17 7     7   3438 use App::DBCritic::Loader;
  7         34  
  7         45  
18              
19             for (qw(username password class_name)) { has $_ => ( is => 'ro' ) }
20              
21             has dsn => ( is => 'ro', lazy => 1, default => \&_build_dsn );
22              
23             sub _build_dsn {
24 0     0   0 my $self = shift;
25              
26             ## no critic (ErrorHandling::RequireUseOfExceptions)
27 0 0       0 croak 'No schema defined' if not $self->has_schema;
28 0         0 my $dbh = $self->schema->storage->dbh;
29              
30             ## no critic (ValuesAndExpressions::ProhibitAccessOfPrivateData)
31 0         0 return join q{:} => 'dbi', $dbh->{Driver}{Name}, $dbh->{Name};
32             }
33              
34             has schema => (
35             is => 'ro',
36             coerce => 1,
37             lazy => 1,
38             default => \&_build_schema,
39             coerce => \&_coerce_schema,
40             predicate => 1,
41             );
42              
43             sub _build_schema {
44 1     1   21 my $self = shift;
45              
46 1         3 my @connect_info = map { $self->$_ } qw(dsn username password);
  3         34  
47              
48 1 50       5 if ( my $class_name = $self->class_name ) {
49 0 0       0 return $class_name->connect(@connect_info)
50             if eval "require $class_name";
51             }
52              
53 1         5 return _coerce_schema( \@connect_info );
54             }
55              
56             sub _coerce_schema {
57 7     7   3067485 my $schema = shift;
58              
59 7 100 66     278 return $schema if blessed $schema and $schema->isa('DBIx::Class::Schema');
60              
61             local $SIG{__WARN__} = sub {
62 0 0   0   0 if ( $_[0] !~ / has no primary key at /ms ) {
63 0         0 print {*STDERR} $_[0];
  0         0  
64             }
65 1         9 };
66 1 50       5 return App::DBCritic::Loader->connect( @{$schema} )
  1         20  
67             if 'ARRAY' eq ref $schema;
68             ## no critic (ErrorHandling::RequireUseOfExceptions)
69 0         0 croak q{don't know how to make a schema from a } . ref $schema;
70             }
71              
72             has _elements => ( is => 'ro', lazy => 1, default => \&_build__elements );
73              
74             sub _build__elements {
75 5     5   60 my $self = shift;
76 5         89 my $schema = $self->schema;
77             return {
78             Schema => [$schema],
79 7         345 ResultSource => [ map { $schema->source($_) } $schema->sources ],
80 5         91 ResultSet => [ map { $schema->resultset($_) } $schema->sources ],
  7         2974  
81             };
82             }
83              
84             sub critique {
85 1     1 1 2 for ( @{ shift->violations } ) {say}
  1         20  
  0         0  
86 1         24 return;
87             }
88              
89             has violations => (
90             is => 'ro',
91             lazy => 1,
92             default => sub {
93             my $self = shift;
94             [ map { $self->_policy_loop( $_, $self->_elements->{$_} ) }
95             keys %{ $self->_elements },
96             ];
97             },
98             );
99              
100             sub _policy_loop {
101 15     15   211 my ( $self, $policy_type, $elements_ref ) = @_;
102 15         30 my @violations;
103 15         79 for my $policy ( grep { _policy_applies_to( $_, $policy_type ) }
  60         108163  
104             $self->policies )
105             {
106 4         6881 push @violations, grep {$_}
107 20         42 map { $policy->violates( $_, $self->schema ) } @{$elements_ref};
  28         2899  
  20         47  
108             }
109 15         188 return @violations;
110             }
111              
112             sub _policy_applies_to {
113 60     60   147 my ( $policy, $type ) = @_;
114 60     60   208 return any { $_ eq $type } @{ $policy->applies_to };
  60         11774  
  60         1064  
115             }
116              
117             1;
118              
119             # ABSTRACT: Critique a database schema for best practices
120              
121             __END__