eval results from the CPAN

eval

Abstract-Meta-Class

view release on metacpan or search on metacpan

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/Method.pm view on Meta::CPAN

    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;

    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/Class.pm view on Meta::CPAN


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]);
            }
        };
        
        if ($@) {
            confess "unknown attribute " . ref($self) ."::" . $mutator
                unless $self->can($mutator);
            confess $@

t/meta/array_storage/association.t view on Meta::CPAN

    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');

t/meta/array_storage/association.t view on Meta::CPAN

    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.+},
           'should catch invalid definition on the other end attribute');

    
    eval { ClassA->new(to_one => $a1) };
    ::like($@, qr{missing other end attribute on AssociatedClassA::classA.+}, 'shuould catch the invalid other end definition');
    has '$.classA' => (associated_class => 'ClassA', the_other_end => 'to_one');
    
    {
        my $clazz = ClassA->new(to_one => $a1);
        ::is($a1, $clazz->to_one, 'should associate');
        $clazz->to_one($a2);
        ::is($a2, $clazz->to_one, 'should deassociate the other end (scalar)');
        ::is($a2->classA, $clazz, 'should associate the other end (scalar)');
    }

t/meta/array_storage/attribute.t view on Meta::CPAN

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);
}

t/meta/array_storage/attribute.t view on Meta::CPAN

    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

{
    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/association.t view on Meta::CPAN

    has '%.to_many' => (associated_class => 'AssociatedClass', index_by => 'a', item_accessor => 'association');
}

{
    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');

t/meta/association.t view on Meta::CPAN

    package AssociatedClassA;
    use Abstract::Meta::Class ':all';
    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.+},
           'should catch invalid definition on the other end attribute');

    
    eval { ClassA->new(to_one => $a1) };
    ::like($@, qr{missing other end attribute on AssociatedClassA::classA.+}, 'shuould catch the invalid other end definition');
    has '$.classA' => (associated_class => 'ClassA', the_other_end => 'to_one');
    
    {
        my $clazz = ClassA->new(to_one => $a1);
        ::is($a1, $clazz->to_one, 'should associate');
        $clazz->to_one($a2);
        ::is($a2, $clazz->to_one, 'should deassociate the other end (scalar)');
        ::is($a2->classA, $clazz, 'should associate the other end (scalar)');
    }

t/meta/attribute.t view on Meta::CPAN

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; };
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';
    has '%.xs' => (item_accessor => 'x', required => 1);
}

t/meta/attribute.t view on Meta::CPAN

    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

    
{
    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

is(ref($z), 'HASH', 'should have a hash');
    

{
    package Req;
    use Abstract::Meta::Class ':all';
    has '@.x' => (required => 1);
    has '%.z' => (required => 1);
}

eval {
    Req->new(z => {a => 1});
};
like($@, qr{x is required}, 'should catch required value');



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');



eval {
    Req->new(x => [z => 1]);
};
like($@, qr{z is required}, 'should catch required value');

( run in 2.788 seconds using v1.01-cache-2.11-cpan-98e64b0badf )