File Coverage

blib/lib/Persistence/Attribute/AMCAdapter.pm

Criterion	Covered	Total	%
statement	21	60	35.0
branch	0	10	0.0
condition			n/a
subroutine	7	20	35.0
pod	12	12	100.0
total	40	102	39.2

package Persistence::Attribute::AMCAdapter;

use strict;
use warnings;

use vars qw($VERSION);

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

use base qw(Persistence::Attribute);
use Carp 'confess';

$VERSION = 0.01;

=head1 NAME

Persistence::Attribute::AMCAdapter - Adapter to Abstract::Meta::Class meta object protocol.

=head1 CLASS HIERARCHY

 Persistence::Attribute
    |
    +----Persistence::Attribute::AMCAdapter

=head1 SYNOPSIS

    package Employee;

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

    my $orm = entity 'emp';
    $orm->set_mop_attribute_adapter('Persistence::Attribute::AMCAdapter');

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


=head1 DESCRIPTION

Interface to MOP attribute object adapters.

=head1 EXPORT

None.

=head2 ATTRIBUES

=over

=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'
    }
);


=item attribute

Any MOP atrribute.

=cut

has '$.attribute' => (associated_class => 'Abstract::Meta::Attribute');


=back

=head2 METHODS

=over

=item name

Attribute name.

=cut

sub name {
    my ($self) = @_;
    $self->attribute->name;
}


=item accessor

Accessor name - name of the method that returns value of the attribute.

    my $accessor = $attribute->accessor;
    my $value = $obj->$accessor;

=cut

sub accessor {
    my ($self) = @_;
    $self->attribute->accessor;
}


=item mutator

Accessor name - name of the method that sets value of the attribute.

=cut

sub mutator {
    my ($self) = @_;
    $self->attribute->mutator;
}


=item storage_key

Attribute storage key.

If this option is set and object_creation_method is set to 'bless'
then a new object creation will use bless method

    bless { map {($_->storage_key,  $args{$_->name})} @attributes}, $class

otherwise new method will be used.

    $class->new(map {($_->name,  $args{$_->name})} @attributes);

=cut

sub storage_key {
    my ($self) = @_;
    $self->attribute->storage_key;
}


=item associated_class

Name of the associated class.

For isntance if you have relationship bettwen My::Employee object and My::Dept
then associated_class will be My::Dept

=cut

sub associated_class {
    my ($self) = @_;
    $self->attribute->associated_class;
}


=item class_name

Class to whom the attribute belongs.

=cut

sub class_name {
    my ($self) = @_;
    $self->attribute->class;
}



=item get_value

Returns value form object without triggering any events.
Takes object as parameter.

=cut

sub get_value {
    my ($self, $object) = @_;
    $self->attribute->get_value($object);
}



=item set_value

Sets object value without triggering any events.
Takes object, value as parameter.

=cut

sub set_value {
    my ($self, $object, $value) = @_;
    $self->attribute->set_value($object, $value);
}


=item has_value

Returns true if object has value for the attribute.

=cut

sub has_value {
    my ($self, $object) = @_;
    my $attribute = $self->attribute;
    my $method = $object->can("has_" . $attribute->accessor);
    $method ? $method->($object) : $self->get_value($object);
}


=item find_attribute

Returns attribute
Takes class name attribute name.


=cut

sub find_attribute {
    my ($clazz, $class, $attribute_name) = @_;
    my $meta_class = Abstract::Meta::Class::meta_class($class);
    $meta_class->attribute($attribute_name);
}


=item create_meta_attribute

Return a new persisitence attribute object

=cut

sub create_meta_attribute {
    my ($clazz, $meta_attribute, $class, $column_name) = @_;
    my $meta_class = Abstract::Meta::Class::meta_class($class);
    my $name = $meta_attribute->{name};
    $name = '$.' . $name unless ($name =~ m/[\$\@\%]\./);
    my %args = (storage_key => $meta_attribute->{name}, %$meta_attribute, name => $name, class => $class);
   $clazz->new(attribute => $meta_class->attribute_class->new(%args), column_name => $column_name);
}


=item install_fetch_interceptor

=cut


sub install_fetch_interceptor {
    my ($self, $code_ref) = @_;
    my $attribute  = $self->attribute;
    $attribute->set_on_read(
        sub {
            my ($this, $attribute, $scope, $index) = @_;
            my $values = $attribute->get_value($this);
            $values = $code_ref->($this, $values);
            if ($scope eq 'accessor') {
                 return $values;
            } else {
                 my $type = ref $values;
                 return $type eq 'HASH' ? $values->{$index} : ($type eq  'ARRAY' ? $values->[$index] : $values);
            }
        }
    );
}

1;

__END__