X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=be577f880de510f8704bb3b9838b9600073be4e4;hb=620db0454d31341c981eb9061132d4f3a08a7310;hp=80c16cdd8117d64c352abeda1f2dfb58c8245ee8;hpb=8d62bf6daf6f67db2ec437a045275024f9188ee3;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 80c16cd..be577f8 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -47,6 +47,14 @@ __PACKAGE__->meta->add_attribute('documentation' => ( predicate => 'has_documentation', )); +# NOTE: +# we need to have a ->does method in here to +# more easily support traits, and the introspection +# of those traits. So in order to do this we +# just alias Moose::Object's version of it. +# - SL +*does = \&Moose::Object::does; + sub new { my ($class, $name, %options) = @_; $class->_process_options($name, \%options); @@ -57,54 +65,47 @@ sub clone_and_inherit_options { my ($self, %options) = @_; # you can change default, required, coerce, documentation and lazy my %actual_options; - foreach my $legal_option (qw(default coerce required documentation lazy)) { + foreach my $legal_option (qw(default coerce required documentation lazy handles builder)) { if (exists $options{$legal_option}) { $actual_options{$legal_option} = $options{$legal_option}; delete $options{$legal_option}; } } - # handles can only be added, not changed - if ($options{handles}) { - confess "You can only add the 'handles' option, you cannot change it" - if $self->has_handles; - $actual_options{handles} = $options{handles}; - delete $options{handles}; - } - - # handles can only be added, not changed - if ($options{builder}) { - confess "You can only add the 'builder' option, you cannot change it" - if $self->has_builder; - $actual_options{builder} = $options{builder}; - delete $options{builder}; - } - - # isa can be changed, but only if the - # new type is a subtype if ($options{isa}) { my $type_constraint; if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { $type_constraint = $options{isa}; } else { - $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options{isa} - ); + # FIXME this causes a failing test, not sure it should + # $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}); + $type_constraint = Moose::Util::TypeConstraints::find_or_parse_type_constraint($options{isa}); (defined $type_constraint) || confess "Could not find the type constraint '" . $options{isa} . "'"; } - # NOTE: - # check here to see if the new type - # is a subtype of the old one - ($type_constraint->is_subtype_of($self->type_constraint->name)) - || confess "New type constraint setting must be a subtype of inherited one" - # iff we have a type constraint that is ... - if $self->has_type_constraint; - # then we use it :) + $actual_options{type_constraint} = $type_constraint; delete $options{isa}; } + + if ($options{does}) { + my $type_constraint; + if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) { + $type_constraint = $options{does}; + } + else { + # FIXME see above + # $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}); + $type_constraint = Moose::Util::TypeConstraints::find_or_parse_type_constraint($options{does}); + (defined $type_constraint) + || confess "Could not find the type constraint '" . $options{does} . "'"; + } + + $actual_options{type_constraint} = $type_constraint; + delete $options{does}; + } + (scalar keys %options == 0) || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")"; $self->clone(%actual_options); @@ -117,7 +118,7 @@ sub _process_options { if ($options->{is} eq 'ro') { $options->{reader} ||= $name; (!exists $options->{trigger}) - || confess "Cannot have a trigger on a read-only attribute"; + || confess "Cannot have a trigger on a read-only attribute $name"; } elsif ($options->{is} eq 'rw') { $options->{accessor} = $name; @@ -126,7 +127,7 @@ sub _process_options { if exists $options->{trigger}; } else { - confess "I do not understand this option (is => " . $options->{is} . ")" + confess "I do not understand this option (is => " . $options->{is} . ") on attribute $name" } } @@ -134,10 +135,10 @@ sub _process_options { 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"; + || confess "Cannot have an isa option and a does option if the isa does not do the does on attribute $name"; } else { - confess "Cannot have an isa option which cannot ->does()"; + confess "Cannot have an isa option which cannot ->does() on attribute $name"; } } @@ -146,12 +147,7 @@ sub _process_options { $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}) } - } - ); + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa}); } } elsif (exists $options->{does}) { @@ -160,34 +156,27 @@ sub _process_options { $options->{type_constraint} = $options->{does}; } else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options->{does} => { - parent => Moose::Util::TypeConstraints::find_type_constraint('Role'), - constraint => sub { - Moose::Util::does_role($_[0], $options->{does}) - } - } - ); + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($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" + || confess "You cannot have coercion without specifying a type constraint on attribute $name"; + confess "You cannot have a weak reference to a coerced value on attribute $name" 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"; + || confess "You cannot auto-dereference without specifying a type constraint on attribute $name"; ($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"; + || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute $name"; } if (exists $options->{lazy_build} && $options->{lazy_build} == 1) { - confess("You can not use lazy_build and default for the same attribute") + confess("You can not use lazy_build and default for the same attribute $name") if exists $options->{default}; $options->{lazy} = 1; $options->{required} = 1; @@ -204,11 +193,11 @@ sub _process_options { if (exists $options->{lazy} && $options->{lazy}) { (exists $options->{default} || defined $options->{builder} ) - || confess "You cannot have lazy attribute without specifying a default value for it"; + || confess "You cannot have lazy attribute ($name) without specifying a default value for it"; } if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) { - confess "You cannot have a required attribute without a default, builder, or an init_arg"; + confess "You cannot have a required attribute ($name) without a default, builder, or an init_arg"; } } @@ -580,6 +569,8 @@ will behave just as L does. =item B +=item B + =item B =item B