File Coverage

lib/DBIx/EAV.pm

Criterion	Covered	Total	%
statement	218	227	96.0
branch	76	114	66.6
condition	12	19	63.1
subroutine	29	29	100.0
pod	4	5	80.0
total	339	394	86.0

package DBIx::EAV;

use Moo;
use strictures 2;
use DBI;
use Lingua::EN::Inflect ();
use Data::Dumper;
use Digest::MD5 qw/ md5_hex /;
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.11";

# 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 '_type_declarations', is => 'ro', default => sub { {} };
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  enable_multi_tenancy
    /;

    @{$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, $name) = @_;
    confess 'usage: eav->type($name)' unless $name;

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

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

    confess "EntityType '$name' 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_or_register_type('id', $value)
        or confess "EntityType 'id=$value' does not exist.";
}

sub declare_entities {
    my ($self, $schema) = @_;
    my $declarations = $self->_type_declarations;

    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Maxdepth = 10;

    for my $name (sort keys %$schema) {

        # generate signature
        my $entity_schema = $self->_normalize_entity_schema($name, $schema->{$name});
        my $signature = md5_hex Dumper($entity_schema);

        # not declared yet
        if (!$declarations->{$name}) {
            $declarations->{$name} = {
                signature => $signature,
                schema => $entity_schema
            };
            next;
        }
        else {

            # same schema, do nothing
            next if $declarations->{$name}{signature} eq $signature;

            # its different, replace declaration and invalidate insalled type
            printf STDERR "# %s declaration changed from %s to %s\n", $name, $declarations->{$name}{signature}, $signature;
            $declarations->{$name} = {
                signature => $signature,
                schema => $entity_schema
            };

            my $type_id = $self->_types->{$name}->id;
            delete $self->_types->{$name};
            delete $self->_types_by_id->{$type_id};
        }
    }
}

sub _load_or_register_type {
    my ($self, $field, $value) = @_;
    my $declarations = $self->_type_declarations;

    # find registered type
    if (my $type_row = $self->table('entity_types')->select_one({ $field => $value })) {

        # find custom class to update type declaration
        if (my $custom_entity_class = $self->_resolve_entity_class($type_row->{name})) {
            $self->declare_entities({ $value => $custom_entity_class->type_definition });
        }

        # update type registration if changed
        my $declaration = $declarations->{$type_row->{name}}
            or die "Found registered but not declared entity type '$type_row->{name}'";

        my $type;
        # declaration didnt change, load from db
        if ($declaration->{signature} eq $type_row->{signature}) {

            # printf STDERR "# loaded $type_row->{name} signature %s.\n", $type_row->{signature};
            $type = DBIx::EAV::EntityType->load({ %$type_row, core => $self});
        }
        # update definition
        else {
            # printf STDERR "# loaded $type_row->{name} signature changed from %s to %s.\n", $type_row->{signature}, $declaration->{signature};
            $self->_update_type_definition($type_row, $declaration->{schema});
            $type = DBIx::EAV::EntityType->new({ %$type_row, core => $self});
        }

        # install type and return
        $self->_types->{$type->name} = $type;
        $self->_types_by_id->{$type->id} = $type;
        return $type;
    }

    # not found, give up unless we have a name
    return unless $field eq 'name';

    # find custom class to update type declaration
    if (my $custom_entity_class = $self->_resolve_entity_class($value)) {
        $self->declare_entities({ $value => $custom_entity_class->type_definition });
    }

    # declaration not found
    return unless $declarations->{$value};

    # register new type
    $self->_register_entity_type($value);
}

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 $type;

    if (blessed $name) {
        confess "invalid argument" unless $name->isa('DBIx::EAV::EntityType');
        $type = $name;
    }
    else {
        $type = $self->type($name);
    }

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

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

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

    # error: undeclared type
    my $declaration = $self->_type_declarations->{$name}
        or die "_register_entity_type() error: No type declaration for '$name'";

    # error: already registered
    my $types_table = $self->table('entity_types');
    if  (my $type = $types_table->select_one({ name => $name })) {
        die "Type '$type->{name}' is already registered!'";
    }

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

    # insert type definition (parent, attributes, relationships)
    $self->_update_type_definition($type, $declaration->{schema});

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


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

    # parent type first
    my $parent_type = $self->_update_type_inheritance($type, $spec);
    $type->{parent} = $parent_type if $parent_type;

    # update or create attributes
    $self->_update_type_attributes($type, $spec);

    # update or create relationships
    foreach my $reltype (qw/ has_one has_many many_to_many /) {

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

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

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

}

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

    my $hierarchy_table = $self->table('type_hierarchy');
    my $inheritance_row = $hierarchy_table->select_one({ child_type_id  => $type->{id} });
    my $parent_type;

    if ($spec->{extends}) {

        die "Unknown type '$spec->{extends}' specified in 'extents' option for type '$type->{name}'."
            unless $parent_type = $self->type($spec->{extends});

        # update parent link
        if ($inheritance_row && $inheritance_row->{parent_type_id} ne $parent_type->id) {

            $hierarchy_table->update({ parent_type_id => $parent_type->id }, $inheritance_row)
                or die "Error updating to inheritance table. ( for '$type->{name}' extends '$spec->{extends}')";
        }
        # insert parent link
        elsif(!$inheritance_row) {

            $hierarchy_table->insert({ child_type_id => $type->{id}, parent_type_id => $parent_type->id })
                or die "Error inserting to inheritance table. ( for '$type->{name}' extends '$spec->{extends}')";
        }

        $type->{parent} = $parent_type;
    }
    else {
        # remove parent link
        if ($inheritance_row) {
            $hierarchy_table->delete($inheritance_row)
                or die "Error deleting from inheritance table. (to remove '$type->{name}' parent link)";
        }
    }

    $parent_type;
}

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

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

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

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

        printf STDERR "[warn] entity '%s' is overriding inherited attribute '%s'", $type->{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) {
            # TODO update attribute definition
        }
        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;
    }
}

sub _register_type_relationship {
    my ($self, $type, $reltype, $params) = @_;

    die sprintf("Error: invalid %s relationship for entity '%s': missing 'entity' parameter.", $reltype, $type->{name})
        unless $params->{entity};

    my $other_entity = $self->type($params->{entity});

    $params->{name} ||= $reltype =~ /_many$/ ? lc Lingua::EN::Inflect::PL($other_entity->name)
                                             : lc $other_entity->name;

    $params->{incoming_name} ||= $reltype eq 'many_to_many' ? lc Lingua::EN::Inflect::PL($type->{name})
                                                            : lc $type->{name};

    my %rel = (
        left_entity_type_id  => $type->{id},
        right_entity_type_id => $other_entity->id,
        name => $params->{name},
        incoming_name => $params->{incoming_name},
        "is_$reltype" => 1
    );

    # update or insert
    my $relationships_table = $self->table('relationships');
    my $existing_rel = $relationships_table->select_one({
        left_entity_type_id => $type->{id},
        name => $rel{name},
    });

    if ($existing_rel) {

        $rel{id} = $existing_rel->{id};

        # update
        my %changed_cols = map { $_ => $rel{$_} }
                           grep { $rel{$_} ne $existing_rel->{$_} }
                           keys %rel;

        $relationships_table->update(\%changed_cols, { id => $rel{id} })
            if keys %changed_cols > 0;
    }
    else {
        my $id = $relationships_table->insert(\%rel);
        die sprintf("Database error while registering  '%s -> %s' relationship.", $type->{name}, $rel{name})
            unless $id;

        $rel{id} = $id;
    }

    # this type side
    $type->{relationships}->{$rel{name}} = \%rel;

    # install their side
    $other_entity->_relationships->{$rel{incoming_name}} = {
        %rel,
        is_right_entity => 1,
        name => $rel{incoming_name},
        incoming_name => $rel{name},
    };
}

sub _normalize_entity_schema {
    my ($self, $entity_name, $schema) = @_;

    # validate, normalize and copy data structures
    my %normalized;

    # scalar keys
    for (qw/ extends /) {
        $normalized{$_} = $schema->{$_}
            if exists $schema->{$_};
    }

    # attributes
    my %static_attributes = map { $_ => {name => $_, is_static => 1} } @{$self->table('entities')->columns};
    foreach my $attr_spec (@{$schema->{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 normalizing attribute '%s' for  entity '%s': can't use names of static attributes (real table columns).", $attr_spec->{name}, $entity_name)
            if exists $static_attributes{$attr_spec->{name}};

        push @{$normalized{attributes}}, { %$attr_spec };
    }

    # relationships
    for my $reltype (qw/ has_one has_many many_to_many /) {

        next unless $schema->{$reltype};

        my $rels = $schema->{$reltype};
        if (my $reftype = ref $rels) {
            die "Error: invalid '$reltype' config for '$entity_name'" if $reftype ne 'ARRAY';
        } else {
            $rels = [$rels]
        }

        foreach my $params (@$rels)  {

            my %rel;
            my $reftype = ref $params;
            # scalar: entity
            if (!$reftype) {
                %rel = ( entity => $params )
            }
            elsif ($reftype eq 'ARRAY') {

                %rel = (
                    name => $params->[0],
                    entity  => $params->[1],
                    incoming_name => $params->[2],
                );
            }
            elsif ($reftype eq 'HAS') {
                %rel = %$params;
            }
            else {
                die "Error: invalid '$reltype' config for '$entity_name'.";
            }

            die sprintf("Error: invalid %s relationship for entity '%s': missing 'entity' parameter.", $reltype, $entity_name)
                unless $rel{entity};

            # push
            push @{$normalized{$reltype}}, \%rel;
        }

    }

    \%normalized;
}

1;

__END__