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

Persistence-Entity documentation Contained in the Persistence-Entity distribution.

Index

Code Index:

NAME

Top

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

CLASS HIERARCHY

Top

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

SYNOPSIS

Top

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

DESCRIPTION

Top

Interface to MOP attribute object adapters.

EXPORT

Top

None.

ATTRIBUES

object_creation_method

Returns object creation method. Allowed values: bless or new

attribute

Any MOP atrribute.

METHODS

name

Attribute name.

accessor

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

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

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

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);
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

class_name

Class to whom the attribute belongs.

get_value

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

set_value

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

has_value

Returns true if object has value for the attribute.

find_attribute

Returns attribute Takes class name attribute name.

create_meta_attribute

Return a new persisitence attribute object

install_fetch_interceptor

COPYRIGHT AND LICENSE

Top

The Persistence::ORM::Attribute module is free software. You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file.

AUTHOR

Top

Adrian Witas,adrian@webapp.strefa.pl

Persistence-Entity documentation Contained in the Persistence-Entity distribution. 
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;


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



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



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



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



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



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



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



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




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




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



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



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



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




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__