Abstract-Meta-Class
view release on metacpan or search on metacpan
Revision history for Perl extension Abstract::Meta::Class.
0.11 Sun Sep 07 2007
- added array storage type
- fix required value for arra and hash perl type attribute
0.10 Sun Jun 08 2008
- fix deserialization bug
0.09 Sun Jun 01 2008
- fix test
0.08 Sat May 31 2008
- added on_validate trigger
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
Abstract::Meta::Attribute - Meta object attribute.
=head1 SYNOPSIS
use Abstract::Meta::Class ':all';
has '$.attr1' => (default => 0);
=head1 DESCRIPTION
An object that describes an attribute.
It includes required, data type, association validation, default value, lazy retrieval.
Name of attribute must begin with one of the follwoing prefix:
$. => Scalar,
@. => Array,
%. => Hash,
&. => Code,
=head1 EXPORT
None.
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
my $storage_key = $storage_type eq 'Array' ? $attribute_index : $args{storage_key} || $args{name};
$options{'$.name'} = $accessor_name;
$options{'$.storage_key'} = $storage_key;
$options{'$.mutator'} = "set_$accessor_name";
$options{'$.accessor'} = $accessor_name;
$options{'$.' . $_ } = $args{$_}
for grep {exists $args{$_}}
(qw(class required default item_accessor associated_class data_type_validation index_by the_other_end transistent storage_type));
$options{'$.perl_type'} = $supported_type{$type};
unless ($args{default}) {
if($type eq '%') {
$options{'$.default'} = sub{ {} };
} elsif ($type eq '@') {
$options{'$.default'} = sub { [] };
}
}
%options;
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
=item mutator
Returns mutator name
=cut
sub mutator { shift()->{'$.mutator'} }
=item required
Returns required flag
=cut
sub required { shift()->{'$.required'} }
=item default
Returns default value
=cut
sub default { shift()->{'$.default'} }
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
sub associated_class { shift()->{'$.associated_class'} }
=item index_by
Name of the asscessor theat will return unique attribute for associated objects.
Only for toMany associaion, by deault uses objecy reference as index.
package Class;
use Abstract::Meta::Class ':all';
has '$.name' => (required => 1);
has '%.details' => (
index_by => 'id',
item_accessor => 'detail',
);
my $obj = Class->
=cut
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=item generate_mutator_method
=cut
sub generate_mutator_method {
my $attr = shift;
my $storage_key = $attr->storage_key;
my $transistent = $attr->transistent;
my $accessor = $attr->accessor;
my $required = $attr->required;
my $default = $attr->default;
my $associated_class = $attr->associated_class;
my $perl_type = $attr->perl_type;
my $index_by = $attr->index_by;
my $on_change = $attr->on_change;
my $data_type_validation = $attr->data_type_validation;
my $on_validate = $attr->on_validate;
my $array_storage_type = $attr->storage_type eq 'Array';
$array_storage_type ?
sub {
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
} else {
$value = $default;
}
}
$on_validate->($self, $attr, 'mutator', \$value) if $on_validate;
if ($data_type_validation) {
$value = index_association_data($value, $accessor, $index_by)
if ($associated_class && $perl_type eq 'Hash');
$attr->validate_data_type($self, $value, $accessor, $associated_class, $perl_type);
if($required) {
if ($perl_type eq 'Hash') {
confess "attribute $accessor is required"
unless scalar %$value;
} elsif ($perl_type eq 'Array') {
confess "attribute $accessor is required"
unless scalar @$value;
}
}
} else {
confess "attribute $accessor is required"
if $required && ! defined $value;
}
$on_change->($self, $attr, 'mutator', \$value) or return $self
if ($on_change && defined $value);
if ($transistent) {
set_attribute($self, $storage_key, $value);
} else {
$self->[$storage_key] = $value;
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
} else {
$value = $default;
}
}
$on_validate->($self, $attr, 'mutator', \$value) if $on_validate;
if ($data_type_validation) {
$value = index_association_data($value, $accessor, $index_by)
if ($associated_class && $perl_type eq 'Hash');
$attr->validate_data_type($self, $value, $accessor, $associated_class, $perl_type);
if($required) {
if ($perl_type eq 'Hash') {
confess "attribute $accessor is required"
unless scalar %$value;
} elsif ($perl_type eq 'Array') {
confess "attribute $accessor is required"
unless scalar @$value;
}
}
} else {
confess "attribute $accessor is required"
if $required && ! defined $value;
}
$on_change->($self, $attr, 'mutator', \$value) or return $self
if ($on_change && defined $value);
if ($transistent) {
set_attribute($self, $storage_key, $value);
} else {
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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';
lib/Abstract/Meta/Class.pm view on Meta::CPAN
use Abstract::Meta::Class ':all';
has '$.name';
has '%.details' => (associated_class => 'Detail', the_other_end => 'master', item_accessor => 'detail', index_by => 'id');
package Detail;
use Abstract::Meta::Class ':all';
has '$.id' => (required => 1);
has '$.master' => (
associated_class => 'Master',
the_other_end => 'details'
);
use Master;
use Detail;
my @details = (
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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
t/meta/array_storage/association.t view on Meta::CPAN
{
my $clazz = ClassA->new(to_many => [$a1, $a2]);
::ok((grep {$_ eq $a1} values %{$clazz->to_many}), 'should associate the other end (hash)');
}
#THE OTHER END BIDIRECTIONAL ASSOCIATION, DEASSOCIATION
{
package Master;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.name' => (required => 1);
has '%.details' => (
associated_class => 'Detail',
index_by => 'id',
item_accessor => 'detail',
the_other_end => 'master',
);
}
{
package Detail;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.id' => (required => 1);
has '$.master' => (
associated_class => 'Master',
the_other_end => 'details'
);
}
{
my @details = (Detail->new(id => 1), Detail->new(id => 2,), Detail->new(id => 3));
my $master = Master->new(name => 'master', details => [@details]);
$master->remove_details($details[1]);
t/meta/array_storage/association.t view on Meta::CPAN
::is_deeply([sort @details_ids1], [1,2], 'should have 2 details index');
::is($master2->detail(3), $details[-1], "should have details");
}
#THE OTHER END BIDIRECTIONAL ASSOCIATION, DEASSOCIATION
{
package MasterA;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.name' => (required => 1);
has '@.details' => (
associated_class => 'DetailA',
index_by => 'id',
item_accessor => 'detail',
the_other_end => 'master',
);
}
{
package DetailA;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.id' => (required => 1);
has '$.master' => (
associated_class => 'MasterA',
the_other_end => 'details'
);
}
{
my @details = (
DetailA->new(id => 1),
DetailA->new(id => 2),
t/meta/array_storage/attribute.t view on Meta::CPAN
isa_ok($dummy, 'Dummy', 'should have a Dummy instance');
ok($dummy->can('x'), 'should have an accessor for x attribute');
ok($dummy->can('set_x'), 'should have a mutator for x attribute');
is($dummy->set_x(101), $dummy, 'should set a value');
is($dummy->x(101), '101', 'should get the value');
{
package Dummy::Required;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.x' => (required => 1);
}
eval { Dummy::Required->new; };
like($@, qr/x is required/, 'should catch x is required attribute');
my $required = Dummy::Required->new(x => 1);
isa_ok($required, 'Dummy::Required', 'should have a Dummy::Required instance');
{
package Dummy::Hash;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '%.xs' => (item_accessor => 'x', required => 1);
}
my $hash = Dummy::Hash->new(xs => {key1 => 1, key2 => 2});
isa_ok($hash, 'Dummy::Hash', 'should have a Dummy::Hash instance');
is($hash->x('key1'), 1, 'should have key1 value');
is($hash->x('key2'), 2, 'should have key2 value');
{
package Dummy::Array;
t/meta/array_storage/attribute.t view on Meta::CPAN
is($array->x(0), 5, 'should have the first extended item');
is($array->shift_xs, 5, 'should shit item');
{
package Dummy::Default;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.z' => (default => 0);
has '$.x' => (default => 'x');
has '%.h' => (default => {a => 1});
has '@.a' => (default => [1, 2, 3], required => 1);
has '&.c' => (required => 1);
has '$.d' => (default => sub { 'stuff' } , required => 1);
}
my $default = Dummy::Default->new(c => sub {123});
isa_ok($default, 'Dummy::Default');
is($default->x, 'x', 'should have default for the x attribute');
is_deeply({$default->h}, {a => 1}, 'should have default for the h attribute');
is_deeply([$default->a], [1, 2, 3], 'should have default for the a attribute');
is($default->d, 'stuff', 'should have default for the x attribute');
is($default->z, 0, 'should have 0 as default value');
t/meta/array_storage/attribute.t view on Meta::CPAN
$on_change->set_a('100');
::ok(! $on_change->a, 'should not change a attribute');
}
{
package Transistent;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.x' => (required => 1);
has '$.t' => (transistent => 3);
has '%.th' => (transistent => 1, item_accessor => 'item_t');
has '@.ta' => (transistent => 1);
my $obj = Transistent->new(x => 1, t => 2, th => {a => 1, b => 2}, ta => [1,2]);
::ok(@$obj == 1, 'should have only x stored in object');
::is($obj->t, 2, 'should have value for t');
::is($obj->item_t('a'), '1', 'should have 1');
::is($obj->item_t('b'), '2', 'should have 2');
t/meta/array_storage/attribute.t view on Meta::CPAN
my $b = $obj->attr('b');
::is_deeply(\%access_log, {item_accessor => 2, accessor => 2}, 'should have updated access log');
::is_deeply(\%hook_access_log, {item_accessor => 1, accessor => 1}, 'should have updated hook_access_log');
}
{
package StorageKey;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.x' => (required => 1, storage_key => 'x');
has '@.y' => (required => 1, storage_key => 'y');
my $obj = StorageKey->new(x => 1, y => [1,2]);
::is_deeply($obj, [1, [1,2]], 'should have storage key');
}
{
package Validate;
use Abstract::Meta::Class ':all'; storage_type 'Array';
my $attr = has '$.x' => (on_validate => sub {
t/meta/association.t view on Meta::CPAN
{
my $clazz = ClassA->new(to_many => [$a1, $a2]);
::ok((grep {$_ eq $a1} values %{$clazz->to_many}), 'should associate the other end (hash)');
}
#THE OTHER END BIDIRECTIONAL ASSOCIATION, DEASSOCIATION
{
package Master;
use Abstract::Meta::Class ':all';
has '$.name' => (required => 1);
has '%.details' => (
associated_class => 'Detail',
index_by => 'id',
item_accessor => 'detail',
the_other_end => 'master',
);
}
{
package Detail;
use Abstract::Meta::Class ':all';
has '$.id' => (required => 1);
has '$.master' => (
associated_class => 'Master',
the_other_end => 'details'
);
}
{
my @details = (Detail->new(id => 1), Detail->new(id => 2,), Detail->new(id => 3));
my $master = Master->new(name => 'master', details => [@details]);
$master->remove_details($details[1]);
t/meta/association.t view on Meta::CPAN
::is_deeply([sort @details_ids1], [1,2], 'should have 2 details index');
::is($master2->detail(3), $details[-1], "should have details");
}
#THE OTHER END BIDIRECTIONAL ASSOCIATION, DEASSOCIATION
{
package MasterA;
use Abstract::Meta::Class ':all';
has '$.name' => (required => 1);
has '@.details' => (
associated_class => 'DetailA',
index_by => 'id',
item_accessor => 'detail',
the_other_end => 'master',
);
}
{
package DetailA;
use Abstract::Meta::Class ':all';
has '$.id' => (required => 1);
has '$.master' => (
associated_class => 'MasterA',
the_other_end => 'details'
);
}
{
my @details = (
DetailA->new(id => 1),
DetailA->new(id => 2),
t/meta/attribute.t view on Meta::CPAN
isa_ok($dummy, 'Dummy', 'should have a Dummy instance');
ok($dummy->can('x'), 'should have an accessor for x attribute');
ok($dummy->can('set_x'), 'should have a mutator for x attribute');
is($dummy->set_x(101), $dummy, 'should set a value');
is($dummy->x(101), '101', 'should get the value');
{
package Dummy::Required;
use Abstract::Meta::Class ':all';
has '$.x' => (required => 1);
}
eval { Dummy::Required->new; };
like($@, qr/x is required/, 'should catch x is required attribute');
my $required = Dummy::Required->new(x => 1);
isa_ok($required, 'Dummy::Required', 'should have a Dummy::Required instance');
{
package Dummy::Hash;
use Abstract::Meta::Class ':all';
has '%.xs' => (item_accessor => 'x', required => 1);
}
my $hash = Dummy::Hash->new(xs => {key1 => 1, key2 => 2});
isa_ok($hash, 'Dummy::Hash', 'should have a Dummy::Hash instance');
is($hash->x('key1'), 1, 'should have key1 value');
is($hash->x('key2'), 2, 'should have key2 value');
{
package Dummy::Array;
t/meta/attribute.t view on Meta::CPAN
is($array->x(0), 5, 'should have the first extended item');
is($array->shift_xs, 5, 'should shit item');
{
package Dummy::Default;
use Abstract::Meta::Class ':all';
has '$.z' => (default => 0);
has '$.x' => (default => 'x');
has '%.h' => (default => {a => 1});
has '@.a' => (default => [1, 2, 3], required => 1);
has '&.c' => (required => 1);
has '$.d' => (default => sub { 'stuff' } , required => 1);
}
my $default = Dummy::Default->new(c => sub {123});
isa_ok($default, 'Dummy::Default');
is($default->x, 'x', 'should have default for the x attribute');
is_deeply({$default->h}, {a => 1}, 'should have default for the h attribute');
is_deeply([$default->a], [1, 2, 3], 'should have default for the a attribute');
is($default->d, 'stuff', 'should have default for the x attribute');
is($default->z, 0, 'should have 0 as default value');
is($default->c->(), '123', 'should have code value');
t/meta/attribute.t view on Meta::CPAN
$on_change->set_a('100');
::ok(! $on_change->a, 'should not change a attribute');
}
{
package Transistent;
use Abstract::Meta::Class ':all';
has '$.x' => (required => 1);
has '$.t' => (transistent => 3);
has '%.th' => (transistent => 1, item_accessor => 'item_t');
has '@.ta' => (transistent => 1);
my $obj = Transistent->new(x => 1, t => 2, th => {a => 1, b => 2}, ta => [1,2]);
::is_deeply([keys %$obj], ['$.x'], 'should have only x stored in object');
::is($obj->t, 2, 'should have value for t');
::is($obj->item_t('a'), '1', 'should have 1');
::is($obj->item_t('b'), '2', 'should have 2');
t/meta/attribute.t view on Meta::CPAN
my $b = $obj->attr('b');
::is_deeply(\%access_log, {item_accessor => 2, accessor => 2}, 'should have updated access log');
::is_deeply(\%hook_access_log, {item_accessor => 1, accessor => 1}, 'should have updated hook_access_log');
}
{
package StorageKey;
use Abstract::Meta::Class ':all';
has '$.x' => (required => 1, storage_key => 'x');
has '@.y' => (required => 1, storage_key => 'y');
my $obj = StorageKey->new(x => 1, y => [1,2]);
::is_deeply($obj, {x => 1, y =>[1,2]}, 'should have storage key');
}
{
package Validate;
use Abstract::Meta::Class ':all';
my $attr = has '$.x' => (on_validate => sub {
t/meta/fix.t view on Meta::CPAN
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);
has '%.z' => (required => 1);
}
eval {
Req->new(z => {a => 1});
};
like($@, qr{x is required}, 'should catch required value');
eval {
Req->new(x => [z => 1]);
};
like($@, qr{z is required}, 'should catch required value');
{
package ReqArray;
use Abstract::Meta::Class ':all';
storage_type 'Array';
has '@.x' => (required => 1);
has '%.z' => (required => 1);
}
eval {
Req->new(z => {a => 1});
};
like($@, qr{x is required}, 'should catch required value');
eval {
Req->new(x => [z => 1]);
};
like($@, qr{z is required}, 'should catch required value');
( run in 1.136 second using v1.01-cache-2.11-cpan-0a6323c29d9 )