Abstract-Meta-Class
view release on metacpan or search on metacpan
- 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
0.07 Sat May 31 2008
- fix test
0.06 Sun May 25 2008
- Added has_<accessr>, reset_<accessor> methods for association attributes
0.05 Sun May 25 2008
- Fix Makefile.PL (Test::Pod, Test::Pod::Coverage)
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
my ($type, $accessor_name) = ($name =~ /^([\$\@\%\&])\.(.*)$/);
confess "invalid attribute defintion ${class}::" .($accessor_name || $name) .", supported prefixes are \$.,%.,\@.,&."
if ! $type || ! $supported_type{$type};
my %options;
$args{data_type_validation} = 1
if (! exists($args{data_type_validation})
&& ($type eq '@' || $type eq '%' || $args{associated_class}));
$options{'&.' . $_ } = $args{$_}
for grep {exists $args{$_}} (qw(on_read on_change on_validate));
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{$_}}
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
Sets code reference that will be executed when data is set,
my $attr = MyClass->meta->attribute('attrs');
$attr->set_on_change(sub {
my ($self, $attribute, $scope, $value, $key) = @_;
if($scope eq 'mutator') {
my $hash = $$value;
foreach my $k (keys %$hash) {
# do some stuff
#$self->validate_trigger($k, $hash->{$k});
}
} else {
# do some stuff
$self->validate_trigger($key. $$value);
}
$self;
});
=cut
sub set_on_change {
my ($attr, $value) = @_;
$attr->{'&.on_change'} = $value;
my $meta= $attr->class->meta;
$meta->install_attribute_methods($attr, 1);
}
=item on_validate
Returns on validate code reference.
It is executed before the data type validation happens.
=cut
sub on_validate { shift()->{'&.on_validate'} }
=item set_on_validate
Sets code reference that will be replace data read routine
my $attr = MyClass->meta->attribute('attrs');
$attr->set_on_read(sub {
my ($self, $attribute, $scope, $key) = @_;
#do some stuff
});
=cut
sub set_on_validate {
my ($attr, $value) = @_;
$attr->{'&.on_validate'} = $value;
my $meta= $attr->class->meta;
$meta->install_attribute_methods($attr, 1);
}
1;
__END__
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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 {
my ($self, $value) = @_;
if (! defined $value && defined $default) {
if (ref($default) eq 'CODE') {
$value = $default->($self, $attr);
} 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;
}
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
sub {
my ($self, $value) = @_;
if (! defined $value && defined $default) {
if (ref($default) eq 'CODE') {
$value = $default->($self, $attr);
} 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;
}
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
my %result;
if($index && $$data[0]->can($index)) {
%result = (map {($_->$index, $_)} @$data);
} else {
%result = (map {($_ . "", $_)} @$data);
}
\%result;
}
=item validate_data_type
=cut
sub validate_data_type {
my ($attr, $self, $value, $accessor, $associated_class, $perl_type) = @_;
my $array_storage_type = $attr->storage_type eq 'Array';
if ($perl_type eq 'Array') {
confess "$accessor must be $perl_type type"
unless (ref($value) eq 'ARRAY');
if ($associated_class) {
validate_associated_class($attr, $self, $_)
for @$value;
}
} elsif ($perl_type eq 'Hash') {
confess "$accessor must be $perl_type type"
unless (ref($value) eq 'HASH');
if ($associated_class) {
validate_associated_class($attr, $self, $_)
for values %$value;
}
} elsif ($associated_class) {
my $transistent = $attr->transistent;
my $storage_key = $attr->storage_key;
my $current_value = $transistent ? get_attribute($self, $storage_key) : ($array_storage_type ? $self->[$storage_key] : $self->{$storage_key});
return if ($value && $current_value && $value eq $current_value);
$attr->deassociate($self);
if (defined $value) {
validate_associated_class($attr, $self, $value);
}
}
}
=item validate_associated_class
=cut
sub validate_associated_class {
my ($attr, $self, $value) = @_;
my $associated_class = $attr->associated_class;
my $name = $attr->name;
my $value_type = ref($value)
or confess "$name must be of the $associated_class type";
return &associate_the_other_end if $value_type eq $associated_class;
return &associate_the_other_end if $value->isa($associated_class);
confess "$name must be of the $associated_class type, is $value_type";
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
my $item_accessor = $attr->item_accessor;
my $on_change = $attr->on_change;
my $on_read = $attr->on_read;
my $index_by = $attr->index_by;
sub {
my ($self, @values) = @_;
my $hash_ref = $self->$accessor();
foreach my $value (@values) {
next unless ref($value);
my $key = ($index_by ? $value->$index_by : $value . "") or confess "unknown key hash at add_$accessor";
$attr->validate_associated_class($self, $value);
$on_change->($self, $attr, 'item_accessor', \$value, $key) or return $hash_ref->{$key}
if ($on_change);
$hash_ref->{$key} = $value;
}
$self;
};
}
=item generate_scalar_reset_method
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
sub generate_array_add_method {
my $attr = shift;
my $accesor = $attr->accessor;
my $accessor = $attr->accessor;
my $the_other_end = $attr->the_other_end;
my $associated_class = $attr->associated_class;
sub {
my ($self, @values) = @_;
my $array_ref = $self->$accesor();
foreach my $value (@values) {
$attr->validate_associated_class($self, $value, $accessor, $associated_class, $the_other_end);
push @$array_ref, $value;
}
$self;
};
}
=item generate_array_remove_method
=cut
lib/Abstract/Meta/Class.pm view on Meta::CPAN
$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;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
print $details[0]->master->name;
- while using an array/hash association storage remove_<attribute_name> | add_<attribute_name> are added.
$master->add_details(Detail->new(id => 4),);
$master->remove_details($details[0]);
#cleanup method is added to class, that deassociates all bidirectional associations
=head2 decorators
....- on_validate
- on_change
- on_read
- initialise_method
package Triggers;
use Abstract::Meta::Class ':all';
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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
t/meta/array_storage/attribute.t view on Meta::CPAN
is($default->c->(), '123', 'should have code value');
{
package Dummy::OnChange;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.a' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
# validate
# does not change anything if return false
return !! 0;
},
);
my $x_value;
my $x_attribute;
my $x_scope;
my $x_attr = has '$.x' => (
t/meta/array_storage/attribute.t view on Meta::CPAN
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 {
});
$attr->set_on_validate(
sub {
my ($self, $attribute, $scope, $value) = @_;
die 'invalid value' if($$value ne 1);
}
);
eval {
Validate->new(x => 2);
};
::like($@, qr{invalid value}, 'should validate');
::isa_ok(Validate->new(x => 1), 'Validate');
}
t/meta/attribute.t view on Meta::CPAN
is($default->c->(), '123', 'should have code value');
{
package Dummy::OnChange;
use Abstract::Meta::Class ':all';
has '$.a' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
# validate
# does not change anything if return false
return !! 0;
},
);
my $x_value;
my $x_attribute;
my $x_scope;
my $x_attr = has '$.x' => (
t/meta/attribute.t view on Meta::CPAN
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 {
});
$attr->set_on_validate(
sub {
my ($self, $attribute, $scope, $value) = @_;
die 'invalid value' if($$value ne 1);
}
);
eval {
Validate->new(x => 2);
};
::like($@, qr{invalid value}, 'should validate');
::isa_ok(Validate->new(x => 1), 'Validate');
}
( run in 0.296 second using v1.01-cache-2.11-cpan-4d50c553e7e )