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' ;
sub is_valid_password {
my ($self, $password) = @_;
!! ($self->password eq sha1_hex($password));
}
##################
my $user = User->new(id => 1, name => 'Scott', email => 'scott@email.com', password => '1234567');
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
=head2 METHODS
=over
=item new
=cut
sub new {
my $class = shift;
unshift @_, $class;
bless {&initialise}, $class;
}
=item initialise
Initialises attribute
=cut
{
my %supported_type = (
'$' => 'Scalar',
'@' => 'Array',
'%' => 'Hash',
'&' => 'Code',
);
sub initialise {
my ($class, %args) = @_;
foreach my $k (keys %args) {
confess "unknown attribute $k"
unless Abstract::Meta::Attribute->can($k);
}
my $name = $args{name} or confess "name is requried";
my $storage_type = $args{storage_type} = $args{transistent} ? 'Hash' : $args{storage_type} || '';
my $attribute_index = 0;
if($storage_type eq 'Array') {
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
$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;
}
}
=item name
Returns attribute name
=cut
sub name { shift()->{'$.name'} }
=item class
Attribute's class name.
=cut
sub class { shift()->{'$.class'} }
=item storage_key
Returns storage attribute key in object
=cut
sub storage_key { shift()->{'$.storage_key'} }
=item perl_type
Returns attribute type, Scalar, Hash, Array, Code
=cut
sub perl_type { shift()->{'$.perl_type'} }
=item accessor
Returns accessor name
=cut
sub accessor { shift()->{'$.accessor'} }
=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'} }
=item storage_type
Hash|Array
=cut
sub storage_type { shift()->{'$.storage_type'} ||= 'Hash' }
=item transistent
If this flag is set, than storage of that attribte, will be force outside the object,
so you cant serialize that attribute,
It is especially useful when using callback, that cant be serialised (Storable dclone)
This option will generate cleanup and DESTORY methods.
=cut
sub transistent { shift()->{'$.transistent'} }
=item item_accessor
Returns name that will be used to construct the hash or array item accessor.
It will be used to retrieve or set array or hash item item
has '%.items' => (item_accessor => 'item');
...
my $item_ref = $obj->items;
$obj->item(x => 3);
my $value = $obj->item('y')'
=cut
sub item_accessor { shift()->{'$.item_accessor'} }
=item associated_class
Return name of the associated class.
=cut
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);
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
index_by => 'id',
item_accessor => 'detail',
);
my $obj = Class->
=cut
sub index_by { shift()->{'$.index_by'} }
=item the_other_end
Name of the asscessor/mutator on associated class to keep bideriectional association
This option will generate cleanup method.
=cut
sub the_other_end { shift()->{'$.the_other_end'} }
=item data_type_validation
Flag that turn on/off data type validation.
Data type validation happens when using association_class or Array or Hash data type
unless you explicitly disable it by seting data_type_validation => 0.
=cut
sub data_type_validation { shift()->{'$.data_type_validation'} }
=item on_read
Returns code reference that will be replace data read routine
has '%.attrs.' => (
item_accessor => 'attr'
on_read => sub {
my ($self, $attribute, $scope, $key) = @_;
my $values = $attribute->get_values($self);
if ($scope eq 'accessor') {
return $values;
} else {
return $values->{$key};
}
},
);
has '@.array_attrs.' => (
item_accessor => 'array_item'
on_read => sub {
my ($self, $attribute, $scope, $index) = @_;
my $values = $attribute->get_values($self);
if ($scope eq 'accessor') {
return $values;
} else {
return $values->[$index];
}
},
);
=cut
sub on_read { shift()->{'&.on_read'} }
=item set_on_read
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_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
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;
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
has '$.attr1' => (default => 0);
=head2 methods
=over
=item generate_scalar_accessor_method
=cut
sub generate_scalar_accessor_method {
my $attr = shift;
my $mutator = $attr->mutator;
my $storage_key = $attr->storage_key;
my $transistent = $attr->transistent;
my $on_read = $attr->on_read;
my $array_storage_type = $attr->storage_type eq 'Array';
$array_storage_type ?
($transistent ? sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read
? $on_read ->($self, $attr, 'accessor')
: get_attribute($self, $storage_key);
$result;
}
: (
$on_read ?
sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read
? $on_read ->($self, $attr, 'accessor')
: $self->[$storage_key];
$result;
} :
sub {
my ($self, @args) = @_;
$self->$mutator(@args) if @args >= 1;
$self->[$storage_key];
}
)
)
:
sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read
? $on_read ->($self, $attr, 'accessor')
: $transistent ? get_attribute($self, $storage_key) : $self->{$storage_key};
$result;
};
}
=item generate_code_accessor_method
=cut
sub generate_code_accessor_method {
my $attr = shift;
$attr->generate_scalar_accessor_method;
}
=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 {
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;
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
if ($transistent) {
set_attribute($self, $storage_key, $value);
} else {
$self->[$storage_key] = $value;
}
$self;
}
:
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;
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
}
$self;
};
}
=item index_association_data
=cut
sub index_association_data {
my ($data, $attr_name, $index) = @_;
return $data if ref($data) eq 'HASH';
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') {
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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 %pending_association;
=item start_association_process
Start association process (to avoid infinitive look of associating the others ends)
Takes obj reference.
=cut
sub start_association_process {
my ($self) = @_;
$pending_association{$self} = 1;
}
=item has_pending_association
Returns true is object is during association process.
=cut
sub has_pending_association {
my ($self) = @_;
$pending_association{$self};
}
=item end_association_process
Compleetes association process.
=cut
sub end_association_process {
my ($self) = @_;
delete $pending_association{$self};
}
}
=item associate_the_other_end
Associate current object reference to the the other end associated class.
TODO
=cut
sub associate_the_other_end {
my ($attr, $self, $value) = @_;
my $the_other_end = $attr->the_other_end;
my $name = $attr->name;
return if ! $the_other_end || has_pending_association($self);
my $associated_class = $attr->associated_class;
my $the_other_end_attribute = $associated_class->meta->attribute($the_other_end);
confess "missing other end attribute on ". ref($value) . "::" . $the_other_end
unless $the_other_end_attribute;
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
end_association_process($value);
die $@ if $@;
}
=item associate_scalar_as_the_other_end
=cut
sub associate_scalar_as_the_other_end {
my ($attr, $self, $value) = @_;
my $the_other_end = $attr->the_other_end;
$value->$the_other_end($self);
}
=item associate_hash_as_the_other_end
=cut
sub associate_hash_as_the_other_end {
my ($attr, $self, $value) = @_;
my $the_other_end = $attr->the_other_end;
my $associated_class = $attr->associated_class;
my $the_other_end_attribute = $associated_class->meta->attribute($the_other_end);
my $item_accessor = $the_other_end_attribute->item_accessor;
my $index_by = $the_other_end_attribute->index_by;
if ($index_by) {
$value->$item_accessor($self->$index_by, $self);
} else {
$value->$item_accessor($self . "", $self);
}
}
=item associate_array_as_the_other_end
=cut
sub associate_array_as_the_other_end {
my ($attr, $self, $value) = @_;
my $the_other_end = $attr->the_other_end;
my $associated_class = $attr->associated_class;
my $the_other_end_attribute = $associated_class->meta->attribute($the_other_end);
my $other_end_accessor = $the_other_end_attribute->accessor;
my $setter = "push_${other_end_accessor}";
$value->$setter($self);
}
=item deassociate
Deassociates assoication values
=cut
sub deassociate {
my ($attr, $self) = @_;
my $transistent = $attr->transistent;
my $storage_key = $attr->storage_key;
my $array_storage_type = $attr->storage_type eq 'Array';
my $value = ($transistent ? get_attribute($self, $storage_key) : ($array_storage_type ? $self->[$storage_key] : $self->{$storage_key})) or return;
my $the_other_end = $attr->the_other_end;
return if ! $the_other_end || has_pending_association($value);
start_association_process($self);
my $associated_class = $attr->associated_class;
my $the_other_end_attribute = $associated_class->meta->attribute($the_other_end);
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
$the_other_end_attribute->$deassociation_call($self, $value);
}
end_association_process($self);
}
=item deassociate_scalar_as_the_other_end
=cut
sub deassociate_scalar_as_the_other_end {
my ($attr, $self, $the_other_end_obj) = @_;
$the_other_end_obj or return;
my $accessor = $attr->accessor;
$the_other_end_obj->$accessor(undef);
undef;
}
=item deassociate_hash_as_the_other_end
=cut
sub deassociate_hash_as_the_other_end {
my ($attr, $self, $the_other_end_obj) = @_;
my $accessor = $attr->accessor;
my $value = $the_other_end_obj->$accessor;
my $index_by = $attr->index_by;
if ($index_by) {
delete $value->{$self->$index_by} if exists($value->{$self->$index_by});
} else {
my @keys = keys %$value;
foreach my $k (@keys) {
if ($value->{$k} eq $self) {
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
}
}
undef;
}
=item deassociate_array_as_the_other_end
=cut
sub deassociate_array_as_the_other_end {
my ($attr, $self, $the_other_end_obj) = @_;
my $accessor = $attr->accessor;
my $value = $the_other_end_obj->$accessor;
for my $i (0 .. $#{$value}) {
if ($value->[$i] eq $self) {
splice @$value, $i--, 1;
}
}
undef;
}
=item generate_scalar_mutator_method
=cut
sub generate_scalar_mutator_method {
shift()->generate_mutator_method;
}
=item generate_code_mutator_method
=cut
sub generate_code_mutator_method {
shift()->generate_mutator_method;
}
=item generate_array_accessor_method
=cut
sub generate_array_accessor_method {
my $attr = shift;
my $mutator = $attr->mutator;
my $storage_key = $attr->storage_key;
my $transistent = $attr->transistent;
my $on_read = $attr->on_read;
my $array_storage_type = $attr->storage_type eq 'Array';
$array_storage_type ?
sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read ? $on_read->($self, $attr, 'accessor')
: ($transistent ? get_attribute($self, $storage_key) : ($self->[$storage_key] ||= []));
wantarray ? @$result : $result;
}
:
sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read ? $on_read->($self, $attr, 'accessor')
: ($transistent ? get_attribute($self, $storage_key) : ($self->{$storage_key} ||= []));
wantarray ? @$result : $result;
};
}
=item generate_array_mutator_method
=cut
sub generate_array_mutator_method {
shift()->generate_mutator_method;
}
=item generate_hash_accessor_method
=cut
sub generate_hash_accessor_method {
my $attr = shift;
my $mutator = $attr->mutator;
my $storage_key = $attr->storage_key;
my $transistent = $attr->transistent;
my $on_read = $attr->on_read;
my $array_storage_type = $attr->storage_type eq 'Array';
$attr->associated_class
? $attr->generate_to_many_accessor_method
: ($array_storage_type ?
sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read
? $on_read->($self, $attr, 'accessor')
: ($transistent ? get_attribute($self, $storage_key) : ($self->[$storage_key] ||= {}));
wantarray ? %$result : $result;
}
: sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read
? $on_read->($self, $attr, 'accessor')
: ($transistent ? get_attribute($self, $storage_key) : ($self->{$storage_key} ||= {}));
wantarray ? %$result : $result;
});
}
=item generate_to_many_accessor_method
=cut
sub generate_to_many_accessor_method {
my $attr = shift;
my $mutator = $attr->mutator;
my $storage_key = $attr->storage_key;
my $transistent = $attr->transistent;
my $on_read = $attr->on_read;
my $array_storage_type = $attr->storage_type eq 'Array';
$array_storage_type ?
sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read
? $on_read->($self, $attr, 'accessor')
: ($transistent ? get_attribute($self, $storage_key) : ($self->[$storage_key] ||= {}));
wantarray ? %$result : $result;
}
:
sub {
my ($self, @args) = @_;
$self->$mutator(@args) if scalar(@args) >= 1;
my $result = $on_read
? $on_read->($self, $attr, 'accessor')
: ($transistent ? get_attribute($self, $storage_key) : ($self->{$storage_key} ||= {}));
wantarray ? %$result : $result;
};
}
=item generate_hash_mutator_method
=cut
sub generate_hash_mutator_method {
shift()->generate_mutator_method;
}
=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
sub generate_scalar_reset_method {
my $attr = shift;
my $mutator = $attr->mutator;
my $index_by = $attr->index_by;
sub {
my ($self, ) = @_;
$self->$mutator(undef);
};
}
=item generate_scalar_has_method
=cut
sub generate_scalar_has_method {
my $attr = shift;
sub {
my ($self, ) = @_;
!! $attr->get_value($self);
};
}
=item generate_hash_reset_method
=cut
sub generate_hash_reset_method {
my $attr = shift;
my $mutator = $attr->mutator;
my $index_by = $attr->index_by;
sub {
my ($self, ) = @_;
$self->$mutator({});
};
}
=item generate_hash_has_method
=cut
sub generate_hash_has_method {
my $attr = shift;
sub {
my ($self, ) = @_;
my $value = $attr->get_value($self);
!! ($value && keys %$value);
};
}
=item generate_array_reset_method
=cut
sub generate_array_reset_method {
my $attr = shift;
my $mutator = $attr->mutator;
my $index_by = $attr->index_by;
sub {
my ($self, ) = @_;
$self->$mutator([]);
};
}
=item generate_array_has_method
=cut
sub generate_array_has_method {
my $attr = shift;
sub {
my ($self, ) = @_;
my $value = $attr->get_value($self);
!! ($value && @$value);
};
}
=item generate_hash_remove_method
=cut
#TODO add on_remove trigger
sub generate_hash_remove_method {
my $attr = shift;
my $accessor = $attr->accessor;
my $item_accessor = $attr->item_accessor;
my $the_other_end = $attr->the_other_end;
my $meta = Abstract::Meta::Class::meta_class($attr->associated_class);
my $reflective_attribute = $the_other_end && $meta ? $meta->attribute($the_other_end) : undef;
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 && ref($value) ? $value->$index_by : $value . "");
$attr->deassociate($self);
$reflective_attribute->set_value($hash_ref->{$key}, undef)
if $reflective_attribute;
delete $hash_ref->{$key};
}
$self;
};
}
=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
sub generate_array_push_method {
my $attr = shift;
my $accesor = $attr->accessor;
sub {
my $self = shift;
my $array_ref = $self->$accesor();
push @$array_ref, @_;
};
}
=item generate_array_pop_method
=cut
sub generate_array_pop_method {
my $attr = shift;
my $accesor = $attr->accessor;
sub {
my $self = shift;
my $array_ref = $self->$accesor();
pop @$array_ref;
};
}
=item generate_array_shift_method
=cut
sub generate_array_shift_method {
my $attr = shift;
my $accesor = $attr->accessor;
sub {
my $self = shift;
my $array_ref= $self->$accesor();
shift @$array_ref;
};
}
=item generate_array_unshift_method
=cut
sub generate_array_unshift_method {
my $attr = shift;
my $accesor = $attr->accessor;
sub {
my $self = shift;
my $array_ref = $self->$accesor();
unshift @$array_ref, @_;
};
}
=item generate_array_count_method
=cut
sub generate_array_count_method {
my $attr = shift;
my $accesor = $attr->accessor;
sub {
my $self = shift;
my $array_ref = $self->$accesor();
scalar @$array_ref;
};
}
=item generate_array_add_method
=cut
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
#TODO add on_remove trigger
sub generate_array_remove_method {
my $attr = shift;
my $accesor = $attr->accessor;
my $accessor = $attr->accessor;
my $the_other_end = $attr->the_other_end;
my $meta = Abstract::Meta::Class::meta_class($attr->associated_class);
my $reflective_attribute = $the_other_end && $meta ? $meta->attribute($the_other_end) : undef;
sub {
my ($self, @values) = @_;
my $array_ref = $self->$accesor();
foreach my $value(@values) {
for my $i (0 .. $#{$array_ref}) {
if ($array_ref->[$i] && $array_ref->[$i] eq $value) {
$reflective_attribute->set_value($value, undef)
if $reflective_attribute;
splice @$array_ref, $i--, 1;
}
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
};
}
=item generate
Returns code reference.
=cut
sub generate {
my ($self, $method_name) = @_;
my $call = "generate_" . lc($self->perl_type) . "_${method_name}_method";
$self->$call;
}
=item set_value
Sets value for attribute
=cut
sub set_value {
my ($attr, $self, $value) = @_;
my $array_storage_type = $attr->storage_type eq 'Array';
my $storage_key = $attr->storage_key;
my $transistent = $attr->transistent;
if($transistent) {
set_attribute($self, $storage_key, $value);
} elsif($array_storage_type) {
$self->[$storage_key] = $value;
} else {
$self->{$storage_key} = $value;
}
}
=item get_value
Returns value for attribute
=cut
sub get_value {
my ($attr, $self) = @_;
my $storage_key = $attr->storage_key;
my $transistent = $attr->transistent;
my $array_storage_type = $attr->storage_type eq 'Array';
if ($transistent) {
return get_attribute($self, $storage_key);
} elsif($array_storage_type) {
$self->[$storage_key];
} else {
return $self->{$storage_key};
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
{
my %storage;
=item get_attribute
Return object's attribute value
=cut
sub get_attribute {
my ($self, $key) = @_;
my $object = $storage{$self} ||= {};
return $object->{$key};
}
=item set_attribute
Sets for passed in object attribue's value
=cut
sub set_attribute {
my ($self, $key, $value) = @_;
my $object = $storage{$self} ||= {};
$object->{$key} = $value;
}
=item delete_object
Deletes passed in object's attribute
=cut
sub delete_object {
my ($self) = @_;
delete $storage{$self};
}
}
1;
__END__
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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);
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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);
lib/Abstract/Meta/Class.pm view on Meta::CPAN
- 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)
#scope can be: item_accessor, accessor
...
#return requested value
},
item_accessor => 'y_item'
);
use Triggers;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
package Class;
use Abstract::Meta::Class ':all';
has '%.attrs' => (item_accessor => 'attr');
my $attr = DynamicInterceptor->meta->attribute('attrs');
my $obj = DynamicInterceptor->new(attrs => {a => 1, b => 2});
my $a = $obj->attr('a');
my %hook_access_log;
my $ncode_ref = sub {
my ($self, $attribute, $scope, $key) = @_;
#do some stuff
# or
if ($scope eq 'accessor') {
return $values;
} else {
return $values->{$key};
}
};
lib/Abstract/Meta/Class.pm view on Meta::CPAN
use Abstract::Meta::Class ':all';
has '$.attr1';
abstract => 'method1';
package Class;
use base 'BaseClass';
sub method1 {};
use Class;
my $obj = BaseClass->new;
# abstract classes
package InterfaceA;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
abstract_class;
abstract => 'method1';
abstract => 'method2';
package ClassA;
use base 'InterfaceA';
sub method1 {};
sub method2 {};
use Class;
my $classA = Class->new;
package Class;
use Abstract::Meta::Class ':all';
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
sub install_cleanup {
my ($self) = @_;
my $attributes;
return if $self->has_cleanup_method;
add_method($self->associated_class, 'cleanup' , sub {
my $this = shift;
my $has_transistent;
my $attributes ||= $self ? $self->all_attributes : [];
for my $attribute (@$attributes) {
$attribute or next;
$has_transistent = 1 if($attribute->transistent);
if($attribute->the_other_end) {
$attribute->deassociate($this);
my $accessor = "set_" . $attribute->accessor;
$this->$accessor(undef);
lib/Abstract/Meta/Class.pm view on Meta::CPAN
$self->set_cleanup_method(1);
}
=item install_destructor
Install destructor method
=cut
sub install_destructor {
my ($self) = @_;
return if $self->has_destory_method;
add_method($self->associated_class, 'DESTROY' , sub {
my $this = shift;
$this->cleanup;
$this;
});
$self->set_destroy_method(1);
}
=item install_constructor
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.
=cut
{
sub apply_contructor_parameters {
my ($self, @args) = @_;
my $mutator;
my $class = ref($self);
eval {
for (my $i = 0; $i < $#args; $i += 2) {
$mutator = "set_" . $args[$i];
$self->$mutator($args[$i + 1]);
}
};
lib/Abstract/Meta/Class.pm view on Meta::CPAN
my $initialise = $self->can($meta->initialise_method);
$initialise->($self) if $initialise;
$self;
}
}
=item meta
=cut
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
sub all_attributes {
my $self = shift;
if(my @super_classes = $self->super_classes) {
my %attributes;
foreach my $super (@super_classes) {
my $meta_class = meta_class($super) or next;
$attributes{$_->name} = $_ for @{$meta_class->all_attributes};
}
$attributes{$_->name} = $_ for @{$self->attributes};
return [values %attributes];
}
$self->attributes;
}
=item attribute
Returns attribute object
=cut
sub attribute {
my ($self, $name) = @_;
my $attributes = $self->all_attributes;
my @result = (grep {$_->accessor eq $name} @$attributes);
@result ? $result[0] : undef;
}
=item super_classes
=cut
sub super_classes {
my $self = shift;
no strict 'refs';
my $class = $self->associated_class;
@{"${class}::ISA"};
}
{
my %meta;
=item install_meta_class
Adds class to meta repository.
=cut
sub install_meta_class {
my ($class) = @_;
$meta{$class} = __PACKAGE__->new(
associated_class => $class,
attributes => [],
initialise_method => 'initialise'
);
add_method($class, 'meta', sub{$meta{$class}});
}
=item meta_class
Returns meta class object for passed in class name.
=cut
sub meta_class {
my ($class) = @_;
install_meta_class($class)unless $meta{$class};
$meta{$class};
}
}
=item add_attribute
=cut
sub add_attribute {
my ($self, $attribute) = @_;
$self->install_attribute_methods($attribute);
push @{$self->attributes}, $attribute;
}
=item attribute_class
Returns meta attribute class
=cut
sub attribute_class { 'Abstract::Meta::Attribute' }
=item has
Creates a meta attribute.
Takes attribute name, and the following attribute options:
see also L<Abstract::Meta::Attribute>
=cut
sub has {
my $name = shift;
my $package = caller();
my $meta_class = meta_class($package);
my $attribute = $meta_class->attribute_class->new(name => $name, @_, class => $package, storage_type => $meta_class->storage_type);
$meta_class->add_attribute($attribute);
$meta_class->install_cleanup
if($attribute->transistent || $attribute->index_by);
$meta_class->install_destructor
if $attribute->transistent;
$attribute;
}
=item storage_type
Sets storage type for the attributes.
allowed values are Array/Hash
=cut
sub storage_type {
my ($param) = @_;
return $param->{'$.storage_type'} ||= 'Hash'
if (ref($param));
my $type = $param;
confess "unknown storage type $type - should be Array or Hash"
unless($type =~ /Array|Hash/);
my $package = caller();
my $meta_class = meta_class($package);
$meta_class->{'$.storage_type'} = $type;
remove_method($meta_class->associated_class, 'new');
lib/Abstract/Meta/Class.pm view on Meta::CPAN
}
=item abstract
Creates an abstract method
=cut
sub abstract {
my $name = shift;
my $package = caller();
my $meta_class = meta_class($package);
$meta_class->install_abstract_methods($name);
}
=item abstract_class
Creates an abstract method
=cut
sub abstract_class {
my $name = shift;
my $package = caller();
my $meta_class = meta_class($package);
$meta_class->set_abstract(1);
no warnings 'redefine';
no strict 'refs';
*{"${package}::new"} = sub {
confess "Can't instantiate abstract class " . $package;
};
}
=item install_abstract_methods
=cut
sub install_abstract_methods {
my ($self, $method_name) = @_;
add_method($self->associated_class, $method_name, sub {
confess $method_name . " is an abstract method";
});
}
=item install_attribute_methods
Installs attribute methods.
=cut
sub install_attribute_methods {
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);
lib/Abstract/Meta/Class.pm view on Meta::CPAN
}
=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
t/meta/array_storage/attribute.t view on Meta::CPAN
{
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');
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'
);
t/meta/array_storage/attribute.t view on Meta::CPAN
}
{
package DynamicInterceptor;
use Abstract::Meta::Class ':all'; storage_type 'Array';
my %access_log;
has '%.attrs' => (
on_read => sub {
my ($self, $attribute, $scope, $key) = @_;
my $values = $attribute->get_value($self);
$access_log{$scope}++;
if ($scope eq 'accessor') {
return $values;
} else {
return $values->{$key};
}
},
item_accessor => 'attr'
);
my $attr = DynamicInterceptor->meta->attribute('attrs');
my $code_ref = $attr->on_read;
my $obj = DynamicInterceptor->new(attrs => {a => 1, b => 2});
my $a = $obj->attr('a');
my %hook_access_log;
my $ncode_ref = sub {
my ($self, $attribute, $scope, $key) = @_;
$hook_access_log{$scope}++;
#do some stuff
$code_ref->($self, $attribute, $scope, $key);
};
$attr->set_on_read($ncode_ref);
my $b = $obj->attr('b');
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/array_storage/class.t view on Meta::CPAN
my $custom = Custom->new;
isa_ok($custom, 'Custom');
{
package Initialise;
use Abstract::Meta::Class ':all';
storage_type 'Array';
has '$.attr';
Initialise->meta->set_initialise_method('init');;
sub init {
my ($self) = @_;
$self->set_attr('initialise ...');
}
}
my $init = Initialise->new;
is($init->attr,'initialise ...', 'should have initialise ...');
{
t/meta/attribute.t view on Meta::CPAN
{
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');
{
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'
);
t/meta/attribute.t view on Meta::CPAN
}
{
package DynamicInterceptor;
use Abstract::Meta::Class ':all';
my %access_log;
has '%.attrs' => (
on_read => sub {
my ($self, $attribute, $scope, $key) = @_;
my $values = $attribute->get_value($self);
$access_log{$scope}++;
if ($scope eq 'accessor') {
return $values;
} else {
return $values->{$key};
}
},
item_accessor => 'attr'
);
my $attr = DynamicInterceptor->meta->attribute('attrs');
my $code_ref = $attr->on_read;
my $obj = DynamicInterceptor->new(attrs => {a => 1, b => 2});
my $a = $obj->attr('a');
my %hook_access_log;
my $ncode_ref = sub {
my ($self, $attribute, $scope, $key) = @_;
$hook_access_log{$scope}++;
#do some stuff
$code_ref->($self, $attribute, $scope, $key);
};
$attr->set_on_read($ncode_ref);
my $b = $obj->attr('b');
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');
}
t/meta/class.t view on Meta::CPAN
my $custom = Custom->new;
isa_ok($custom, 'Custom');
{
package Initialise;
use Abstract::Meta::Class ':all';
has '$.attr';
Initialise->meta->set_initialise_method('init');;
sub init {
my ($self) = @_;
$self->set_attr('initialise ...');
}
}
my $init = Initialise->new;
is($init->attr,'initialise ...', 'should have initialise ...');
{
( run in 0.284 second using v1.01-cache-2.11-cpan-a5abf4f5562 )