File Coverage

blib/lib/Persistence/ORM.pm

Criterion	Covered	Total	%
statement	36	216	16.6
branch	0	52	0.0
condition	0	11	0.0
subroutine	12	42	28.5
pod	29	29	100.0
total	77	350	22.0

package Persistence::ORM;

use strict;
use warnings;

use Abstract::Meta::Class ':all';

use Persistence::Attribute::AMCAdapter;
use Persistence::Relationship ':all';
use Persistence::LOB;
use Persistence::Relationship::ToOne ':all';
use Persistence::Relationship::OneToMany ':all';
use Persistence::Relationship::ManyToMany ':all';


use vars qw(@EXPORT_OK %EXPORT_TAGS $VERSION);
use Carp 'confess';
use base 'Exporter';

$VERSION = 0.04;

@EXPORT_OK = qw(entity column trigger to_one one_to_many many_to_many lob LAZY EAGER NONE ALL ON_INSERT ON_UPDATE ON_DELETE);
%EXPORT_TAGS = (all => \@EXPORT_OK);

=head1 NAME

Persistence::ORM - Object-relational mapping.

=cut

=head1 SYNOPSIS

    package Employee;

    use Abstract::Meta::Class ':all';
    use Persistence::ORM ':all';

    entity 'emp';
    column empno => has('$.no') ;
    column ename => has('$.name');


=head1 DESCRIPTION

Object-relational mapping module.

=head1 EXPORT

entity column trigger to_one one_to_many many_to_many
LAZY EAGER NONE ALL ON_INSERT ON_UPDATE ON_DELETE  by 'all' tag

=head2 ATTRIBUTES

=over

=item class

class name

=cut

has '$.class' => (
    required  => 1,
    on_change => sub {
        my ($self, $attribute, $scope, $value_ref) = @_;
        mapping_meta($$value_ref, $self);
    }
);


=item entity_name

entity name.

=cut

has '$.entity_name' => (required => 1);


=item columns

A map between database column and object attribute

=cut

has '%.columns' => (
    item_accessor    => '_column',
    associated_class => 'Persistence::Attribute',
    index_by         => 'column_name',
    on_validate      => sub {
        my ($self, $attribute, $scope, $value_ref) = @_;
        my $values = $$value_ref;
        if (ref($values) eq 'HASH') {
            my $class = $self->class;
            foreach my $k (keys %$values) {
                my $value =  $values->{$k};
                $values->{$k} = $self->_create_meta_attribute($value, $class, $k)
                    if(ref($value) eq 'HASH')
            }
        }
    }
);


=item lobs

Assocation to LOB objects definition.

=cut

has '%.lobs' => (item_accessor => '_lob', associated_class => 'Persistence::LOB', the_other_end => 'orm');


=item relationships

Assocation to objects relationship definition.

=cut

has '%.relationships' => (item_accessor => '_relationship', associated_class => 'Persistence::Relationship', index_by => 'attribute_name', the_other_end => 'orm');


=item trigger

Defines tigger that will execute on one of the following event
before_insert after_insert before_update after_update before_delete after_delete, on_fetch
Takes event name as first parameter, and callback as secound parameter.

    $entity_manager->trigger(before_insert => sub {
        my ($self) = @_;
        #do stuff
    });

=cut

{

    has '%.triggers' => (
        item_accessor => '_trigger',
        on_change => sub {
            my ($self, $attribute, $scope, $value, $key) = @_;
            if($scope eq 'mutator') {
                my $hash = $$value;
                foreach my $k (keys %$hash) {
                    $self->validate_trigger($k. $hash->{$k});
                }
            } else {
                $self->validate_trigger($key, $$value);
            }
            $self;
        },
    );
}


=item entity_manager

=cut

has '$.entity_manager' => (transistent => 1);


=item mop_attribute_adapter

Name of the class that is an adapter to meta object protocols.
That class have to implements Persistence::Attribute interface.

=cut

has '$.mop_attribute_adapter' => (
    default => 'Persistence::Attribute::AMCAdapter',
);


=item object_creation_method

Returns object creation method.
Allowed values: bless or new

=cut

has '$.object_creation_method' => (
    default => 'bless',
    on_change => sub {
        my ($self, $attribute, $scope, $value) = @_;
        confess "invalid value for " . __PACKAGE__ . "::object_creation_method - allowed values(bless | new)"
            if ($$value ne 'bless' && $$value ne 'new');
        $self;
    }
);


=item _attributes_to_columns

Cache for  the attributes_to_columns method result

=cut

has '$._attributes_to_columns';


=item _columns_to_attributes

Cache for the columns_to_attributes method result

=cut

has '$._columns_to_attributes';


=item _columns_to_storage_attributes

Cache for the columns_to_storage_attributes method result

=cut

has '$._columns_to_storage_attributes';


=back

=head2 METHODS

=over

=item entity

Creates a meta entity class.

=cut

sub entity {
    my ($name, $package) = @_;
    $package ||= caller();
    __PACKAGE__->new(entity_name => $name, class => $package);
}


{
    my %meta;

=item mapping_meta

Returns meta enity class.
Takes optionally package name as parameter.

=cut

    sub mapping_meta {
        my ($package, $value) = @_;
        $package ||= caller();
        $meta{$package} = $value if defined $value;
        $meta{$package};
    }
}

=item column

Adds mapping between column name and related attribute.
Takes column name and attribute object as parameter.

    column ('column1' => has '$.attr1');

=cut

sub column {
    my ($name, $attribute) = @_;
    my $attr_class = 'Persistence::Attribute';
    my $package = caller();
    my $self = mapping_meta($package) or confess "no entity defined for class $package";
    my $attribute_class = $self->mop_attribute_adapter;
    $attribute  =  $attribute_class->new(attribute => $attribute, column_name => $name)
        unless $attribute->isa('Persistence::Attribute');
    $self->add_columns($attribute);
}


=item lob

Adds mapping between lob column name and related attribute.

    lob 'lob_column' => (
        attribute    => has('$.photo'),
        fetch_method => LAZY,
    );


=cut

sub lob {
    my ($name, %args) = @_;
    my $attribute = $args{attribute};
    my $attr_class = 'Persistence::Attribute';
    my $package = caller();
    my $self = mapping_meta($package) or confess "no entity defined for class $package";
    my $attribute_class = $self->mop_attribute_adapter;
    $args{attribute} =  $attribute_class->new(attribute => $attribute, column_name => $name)
      unless $attribute->isa('Persistence::Attribute');
    $self->add_lobs(Persistence::LOB->new(%args));
}


=item covert_to_attributes

Converts passed in data structure to attributes

=cut

sub covert_to_attributes {
    my ($self, $columns) = @_;
    my $class = $self->class;
    my $attribute_class = $self->mop_attribute_adapter;
    my $result = {};
    for my $column(keys %$columns) {
        my $meta_attribute = $columns->{$column};
        my $attribute = $attribute_class->find_attribute($class, $meta_attribute->{name});
        unless ($attribute) {
            $attribute = $self->_create_meta_attribute($meta_attribute, $class, $column);
        } else {
            $attribute = $attribute_class->new(attribute => $attribute, column_name => $column);
        }
        $result->{$column} = $attribute;
    }
    $result;
}


=item covert_to_lob_attributes

Converts passed in data structure to lob attributes

=cut

sub covert_to_lob_attributes {
    my ($self, $lobs) = @_;
    my $class = $self->class;
    my $attribute_class = $self->mop_attribute_adapter;
    my $result = {};
    for my $lob (@$lobs) {
        my $column = $lob->{name};
        my $fetch_method = $lob->{fetch_method};
        my $attribute_name = $lob->{attribute};

        my $attribute = $attribute_class->find_attribute($class, $attribute_name);
        unless ($attribute) {
            $attribute = $self->_create_meta_attribute({name => $attribute_name}, $class, $column);
        } else {
            $attribute = $attribute_class->new(attribute => $attribute, column_name => $column);
        }
        $result->{$column} =  Persistence::LOB->new(
            attribute => $attribute,
            ($fetch_method ? (fetch_method => Persistence::LOB->$fetch_method) :())
        );
    }
    $result;
}


=item _create_meta_attribute

Creates a meta attribute

=cut

sub _create_meta_attribute {
    my ($clazz, $meta_attribute, $class, $column_name) = @_;
    my $self = mapping_meta($class) or confess "no entity defined for class $class";
    my $attribute_class = $self->mop_attribute_adapter;
    $attribute_class->create_meta_attribute($meta_attribute, $class, $column_name);
}


=item add_lob_column

Adds lob column.
Takes lob column name, attribute name;

=cut

sub add_lob_column {
    my ($self, $column, $attribute_name, $fetch_method) = @_;
    $self->add_lobs(
        Persistence::LOB->new(
            name         => 'column',
            attribute    => $self->attribute($attribute_name),
            ($fetch_method ? (fetch_method => Persistence::LOB->$fetch_method) :()),
        )
    );
}


=item eager_fetch_lobs

=cut

sub eager_fetch_lobs {
    my ($self) = @_;
    my $lobs = $self->lobs;
    Persistence::LOB->eager_fetch_filter($lobs);
}


=item lazy_fetch_lobs

=cut

sub lazy_fetch_lobs {
    my ($self) = @_;
    my $lobs = $self->lobs;
    Persistence::LOB->lazy_fetch_filter($lobs);
}


=item attribute

=cut

sub attribute {
    my ($self, $attribute_name) = @_;
    my $meta = Abstract::Meta::Class::meta_class($self->class)
        or confess "cant find meta class defintion (Abstract::Meta::Class) for " . $self->class;
    my $attribute = $meta->attribute($attribute_name)
        or confess "cant find attribute ${attribute_name} for class " . $self->class;
    $attribute;
}


=item deserialise

Deserialises resultset to object.

=cut

sub deserialise {
    my ($self, $args, $entity_manager) = @_;
    my $object_creation_method = $self->object_creation_method;
    my $columns_to_attributes = $self->columns_to_attributes;
    my $result = $object_creation_method eq 'bless'
        ? bless ({
        $self->storage_attribute_values($args)
    }, $self->class)
        : $self->class->new(map { $args->{$_} } keys %$columns_to_attributes);

    $entity_manager->initialise_operation($self->entity_name, $result);
    $self->deserialise_eager_relation_attributes($result, $entity_manager);
    $self->deserialise_eager_lob_attributes($result, $entity_manager);
    $entity_manager->complete_operation($self->entity_name);
    $self->run_event('on_fetch', $result);
    $result;
}


=item deserialise_eager_relation_attributes

=cut

sub deserialise_eager_relation_attributes {
    my ($self, $object, $entity_manager) = @_;
    my @relations = Persistence::Relationship->eager_fetch_relations(ref($object));
    foreach my $relation (@relations) {
        $relation->deserialise_attribute($object, $entity_manager, $self);
    }
}


=item deserialise_eager_lob_attributes

=cut

sub deserialise_eager_lob_attributes {
    my ($self, $object, $entity_manager) = @_;
    my @lobs = $self->eager_fetch_lobs;
    foreach my $lob (@lobs) {
        $lob->deserialise_attribute($object, $entity_manager, $self);
    }
}


=item deserialise_lazy_relation_attributes

=cut

sub deserialise_lazy_relation_attributes {
    my ($self, $object, $entity_manager) = @_;
    my @relations = Persistence::Relationship->lazy_fetch_relations(ref($object));
    foreach my $relation (@relations) {
        my $name = $relation->attribute->name;
        $object->$name;
    }
}


=item update_object

=cut

sub update_object {
    my ($self, $object, $column_values, $columns_to_update) = @_;
    my $columns = $self->columns;
    $columns_to_update ||= [keys %$column_values];
    for my $column_name (@$columns_to_update) {
        my $attribute = $columns->{$column_name} or next;
        $attribute->set_value($object, $column_values->{$column_name});
    }
}


=item join_columns_values

Returns join columns values for passed in relation

=cut

sub join_columns_values {
    my ($self, $entity, $relation_name, $object) = @_;
    my $relation = $entity->to_many_relationship($relation_name);
    my $pk_values = $self->column_values($object, $entity->primary_key);
    unless ($entity->has_primary_key_values($pk_values)) {
        my $values = $self->unique_values($object, $entity);
        $pk_values = $self->retrive_primary_key_values($values);
    }
    $entity->_join_columns_values($relation, $pk_values);
}


=item unique_values

Return unique columns values

=cut

sub unique_values {
    my ($self, $object, $entity) = @_;
    my @unique_columns = map { $_->name }  $entity->unique_columns;;
    $self->column_values($object, $entity->primary_key, @unique_columns);
}


=item primary_key_values

Return primary key values

=cut

sub primary_key_values {
    my ($self, $object, $entity) = @_;
    $self->column_values($object, $entity->primary_key);
}


=item trigger

=cut

sub trigger {
    my ($event_name, $code_ref) = @_;
    my $attr_class = 'Abstract::Meta::Attribute';
    my $package = caller();
    my $mapping_meta = mapping_meta($package) or confess "no entity defined for class $package";
    $mapping_meta->_trigger($event_name, $code_ref);
}


=item validate_trigger

Validates triggers types

=cut

{
    my @triggers = qw(before_insert after_insert before_update after_update before_delete after_delete on_fetch);
    sub validate_trigger {
        my ($self, $name, $value) = @_;
        confess "invalid trigger name: $name , must be one of " . join(",", @triggers)
            unless (grep {$name eq $_} @triggers);
        confess "secound parameter must be a callback"
            unless ref($value) eq 'CODE';
    }
}


=item run_event

=cut

sub run_event {
    my ($self, $name, @args) = @_;
    my $event = $self->_trigger($name);
    $event->($self, @args) if $event;
}


=item attributes_to_columns

=cut

sub attributes_to_columns {
    my ($self) = @_;
    my $attributes_to_columns = $self->_attributes_to_columns;
    return $attributes_to_columns if $attributes_to_columns;
    my $columns = $self->columns;
    my $result = {};
    foreach my $k (keys %$columns) {
        $result->{$columns->{$k}->name} = $k;
    }
    $self->_attributes_to_columns($result);
    return $result;
}


=item columns_to_attributes

=cut

sub columns_to_attributes {
    my ($self) = @_;
    my $columns_to_attributes = $self->_columns_to_attributes;
    return $columns_to_attributes if $columns_to_attributes;
    my $columns = $self->columns;
    my $result = {};
    foreach my $k (keys %$columns) {
        $result->{$k} = $columns->{$k}->name;
    }
    my $lobs = $self->lobs;
    foreach my $k (keys %$lobs) {
        my $attribute = $lobs->{$k}->attribute;
        $result->{$attribute->column_name} = $attribute->name;
    }

    $self->_columns_to_attributes($result);
    return $result;
}



=item columns_to_storage_attributes

=cut

sub columns_to_storage_attributes {
    my ($self) = @_;
    my $columns_to_storage_attributes = $self->_columns_to_storage_attributes;
    return $columns_to_storage_attributes if $columns_to_storage_attributes;
    my $columns = $self->columns;
    my $result = {};
    foreach my $k (keys %$columns) {
        $result->{$k} = $columns->{$k}->storage_key;
    }
    $self->_columns_to_storage_attributes($result);
    return $result;
}


=item attribute_to_column

Returns column name.
Takes attribute name.

=cut

sub attribute_to_column {
    my ($self, $attribute_name) = @_;
    my $attributes_to_columns = $self->attributes_to_columns;
    $attributes_to_columns->{$attribute_name};
}


=item storage_attribute_values

Transforms column values to the hash that can be blessed as an object.
Takes hash ref of column_values

=cut

sub storage_attribute_values {
    my ($self, $column_values) = @_;
    my $columns = $self->columns;
    my $columns_to_storage_attributes = $self->columns_to_storage_attributes;
    my %result = map {
        ($columns_to_storage_attributes->{$_},  $column_values->{$_})} keys %$columns;
    wantarray ? (%result) : \%result;
}


=item attribute_values

Transforms column values to the object attribute value hash.
Takes hash ref of column_values

=cut

sub attribute_values {
    my ($self,  $column_values) = @_;
    my $columns = $self->columns;
    my $columns_to_attributes = $self->columns_to_attributes;
    my %result = map {
        ($columns_to_attributes->{$_}, $column_values->{$_} )} keys %$columns;
    wantarray ? (%result) : \%result;
}


=item column_values

Transforms objects attributes to column values
Takes object, optionally required columns. (by default all colunms)

=cut

sub column_values {
    my ($self, $obj, @columns) = @_;
    my $columns_to_attributes = $self->columns_to_attributes;
    my $lobs = $self->lobs;
    @columns = (keys %$columns_to_attributes)
        unless @columns;
    my %result = map {
        my $accessor = $columns_to_attributes->{$_};
        ($_, $obj->$accessor)} @columns;
    wantarray ? (%result) : \%result;
}


=item attribute_values_to_column_values

Returns column values.
Takes attribute values hash.

=cut

sub attribute_values_to_column_values {
    my ($self, %args) = @_;
    my $attributes_to_columns = $self->attributes_to_columns;
    my %result;
    for my $k(keys %args) {
        my $column = $attributes_to_columns->{$k} || $k;
        $result{$column} = $args{$k};
    }
    (%result);
}



1;

__END__