Abstract-Meta-Class
view release on metacpan or search on metacpan
examples/example1.pl view on Meta::CPAN
use Digest::SHA1 qw(sha1_hex);
use Abstract::Meta::Class ':all';
has '$.id';
has '$.name';
has '$.password' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
$$value_ref = sha1_hex($$value_ref);
$self;
}
);
has '$.email' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
die "invalid email format:" . $$value_ref
unless $$value_ref =~ m/^<?[^@<>]+@[^@.<>]+(?:\.[^@.<>]+)+>?$/;
$self;
}
);
has '$.address';
has '%.roles' ;
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
=cut
sub set_on_read {
my ($attr, $value) = @_;
$attr->{'&.on_read'} = $value;
my $meta= $attr->class->meta;
$meta->install_attribute_methods($attr, 1);
}
=item on_change
Code reference that will be executed when data is set,
Takes reference to the variable to be set.
=cut
sub on_change { shift()->{'&.on_change'} }
=item set_on_change
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
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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 {
my ($self, $value) = @_;
if (! defined $value && defined $default) {
if (ref($default) eq 'CODE') {
$value = $default->($self, $attr);
} else {
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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;
}
$self;
}
:
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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;
}
$self;
};
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
}
=item generate_hash_item_accessor_method
=cut
sub generate_hash_item_accessor_method {
my $attr = shift;
my $accesor = $attr->accessor;
my $on_change = $attr->on_change;
my $on_read = $attr->on_read;
sub {
my $self = shift;
my ($key, $value) = (@_);
my $hash_ref = $self->$accesor();
if(defined $value) {
$on_change->($self, $attr, 'item_accessor', \$value, $key) or return $hash_ref->{$key}
if ($on_change);
$hash_ref->{$key} = $value;
}
$on_read ? $on_read->($self, $attr, 'item_accessor', $key) : $hash_ref->{$key};
};
}
=item generate_hash_add_method
=cut
sub generate_hash_add_method {
my $attr = shift;
my $accessor = $attr->accessor;
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
=cut
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=item generate_array_item_accessor_method
=cut
sub generate_array_item_accessor_method {
my $attr = shift;
my $accesor = $attr->accessor;
my $on_change = $attr->on_change;
my $on_read = $attr->on_read;
sub {
my $self = shift;
my ($index, $value) = (@_);
my $hash_ref = $self->$accesor();
if (defined $value) {
$on_change->($self, $attr, 'item_accessor', \$value, $index) or return $hash_ref->[$index]
if ($on_change);
$hash_ref->[$index] = $value;
}
$on_read ? $on_read->($self, $attr, 'item_accessor', $index) : $hash_ref->[$index];
};
}
=item generate_array_push_method
=cut
lib/Abstract/Meta/Class.pm view on Meta::CPAN
- 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';
has '@.y' => (
on_change => sub {
my ($self, $attribute_name, $scope, $value_ref, $index) = @_;
# scope -> mutator, item_accessor
... do some stuff
# process further in standard way by returning true
$self;
},
# replaces standard read
on_read => sub {
my ($self, $attr_name, $scope, $index)
t/meta/array_storage/attribute.t view on Meta::CPAN
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');
{
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' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
$x_value = $$value_ref;
$x_attribute = $attribute;
$x_scope = $scope;
$self;
},
);
my $y_value;
my $y_attribute;
my $y_scope;
my $y_index;
my $y_attr = has '@.y' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref, $index) = @_;
$y_value = $$value_ref;
$y_attribute = $attribute;
$y_scope = $scope;
$y_index = $index;
$self;
},
item_accessor => 'y_item'
);
my $z_value;
my $z_attribute;
my $z_scope;
my $z_key;
my $z_attr = has '%.z' => (
on_change => sub {
my ($self, $attribute, $scope, $value, $key) = @_;
$z_value = $$value;
$z_attribute = $attribute;
$z_scope = $scope;
$z_key = $key;
$self;
},
item_accessor => 'z_value'
);
my $on_change = Dummy::OnChange->new;
::isa_ok($on_change, 'Dummy::OnChange', 'should have a Dummy::OnChange instance');
$on_change->x(100);
::is_deeply([100, 'mutator', $x_attr], [$x_value, $x_scope, $x_attribute], 'should trigger on change for scalar');
$on_change->y(['1', '2', '3']);
::is_deeply([['1', '2', '3'], 'mutator', $y_attr], [$y_value, $y_scope, $y_attribute], 'should trigger on change for array');
$on_change->y_item(1, 20);
::is_deeply([20, 'item_accessor', $y_attr, 1], [$y_value, $y_scope, $y_attribute, $y_index], 'should trigger on change for array by item accessor');
$on_change->z({ a => '1'});
::is_deeply([{ a => '1'}, 'mutator', $z_attr], [$z_value, $z_scope, $z_attribute], 'should trigger on change for hash');
$on_change->z_value( b => '10');
::is_deeply([10, 'item_accessor', $z_attr, 'b'], [$z_value, $z_scope, $z_attribute, $z_key], 'should trigger on change for hash');
::is_deeply({ a => '1', b => 10}, {$on_change->z}, 'should have modyfied hash');
$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');
t/meta/attribute.t view on Meta::CPAN
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');
{
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' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
$x_value = $$value_ref;
$x_attribute = $attribute;
$x_scope = $scope;
$self;
},
);
my $y_value;
my $y_attribute;
my $y_scope;
my $y_index;
my $y_attr = has '@.y' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref, $index) = @_;
$y_value = $$value_ref;
$y_attribute = $attribute;
$y_scope = $scope;
$y_index = $index;
$self;
},
item_accessor => 'y_item'
);
my $z_value;
my $z_attribute;
my $z_scope;
my $z_key;
my $z_attr = has '%.z' => (
on_change => sub {
my ($self, $attribute, $scope, $value, $key) = @_;
$z_value = $$value;
$z_attribute = $attribute;
$z_scope = $scope;
$z_key = $key;
$self;
},
item_accessor => 'z_value'
);
my $on_change = Dummy::OnChange->new;
::isa_ok($on_change, 'Dummy::OnChange', 'should have a Dummy::OnChange instance');
$on_change->x(100);
::is_deeply([100, 'mutator', $x_attr], [$x_value, $x_scope, $x_attribute], 'should trigger on change for scalar');
$on_change->y(['1', '2', '3']);
::is_deeply([['1', '2', '3'], 'mutator', $y_attr], [$y_value, $y_scope, $y_attribute], 'should trigger on change for array');
$on_change->y_item(1, 20);
::is_deeply([20, 'item_accessor', $y_attr, 1], [$y_value, $y_scope, $y_attribute, $y_index], 'should trigger on change for array by item accessor');
$on_change->z({ a => '1'});
::is_deeply([{ a => '1'}, 'mutator', $z_attr], [$z_value, $z_scope, $z_attribute], 'should trigger on change for hash');
$on_change->z_value( b => '10');
::is_deeply([10, 'item_accessor', $z_attr, 'b'], [$z_value, $z_scope, $z_attribute, $z_key], 'should trigger on change for hash');
::is_deeply({ a => '1', b => 10}, {$on_change->z}, 'should have modyfied hash');
$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');
( run in 0.305 second using v1.01-cache-2.11-cpan-5dc5da66d9d )