X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=fd61cbaf986dda8f58d17e03c8c51b03bc85ed6b;hb=55d05fb16429c2150b5337b1a0130ae334e129d0;hp=0ebc1b8602281431352739896d94048862026d43;hpb=113d3174264db82cb788bc846f617584072cba39;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 0ebc1b8..fd61cba 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -5,48 +5,21 @@ use strict; use warnings; use Scalar::Util 'blessed', 'weaken'; +use List::MoreUtils 'any'; +use Try::Tiny; use overload (); -our $VERSION = '0.91'; +our $VERSION = '1.12'; our $AUTHORITY = 'cpan:STEVAN'; +use Moose::Deprecated; use Moose::Meta::Method::Accessor; use Moose::Meta::Method::Delegation; use Moose::Util (); use Moose::Util::TypeConstraints (); -use base 'Class::MOP::Attribute'; - -# options which are not directly used -# but we store them for metadata purposes -__PACKAGE__->meta->add_attribute('isa' => (reader => '_isa_metadata')); -__PACKAGE__->meta->add_attribute('does' => (reader => '_does_metadata')); -__PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata')); - -# these are actual options for the attrs -__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' )); -__PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' )); -__PACKAGE__->meta->add_attribute('lazy_build' => (reader => 'is_lazy_build' )); -__PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' )); -__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' )); -__PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref')); -__PACKAGE__->meta->add_attribute('type_constraint' => ( - reader => 'type_constraint', - predicate => 'has_type_constraint', -)); -__PACKAGE__->meta->add_attribute('trigger' => ( - reader => 'trigger', - predicate => 'has_trigger', -)); -__PACKAGE__->meta->add_attribute('handles' => ( - reader => 'handles', - writer => '_set_handles', - predicate => 'has_handles', -)); -__PACKAGE__->meta->add_attribute('documentation' => ( - reader => 'documentation', - predicate => 'has_documentation', -)); +use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore'; + __PACKAGE__->meta->add_attribute('traits' => ( reader => 'applied_traits', predicate => 'has_applied_traits', @@ -58,7 +31,7 @@ __PACKAGE__->meta->add_attribute('traits' => ( # for metatrait aliases. sub does { my ($self, $role_name) = @_; - my $name = eval { + my $name = try { Moose::Util::resolve_metatrait_alias(Attribute => $role_name) }; return 0 if !defined($name); # failed to load class @@ -159,15 +132,10 @@ sub interpolate_class { # ... -my @legal_options_for_inheritance = qw( - default coerce required - documentation lazy handles - builder type_constraint - definition_context - lazy_build weak_ref -); - -sub legal_options_for_inheritance { @legal_options_for_inheritance } +# method-generating options shouldn't be overridden +sub illegal_options_for_inheritance { + qw(reader writer accessor clearer predicate) +} # NOTE/TODO # This method *must* be able to handle @@ -186,10 +154,6 @@ sub legal_options_for_inheritance { @legal_options_for_inheritance } sub clone_and_inherit_options { my ($self, %options) = @_; - my %copy = %options; - - my %actual_options; - # NOTE: # we may want to extends a Class::MOP::Attribute # in which case we need to be able to use the @@ -197,16 +161,13 @@ sub clone_and_inherit_options { # been here. But we allows Moose::Meta::Attribute # instances to changes them. # - SL - my @legal_options = $self->can('legal_options_for_inheritance') - ? $self->legal_options_for_inheritance - : @legal_options_for_inheritance; - - foreach my $legal_option (@legal_options) { - if (exists $options{$legal_option}) { - $actual_options{$legal_option} = $options{$legal_option}; - delete $options{$legal_option}; - } - } + my @illegal_options = $self->can('illegal_options_for_inheritance') + ? $self->illegal_options_for_inheritance + : (); + + my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options; + (scalar @found_illegal_options == 0) + || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options); if ($options{isa}) { my $type_constraint; @@ -219,8 +180,7 @@ sub clone_and_inherit_options { || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa}); } - $actual_options{type_constraint} = $type_constraint; - delete $options{isa}; + $options{type_constraint} = $type_constraint; } if ($options{does}) { @@ -234,8 +194,7 @@ sub clone_and_inherit_options { || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does}); } - $actual_options{type_constraint} = $type_constraint; - delete $options{does}; + $options{type_constraint} = $type_constraint; } # NOTE: @@ -243,20 +202,14 @@ sub clone_and_inherit_options { # so we can ignore it for them. # - SL if ($self->can('interpolate_class')) { - ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(\%options); + ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options); my %seen; my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits; - $actual_options{traits} = \@all_traits if @all_traits; - - delete @options{qw(metaclass traits)}; + $options{traits} = \@all_traits if @all_traits; } - (scalar keys %options == 0) - || $self->throw_error("Illegal inherited options => (" . (join ', ' => keys %options) . ")", data => \%options); - - - $self->clone(%actual_options); + $self->clone(%options); } sub clone { @@ -318,7 +271,7 @@ sub _process_options { if (exists $options->{isa}) { if (exists $options->{does}) { - if (eval { $options->{isa}->can('does') }) { + if (try { $options->{isa}->can('does') }) { ($options->{isa}->does($options->{does})) || $class->throw_error("Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)", data => $options); } @@ -350,6 +303,16 @@ sub _process_options { || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options); $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options) if $options->{weak_ref}; + + unless ( $options->{type_constraint}->has_coercion ) { + my $type = $options->{type_constraint}->name; + + Moose::Deprecated::deprecated( + feature => 'coerce without coercion', + message => + "You cannot coerce an attribute ($name) unless its type ($type) has a coercion" + ); + } } if (exists $options->{trigger}) { @@ -426,8 +389,10 @@ sub initialize_instance_slot { $val = $self->_coerce_and_verify( $val, $instance ); $self->set_initial_value($instance, $val); - $meta_instance->weaken_slot_value($instance, $self->name) - if ref $val && $self->is_weak_ref; + + if ( ref $val && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } } sub _call_builder { @@ -463,12 +428,6 @@ sub _set_initial_slot_value { return $meta_instance->set_slot_value($instance, $slot_name, $value) unless $self->has_initializer; - my ($type_constraint, $can_coerce); - if ($self->has_type_constraint) { - $type_constraint = $self->type_constraint; - $can_coerce = ($self->should_coerce && $type_constraint->has_coercion); - } - my $callback = sub { my $val = $self->_coerce_and_verify( shift, $instance );; @@ -493,18 +452,15 @@ sub set_value { $value = $self->_coerce_and_verify( $value, $instance ); - my $meta_instance = Class::MOP::Class->initialize(blessed($instance)) - ->get_meta_instance; - my @old; if ( $self->has_trigger && $self->has_value($instance) ) { @old = $self->get_value($instance, 'for trigger'); } - $meta_instance->set_slot_value($instance, $attr_name, $value); + $self->SUPER::set_value($instance, $value); - if (ref $value && $self->is_weak_ref) { - $meta_instance->weaken_slot_value($instance, $attr_name); + if ( ref $value && $self->is_weak_ref ) { + $self->_weaken_value($instance); } if ($self->has_trigger) { @@ -512,6 +468,15 @@ sub set_value { } } +sub _weaken_value { + my ( $self, $instance ) = @_; + + my $meta_instance = Class::MOP::Class->initialize( blessed($instance) ) + ->get_meta_instance; + + $meta_instance->weaken_slot_value( $instance, $self->name ); +} + sub get_value { my ($self, $instance, $for_trigger) = @_; @@ -595,6 +560,13 @@ sub _process_accessors { . "an accessor" ); } + if (!$self->associated_class->has_method($accessor) + && $self->associated_class->has_package_symbol('&' . $accessor)) { + Carp::cluck( + "You are overwriting a locally defined function ($accessor) with " + . "an accessor" + ); + } $self->SUPER::_process_accessors(@_); } @@ -648,6 +620,9 @@ sub remove_delegation { my %handles = $self->_canonicalize_handles; my $associated_class = $self->associated_class; foreach my $handle (keys %handles) { + next unless any { $handle eq $_ } + map { $_->name } + @{ $self->associated_methods }; $self->associated_class->remove_method($handle); } } @@ -676,23 +651,25 @@ sub _canonicalize_handles { elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) { return map { $_ => $_ } @{ $handles->methods }; } + elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) { + $handles = $handles->role; + } else { $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles); } } - else { - Class::MOP::load_class($handles); - my $role_meta = Class::MOP::class_of($handles); - (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) - || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles); + Class::MOP::load_class($handles); + my $role_meta = Class::MOP::class_of($handles); - return map { $_ => $_ } - grep { $_ ne 'meta' } ( - $role_meta->get_method_list, - map { $_->name } $role_meta->get_required_method_list, - ); - } + (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) + || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles); + + return map { $_ => $_ } + grep { $_ ne 'meta' } ( + $role_meta->get_method_list, + map { $_->name } $role_meta->get_required_method_list, + ); } sub _find_delegate_metaclass { @@ -701,7 +678,7 @@ sub _find_delegate_metaclass { # we might be dealing with a non-Moose class, # and need to make our own metaclass. if there's # already a metaclass, it will be returned - return Moose::Meta::Class->initialize($class); + return Class::MOP::Class->initialize($class); } elsif (my $role = $self->_does_metadata) { return Class::MOP::class_of($role); @@ -732,11 +709,6 @@ sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } sub _make_delegation_method { my ( $self, $handle_name, $method_to_call ) = @_; - my $method_body; - - $method_body = $method_to_call - if 'CODE' eq ref($method_to_call); - my @curried_arguments; ($method_to_call, @curried_arguments) = @$method_to_call @@ -758,10 +730,8 @@ sub _coerce_and_verify { return $val unless $self->has_type_constraint; - my $type_constraint = $self->type_constraint; - if ($self->should_coerce && $type_constraint->has_coercion) { - $val = $type_constraint->coerce($val); - } + $val = $self->type_constraint->coerce($val) + if $self->should_coerce && $self->type_constraint->has_coercion; $self->verify_against_type_constraint($val, instance => $instance); @@ -964,7 +934,7 @@ I Before setting the value, a check is made on the type constraint of the attribute, if it has one, to see if the value passes it. If the -value fails to pass, the set operation dies with a L. +value fails to pass, the set operation dies with a L. Any coercion to convert values is done before checking the type constraint. @@ -1050,16 +1020,16 @@ of processing on the supplied C<%options> before ultimately calling the C method. One of its main tasks is to make sure that the C<%options> provided -only includes the options returned by the -C method. +does not include the options returned by the +C method. -=item B<< $attr->legal_options_for_inheritance >> +=item B<< $attr->illegal_options_for_inheritance >> -This returns a whitelist of options that can be overridden in a +This returns a blacklist of options that can not be overridden in a subclass's attribute definition. This exists to allow a custom metaclass to change or add to the list -of options which can be changed. +of options which can not be changed. =item B<< $attr->type_constraint >> @@ -1143,9 +1113,7 @@ Returns true if this attribute has any traits applied. =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. +See L for details on reporting bugs. =head1 AUTHOR @@ -1155,7 +1123,7 @@ Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2009 by Infinity Interactive, Inc. +Copyright 2006-2010 by Infinity Interactive, Inc. L