view release on metacpan or  search on metacpan

lib/Abstract/Meta/Class.pm  view on Meta::CPAN

package Abstract::Meta::Class;

use strict;
use warnings;

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

$VERSION = 0.11;

@EXPORT_OK = qw(has new apply_contructor_parameter install_meta_class abstract abstract_class storage_type);
%EXPORT_TAGS = (all => \@EXPORT_OK, has => ['has', 'install_meta_class', 'abstract', 'abstract_class', 'storage_type']);

use Abstract::Meta::Attribute;
use Abstract::Meta::Attribute::Method;

=head1 NAME

Abstract::Meta::Class - Simple meta object protocol implementation.

=head1 SYNOPSIS

    package Dummy;

    use Abstract::Meta::Class ':all';
    
    
    has '$.attr1' => (default => 0);
    has '%.attrs2' => (default => {a => 1, b => 3}, item_accessor => 'attr2');
    has '@.atts3' => (default => [1, 2, 3], required => 1, item_accessor => 'attr3');
    has '&.att3' => (required => 1);
    has '$.att4' => (default => sub { 'stuff' } , required => 1);


    my $dummt = Dummy->new(
        att3 => 3,
    );

    use Dummy;

    my $obj = Dummy->new(attr3 => sub {});
    my $attr1 = $obj->attr1; #0
    $obj->set_attr1(1);
    $obj->attr2('c', 4);
    $obj->attrs2 #{a => 1, b => 3. c => 4};
    my $val_a = $obj->attr2('a');
    my $item_1 = $obj->attr3(1);
    $obj->count_attrs3();
    $obj->push_attrs3(4);



=head1 DESCRIPTION

Meta object protocol implementation,

=head2 hash/array storage type

To speed up bless time as well optimise memory usage you can use Array storage type.
(Hash is the default storage type)

    package Dummy;

    use Abstract::Meta::Class ':all';
    storage_type 'Array';
    
    has '$.attr1' => (default => 0);
    has '%.attrs2' => (default => {a => 1, b => 3}, item_accessor => 'attr2');
    has '@.attrs3' => (default => [1, 2, 3], required => 1, item_accessor => 'attr3');
    has '&.attr4' => (required => 1);
    has '$.attr5';
    has '$.attr6' => (default => sub { 'stuff' } , required => 1);


    my $dummy = Dummy->new(
        attr4 => sub {},
    );
    
    use Data::Dumper;
    warn Dumper $dummy;
    # bless [0, {a =>1,b => 3}, [1,2,3],sub{},undef,sub {}], 'Dummy'

=head2 simple validation and default values

    package Dummy;

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

    has '$.attr1' => (default => 0);
    has '&.att3' => (required => 1);

    use Dummy;

    my $obj = Dummy->new; #dies - att3 required


=head2 utility methods for an array type

    While specyfing array type of attribute
    the following methods are added (count || push || pop || shift || unshift)_accessor.

    package Dummy;

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

    has '@.array' => (item_accessor => 'array_item');


    use Dummy;

    my $obj = Dummy->new;

    $obj->count_array();
    $obj->push_array(1);
    my $x = $obj->array_item(0);
    my $y = $obj->pop_array;

    #NOTE scalar, array context sensitive
    my $array_ref = $obj->array;
    my @array = $obj->array;


=head2 item accessor method for complex types

    While specyfing an array or a hash type of attribute then
    you may specify item_accessor for get/set value by hash key or array index.


    package Dummy;

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

    has '%.hash' => (item_accessor => 'hash_item');

    use Dummy;

    my $obj = Dummy->new;
    $obj->hash_item('key1', 'val1');
    $obj->hash_item('key2', 'val2');
    my $val = $obj->hash_item('key1');

lib/Abstract/Meta/Class.pm  view on Meta::CPAN

    my $a = $obj->attr('a');

=head2 abstract methods/classes

    package BaseClass;

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

    has '$.attr1';
    abstract => 'method1';


    package Class;

    use base 'BaseClass';
    sub method1 {};

    use Class;

    my $obj = BaseClass->new;


    # abstract classes

    package InterfaceA;

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

    abstract_class;
    abstract => 'method1';
    abstract => 'method2';


    package ClassA;

    use base 'InterfaceA';

    sub method1 {};
    sub method2 {};

    use Class;

    my $classA = Class->new;


    package Class;

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

    has 'attr1';
    has 'interface_attr' => (associated_class => 'InterfaceA', required => 1);


    use Class;

    my $obj =  Class->new(interface_attr => $classA);


=head2 external attributes storage

    You may want store attributes values outside the blessed reference, then you may
    use transistent keyword (Inside Out Objects)

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

    has '$.attr1';
    has '$.x' => (required => 1);
    has '$.t' => (transistent => 1);
    has '%.th' => (transistent => 1);
    has '@.ta' => (transistent => 1);

    use Transistent;

    my $obj = Transistent->new(attr1 => 1, x => 2, t => 3, th => {a =>1}, ta => [1,2,3]);
    use Data::Dumper;
    print  Dumper $obj;

    Cleanup and DESTORY methods are added to class, that delete externally stored attributes.


=head2 METHODS

=over

=item new

=cut

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    unshift @_, $self;
    &apply_contructor_parameters;
}


=item install_cleanup

Install cleanup method

=cut

sub install_cleanup {
    my ($self) = @_;
    my $attributes;
    return if $self->has_cleanup_method;
    add_method($self->associated_class, 'cleanup' , sub {
        my $this = shift;
        my $has_transistent;
        my $attributes ||= $self ? $self->all_attributes : [];
        for my $attribute (@$attributes) {
            $attribute or next;
            $has_transistent = 1 if($attribute->transistent);
            if($attribute->the_other_end) {
                $attribute->deassociate($this);
                my $accessor = "set_" . $attribute->accessor;
                $this->$accessor(undef);
            }
        }
        Abstract::Meta::Attribute::Method::delete_object($this) if $has_transistent;
    });
    $self->set_cleanup_method(1);
}


=item install_destructor

Install destructor method

=cut

sub install_destructor {
    my ($self) = @_;
    return if $self->has_destory_method;
    add_method($self->associated_class, 'DESTROY' , sub {
        my $this = shift;
        $this->cleanup;
        $this;
    });
    $self->set_destroy_method(1);
}



=item install_constructor

Install constructor

=cut

sub install_constructor {
    my ($self) = @_;
    add_method($self->associated_class, 'new' ,
        $self->storage_type eq 'Array' ?
        sub {
            my $class = shift;
            my $this = bless [], $class;
            unshift @_, $this;
            &apply_contructor_parameters;
        }: sub {
            my $class = shift;
            my $this = bless {}, $class;
            unshift @_, $this;
            &apply_contructor_parameters;
        });
}


=item apply_contructor_parameters

Applies constructor parameters.

=cut

{
    sub apply_contructor_parameters {
        my ($self, @args) = @_;
        my $mutator;
        my $class = ref($self);
        eval {
            for (my $i = 0; $i < $#args; $i += 2) {
                    $mutator = "set_" . $args[$i];
                    $self->$mutator($args[$i + 1]);
            }
        };
        
        if ($@) {
            confess "unknown attribute " . ref($self) ."::" . $mutator
                unless $self->can($mutator);
            confess $@    
        }
        
        my $meta = $self->meta;
        return $self if $self eq $meta;
    
        for my $attribute ($meta->constructor_attributes) {
            if(! $attribute->get_value($self)) {
                my $can = $self->can($attribute->mutator) or next;
                $can->($self);
            }
        }
    
        my $initialise = $self->can($meta->initialise_method);
        $initialise->($self) if $initialise;
        $self;
    }
}

=item meta

=cut

sub meta { shift(); }


=item attributes

Returns attributes for meta class

=cut

sub attributes { shift()->{'@.attributes'} || {};}