use Carp 'confess';
use overload ();
-our $VERSION = '0.14';
+our $VERSION = '0.15';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Accessor;
));
sub new {
- my ($class, $name, %options) = @_;
- $class->_process_options($name, \%options);
- return $class->SUPER::new($name, %options);
+ my ($class, $name, %options) = @_;
+ $class->_process_options($name, \%options);
+ return $class->SUPER::new($name, %options);
}
sub clone_and_inherit_options {
$type_constraint = $options{isa};
}
else {
- $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
+ $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint(
+ $options{isa}
+ );
(defined $type_constraint)
|| confess "Could not find the type constraint '" . $options{isa} . "'";
}
sub _process_options {
my ($class, $name, $options) = @_;
-
- if (exists $options->{is}) {
- if ($options->{is} eq 'ro') {
- $options->{reader} ||= $name;
- (!exists $options->{trigger})
- || confess "Cannot have a trigger on a read-only attribute";
- }
- elsif ($options->{is} eq 'rw') {
- $options->{accessor} = $name;
- ((reftype($options->{trigger}) || '') eq 'CODE')
- || confess "Trigger must be a CODE ref"
- if exists $options->{trigger};
- }
- else {
- confess "I do not understand this option (is => " . $options->{is} . ")"
- }
- }
-
- if (exists $options->{isa}) {
-
- if (exists $options->{does}) {
- if (eval { $options->{isa}->can('does') }) {
- ($options->{isa}->does($options->{does}))
- || confess "Cannot have an isa option and a does option if the isa does not do the does";
- }
- else {
- confess "Cannot have an isa option which cannot ->does()";
- }
+
+ if (exists $options->{is}) {
+ if ($options->{is} eq 'ro') {
+ $options->{reader} ||= $name;
+ (!exists $options->{trigger})
+ || confess "Cannot have a trigger on a read-only attribute";
+ }
+ elsif ($options->{is} eq 'rw') {
+ $options->{accessor} = $name;
+ ((reftype($options->{trigger}) || '') eq 'CODE')
+ || confess "Trigger must be a CODE ref"
+ if exists $options->{trigger};
+ }
+ else {
+ confess "I do not understand this option (is => " . $options->{is} . ")"
+ }
+ }
+
+ if (exists $options->{isa}) {
+
+ if (exists $options->{does}) {
+ if (eval { $options->{isa}->can('does') }) {
+ ($options->{isa}->does($options->{does}))
+ || confess "Cannot have an isa option and a does option if the isa does not do the does";
+ }
+ else {
+ confess "Cannot have an isa option which cannot ->does()";
}
-
- # allow for anon-subtypes here ...
- if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
- $options->{type_constraint} = $options->{isa};
- }
- else {
- $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
- $options->{isa} => {
- parent => Moose::Util::TypeConstraints::find_type_constraint('Object'),
- constraint => sub { $_[0]->isa($options->{isa}) }
- }
- );
- }
}
- elsif (exists $options->{does}) {
- # allow for anon-subtypes here ...
- if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
- $options->{type_constraint} = $options->{isa};
+
+ # allow for anon-subtypes here ...
+ if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
+ $options->{type_constraint} = $options->{isa};
+ }
+ else {
+ $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
+ $options->{isa} => {
+ parent => Moose::Util::TypeConstraints::find_type_constraint('Object'),
+ constraint => sub { $_[0]->isa($options->{isa}) }
}
- else {
- $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
- $options->{does} => {
- parent => Moose::Util::TypeConstraints::find_type_constraint('Role'),
- constraint => sub { $_[0]->does($options->{does}) }
- }
- );
+ );
+ }
+ }
+ elsif (exists $options->{does}) {
+ # allow for anon-subtypes here ...
+ if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
+ $options->{type_constraint} = $options->{isa};
+ }
+ else {
+ $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
+ $options->{does} => {
+ parent => Moose::Util::TypeConstraints::find_type_constraint('Role'),
+ constraint => sub { $_[0]->does($options->{does}) }
}
- }
-
- if (exists $options->{coerce} && $options->{coerce}) {
- (exists $options->{type_constraint})
- || confess "You cannot have coercion without specifying a type constraint";
- confess "You cannot have a weak reference to a coerced value"
- if $options->{weak_ref};
- }
-
- if (exists $options->{auto_deref} && $options->{auto_deref}) {
- (exists $options->{type_constraint})
- || confess "You cannot auto-dereference without specifying a type constraint";
- ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
- $options->{type_constraint}->is_a_type_of('HashRef'))
- || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
- }
-
- if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
- confess("You can not use lazy_build and default for the same attribute")
- if exists $options->{default};
- $options->{lazy} = 1;
- $options->{required} = 1;
- $options->{builder} ||= "_build_${name}";
- if($name =~ /^_/){
- $options->{clearer} ||= "_clear${name}";
- $options->{predicate} ||= "_has${name}";
- } else {
- $options->{clearer} ||= "clear_${name}";
- $options->{predicate} ||= "has_${name}";
+ );
}
+ }
+
+ if (exists $options->{coerce} && $options->{coerce}) {
+ (exists $options->{type_constraint})
+ || confess "You cannot have coercion without specifying a type constraint";
+ confess "You cannot have a weak reference to a coerced value"
+ if $options->{weak_ref};
+ }
+
+ if (exists $options->{auto_deref} && $options->{auto_deref}) {
+ (exists $options->{type_constraint})
+ || confess "You cannot auto-dereference without specifying a type constraint";
+ ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
+ $options->{type_constraint}->is_a_type_of('HashRef'))
+ || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
+ }
+
+ if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
+ confess("You can not use lazy_build and default for the same attribute")
+ if exists $options->{default};
+ $options->{lazy} = 1;
+ $options->{required} = 1;
+ $options->{builder} ||= "_build_${name}";
+ if($name =~ /^_/){
+ $options->{clearer} ||= "_clear${name}";
+ $options->{predicate} ||= "_has${name}";
+ } else {
+ $options->{clearer} ||= "clear_${name}";
+ $options->{predicate} ||= "has_${name}";
}
-
- if (exists $options->{lazy} && $options->{lazy}) {
- (exists $options->{default} || exists $options->{builder} )
- || confess "You cannot have lazy attribute without specifying a default value for it";
- }
+ }
+
+ if (exists $options->{lazy} && $options->{lazy}) {
+ (exists $options->{default} || exists $options->{builder} )
+ || confess "You cannot have lazy attribute without specifying a default value for it";
+ }
}
# to delagate to, see that method for details
my %handles = $self->_canonicalize_handles();
- # find the name of the accessor for this attribute
- my $accessor_name = $self->reader || $self->accessor;
- (defined $accessor_name)
- || confess "You cannot install delegation without a reader or accessor for the attribute";
-
- # make sure we handle HASH accessors correctly
- ($accessor_name) = keys %{$accessor_name}
- if ref($accessor_name) eq 'HASH';
+ # find the accessor method for this attribute
+ my $accessor = $self->get_read_method_ref;
+ # then unpack it if we need too ...
+ $accessor = $accessor->body if blessed $accessor;
# install the delegation ...
my $associated_class = $self->associated_class;
# we should check for lack of
# a callable return value from
# the accessor here
- my $proxy = (shift)->$accessor_name();
+ my $proxy = (shift)->$accessor();
@_ = ($proxy, @_);
- goto &{ $proxy->can($method_to_call)};
+ goto &{ $proxy->can($method_to_call) };
});
}
}
use strict;
use warnings;
-use Test::More tests => 72;
+use Test::More tests => 80;
use Test::Exception;
BEGIN {
has 'bling' => (is => 'ro', isa => 'Thing');
has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']);
+ has 'bunch_of_stuff' => (is => 'rw', isa => 'ArrayRef');
+
# this one will work here ....
has 'fail' => (isa => 'CodeRef');
has 'other_fail';
::lives_ok {
has '+gloum' => (lazy => 1);
} '... we can change/add lazy as an attribute option';
+
+ ::lives_ok {
+ has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]');
+ } '... extend an attribute with parameterized type';
::lives_ok {
has '+bling' => (handles => ['hello']);
lives_ok { $foo->baz($scalar_ref) } '... Foo::baz accepts scalar ref';
is($foo->baz, $scalar_ref, '... got the right value assigned to baz');
+ lives_ok { $foo->bunch_of_stuff([qw[one two three]]) } '... Foo::bunch_of_stuff accepts an array of strings';
+
my $code_ref = sub { 1 };
lives_ok { $foo->baz($code_ref) } '... Foo::baz accepts a code ref';
is($foo->baz, $code_ref, '... got the right value assigned to baz');
my $scalar_ref = \(my $var);
dies_ok { $bar->baz($scalar_ref) } '... Bar::baz does not accept a scalar ref';
+ lives_ok { $bar->bunch_of_stuff([1, 2, 3]) } '... Bar::bunch_of_stuff accepts an array of ints';
+ dies_ok { $bar->bunch_of_stuff([qw[one two three]]) } '... Bar::bunch_of_stuff does not accept an array of strings';
+
my $code_ref = sub { 1 };
dies_ok { $bar->baz($code_ref) } '... Bar::baz does not accept a code ref';
}
ok(Bar->meta->has_attribute('gorch'), '... Bar has a gorch attr');
ok(Bar->meta->has_attribute('gloum'), '... Bar has a gloum attr');
ok(Bar->meta->has_attribute('bling'), '... Bar has a bling attr');
+ok(Bar->meta->has_attribute('bunch_of_stuff'), '... Bar does have a bunch_of_stuff attr');
ok(!Bar->meta->has_attribute('blang'), '... Bar has a blang attr');
ok(!Bar->meta->has_attribute('fail'), '... Bar does not have a fail attr');
ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have a fail attr');
isnt(Foo->meta->get_attribute('bling'),
Bar->meta->get_attribute('bling'),
'... Foo and Bar have different copies of bling');
+isnt(Foo->meta->get_attribute('bunch_of_stuff'),
+ Bar->meta->get_attribute('bunch_of_stuff'),
+ '... Foo and Bar have different copies of bunch_of_stuff');
ok(Bar->meta->get_attribute('bar')->has_type_constraint,
'... Bar::bar inherited the type constraint too');
ok(Bar->meta->get_attribute('gorch')->is_required,
'... Bar::gorch is a required attr');
+is(Foo->meta->get_attribute('bunch_of_stuff')->type_constraint->name,
+ 'ArrayRef',
+ '... Foo::bunch_of_stuff is an ArrayRef');
+is(Bar->meta->get_attribute('bunch_of_stuff')->type_constraint->name,
+ 'ArrayRef[Int]',
+ '... Bar::bunch_of_stuff is an ArrayRef[Int]');
+
ok(!Foo->meta->get_attribute('gloum')->is_lazy,
'... Foo::gloum is not a required attr');
ok(Bar->meta->get_attribute('gloum')->is_lazy,
projects / gitmo/Moose.git / commitdiff