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

package App::DBCritic;

# ABSTRACT: Critique a database schema for best practices

#pod =head1 SYNOPSIS
#pod
#pod     use App::DBCritic;
#pod
#pod     my $critic = App::DBCritic->new(
#pod         dsn => 'dbi:Oracle:HR', username => 'scott', password => 'tiger');
#pod     $critic->critique();
#pod
#pod =head1 DESCRIPTION
#pod
#pod This package is used to scan a database schema and catalog any violations
#pod of best practices as defined by a set of policy plugins.  It takes conceptual
#pod and API inspiration from L.
#pod
#pod B is the command line interface.
#pod
#pod This is a work in progress - please see the L section below for
#pod information on how to contribute.  It especially needs ideas (and
#pod implementations!) of new policies!
#pod
#pod =cut

use strict;
use utf8;
use Modern::Perl '2011';    ## no critic (Modules::ProhibitUseQuotedVersion)

our $VERSION = '0.023';     # VERSION
use Carp;
use English '-no_match_vars';
use List::Util 1.33 'any';
use Module::Pluggable
    search_path => [ __PACKAGE__ . '::Policy' ],
    sub_name    => 'policies',
    instantiate => 'new';

#pod =method policies
#pod
#pod Returns an array of loaded policy names that will be applied during
#pod L.  By default all modules under the
#pod C namespace are loaded.
#pod
#pod =cut

use Moo;
use Scalar::Util 'blessed';
use App::DBCritic::Loader;

for (qw(username password class_name)) { has $_ => ( is => 'ro' ) }

#pod =attr username
#pod
#pod The optional username used to connect to the database.
#pod
#pod =attr password
#pod
#pod The optional password used to connect to the database.
#pod
#pod =attr class_name
#pod
#pod The name of a L class you wish to
#pod L.
#pod Only settable at construction time.
#pod
#pod =cut

has dsn => ( is => 'ro', lazy => 1, default => \&_build_dsn );

sub _build_dsn {
    my $self = shift;

    ## no critic (ErrorHandling::RequireUseOfExceptions)
    croak 'No schema defined' if not $self->has_schema;
    my $dbh = $self->schema->storage->dbh;

    ## no critic (ValuesAndExpressions::ProhibitAccessOfPrivateData)
    return join q{:} => 'dbi', $dbh->{Driver}{Name}, $dbh->{Name};
}

#pod =attr dsn
#pod
#pod The L data source name (required) used to connect to the database.
#pod If no L or L is provided, L will then
#pod construct schema classes dynamically to be critiqued.
#pod
#pod =cut

has schema => (
    is        => 'ro',
    coerce    => 1,
    lazy      => 1,
    default   => \&_build_schema,
    coerce    => \&_coerce_schema,
    predicate => 1,
);

sub _build_schema {
    my $self = shift;

    my @connect_info = map { $self->$_ } qw(dsn username password);

    if ( my $class_name = $self->class_name ) {
        return $class_name->connect(@connect_info)
            if eval "require $class_name";
    }

    return _coerce_schema( \@connect_info );
}

sub _coerce_schema {
    my $schema = shift;

    return $schema if blessed $schema and $schema->isa('DBIx::Class::Schema');

    local $SIG{__WARN__} = sub {
        if ( $_[0] !~ / has no primary key at /ms ) {
            print {*STDERR} $_[0];
        }
    };
    return App::DBCritic::Loader->connect( @{$schema} )
        if 'ARRAY' eq ref $schema;
    ## no critic (ErrorHandling::RequireUseOfExceptions)
    croak q{don't know how to make a schema from a } . ref $schema;
}

#pod =attr schema
#pod
#pod A L object you wish to L.
#pod Only settable at construction time.
#pod
#pod =attr has_schema
#pod
#pod An attribute predicates that is true or false, depending on whether L
#pod has been defined.
#pod
#pod =cut

has _elements => ( is => 'ro', lazy => 1, default => \&_build__elements );

sub _build__elements {
    my $self   = shift;
    my $schema = $self->schema;
    return {
        Schema       => [$schema],
        ResultSource => [ map { $schema->source($_) } $schema->sources ],
        ResultSet    => [ map { $schema->resultset($_) } $schema->sources ],
    };
}

sub critique {
    for ( @{ shift->violations } ) {say}
    return;
}

#pod =method critique
#pod
#pod Runs the L through the C engine using all
#pod the policies that have been loaded and dumps a string representation of
#pod L to C.
#pod
#pod =cut

has violations => (
    is      => 'ro',
    lazy    => 1,
    default => sub {
        my $self = shift;
        [   map { $self->_policy_loop( $_, $self->_elements->{$_} ) }
                keys %{ $self->_elements },
        ];
    },
);

#pod =method violations
#pod
#pod Returns an array reference of all
#pod Ls
#pod picked up by the various policies.
#pod
#pod =cut

sub _policy_loop {
    my ( $self, $policy_type, $elements_ref ) = @_;
    my @violations;
    for my $policy ( grep { _policy_applies_to( $_, $policy_type ) }
        $self->policies )
    {
        push @violations, grep {$_}
            map { $policy->violates( $_, $self->schema ) } @{$elements_ref};
    }
    return @violations;
}

sub _policy_applies_to {
    my ( $policy, $type ) = @_;
    return any { $_ eq $type } @{ $policy->applies_to };
}

1;

__END__