Abstract-Meta-Class

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

    #NOTE scalar, array context sensitive
    my $hash_ref = $obj->hash;
    my %hash = $obj->hash;


=head2 perl types validation

    Dy default all complex types are validated against its definition.

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

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


    use Dummy;

    my $obj = Dummy->new(array => {}, hash => []) #dies incompatible types.


=head2 associations

    This module handles different types of associations(to one, to many, to many ordered).
    You may also use bidirectional association by using the_other_end option,

    NOTE: When using the_other_end automatic association/deassociation happens,
    celanup method is installed.

    package Class;

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

    has '$.to_one'  => (associated_class => 'AssociatedClass');
    has '@.ordered' => (associated_class => 'AssociatedClass');
    has '%.to_many' => (associated_class => 'AssociatedClass', item_accessor => 'many', index_by => 'id');


    use Class;
    use AssociatedClass;

    my $obj1 = Class->new(to_one => AssociatedClass->new);

    my $obj2 = Class->new(ordered => [AssociatedClass->new]);

    # NOTE: context sensitive (scalar, array)
    my @association_objs = $obj2->ordered;
    my @array_ref = $obj2->ordered;

    my $obj3 = Class->new(to_many => [AssociatedClass->new(id =>'001'), AssociatedClass->new(id =>'002')]);
    my $association_obj = $obj3->many('002);

    # NOTE: context sensitive (scalar, array)
    my @association_objs = values %{$obj3->to_many};
    my $hash_ref = $obj3->to_many;


    - bidirectional associations (the_other_end attribute)

    package Master;

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

    has '$.name';
    has '%.details' => (associated_class => 'Detail', the_other_end => 'master', item_accessor => 'detail', index_by => 'id');


    package Detail;

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

sub meta { shift(); }


=item attributes

Returns attributes for meta class

=cut

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


=item set_attributes

Mutator sets attributes for the meta class

=cut

sub set_attributes { $_[0]->{'@.attributes'} = $_[1]; }



=item has_cleanup_method

Returns true if cleanup method was generated

=cut

sub has_cleanup_method { shift()->{'$.cleanup'};}


=item set_cleanup_method

Sets clean up

=cut

sub set_cleanup_method { $_[0]->{'$.cleanup'} = $_[1]; }


=item has_destory_method

Returns true is destroy method was generated

=cut

sub has_destory_method { shift()->{'$.destructor'};}


=item set_destroy_method

Sets set_destructor flag.

=cut

sub set_destroy_method { $_[0]->{'$.destructor'} = $_[1]; }


=item initialise_method

Returns initialise method's name default is 'initialise'


=cut

sub initialise_method { shift()->{'$.initialise_method'};}


=item is_abstract

Returns is class is an abstract class.

=cut

sub is_abstract{ shift()->{'$.abstract'};}



=item set_abstract

Set an abstract class flag.

=cut

sub set_abstract{ shift()->{'$.abstract'} = 1;}


=item set_initialise_method

Mutator sets initialise_method for the meta class

=cut

sub set_initialise_method { $_[0]->{'$.initialise_method'} = $_[1]; }


=item associated_class

Returns associated class name

=cut

sub associated_class { shift()->{'$.associated_class'} }


=item set_associated_class

Mutator sets associated class name

=cut

sub set_associated_class { $_[0]->{'$.associated_class'} = $_[1]; }



=item all_attributes

Returns all_attributes for all inherited meta classes

=cut

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

    my ($self, $attribute, $remove_existing_method) = @_;
    my $accessor = $attribute->accessor;
    foreach (qw(accessor mutator)) {
        add_method($self->associated_class, $attribute->$_, $attribute->generate($_), $remove_existing_method); 
    }

    my $perl_type = $attribute->perl_type ;
    if ($perl_type eq 'Array') {
        add_method($self->associated_class, "${_}_$accessor", $attribute->generate("$_"), $remove_existing_method)
        for qw(count push pop shift unshift);
    }

    if (my $item_accessor = $attribute->item_accessor) {
        add_method($self->associated_class, $item_accessor, $attribute->generate('item_accessor'), $remove_existing_method);
    }
    
    if (($perl_type eq 'Array' || $perl_type eq 'Hash') && $attribute->associated_class) {
        add_method($self->associated_class, "add_${accessor}", $attribute->generate('add'), $remove_existing_method);
        add_method($self->associated_class, "remove_${accessor}", $attribute->generate('remove'), $remove_existing_method);
    }
    
    if($attribute->associated_class) {
        add_method($self->associated_class, "reset_${accessor}", $attribute->generate('reset'), $remove_existing_method);
        add_method($self->associated_class, "has_${accessor}", $attribute->generate('has'), $remove_existing_method);
    }
}


=item add_method

Adds code reference to the class symbol table.
Takes a class name, method name and CODE reference.

=cut

sub add_method {
    my ($class, $name, $code, $remove_existing_method) = @_;
    remove_method($class, $name) if $remove_existing_method;
    no strict 'refs';
    *{"${class}::$name"} = $code;
}


=item remove_method

Adds code reference to the class symbol table.
Takes a class name, method name and CODE reference.

=cut

sub remove_method {
    my ($class, $name) = @_;
    no strict 'refs';
    delete ${"${class}::"}{"$name"};
}



=item constructor_attributes

Returns a list of attributes that need be validated and all that have default value

=cut

sub constructor_attributes {
    my ($self) = @_;
    my $all_attributes = $self->all_attributes || [];
    grep  {$_->required || defined $_->default}  @$all_attributes;
}

1

__END__

=back

=head1 SEE ALSO

L<Abstract::Meta::Attribute>

=head1 COPYRIGHT AND LICENSE

The Abstract::Meta::Class 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.

=head1 AUTHOR

Adrian Witas, adrian@webapp.strefa.pl

=cut