#!/usr/bin/env perl5.10
use strict;
use warnings;
use Test::More tests => 28;
use Test::Exception;
my $tmp;
#### Custom Traits
{
package Wonky;
use Moose::Role;
has wonkiness => (
is => 'rw',
isa => 'Str',
required => 1,
);
has 0 => (
reader => 'attr_get_zero',
writer => 'attr_set_zero',
accessor => 'attr_access_zero',
clearer => 'attr_clear_zero',
predicate => 'attr_has_zero',
);
}
{
package Moose::Meta::Attribute::Custom::Trait::Wonky;
sub register_implementation { 'Wonky' };
}
#### Foo class with 0 (zero) attribute
{
package Foo;
use Moose;
has 0 => (
reader => 'get_zero',
writer => 'set_zero',
accessor => 'access_zero',
clearer => 'clear_zero',
predicate => 'has_zero',
traits => [qw/Wonky/],
wonkiness => 'high',
0 => 321,
isa => 'Int',
);
}
### construction
my $foo = Foo->new();
isa_ok($foo, 'Foo');
### accessors
lives_ok {
$foo->set_zero(100);
} '... set_zero wrote successfully';
dies_ok {
$foo->set_zero('hello');
} '... type constraint fails';
is($foo->get_zero, 100, '... get_zero read successfully');
is($foo->access_zero, 100, '... access_zero read successfully');
lives_ok {
$foo->access_zero(200);
} '... access_zero wrote successfully';
is($foo->access_zero, 200, '... access_zero set the correct value');
lives_ok {
$foo->clear_zero();
} '... clear_zero cleared successfully';
ok(!$foo->has_zero, '... zero is no longer set');
lives_ok {
$foo = Foo->new(0 => 456);
} '... value defined in constructor';
is($foo->get_zero, 456, '... constructor wrote successfully');
### trait/role composition
lives_ok {
$tmp = $foo->meta->get_attribute(0);
} '... got attribute via meta';
is($tmp->wonkiness, 'high', '... trait applied successfully');
lives_ok {
$tmp->attr_set_zero(100);
} '... attr_set_zero wrote successfully';
is($tmp->attr_get_zero, 100, '... attr_get_zero read successfully');
is($tmp->attr_access_zero, 100, '... attr_access_zero read successfully');
lives_ok {
$tmp->attr_access_zero(200);
} '... attr_access_zero wrote successfully';
is($tmp->attr_access_zero, 200, '... attr_access_zero set the correct value');
lives_ok {
$tmp->attr_clear_zero();
} '... attr_clear_zero cleared successfully';
ok(!$tmp->attr_has_zero, '... attr zero is no longer set');
undef $tmp;
### delegation
{
package Bar;
use Moose;
has 'foo' => (
is => 'rw',
isa => 'Foo',
handles => qr{zero},
);
}
my $bar = Bar->new(foo => $foo);
isa_ok($bar, 'Bar');
lives_ok {
$bar->set_zero(123);
} '... set_zero delegation worked';
lives_ok {
$tmp = $bar->get_zero();
} '... get_zero delegation worked';
is($tmp, 123, '... get_zero returned the correct value');
undef $tmp;
### subclassing
{
package Baz;
use Moose;
extends 'Foo';
has '+0' => ( default => 111 );
}
my $baz;
lives_ok {
$baz = Baz->new();
} '... subclass instantiated';
lives_ok {
$tmp = $baz->get_zero;
} '... reader inherited successfully';
is($tmp, 111, '... attribute overriding successful');
### removing attribute
lives_ok {
$foo->meta->remove_attribute(0);
} '... remove attribute successful';
