Abstract-Meta-Class
view release on metacpan or search on metacpan
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)
0.04 Sat May 24 2008
- Fix pod documentation.
- Storage key option fix
0.03 Mon May 05 2008
- Fix pod documentation.
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
&& ($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 '@') {
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
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
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
=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
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
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
} 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;
}
:
sub {
my ($self, $value) = @_;
if (! defined $value && defined $default) {
if (ref($default) eq 'CODE') {
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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;
};
}
=item index_association_data
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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 {
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
$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);
};
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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({});
};
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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([]);
};
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
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;
}
}
}
$self;
};
}
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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);
=head1 DESCRIPTION
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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
# or
if ($scope eq 'accessor') {
return $values;
} else {
return $values->{$key};
}
};
$attr->set_on_read($ncode_ref);
# from now it will apply to Class::attrs calls.
my $a = $obj->attr('a');
=head2 abstract methods/classes
package BaseClass;
use Abstract::Meta::Class ':all';
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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);
}
}
Abstract::Meta::Attribute::Method::delete_object($this) if $has_transistent;
});
$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
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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]);
}
};
if ($@) {
confess "unknown attribute " . ref($self) ."::" . $mutator
unless $self->can($mutator);
confess $@
}
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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'};}
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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 {
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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);
}
}
=item add_method
Adds code reference to the class symbol table.
Takes a class name, method name and CODE reference.
t/meta/array_storage/association.t view on Meta::CPAN
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');
t/meta/array_storage/association.t view on Meta::CPAN
my @details = (
Detail->new(id => 1),
Detail->new(id => 2),
Detail->new(id => 3),
);
my $master = Master->new(name => 'foo', details => [@details]);
::is($details[$_]->master, $master, "should associate by biderectional def") for (0 .. 2);
my $master2 = Master->new(name => 'foo2');
$details[-1]->set_master($master2);
my @detail1 = values %{$master->details};
my @details_ids1 = keys %{$master->details};
::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");
}
t/meta/array_storage/association.t view on Meta::CPAN
my @details = (
DetailA->new(id => 1),
DetailA->new(id => 2),
DetailA->new(id => 3),
);
my $master = MasterA->new(name => 'foo', details => [@details]);
::is($details[$_]->master, $master, "should associate by biderectional def") for (0 .. 2);
my $master2 = MasterA->new(name => 'foo2');
$details[-1]->set_master($master2);
my @detail1 = $master->details;
::is_deeply(\@detail1, [@details[0 .. 1]], 'should have 2 details elements');
::is($master2->detail(0), $details[-1], "should have details");
$master->cleanup;
::is($_->master, undef, 'should be deassociiated') for @details[0 .. 1];
t/meta/array_storage/attribute.t view on Meta::CPAN
{
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; };
t/meta/array_storage/attribute.t view on Meta::CPAN
$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);
t/meta/array_storage/attribute.t view on Meta::CPAN
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');
::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';
t/meta/array_storage/attribute.t view on Meta::CPAN
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 ...');
{
package ClassA;
use Abstract::Meta::Class ':all';
t/meta/association.t view on Meta::CPAN
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');
$obj->reset_to_many;
ok(! $obj->has_to_many, 'should have reset value');
}
{
package ClassA;
use Abstract::Meta::Class ':all';
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');
t/meta/association.t view on Meta::CPAN
my @details = (
Detail->new(id => 1),
Detail->new(id => 2),
Detail->new(id => 3),
);
my $master = Master->new(name => 'foo', details => [@details]);
::is($details[$_]->master, $master, "should associate by biderectional def") for (0 .. 2);
my $master2 = Master->new(name => 'foo2');
$details[-1]->set_master($master2);
my @detail1 = values %{$master->details};
my @details_ids1 = keys %{$master->details};
::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");
}
t/meta/association.t view on Meta::CPAN
my @details = (
DetailA->new(id => 1),
DetailA->new(id => 2),
DetailA->new(id => 3),
);
my $master = MasterA->new(name => 'foo', details => [@details]);
::is($details[$_]->master, $master, "should associate by biderectional def") for (0 .. 2);
my $master2 = MasterA->new(name => 'foo2');
$details[-1]->set_master($master2);
my @detail1 = $master->details;
::is_deeply(\@detail1, [@details[0 .. 1]], 'should have 2 details elements');
::is($master2->detail(0), $details[-1], "should have details");
$master->cleanup;
::is($_->master, undef, 'should be deassociiated') for @details[0 .. 1];
t/meta/attribute.t view on Meta::CPAN
{
package Dummy;
use Abstract::Meta::Class ':all';
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';
has '$.x' => (required => 1);
}
eval { Dummy::Required->new; };
t/meta/attribute.t view on Meta::CPAN
$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);
t/meta/attribute.t view on Meta::CPAN
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');
::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';
t/meta/attribute.t view on Meta::CPAN
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 ...');
{
package ClassA;
use Abstract::Meta::Class ':all';
( run in 1.291 second using v1.01-cache-2.11-cpan-49f99fa48dc )