Abstract-Meta-Class
view release on metacpan or search on metacpan
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
$VERSION = 0.04;
=head1 NAME
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
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
Returns attribute name
lib/Abstract/Meta/Attribute.pm view on Meta::CPAN
=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' }
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
Abstract::Meta::Attribute::Method - Method generator.
=head1 DESCRIPTION
Generates methods for attribute's definition.
=head1 SYNOPSIS
use Abstract::Meta::Class ':all';
has '$.attr1' => (default => 0);
=head2 methods
=over
=item generate_scalar_accessor_method
=cut
sub generate_scalar_accessor_method {
lib/Abstract/Meta/Attribute/Method.pm view on Meta::CPAN
=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;
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') {
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;
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') {
lib/Abstract/Meta/Class.pm view on Meta::CPAN
Abstract::Meta::Class - Simple meta object protocol implementation.
=head1 SYNOPSIS
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
lib/Abstract/Meta/Class.pm view on Meta::CPAN
=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(
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);
use Dummy;
my $obj = Dummy->new; #dies - att3 required
=head2 utility methods for an array type
While specyfing array type of attribute
lib/Abstract/Meta/Class.pm view on Meta::CPAN
$obj->hash_item('key2', 'val2');
my $val = $obj->hash_item('key1');
#NOTE scalar, array context sensitive
my $hash_ref = $obj->hash;
my %hash = $obj->hash;
=head2 perl types validation
Dy default all complex types are validated against its definition.
package Dummy;
use Abstract::Meta::Class ':all';
has '%.hash' => (item_accessor => 'hash_item');
has '@.array' => (item_accessor => 'array_item');
use Dummy;
lib/Abstract/Meta/Class.pm view on Meta::CPAN
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.
lib/Abstract/Meta/Class.pm view on Meta::CPAN
sub remove_method {
my ($class, $name) = @_;
no strict 'refs';
delete ${"${class}::"}{"$name"};
}
=item constructor_attributes
Returns a list of attributes that need be validated and all that have default value
=cut
sub constructor_attributes {
my ($self) = @_;
my $all_attributes = $self->all_attributes || [];
grep {$_->required || defined $_->default} @$all_attributes;
}
1
__END__
=back
=head1 SEE ALSO
t/meta/array_storage/attribute.t view on Meta::CPAN
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');
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
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';
t/meta/array_storage/class.t view on Meta::CPAN
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;
eval {ClassA->new;};
::like($@, qr{Can't instantiate abstract class}, 'can\'t instantiate abstract class');
t/meta/attribute.t view on Meta::CPAN
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';
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
t/meta/class.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 7;
{
package SuperDummy;
use Abstract::Meta::Class ':all';
has '$.x' => (default => 'x value');
has '$.z' => (default => 'z value');
}
{
package SubDummy;
use Abstract::Meta::Class ':all';
use base 'SuperDummy';
has '$.y';
has '$.k';
}
t/meta/class.t view on Meta::CPAN
}
my $init = Initialise->new;
is($init->attr,'initialise ...', 'should have initialise ...');
{
package ClassA;
use Abstract::Meta::Class ':all';
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;
eval {ClassA->new;};
::like($@, qr{Can't instantiate abstract class}, 'can\'t instantiate abstract class');
t/meta/fix.t view on Meta::CPAN
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;
my $z = $obj->z;
is(ref($x), 'ARRAY', 'should have an array');
is(ref($z), 'HASH', 'should have a hash');
{
( run in 0.618 second using v1.01-cache-2.11-cpan-0a6323c29d9 )