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
--- #YAML:1.0
name: Abstract-Meta-Class
version: 0.11
author:
- 'Adrian Witas <adrian@webapp.strefa.pl>'
abstract: Simple meta object protocol implementation.
license: perl
resources:
license: http://dev.perl.org/licenses/
generated_by: ExtUtils::MakeMaker version 6.3201
distribution_type: module
requires:
perl: 5.6.1
Carp: 0
Test::More: 0
Test::Pod: 0
Test::Pod::Coverage: 0
tests: t/* t/meta/*.t
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.2.html
version: 1.2
Abstract/Meta/Class version 0.11
===========================
Simple meta object protocol implementation.
INSTALLATION
To install this module type the following:
perl Makefile.PL
make
make test
make install
DEPENDENCIES
This module requires these other modules and libraries:
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
}
=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') {
my $meta_class= Abstract::Meta::Class::meta_class($args{class});
$attribute_index = $#{$meta_class->all_attributes} + 1;
}
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{$_}}
(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
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
=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'} }
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
=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
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
=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) = @_;
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
$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
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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 ?
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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;
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;
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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;
}
}
} else {
confess "attribute $accessor is required"
if $required && ! defined $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";
}
=item pending_transation
=cut
{ my %pending_association;
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
confess "missing other end attribute on ". ref($value) . "::" . $the_other_end
unless $the_other_end_attribute;
confess "invalid definition for " . ref($self) ."::". $name
. " - associatied class not defined on " . ref($value) ."::" . $the_other_end
unless $the_other_end_attribute->associated_class;
start_association_process($value);
eval {
my $association_call = 'associate_' . lc($the_other_end_attribute->perl_type) . '_as_the_other_end';
$attr->$association_call($self, $value);
};
end_association_process($value);
die $@ if $@;
}
=item associate_scalar_as_the_other_end
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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);
my $deassociation_call = 'deassociate_' . lc($the_other_end_attribute->perl_type) . '_as_the_other_end';
if(ref($value) eq 'ARRAY') {
$the_other_end_attribute->$deassociation_call($self, $_) for @$value;
} elsif(ref($value) eq 'HASH') {
$the_other_end_attribute->$deassociation_call($self, $value->{$_}) for(keys %$value);
} else {
$the_other_end_attribute->$deassociation_call($self, $value);
}
end_association_process($self);
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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) = @_;
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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) = @_;
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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 {
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};
}
}
{
my %storage;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
use strict;
use warnings;
use base 'Exporter';
use vars qw(@EXPORT_OK %EXPORT_TAGS);
use Carp 'confess';
use vars qw($VERSION);
$VERSION = 0.11;
@EXPORT_OK = qw(has new apply_contructor_parameter install_meta_class abstract abstract_class storage_type);
%EXPORT_TAGS = (all => \@EXPORT_OK, has => ['has', 'install_meta_class', 'abstract', 'abstract_class', 'storage_type']);
use Abstract::Meta::Attribute;
use Abstract::Meta::Attribute::Method;
=head1 NAME
Abstract::Meta::Class - Simple meta object protocol implementation.
=head1 SYNOPSIS
lib/Abstract/Meta/Class.pm view on Meta::CPAN
my $item_1 = $obj->attr3(1);
$obj->count_attrs3();
$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');
has '&.attr4' => (required => 1);
has '$.attr5';
has '$.attr6' => (default => sub { 'stuff' } , required => 1);
my $dummy = Dummy->new(
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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';
has '@.array' => (item_accessor => 'array_item');
use Dummy;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
$obj->count_array();
$obj->push_array(1);
my $x = $obj->array_item(0);
my $y = $obj->pop_array;
#NOTE scalar, array context sensitive
my $array_ref = $obj->array;
my @array = $obj->array;
=head2 item accessor method for complex types
While specyfing an array or a hash type of attribute then
you may specify item_accessor for get/set value by hash key or array index.
package Dummy;
use Abstract::Meta::Class ':all';
has '%.hash' => (item_accessor => 'hash_item');
use Dummy;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
my $obj = Dummy->new;
$obj->hash_item('key1', 'val1');
$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;
my $obj = Dummy->new(array => {}, hash => []) #dies incompatible types.
=head2 associations
This module handles different types of associations(to one, to many, to many ordered).
You may also use bidirectional association by using the_other_end option,
NOTE: When using the_other_end automatic association/deassociation happens,
celanup method is installed.
package Class;
use Abstract::Meta::Class ':all';
has '$.to_one' => (associated_class => 'AssociatedClass');
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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');
$meta_class->install_constructor();
}
=item abstract
Creates an abstract method
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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);
}
if (my $item_accessor = $attribute->item_accessor) {
add_method($self->associated_class, $item_accessor, $attribute->generate('item_accessor'), $remove_existing_method);
}
if (($perl_type eq 'Array' || $perl_type eq 'Hash') && $attribute->associated_class) {
add_method($self->associated_class, "add_${accessor}", $attribute->generate('add'), $remove_existing_method);
add_method($self->associated_class, "remove_${accessor}", $attribute->generate('remove'), $remove_existing_method);
}
if($attribute->associated_class) {
add_method($self->associated_class, "reset_${accessor}", $attribute->generate('reset'), $remove_existing_method);
add_method($self->associated_class, "has_${accessor}", $attribute->generate('has'), $remove_existing_method);
}
}
t/meta/array_storage/association.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 41;
{
package Class;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.to_one' => (associated_class => 'AssociatedClass');
has '@.ordered' => (associated_class => 'AssociatedClass');
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');
ok($obj->has_to_many, 'should have value');
$obj->reset_to_many;
ok(! $obj->has_to_many, 'should have reset value');
}
{
package ClassA;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.to_oneA' => (associated_class => 'AssociatedClassA', the_other_end => 'classAA' );
has '$.to_one' => (associated_class => 'AssociatedClassA', the_other_end => 'classA' );
has '@.ordered' => (associated_class => 'AssociatedClassA');
has '%.to_many' => (associated_class => 'AssociatedClassA', index_by => 'a', item_accessor => 'association');
}
{
package AssociatedClassA;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.a';
has '$.ordered_ClassA' => (associated_class => 'ClassA', the_other_end => 'ordered');
has '$.to_many_ClassA' => (associated_class => 'ClassA', the_other_end => 'to_many');
has '$.classAA';
my $a1 = AssociatedClassA->new(a => 1);
my $a2 = AssociatedClassA->new(a => 2);
;
eval { ClassA->new(to_oneA => $a1) };
::like($@, qr{invalid definition for ClassA::to_oneA - associatied class not defined on AssociatedClassA::classAA.+},
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]);
t/meta/array_storage/association.t view on Meta::CPAN
::is_deeply([sort @detail1], [sort @details[0 .. 1]], 'should have 2 details elements');
::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),
t/meta/array_storage/attribute.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 47;
{
package Dummy;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '$.x';
}
my $dummy = Dummy->new;
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;
use Abstract::Meta::Class ':all'; storage_type 'Array';
has '@.xs' => (item_accessor => 'x');
}
my $array = Dummy::Array->new(xs => [3, 2, 1]);
isa_ok($array, 'Dummy::Array', 'should have a Dummy::Array instance');
my $array_ref = $array->xs; # scalar context
is_deeply($array_ref, [3, 2, 1], 'should have xs attribute');
my @array = $array->xs; #list contect
is(@array, 3, 'should have 3 items');
is($array->x(0), 3, 'should have [0] value');
t/meta/array_storage/attribute.t view on Meta::CPAN
is($array->push_xs(0,7), 5, 'should extent array by push');
is($array->x(4), 7, 'should have the last extended item');
is($array->pop_xs, 7, 'should pop item');
is($array->unshift_xs(5, 6), 6, 'should extent array by unshift');
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');
t/meta/array_storage/attribute.t view on Meta::CPAN
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;
},
);
t/meta/array_storage/attribute.t view on Meta::CPAN
::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');
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');
t/meta/array_storage/attribute.t view on Meta::CPAN
$obj->cleanup;
::is($obj->t, undef, 'should not have value for t after cleanup method was called');
}
{
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;
t/meta/array_storage/attribute.t view on Meta::CPAN
$attr->set_on_read($ncode_ref);
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 {
});
$attr->set_on_validate(
sub {
my ($self, $attribute, $scope, $value) = @_;
die 'invalid value' if($$value ne 1);
}
);
eval {
t/meta/array_storage/class.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 7;
{
package SuperDummy;
use Abstract::Meta::Class ':all';
storage_type 'Array';
has '$.x' => (default => 'x value');
has '$.z' => (default => 'z value');
}
{
package SubDummy;
use base 'SuperDummy';
use Abstract::Meta::Class ':all';
storage_type 'Array';
has '$.y';
has '$.k';
}
my $subclass = SubDummy->new;
isa_ok($subclass,'SubDummy');
is($subclass->x, 'x value', 'should have x value');
{
package Custom;
use Abstract::Meta::Class ':has';
storage_type 'Array';
has '$.a';
Custom->meta->install_constructor;
# or your own contructor
}
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 ...');
{
package ClassA;
use Abstract::Meta::Class ':all';
storage_type 'Array';
has '$.z' => (default => 0);
abstract 'method1';
my $classA = ClassA->new;
::isa_ok($classA , 'ClassA');
eval {$classA->method1};
::like($@, qr{method1 is an abstract method}, 'catch an exception method1 is an abstract method');
abstract_class;
t/meta/association.t view on Meta::CPAN
}
{
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');
ok($obj->has_to_many, 'should have value');
t/meta/fix.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 6;
#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;
t/meta/fix.t view on Meta::CPAN
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');
( run in 3.547 seconds using v1.01-cache-2.11-cpan-2398b32b56e )