X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=aebca6f48b66dcb61a0d764a1980103f99ef037a;hb=6feff4da00150d5d62ef567ce007936bb76eac6c;hp=4beca35bb5803a4dec1c9136e4535ccb7f208579;hpb=6c83959442f106783570ceccfe82ad98869b2c1e;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 4beca35..aebca6f 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -5,48 +5,24 @@ use strict; use warnings; use Scalar::Util 'blessed', 'weaken'; +use List::MoreUtils 'any'; +use Try::Tiny; use overload (); -our $VERSION = '0.84'; +our $VERSION = '1.14'; 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 Class::MOP::MiniTrait; + +use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); -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', -)); __PACKAGE__->meta->add_attribute('traits' => ( reader => 'applied_traits', predicate => 'has_applied_traits', @@ -58,7 +34,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 +135,10 @@ sub interpolate_class { # ... -my @legal_options_for_inheritance = qw( - default coerce required - documentation lazy handles - builder type_constraint - definition_context - lazy_build -); - -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 +157,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 +164,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 +183,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 +197,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 +205,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 +274,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 +306,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 +392,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 +431,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,22 +455,33 @@ 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) { - $self->trigger->($instance, $value); + $self->trigger->($instance, $value, @old); } } +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) = @_; + my ($self, $instance, $for_trigger) = @_; if ($self->is_lazy) { unless ($self->has_value($instance)) { @@ -525,7 +498,7 @@ sub get_value { } } - if ($self->should_auto_deref) { + if ( $self->should_auto_deref && ! $for_trigger ) { my $type_constraint = $self->type_constraint; @@ -586,7 +559,14 @@ sub _process_accessors { && (!$self->definition_context || $method->package_name eq $self->definition_context->{package})) { Carp::cluck( - "You cannot overwrite a locally defined method ($accessor) with " + "You are overwriting a locally defined method ($accessor) with " + . "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" ); } @@ -600,6 +580,22 @@ sub remove_accessors { return; } +sub inline_set { + my $self = shift; + my ( $instance, $value ) = @_; + + my $mi = $self->associated_class->get_meta_instance; + + my $code + = $mi->inline_set_slot_value( $instance, $self->slots, $value ) . ";"; + $code + .= $mi->inline_weaken_slot_value( $instance, $self->slots, $value ) + . " if ref $value;" + if $self->is_weak_ref; + + return $code; +} + sub install_delegation { my $self = shift; @@ -643,6 +639,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); } } @@ -671,22 +670,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); + + (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 { $_ => $_ } ( - $role_meta->get_method_list, - map { $_->name } $role_meta->get_required_method_list, + return map { $_ => $_ } + grep { $_ ne 'meta' } ( + $role_meta->get_method_list, + map { $_->name } $role_meta->get_required_method_list, ); - } } sub _find_delegate_metaclass { @@ -695,7 +697,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); @@ -726,14 +728,9 @@ sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } sub _make_delegation_method { my ( $self, $handle_name, $method_to_call ) = @_; - my $method_body; + my @curried_arguments; - $method_body = $method_to_call - if 'CODE' eq ref($method_to_call); - - my $curried_arguments = []; - - ($method_to_call, $curried_arguments) = @$method_to_call + ($method_to_call, @curried_arguments) = @$method_to_call if 'ARRAY' eq ref($method_to_call); return $self->delegation_metaclass->new( @@ -741,7 +738,7 @@ sub _make_delegation_method { package_name => $self->associated_class->name, attribute => $self, delegate_to_method => $method_to_call, - curried_arguments => $curried_arguments || [], + curried_arguments => \@curried_arguments, ); } @@ -752,10 +749,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); @@ -860,7 +855,7 @@ object which does the named role. =item * coerce => $bool This option is only valid for objects with a type constraint -(C). If this is true, then coercions will be applied whenever +(C) that defined a coercion. If this is true, then coercions will be applied whenever this attribute is set. You can make both this and the C option true. @@ -958,7 +953,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. @@ -987,6 +982,12 @@ methods is almost always an error.) This method overrides the parent to also remove delegation methods. +=item B<< $attr->inline_set($instance_var, $value_var) >> + +This method return a code snippet suitable for inlining the relevant +operation. It expect strings containing variable names to be used in the +inlining, like C<'$self'> or C<'$_[1]'>. + =item B<< $attr->install_delegation >> This method adds its delegation methods to the attribute's associated @@ -1044,16 +1045,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 >> @@ -1137,9 +1138,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 @@ -1149,7 +1148,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