File Coverage

lib/DBIx/EAV.pm

Criterion	Covered	Total	%
statement	34	36	94.4
branch			n/a
condition			n/a
subroutine	12	12	100.0
pod			n/a
total	46	48	95.8

package DBIx::EAV;

use Moo;
use strictures 2;
use DBI;
use Lingua::EN::Inflect ();
use Data::Dumper;
use DBIx::EAV::EntityType;
use DBIx::EAV::Entity;
use DBIx::EAV::ResultSet;
use DBIx::EAV::Schema;
use Carp qw' croak confess ';
use Scalar::Util 'blessed';
use Class::Load qw' try_load_class ';
use namespace::clean;

our $VERSION = "0.08";

# required
has 'dbh', is => 'ro', required => 1;

# options
has 'default_attribute_type', is => 'ro', default => 'varchar';
has 'schema_config', is => 'ro', default => sub { {} };
has 'entity_namespaces', is => 'ro', default => sub { [] };
has 'resultset_namespaces', is => 'ro', default => sub { [] };

# internal
has 'schema', is => 'ro', lazy => 1, builder => 1, init_arg => undef, handles => [qw/ table dbh_do /];
has '_types', is => 'ro', default => sub { {} };
has '_types_by_id', is => 'ro', default => sub { {} };

# group schema_config params
around BUILDARGS => sub {
    my ( $orig, $class, @args ) = @_;
    my $params = @args == 1 && ref $args[0] ? $args[0] : { @args };
    my $schema_config = delete $params->{schema_config} || {};

    my @schema_params = grep { exists $params->{$_} } qw/
        tenant_id         data_types   database_cascade_delete static_attributes
        table_prefix      id_type      default_attribute_type
    /;

    @{$schema_config}{@schema_params} = delete @{$params}{@schema_params};

    $class->$orig(%$params, schema_config => $schema_config);
};


sub _build_schema {
    my $self = shift;
    DBIx::EAV::Schema->new(%{$self->schema_config}, dbh => $self->dbh);
}

sub connect {
    my ($class, $dsn, $user, $pass, $attrs, $constructor_params) = @_;

    croak 'Missing $dsn argument for connect()' unless $dsn;

    croak "connect() must be called as a class method."
        if ref $class;

    $constructor_params //= {};

    $constructor_params->{dbh} = DBI->connect($dsn, $user, $pass, $attrs)
        or die $DBI::errstr;

    $class->new($constructor_params);
}

sub type {
    my ($self, $value) = @_;

    return $self->_types->{$value}
        if exists $self->_types->{$value};

    my $type = $self->_load_type('name', $value);

    # not registered, try to find  a custom entity class and register it
    if (!$type && (my $entity_class = $self->_resolve_entity_class($value))) {

        ($type) = $self->register_types({$value => $entity_class->type_definition});
    }

    confess "EntityType '$value' does not exist."
        unless $type;

    $type;
}

sub type_by_id {
    my ($self, $value) = @_;

    return $self->_types_by_id->{$value}
        if exists $self->_types_by_id->{$value};

    $self->_load_type('id', $value)
        or confess "EntityType 'id=$value' does not exist.";
}

sub _load_type {
    my ($self, $field, $value) = @_;

    my $type_row = $self->table('entity_types')->select_one({ $field => $value });
    return unless $type_row;

    my $type = DBIx::EAV::EntityType->load({ %$type_row, core => $self});
    $self->_types->{$type->name} = $type;
    $self->_types_by_id->{$type->id} = $type;
    $type;
}

sub _resolve_entity_class {
    my ($self, $name) = @_;

    foreach my $ns (@{ $self->entity_namespaces }) {

        my $entity_class = join '::', $ns, $name;
        my ($is_loaded, $error) = try_load_class $entity_class;

        return $entity_class if $is_loaded;

        # rethrow compilation errors
        die $error if $error =~ /^Can't locate .* in \@INC/;
    }

    return;
}

sub _resolve_resultset_class {
    my ($self, $name) = @_;

    foreach my $ns (@{ $self->resultset_namespaces }) {

        my $class = join '::', $ns, $name;
        my ($is_loaded, $error) = try_load_class $class;

        return $class if $is_loaded;

        # rethrow compilation errors
        die $class;
    }

    return;
}

sub resultset {
    my ($self, $name) = @_;

    my $rs_class = $self->_resolve_resultset_class($name)
        || 'DBIx::EAV::ResultSet';

    $rs_class->new({
        eav  => $self,
        type => $self->type($name),
    });
}


sub register_types {
    my ($self, $schema) = @_;
    my %skip;

    # register only not-installed entities to
    # allow multiple calls to this method
    my @new_types = grep { not exists $self->_types->{$_} } keys %$schema;

    # create or update each entity type on database
    my @registered_types;
    foreach my $name (@new_types) {
        next if exists $self->_types->{$name};
        push @registered_types,
             $self->_register_entity_type($name, $schema->{$name}, $schema);
    }

    # register relationships
    foreach my $name (@new_types) {

        my $spec = $schema->{$name};
        my $entity_type = $self->type($name);

        foreach my $reltype (qw/ has_one has_many many_to_many /) {

            next unless defined $spec->{$reltype};

            $spec->{$reltype} ||= [];
            $spec->{$reltype} = [$spec->{$reltype}]
                unless ref $spec->{$reltype} eq 'ARRAY';

            foreach my $rel (@{$spec->{$reltype}}) {
                $entity_type->register_relationship($reltype, $rel);
            }
        }
    }

    @registered_types;
}


sub _register_entity_type {
    my ($self, $name, $spec, $schema) = @_;

    # parent type first
    my $parent_type;
    if ($spec->{extends}) {

        unless ($parent_type = $self->_types->{$spec->{extends}}) {

            die "Unknown type '$spec->{extends}' specified in 'extents' option for type '$name'."
                unless exists $schema->{$spec->{extends}};

            $parent_type = $self->_register_entity_type($spec->{extends}, $schema->{$spec->{extends}}, $schema);
        }
    }

    # find or create entity type
    my $types_table = $self->table('entity_types');
    my $hierarchy_table = $self->table('type_hierarchy');
    my $type = $types_table->select_one({ name => $name });

    if (defined $type) {

        # change parent
    }
    else {

        # TODO implement rename
        # if ($spec->{rename_from}) { ... }

        my $id = $types_table->insert({ name => $name });
        $type = $types_table->select_one({ id => $id });
        die "Error inserting entity type '$name'!" unless $type;

        if ($parent_type) {
            $hierarchy_table->insert({
                parent_type_id => $parent_type->{id},
                child_type_id  => $type->{id}
            });

            $type->{parent} = $parent_type;
        }
    }

    # update or create attributes
    my $attributes = $self->table('attributes');
    my %static_attributes = map { $_ => {name => $_, is_static => 1} } @{$self->table('entities')->columns};
    $type->{attributes} = {};

    my %inherited_attributes = $parent_type ? map { $_->{name} => $_ } $parent_type->attributes( no_static => 1 )
                                            : ();

    foreach my $attr_spec (@{$spec->{attributes}}) {

        # expand string to name/type
        unless (ref $attr_spec) {
            my ($name, $type) = split ':', $attr_spec;
            $attr_spec = {
                name => $name,
                type => $type || $self->default_attribute_type
            };
        }

        die sprintf("Error registering attribute '%s' for  entity '%s'. Can't use names of static attributes (real table columns).", $attr_spec->{name}, $type->{name})
            if exists $static_attributes{$attr_spec->{name}};

        printf STDERR "[warn] entity '%s' is overriding inherited attribute '%s'", $name, $attr_spec->{name}
            if $inherited_attributes{$attr_spec->{name}};

        my $attr = $attributes->select_one({
            entity_type_id => $type->{id},
            name => $attr_spec->{name}
        });

        if (defined $attr) {
            # update
        }
        else {
            delete $attr_spec->{id}; # safety

            my %data = %$attr_spec;

            $data{entity_type_id} = $type->{id};
            $data{data_type} = delete($data{type}) || $self->default_attribute_type;

            die sprintf("Attribute '%s' has unknown data type '%s'.", $data{name}, $data{data_type})
                unless $self->schema->has_data_type($data{data_type});

            $attributes->insert(\%data);
            $attr = $attributes->select_one(\%data);
            die "Error inserting attribute '$attr_spec->{name}'!" unless $attr;
        }

        $type->{attributes}{$attr->{name}} = $attr;
    }

    $self->_types->{$name} =
        $self->_types_by_id->{$type->{id}} = DBIx::EAV::EntityType->new(%$type, core => $self);
}



1;

__END__