X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=e59ebaf0122e74d6158b0098db5a04d859213757;hb=a486d5ade76c569625615022b49d03c92d6e93c2;hp=2224b3fc023e05a072a01378b166ce09178f58d8;hpb=13e0ee4c017cc00917e026d760a629b0adac6a00;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 2224b3f..e59ebaf 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -4,21 +4,26 @@ package Moose::Meta::Attribute; use strict; use warnings; +use Class::MOP (); use Scalar::Util 'blessed', 'weaken'; use List::MoreUtils 'any'; use Try::Tiny; use overload (); -our $VERSION = '1.08'; +our $VERSION = '1.19'; 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'); + __PACKAGE__->meta->add_attribute('traits' => ( reader => 'applied_traits', predicate => 'has_applied_traits', @@ -133,7 +138,7 @@ sub interpolate_class { # method-generating options shouldn't be overridden sub illegal_options_for_inheritance { - qw(is reader writer accessor clearer predicate) + qw(reader writer accessor clearer predicate) } # NOTE/TODO @@ -208,6 +213,11 @@ sub clone_and_inherit_options { $options{traits} = \@all_traits if @all_traits; } + # This method can be called on a CMOP::Attribute object, so we need to + # make sure we can call this method. + $self->_process_lazy_build_option( $self->name, \%options ) + if $self->can('_process_lazy_build_option'); + $self->clone(%options); } @@ -236,116 +246,206 @@ sub clone { } sub _process_options { - my ($class, $name, $options) = @_; + my ( $class, $name, $options ) = @_; + + $class->_process_is_option( $name, $options ); + $class->_process_isa_option( $name, $options ); + $class->_process_does_option( $name, $options ); + $class->_process_coerce_option( $name, $options ); + $class->_process_trigger_option( $name, $options ); + $class->_process_auto_deref_option( $name, $options ); + $class->_process_lazy_build_option( $name, $options ); + $class->_process_lazy_option( $name, $options ); + $class->_process_required_option( $name, $options ); +} - if (exists $options->{is}) { +sub _process_is_option { + my ( $class, $name, $options ) = @_; - ### ------------------------- - ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before - ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo) - ## is => rw, accessor => _foo # turns into (accessor => _foo) - ## is => ro, accessor => _foo # error, accesor is rw - ### ------------------------- + return unless $options->{is}; - if ($options->{is} eq 'ro') { - $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options) - if exists $options->{accessor}; + ### ------------------------- + ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before + ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo) + ## is => rw, accessor => _foo # turns into (accessor => _foo) + ## is => ro, accessor => _foo # error, accesor is rw + ### ------------------------- + + if ( $options->{is} eq 'ro' ) { + $class->throw_error( + "Cannot define an accessor name on a read-only attribute, accessors are read/write", + data => $options ) + if exists $options->{accessor}; + $options->{reader} ||= $name; + } + elsif ( $options->{is} eq 'rw' ) { + if ( $options->{writer} ) { $options->{reader} ||= $name; } - elsif ($options->{is} eq 'rw') { - if ($options->{writer}) { - $options->{reader} ||= $name; - } - else { - $options->{accessor} ||= $name; - } - } - elsif ($options->{is} eq 'bare') { - # do nothing, but don't complain (later) about missing methods - } else { - $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is}); + $options->{accessor} ||= $name; } } + elsif ( $options->{is} eq 'bare' ) { + return; + # do nothing, but don't complain (later) about missing methods + } + else { + $class->throw_error( "I do not understand this option (is => " + . $options->{is} + . ") on attribute ($name)", data => $options->{is} ); + } +} - if (exists $options->{isa}) { - if (exists $options->{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); - } - else { - $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options); - } - } +sub _process_isa_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{isa}; - # allow for anon-subtypes here ... - if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{isa}; + if ( exists $options->{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 ); } else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa}); + $class->throw_error( + "Cannot have an isa option which cannot ->does() on attribute ($name)", + data => $options ); } } - elsif (exists $options->{does}) { - # allow for anon-subtypes here ... - if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{does}; - } - else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{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_isa_type_constraint( + $options->{isa} ); + } +} - if (exists $options->{coerce} && $options->{coerce}) { - (exists $options->{type_constraint}) - || $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}; +sub _process_does_option { + my ( $class, $name, $options ) = @_; - unless ( $options->{type_constraint}->has_coercion ) { - my $type = $options->{type_constraint}->name; - $class->throw_error("You cannot coerce an attribute ($name) unless its type ($type) has a coercion", data => $options); - } - } + return unless exists $options->{does} && ! exists $options->{isa}; - if (exists $options->{trigger}) { - ('CODE' eq ref $options->{trigger}) - || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger}); + # allow for anon-subtypes here ... + if ( blessed( $options->{does} ) + && $options->{does}->isa('Moose::Meta::TypeConstraint') ) { + $options->{type_constraint} = $options->{does}; } - - if (exists $options->{auto_deref} && $options->{auto_deref}) { - (exists $options->{type_constraint}) - || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options); - ($options->{type_constraint}->is_a_type_of('ArrayRef') || - $options->{type_constraint}->is_a_type_of('HashRef')) - || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options); + else { + $options->{type_constraint} + = Moose::Util::TypeConstraints::find_or_create_does_type_constraint( + $options->{does} ); } +} - if (exists $options->{lazy_build} && $options->{lazy_build} == 1) { - $class->throw_error("You can not use lazy_build and default for the same attribute ($name)", data => $options) - if exists $options->{default}; - $options->{lazy} = 1; - $options->{builder} ||= "_build_${name}"; - if ($name =~ /^_/) { - $options->{clearer} ||= "_clear${name}"; - $options->{predicate} ||= "_has${name}"; - } - else { - $options->{clearer} ||= "clear_${name}"; - $options->{predicate} ||= "has_${name}"; - } - } +sub _process_coerce_option { + my ( $class, $name, $options ) = @_; - if (exists $options->{lazy} && $options->{lazy}) { - (exists $options->{default} || defined $options->{builder} ) - || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options); + return unless $options->{coerce}; + + ( exists $options->{type_constraint} ) + || $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" + ); } +} + +sub _process_trigger_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{trigger}; + + ( 'CODE' eq ref $options->{trigger} ) + || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger}); +} + +sub _process_auto_deref_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{auto_deref}; + + ( exists $options->{type_constraint} ) + || $class->throw_error( + "You cannot auto-dereference without specifying a type constraint on attribute ($name)", + data => $options ); + + ( $options->{type_constraint}->is_a_type_of('ArrayRef') + || $options->{type_constraint}->is_a_type_of('HashRef') ) + || $class->throw_error( + "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", + data => $options ); +} + +sub _process_lazy_build_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{lazy_build}; - if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) { - $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options); + $class->throw_error( + "You can not use lazy_build and default for the same attribute ($name)", + data => $options ) + if exists $options->{default}; + + $options->{lazy} = 1; + $options->{builder} ||= "_build_${name}"; + + if ( $name =~ /^_/ ) { + $options->{clearer} ||= "_clear${name}"; + $options->{predicate} ||= "_has${name}"; + } + else { + $options->{clearer} ||= "clear_${name}"; + $options->{predicate} ||= "has_${name}"; } +} + +sub _process_lazy_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{lazy}; + + ( exists $options->{default} || defined $options->{builder} ) + || $class->throw_error( + "You cannot have a lazy attribute ($name) without specifying a default value for it", + data => $options ); +} + +sub _process_required_option { + my ( $class, $name, $options ) = @_; + if ( + $options->{required} + && !( + ( !exists $options->{init_arg} || defined $options->{init_arg} ) + || exists $options->{default} + || defined $options->{builder} + ) + ) { + $class->throw_error( + "You cannot have a required attribute ($name) without a default, builder, or an init_arg", + data => $options ); + } } sub initialize_instance_slot { @@ -544,23 +644,42 @@ sub _check_associated_methods { sub _process_accessors { my $self = shift; my ($type, $accessor, $generate_as_inline_methods) = @_; - $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH'; + + $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH'; my $method = $self->associated_class->get_method($accessor); - if ($method && !$method->isa('Class::MOP::Method::Accessor') - && (!$self->definition_context - || $method->package_name eq $self->definition_context->{package})) { + + if ( $method + && $method->isa('Class::MOP::Method::Accessor') + && $method->associated_attribute->name ne $self->name ) { + + my $other_attr_name = $method->associated_attribute->name; + my $name = $self->name; + + Carp::cluck( + "You are overwriting an accessor ($accessor) for the $other_attr_name attribute" + . " with a new accessor method for the $name attribute" ); + } + + if ( + $method + && !$method->isa('Class::MOP::Method::Accessor') + && ( !$self->definition_context + || $method->package_name eq $self->definition_context->{package} ) + ) { + Carp::cluck( "You are overwriting a locally defined method ($accessor) with " - . "an accessor" - ); + . "an accessor" ); } - if (!$self->associated_class->has_method($accessor) - && $self->associated_class->has_package_symbol('&' . $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" - ); + . "an accessor" ); } + $self->SUPER::_process_accessors(@_); } @@ -571,6 +690,22 @@ sub remove_accessors { return; } +sub _inline_set_value { + my $self = shift; + my ($instance, $value) = @_; + + my $mi = $self->associated_class->get_meta_instance; + + my @code = ($self->SUPER::_inline_set_value(@_)); + + push @code, ( + $mi->inline_weaken_slot_value($instance, $self->name, $value), + 'if ref ' . $value . ';', + ) if $self->is_weak_ref; + + return @code; +} + sub install_delegation { my $self = shift; @@ -660,21 +795,55 @@ sub _canonicalize_handles { || $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, + map { $_->name } + grep { !$_->isa('Class::MOP::Method::Meta') } ( + $role_meta->_get_local_methods, + $role_meta->get_required_method_list, ); } +sub _get_delegate_method_list { + my $self = shift; + my $meta = $self->_find_delegate_metaclass; + if ($meta->isa('Class::MOP::Class')) { + return map { $_->name } # NOTE: !never! delegate &meta + grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') } + $meta->get_all_methods; + } + elsif ($meta->isa('Moose::Meta::Role')) { + return $meta->get_method_list; + } + else { + $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta); + } +} + sub _find_delegate_metaclass { my $self = shift; if (my $class = $self->_isa_metadata) { + unless ( Class::MOP::is_class_loaded($class) ) { + $self->throw_error( + sprintf( + 'The %s attribute is trying to delegate to a class which has not been loaded - %s', + $self->name, $class + ) + ); + } # 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 Class::MOP::Class->initialize($class); } elsif (my $role = $self->_does_metadata) { + unless ( Class::MOP::is_class_loaded($class) ) { + $self->throw_error( + sprintf( + 'The %s attribute is trying to delegate to a role which has not been loaded - %s', + $self->name, $role + ) + ); + } + return Class::MOP::class_of($role); } else { @@ -682,22 +851,6 @@ sub _find_delegate_metaclass { } } -sub _get_delegate_method_list { - my $self = shift; - my $meta = $self->_find_delegate_metaclass; - if ($meta->isa('Class::MOP::Class')) { - return map { $_->name } # NOTE: !never! delegate &meta - grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' } - $meta->get_all_methods; - } - elsif ($meta->isa('Moose::Meta::Role')) { - return $meta->get_method_list; - } - else { - $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta); - } -} - sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } sub _make_delegation_method { @@ -725,7 +878,7 @@ sub _coerce_and_verify { return $val unless $self->has_type_constraint; $val = $self->type_constraint->coerce($val) - if $self->should_coerce; + if $self->should_coerce && $self->type_constraint->has_coercion; $self->verify_against_type_constraint($val, instance => $instance); @@ -830,7 +983,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. @@ -886,6 +1039,29 @@ is equivalent to this: predicate => 'has_size', ); + +If your attribute name starts with an underscore (C<_>), then the clearer +and predicate will as well: + + has '_size' => ( + is => 'ro', + lazy_build => 1, + ); + +becomes: + + has '_size' => ( + is => 'ro', + lazy => 1, + builder => '_build__size', + clearer => '_clear_size', + predicate => '_has_size', + ); + +Note the doubled underscore in the builder name. Internally, Moose +simply prepends the attribute name with "_build_" to come up with the +builder name. + =item * documentation An arbitrary string that can be retrieved later by calling C<< @@ -957,6 +1133,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