Abstract-Meta-Class

 view release on metacpan or  search on metacpan

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

=over

=item new

=cut


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


=item initialise

Initialises attribute

=cut

{

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

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

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

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

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

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

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

=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

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

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.

t/meta/array_storage/association.t  view on Meta::CPAN

    has '%.to_many' => (associated_class => 'AssociatedClass', index_by => 'a', item_accessor => 'association');
}

{
    package AssociatedClass;
    use Abstract::Meta::Class ':all'; storage_type 'Array';
    has '$.a';
}

{
    eval {Class->new(to_one => bless({},'main') )};
    like($@, qr{to_one must be of the AssociatedClass type},  'should catch invalid assocated_class - to one type');
    my $obj = Class->new(to_one => AssociatedClass->new);
    isa_ok($obj, 'Class');
    ok($obj->has_to_one, 'should have value');
    $obj->reset_to_one;
    ok(! $obj->has_to_one, 'should have reset value');
}

{
    eval {Class->new(ordered => [bless({},'main')])};
    like($@, qr{ordered must be of the AssociatedClass type},  'should catch invalid assocated_class - ordered type' );
    my $obj = Class->new(ordered => [AssociatedClass->new]);
    isa_ok($obj, 'Class');
    ok($obj->has_ordered, 'should have value');
    $obj->reset_ordered;
    ok(! $obj->has_ordered, 'should have reset value');
}

{
    eval {Class->new(to_many => [bless({},'main')])};
    like($@, qr{to_many must be of the AssociatedClass type},  'should catch invalid assocated_class - to many type');
    my @associations = (AssociatedClass->new(a => '002'), AssociatedClass->new(a => '302'));
    my $obj = Class->new(to_many => \@associations);
    isa_ok($obj, 'Class');
    my @exp_association = values %{$obj->to_many};
    is_deeply([sort @associations], [sort @exp_association], 'should have associations');

    is($obj->association('002'), $associations[0], 'should have indexed association');
    is($obj->association('302'), $associations[1], 'should have indexed association');

t/meta/association.t  view on Meta::CPAN

    has '%.to_many' => (associated_class => 'AssociatedClass', index_by => 'a', item_accessor => 'association');
}

{
    package AssociatedClass;
    use Abstract::Meta::Class ':all';
    has '$.a';
}

{
    eval {Class->new(to_one => bless({},'main') )};
    like($@, qr{to_one must be of the AssociatedClass type},  'should catch invalid assocated_class - to one type');
    my $obj = Class->new(to_one => AssociatedClass->new);
    isa_ok($obj, 'Class');
    ok($obj->has_to_one, 'should have value');
    $obj->reset_to_one;
    ok(! $obj->has_to_one, 'should have reset value');
}

{
    eval {Class->new(ordered => [bless({},'main')])};
    like($@, qr{ordered must be of the AssociatedClass type},  'should catch invalid assocated_class - ordered type' );
    my $obj = Class->new(ordered => [AssociatedClass->new]);
    isa_ok($obj, 'Class');
    ok($obj->has_ordered, 'should have value');
    $obj->reset_ordered;
    ok(! $obj->has_ordered, 'should have reset value');
}

{
    eval {Class->new(to_many => [bless({},'main')])};
    like($@, qr{to_many must be of the AssociatedClass type},  'should catch invalid assocated_class - to many type');
    my @associations = (AssociatedClass->new(a => '002'), AssociatedClass->new(a => '302'));
    my $obj = Class->new(to_many => \@associations);
    isa_ok($obj, 'Class');
    my @exp_association = values %{$obj->to_many};
    is_deeply([sort @associations], [sort @exp_association], 'should have associations');

    is($obj->association('002'), $associations[0], 'should have indexed association');
    is($obj->association('302'), $associations[1], 'should have indexed association');

t/meta/fix.t  view on Meta::CPAN

#BUG 0.09-1
#deserialized object breaks on accessing array, hash attribute perl type.

{
    package SuperDummy;
    use Abstract::Meta::Class ':all';
    has '@.x' => (default => 'x value');
    has '%.z' => (default => 'z value');
}

my $obj = bless {}, 'SuperDummy';
my $x = $obj->x;
my $z = $obj->z;
is(ref($x), 'ARRAY', 'should have an array');
is(ref($z), 'HASH', 'should have a hash');
    

{
    package Req;
    use Abstract::Meta::Class ':all';
    has '@.x' => (required => 1);