X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=46a8412f0ecd474a7641091acfeb3475864c798c;hb=ee05962b4ec91f86a0dc19ceddb869ca4e609a67;hp=7111abce915def9b4c8085be7beda9f71674c923;hpb=525129a5a7413b8c2ea745d170a1913e93bfd4bf;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 7111abc..46a8412 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -4,101 +4,136 @@ package Moose::Meta::Attribute; use strict; use warnings; +use B (); +use Class::Load qw(is_class_loaded load_class); use Scalar::Util 'blessed', 'weaken'; +use List::MoreUtils 'any'; +use Try::Tiny; use overload (); -our $VERSION = '0.69'; -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', - 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', + Class::MOP::_definition_context(), )); -# we need to have a ->does method in here to -# more easily support traits, and the introspection +# we need to have a ->does method in here to +# more easily support traits, and the introspection # of those traits. We extend the does check to look # 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 return $self->Moose::Object::does($name); } +sub _error_thrower { + my $self = shift; + require Moose::Meta::Class; + ( ref $self && $self->associated_class ) || "Moose::Meta::Class"; +} + sub throw_error { my $self = shift; - my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class"; + my $inv = $self->_error_thrower; unshift @_, "message" if @_ % 2 == 1; unshift @_, attr => $self if ref $self; - unshift @_, $class; - my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1 + unshift @_, $inv; + my $handler = $inv->can("throw_error"); # to avoid incrementing depth by 1 goto $handler; } +sub _inline_throw_error { + my ( $self, $msg, $args ) = @_; + + my $inv = $self->_error_thrower; + # XXX ugh + $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error'); + + # XXX ugh ugh UGH + my $class = $self->associated_class; + if ($class) { + my $class_name = B::perlstring($class->name); + my $attr_name = B::perlstring($self->name); + $args = 'attr => Class::MOP::class_of(' . $class_name . ')' + . '->find_attribute_by_name(' . $attr_name . '), ' + . (defined $args ? $args : ''); + } + + return $inv->_inline_throw_error($msg, $args) +} + sub new { my ($class, $name, %options) = @_; $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS + + delete $options{__hack_no_process_options}; + + my %attrs = + ( map { $_ => 1 } + grep { defined } + map { $_->init_arg() } + $class->meta()->get_all_attributes() + ); + + my @bad = sort grep { ! $attrs{$_} } keys %options; + + if (@bad) + { + my $s = @bad > 1 ? 's' : ''; + my $list = join "', '", @bad; + + my $package = $options{definition_context}{package}; + my $context = $options{definition_context}{context} + || 'attribute constructor'; + my $type = $options{definition_context}{type} || 'class'; + + my $location = ''; + if (defined($package)) { + $location = " in "; + $location .= "$type " if $type; + $location .= $package; + } + + Carp::cluck "Found unknown argument$s '$list' in the $context for '$name'$location"; + } + return $class->SUPER::new($name, %options); } sub interpolate_class_and_new { - my ($class, $name, @args) = @_; + my ($class, $name, %args) = @_; - my ( $new_class, @traits ) = $class->interpolate_class(@args); - - $new_class->new($name, @args, ( scalar(@traits) ? ( traits => \@traits ) : () ) ); + my ( $new_class, @traits ) = $class->interpolate_class(\%args); + + $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) ); } sub interpolate_class { - my ($class, %options) = @_; + my ($class, $options) = @_; $class = ref($class) || $class; - if ( my $metaclass_name = delete $options{metaclass} ) { + if ( my $metaclass_name = delete $options->{metaclass} ) { my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name ); - + if ( $class ne $new_class ) { if ( $new_class->can("interpolate_class") ) { - return $new_class->interpolate_class(%options); + return $new_class->interpolate_class($options); } else { $class = $new_class; } @@ -107,8 +142,10 @@ sub interpolate_class { my @traits; - if (my $traits = $options{traits}) { + if (my $traits = $options->{traits}) { my $i = 0; + my $has_foreign_options = 0; + while ($i < @$traits) { my $trait = $traits->[$i++]; next if ref($trait); # options to a trait we discarded @@ -121,17 +158,28 @@ sub interpolate_class { push @traits, $trait; # are there options? - push @traits, $traits->[$i++] - if $traits->[$i] && ref($traits->[$i]); + if ($traits->[$i] && ref($traits->[$i])) { + $has_foreign_options = 1 + if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] }; + + push @traits, $traits->[$i++]; + } } if (@traits) { - my $anon_class = Moose::Meta::Class->create_anon_class( + my %options = ( superclasses => [ $class ], roles => [ @traits ], - cache => 1, ); + if ($has_foreign_options) { + $options{weaken} = 0; + } + else { + $options{cache} = 1; + } + + my $anon_class = Moose::Meta::Class->create_anon_class(%options); $class = $anon_class->name; } } @@ -141,53 +189,42 @@ sub interpolate_class { # ... -my @legal_options_for_inheritance = qw( - default coerce required - documentation lazy handles - builder type_constraint - definition_context -); - -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 -# Class::MOP::Attribute instances as -# well. Yes, I know that is wrong, but -# apparently we didn't realize it was -# doing that and now we have some code -# which is dependent on it. The real -# solution of course is to push this +# This method *must* be able to handle +# Class::MOP::Attribute instances as +# well. Yes, I know that is wrong, but +# apparently we didn't realize it was +# doing that and now we have some code +# which is dependent on it. The real +# solution of course is to push this # feature back up into Class::MOP::Attribute # but I not right now, I am too lazy. -# However if you are reading this and -# looking for something to do,.. please +# However if you are reading this and +# looking for something to do,.. please # be my guest. # - stevan 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 - # core set of legal options that have always + # in which case we need to be able to use the + # core set of legal options that have always # 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; @@ -195,184 +232,277 @@ sub clone_and_inherit_options { $type_constraint = $options{isa}; } else { - $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}); + $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}, { package_defined_in => $options{definition_context}->{package} }); (defined $type_constraint) || $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}) { my $type_constraint; if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) { $type_constraint = $options{does}; } else { - $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}); + $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}, { package_defined_in => $options{definition_context}->{package} }); (defined $type_constraint) || $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: - # this doesn't apply to Class::MOP::Attributes, + # this doesn't apply to Class::MOP::Attributes, # 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); - + # 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(%actual_options); + $self->clone(%options); } sub clone { my ( $self, %params ) = @_; - my $class = $params{metaclass} || ref $self; - - if ( 0 and $class eq ref $self ) { - return $self->SUPER::clone(%params); - } else { - my ( @init, @non_init ); + my $class = delete $params{metaclass} || ref $self; - foreach my $attr ( grep { $_->has_value($self) } $self->meta->compute_all_applicable_attributes ) { - push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr; - } - - my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params ); + my ( @init, @non_init ); - my $name = delete $new_params{name}; + foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) { + push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr; + } - my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 ); + my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params ); - foreach my $attr ( @non_init ) { - $attr->set_value($clone, $attr->get_value($self)); - } + my $name = delete $new_params{name}; + my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 ); - return $clone; + foreach my $attr ( @non_init ) { + $attr->set_value($clone, $attr->get_value($self)); } + + return $clone; } sub _process_options { - my ($class, $name, $options) = @_; - - if (exists $options->{is}) { - - ### ------------------------- - ## 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}; + 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 ); +} + +sub _process_is_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{is}; + + ### ------------------------- + ## 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; - } - } 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 (eval { $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 ) = @_; - # 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}); - } - } - elsif (exists $options->{does}) { - # allow for anon-subtypes here ... - if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{does}; + return unless 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 { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does}); + $class->throw_error( + "Cannot have an isa option which cannot ->does() on attribute ($name)", + data => $options ); } } - 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}; + # allow for anon-subtypes here ... + if ( blessed( $options->{isa} ) + && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) { + $options->{type_constraint} = $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}); + else { + $options->{type_constraint} + = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint( + $options->{isa}, + { package_defined_in => $options->{definition_context}->{package} } + ); } +} - 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); - } +sub _process_does_option { + my ( $class, $name, $options ) = @_; - 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->{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}"; - } + return unless exists $options->{does} && ! exists $options->{isa}; + + # 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}, + { package_defined_in => $options->{definition_context}->{package} } + ); + } +} + +sub _process_coerce_option { + my ( $class, $name, $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}; - 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); + 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 ); +} - 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 _process_lazy_build_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{lazy_build}; + + $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 { @@ -384,7 +514,7 @@ sub initialize_instance_slot { my $value_is_set; if ( defined($init_arg) and exists $params->{$init_arg}) { $val = $params->{$init_arg}; - $value_is_set = 1; + $value_is_set = 1; } else { # skip it if it's lazy @@ -398,7 +528,7 @@ sub initialize_instance_slot { if ($self->has_default) { $val = $self->default($instance); $value_is_set = 1; - } + } elsif ($self->has_builder) { $val = $self->_call_builder($instance); $value_is_set = 1; @@ -407,17 +537,13 @@ sub initialize_instance_slot { return unless $value_is_set; - if ($self->has_type_constraint) { - my $type_constraint = $self->type_constraint; - if ($self->should_coerce && $type_constraint->has_coercion) { - $val = $type_constraint->coerce($val); - } - $self->verify_against_type_constraint($val, instance => $instance); - } + $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 { @@ -440,81 +566,266 @@ sub _call_builder { ## Slot management -# FIXME: -# this duplicates too much code from -# Class::MOP::Attribute, we need to -# refactor these bits eventually. -# - SL -sub _set_initial_slot_value { - my ($self, $meta_instance, $instance, $value) = @_; - - my $slot_name = $self->name; - - 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 = shift; - if ($type_constraint) { - $val = $type_constraint->coerce($val) - if $can_coerce; - $self->verify_against_type_constraint($val, object => $instance); - } - $meta_instance->set_slot_value($instance, $slot_name, $val); +sub _make_initializer_writer_callback { + my $self = shift; + my ($meta_instance, $instance, $slot_name) = @_; + my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_); + return sub { + $old_callback->($self->_coerce_and_verify($_[0], $instance)); }; - - my $initializer = $self->initializer; - - # most things will just want to set a value, so make it first arg - $instance->$initializer($value, $callback, $self); } sub set_value { my ($self, $instance, @args) = @_; my $value = $args[0]; - my $attr_name = $self->name; + my $attr_name = quotemeta($self->name); if ($self->is_required and not @args) { $self->throw_error("Attribute ($attr_name) is required", object => $instance); } - if ($self->has_type_constraint) { + $value = $self->_coerce_and_verify( $value, $instance ); - my $type_constraint = $self->type_constraint; + my @old; + if ( $self->has_trigger && $self->has_value($instance) ) { + @old = $self->get_value($instance, 'for trigger'); + } + + $self->SUPER::set_value($instance, $value); - if ($self->should_coerce) { - $value = $type_constraint->coerce($value); - } - $type_constraint->_compiled_type_constraint->($value) - || $self->throw_error("Attribute (" - . $self->name - . ") does not pass the type constraint because " - . $type_constraint->get_message($value), object => $instance, data => $value); + if ( ref $value && $self->is_weak_ref ) { + $self->_weaken_value($instance); } - my $meta_instance = Class::MOP::Class->initialize(blessed($instance)) - ->get_meta_instance; + if ($self->has_trigger) { + $self->trigger->($instance, $value, @old); + } +} + +sub _inline_set_value { + my $self = shift; + my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_; + + my $old = '@old'; + my $copy = '$val'; + $tc ||= '$type_constraint'; + $coercion ||= '$type_coercion'; + $message ||= '$type_message'; + + my @code; + if ($self->_writer_value_needs_copy) { + push @code, $self->_inline_copy_value($value, $copy); + $value = $copy; + } + + # constructors already handle required checks + push @code, $self->_inline_check_required + unless $for_constructor; + + push @code, $self->_inline_tc_code($value, $tc, $coercion, $message); + + # constructors do triggers all at once at the end + push @code, $self->_inline_get_old_value_for_trigger($instance, $old) + unless $for_constructor; + + push @code, ( + $self->SUPER::_inline_set_value($instance, $value), + $self->_inline_weaken_value($instance, $value), + ); + + # constructors do triggers all at once at the end + push @code, $self->_inline_trigger($instance, $value, $old) + unless $for_constructor; + + return @code; +} + +sub _writer_value_needs_copy { + my $self = shift; + return $self->should_coerce; +} + +sub _inline_copy_value { + my $self = shift; + my ($value, $copy) = @_; + + return 'my ' . $copy . ' = ' . $value . ';' +} + +sub _inline_check_required { + my $self = shift; + + return unless $self->is_required; + + my $attr_name = quotemeta($self->name); - $meta_instance->set_slot_value($instance, $attr_name, $value); + return ( + 'if (@_ < 2) {', + $self->_inline_throw_error( + '"Attribute (' . $attr_name . ') is required"' + ) . ';', + '}', + ); +} + +sub _inline_tc_code { + my $self = shift; + my ($value, $tc, $coercion, $message, $is_lazy) = @_; + return ( + $self->_inline_check_coercion( + $value, $tc, $coercion, $is_lazy, + ), + $self->_inline_check_constraint( + $value, $tc, $message, $is_lazy, + ), + ); +} - if (ref $value && $self->is_weak_ref) { - $meta_instance->weaken_slot_value($instance, $attr_name); +sub _inline_check_coercion { + my $self = shift; + my ($value, $tc, $coercion) = @_; + + return unless $self->should_coerce && $self->type_constraint->has_coercion; + + if ( $self->type_constraint->can_be_inlined ) { + return ( + 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', + $value . ' = ' . $coercion . '->(' . $value . ');', + '}', + ); + } + else { + return ( + 'if (!' . $tc . '->(' . $value . ')) {', + $value . ' = ' . $coercion . '->(' . $value . ');', + '}', + ); } +} - if ($self->has_trigger) { - $self->trigger->($instance, $value); +sub _inline_check_constraint { + my $self = shift; + my ($value, $tc, $message) = @_; + + return unless $self->has_type_constraint; + + my $attr_name = quotemeta($self->name); + + if ( $self->type_constraint->can_be_inlined ) { + return ( + 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', + $self->_inline_throw_error( + '"Attribute (' . $attr_name . ') does not pass the type ' + . 'constraint because: " . ' + . 'do { local $_ = ' . $value . '; ' + . $message . '->(' . $value . ')' + . '}', + 'data => ' . $value + ) . ';', + '}', + ); + } + else { + return ( + 'if (!' . $tc . '->(' . $value . ')) {', + $self->_inline_throw_error( + '"Attribute (' . $attr_name . ') does not pass the type ' + . 'constraint because: " . ' + . 'do { local $_ = ' . $value . '; ' + . $message . '->(' . $value . ')' + . '}', + 'data => ' . $value + ) . ';', + '}', + ); + } +} + +sub _inline_get_old_value_for_trigger { + my $self = shift; + my ($instance, $old) = @_; + + return unless $self->has_trigger; + + return ( + 'my ' . $old . ' = ' . $self->_inline_instance_has($instance), + '? ' . $self->_inline_instance_get($instance), + ': ();', + ); +} + +sub _inline_weaken_value { + my $self = shift; + my ($instance, $value) = @_; + + return unless $self->is_weak_ref; + + my $mi = $self->associated_class->get_meta_instance; + return ( + $mi->inline_weaken_slot_value($instance, $self->name), + 'if ref ' . $value . ';', + ); +} + +sub _inline_trigger { + my $self = shift; + my ($instance, $value, $old) = @_; + + return unless $self->has_trigger; + + return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');'; +} + +sub _eval_environment { + my $self = shift; + + my $env = { }; + + $env->{'$trigger'} = \($self->trigger) + if $self->has_trigger; + $env->{'$attr_default'} = \($self->default) + if $self->has_default; + + if ($self->has_type_constraint) { + my $tc_obj = $self->type_constraint; + + $env->{'$type_constraint'} = \( + $tc_obj->_compiled_type_constraint + ) unless $tc_obj->can_be_inlined; + # these two could probably get inlined versions too + $env->{'$type_coercion'} = \( + $tc_obj->coercion->_compiled_type_coercion + ) if $tc_obj->has_coercion; + $env->{'$type_message'} = \( + $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message + ); + + $env = { %$env, %{ $tc_obj->inline_environment } }; } + + # XXX ugh, fix these + $env->{'$attr'} = \$self + if $self->has_initializer && $self->is_lazy; + # pretty sure this is only going to be closed over if you use a custom + # error class at this point, but we should still get rid of this + # at some point + $env->{'$meta'} = \($self->associated_class); + + return $env; +} + +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)) { @@ -524,17 +835,18 @@ sub get_value { } elsif ( $self->has_builder ) { $value = $self->_call_builder($instance); } - if ($self->has_type_constraint) { - my $type_constraint = $self->type_constraint; - $value = $type_constraint->coerce($value) - if ($self->should_coerce); - $self->verify_against_type_constraint($value); - } + + $value = $self->_coerce_and_verify( $value, $instance ); + $self->set_initial_value($instance, $value); + + if ( ref $value && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } } } - if ($self->should_auto_deref) { + if ( $self->should_auto_deref && ! $for_trigger ) { my $type_constraint = $self->type_constraint; @@ -559,6 +871,147 @@ sub get_value { } } +sub _inline_get_value { + my $self = shift; + my ($instance, $tc, $coercion, $message) = @_; + + my $slot_access = $self->_inline_instance_get($instance); + $tc ||= '$type_constraint'; + $coercion ||= '$type_coercion'; + $message ||= '$type_message'; + + return ( + $self->_inline_check_lazy($instance, $tc, $coercion, $message), + $self->_inline_return_auto_deref($slot_access), + ); +} + +sub _inline_check_lazy { + my $self = shift; + my ($instance, $tc, $coercion, $message) = @_; + + return unless $self->is_lazy; + + my $slot_exists = $self->_inline_instance_has($instance); + + return ( + 'if (!' . $slot_exists . ') {', + $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'), + '}', + ); +} + +sub _inline_init_from_default { + my $self = shift; + my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_; + + if (!($self->has_default || $self->has_builder)) { + $self->throw_error( + 'You cannot have a lazy attribute ' + . '(' . $self->name . ') ' + . 'without specifying a default value for it', + attr => $self, + ); + } + + return ( + $self->_inline_generate_default($instance, $default), + # intentionally not using _inline_tc_code, since that can be overridden + # to do things like possibly only do member tc checks, which isn't + # appropriate for checking the result of a default + $self->has_type_constraint + ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy), + $self->_inline_check_constraint($default, $tc, $message, $for_lazy)) + : (), + $self->_inline_init_slot($instance, $default), + $self->_inline_weaken_value($instance, $default), + ); +} + +sub _inline_generate_default { + my $self = shift; + my ($instance, $default) = @_; + + if ($self->has_default) { + my $source = 'my ' . $default . ' = $attr_default'; + $source .= '->(' . $instance . ')' + if $self->is_default_a_coderef; + return $source . ';'; + } + elsif ($self->has_builder) { + my $builder = B::perlstring($self->builder); + my $builder_str = quotemeta($self->builder); + my $attr_name_str = quotemeta($self->name); + return ( + 'my ' . $default . ';', + 'if (my $builder = ' . $instance . '->can(' . $builder . ')) {', + $default . ' = ' . $instance . '->$builder;', + '}', + 'else {', + 'my $class = ref(' . $instance . ') || ' . $instance . ';', + $self->_inline_throw_error( + '"$class does not support builder method ' + . '\'' . $builder_str . '\' for attribute ' + . '\'' . $attr_name_str . '\'"' + ) . ';', + '}', + ); + } + else { + $self->throw_error( + "Can't generate a default for " . $self->name + . " since no default or builder was specified" + ); + } +} + +sub _inline_init_slot { + my $self = shift; + my ($inv, $value) = @_; + + if ($self->has_initializer) { + return '$attr->set_initial_value(' . $inv . ', ' . $value . ');'; + } + else { + return $self->_inline_instance_set($inv, $value) . ';'; + } +} + +sub _inline_return_auto_deref { + my $self = shift; + + return 'return ' . $self->_auto_deref(@_) . ';'; +} + +sub _auto_deref { + my $self = shift; + my ($ref_value) = @_; + + return $ref_value unless $self->should_auto_deref; + + my $type_constraint = $self->type_constraint; + + my $sigil; + if ($type_constraint->is_a_type_of('ArrayRef')) { + $sigil = '@'; + } + elsif ($type_constraint->is_a_type_of('HashRef')) { + $sigil = '%'; + } + else { + $self->throw_error( + 'Can not auto de-reference the type constraint \'' + . $type_constraint->name + . '\'', + type_constraint => $type_constraint, + ); + } + + return 'wantarray ' + . '? ' . $sigil . '{ (' . $ref_value . ') || return } ' + . ': (' . $ref_value . ')'; +} + ## installing accessors sub accessor_metaclass { 'Moose::Meta::Method::Accessor' } @@ -570,6 +1023,65 @@ sub install_accessors { return; } +sub _check_associated_methods { + my $self = shift; + unless ( + @{ $self->associated_methods } + || ($self->_is_metadata || '') eq 'bare' + ) { + Carp::cluck( + 'Attribute (' . $self->name . ') of class ' + . $self->associated_class->name + . ' has no associated methods' + . ' (did you mean to provide an "is" argument?)' + . "\n" + ) + } +} + +sub _process_accessors { + my $self = shift; + my ($type, $accessor, $generate_as_inline_methods) = @_; + + $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') + && $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->is_stub + && !$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" ); + } + + 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(@_); +} + sub remove_accessors { my $self = shift; $self->SUPER::remove_accessors(@_); @@ -590,13 +1102,17 @@ sub install_delegation { # install the delegation ... my $associated_class = $self->associated_class; - foreach my $handle (keys %handles) { + foreach my $handle (sort keys %handles) { my $method_to_call = $handles{$handle}; my $class_name = $associated_class->name; my $name = "${class_name}::${handle}"; - (!$associated_class->has_method($handle)) - || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle); + if ( my $method = $associated_class->get_method($handle) ) { + $self->throw_error( + "You cannot overwrite a locally defined method ($handle) with a delegation", + method_name => $handle + ) unless $method->is_stub; + } # NOTE: # handles is not allowed to delegate @@ -611,7 +1127,8 @@ sub install_delegation { my $method = $self->_make_delegation_method($handle, $method_to_call); $self->associated_class->add_method($method->name, $method); - } + $self->associate_method($method); + } } sub remove_delegation { @@ -619,6 +1136,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); } } @@ -644,49 +1164,29 @@ sub _canonicalize_handles { elsif ($handle_type eq 'CODE') { return $handles->($self, $self->_find_delegate_metaclass); } + 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) - unless Class::MOP::is_class_loaded($handles); - - my $role_meta = eval { $handles->meta }; - if ($@) { - $self->throw_error("Unable to canonicalize the 'handles' option with $handles because : $@", data => $handles, error => $@); - } - (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) - || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role", data => $handles); - - return map { $_ => $_ } ( - $role_meta->get_method_list, - $role_meta->get_required_method_list - ); - } -} + load_class($handles); + my $role_meta = Class::MOP::class_of($handles); -sub _find_delegate_metaclass { - my $self = shift; - if (my $class = $self->_isa_metadata) { - # if the class does have - # a meta method, use it - return $class->meta if $class->can('meta'); - # otherwise we might be - # dealing with a non-Moose - # class, and need to make - # our own metaclass - return Moose::Meta::Class->initialize($class); - } - elsif (my $role = $self->_does_metadata) { - # our role will always have - # a meta method - return $role->meta; - } - else { - $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name); - } + (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 { $_ => $_ } + map { $_->name } + grep { !$_->isa('Class::MOP::Method::Meta') } ( + $role_meta->_get_local_methods, + $role_meta->get_required_method_list, + ); } sub _get_delegate_method_list { @@ -694,7 +1194,7 @@ sub _get_delegate_method_list { 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' } + grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') } $meta->get_all_methods; } elsif ($meta->isa('Moose::Meta::Role')) { @@ -705,24 +1205,73 @@ sub _get_delegate_method_list { } } +sub _find_delegate_metaclass { + my $self = shift; + if (my $class = $self->_isa_metadata) { + unless ( 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 ( 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 { + $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name); + } +} + 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); + ($method_to_call, @curried_arguments) = @$method_to_call + if 'ARRAY' eq ref($method_to_call); return $self->delegation_metaclass->new( name => $handle_name, package_name => $self->associated_class->name, attribute => $self, delegate_to_method => $method_to_call, + curried_arguments => \@curried_arguments, ); } +sub _coerce_and_verify { + my $self = shift; + my $val = shift; + my $instance = shift; + + return $val unless $self->has_type_constraint; + + $val = $self->type_constraint->coerce($val) + if $self->should_coerce && $self->type_constraint->has_coercion; + + $self->verify_against_type_constraint($val, instance => $instance); + + return $val; +} + sub verify_against_type_constraint { my $self = shift; my $val = shift; @@ -743,53 +1292,189 @@ sub register_implementation { 'Moose::Meta::Attribute' } 1; +# ABSTRACT: The Moose attribute metaclass + __END__ =pod -=head1 NAME +=head1 DESCRIPTION -Moose::Meta::Attribute - The Moose attribute metaclass +This class is a subclass of L that provides +additional Moose-specific functionality. -=head1 DESCRIPTION +To really understand this class, you will need to start with the +L documentation. This class can be understood +as a set of additional features on top of the basic feature provided +by that parent class. -This is a subclass of L with Moose specific -extensions. +=head1 INHERITANCE -For the most part, the only time you will ever encounter an -instance of this class is if you are doing some serious deep -introspection. To really understand this class, you need to refer -to the L documentation. +C is a subclass of L. =head1 METHODS -=head2 Overridden methods +Many of the documented below override methods in +L and add Moose specific features. -These methods override methods in L and add -Moose specific features. You can safely assume though that they -will behave just as L does. +=head2 Creation =over 4 -=item B +=item B<< Moose::Meta::Attribute->new($name, %options) >> + +This method overrides the L constructor. + +Many of the options below are described in more detail in the +L document. + +It adds the following options to the constructor: + +=over 8 + +=item * is => 'ro', 'rw', 'bare' + +This provides a shorthand for specifying the C, C, or +C names. If the attribute is read-only ('ro') then it will +have a C method with the same attribute as the name. + +If it is read-write ('rw') then it will have an C method +with the same name. If you provide an explicit C for a +read-write attribute, then you will have a C with the same +name as the attribute, and a C with the name you provided. + +Use 'bare' when you are deliberately not installing any methods +(accessor, reader, etc.) associated with this attribute; otherwise, +Moose will issue a deprecation warning when this attribute is added to a +metaclass. + +=item * isa => $type + +This option accepts a type. The type can be a string, which should be +a type name. If the type name is unknown, it is assumed to be a class +name. + +This option can also accept a L object. + +If you I provide a C option, then your C option must +be a class name, and that class must do the role specified with +C. + +=item * does => $role + +This is short-hand for saying that the attribute's type must be an +object which does the named role. + +=item * coerce => $bool + +This option is only valid for objects with a type constraint +(C) that defined a coercion. If this is true, then coercions will be applied whenever +this attribute is set. -=item B +You can make both this and the C option true. -=item B +=item * trigger => $sub -=item B +This option accepts a subroutine reference, which will be called after +the attribute is set. -=item B +=item * required => $bool -=item B +An attribute which is required must be provided to the constructor. An +attribute which is required can also have a C or C, +which will satisfy its required-ness. -=item B +A required attribute must have a C, C or a +non-C C -=item B +=item * lazy => $bool -=item B +A lazy attribute must have a C or C. When an +attribute is lazy, the default value will not be calculated until the +attribute is read. -=item B +=item * weak_ref => $bool + +If this is true, the attribute's value will be stored as a weak +reference. + +=item * auto_deref => $bool + +If this is true, then the reader will dereference the value when it is +called. The attribute must have a type constraint which defines the +attribute as an array or hash reference. + +=item * lazy_build => $bool + +Setting this to true makes the attribute lazy and provides a number of +default methods. + + has 'size' => ( + is => 'ro', + lazy_build => 1, + ); + +is equivalent to this: + + has 'size' => ( + is => 'ro', + lazy => 1, + builder => '_build_size', + clearer => 'clear_size', + 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<< +$attr->documentation >>. + +=back + +=item B<< $attr->clone(%options) >> + +This creates a new attribute based on attribute being cloned. You must +supply a C option to provide a new name for the attribute. + +The C<%options> can only specify options handled by +L. + +=back + +=head2 Value management + +=over 4 + +=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >> + +This method is used internally to initialize the attribute's slot in +the object C<$instance>. + +This overrides the L method to handle lazy +attributes, weak references, and type constraints. =item B @@ -804,175 +1489,191 @@ 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. Any coercion to convert values is done before checking the type constraint. To check a value against a type constraint before setting it, fetch the attribute instance using L, fetch the type_constraint from the attribute using L -and call L. See L +and call L. See L for an example. =back -=head2 Additional Moose features - -Moose attributes support type-constraint checking, weak reference -creation and type coercion. +=head2 Attribute Accessor generation =over 4 -=item B +=item B<< $attr->install_accessors >> -Delegates to C or C if there is none. +This method overrides the parent to also install delegation methods. -=item B +If, after installing all methods, the attribute object has no associated +methods, it throws an error unless C<< is => 'bare' >> was passed to the +attribute constructor. (Trying to add an attribute that has no associated +methods is almost always an error.) -=item B +=item B<< $attr->remove_accessors >> -When called as a class method causes interpretation of the C and -C options. +This method overrides the parent to also remove delegation methods. -=item B +=item B<< $attr->inline_set($instance_var, $value_var) >> -This is to support the C feature, it clones an attribute -from a superclass and allows a very specific set of changes to be made -to the attribute. +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 +=item B<< $attr->install_delegation >> -Whitelist with options you can change. You can overload it in your custom -metaclass to allow your options be inheritable. +This method adds its delegation methods to the attribute's associated +class, if it has any to add. -=item B +=item B<< $attr->remove_delegation >> -Returns true if this meta-attribute has a type constraint. +This method remove its delegation methods from the attribute's +associated class. -=item B +=item B<< $attr->accessor_metaclass >> -A read-only accessor for this meta-attribute's type constraint. For -more information on what you can do with this, see the documentation -for L. +Returns the accessor metaclass name, which defaults to +L. -=item B +=item B<< $attr->delegation_metaclass >> -Verifies that the given value is valid under this attribute's type -constraint, otherwise throws an error. +Returns the delegation metaclass name, which defaults to +L. -=item B +=back -Returns true if this meta-attribute performs delegation. +=head2 Additional Moose features -=item B +These methods are not found in the superclass. They support features +provided by Moose. -This returns the value which was passed into the handles option. +=over 4 -=item B +=item B<< $attr->does($role) >> -Returns true if this meta-attribute produces a weak reference. +This indicates whether the I does the given +role. The role can be given as a full class name, or as a resolvable +trait name. -=item B +Note that this checks the attribute itself, not its type constraint, +so it is checking the attribute's metaclass and any traits applied to +the attribute. -Returns true if this meta-attribute is required to have a value. +=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >> -=item B +This is an alternate constructor that handles the C and +C options. -Returns true if this meta-attribute should be initialized lazily. +Effectively, this method is a factory that finds or creates the +appropriate class for the given C and/or C. -NOTE: lazy attributes, B have a C or C field set. +Once it has the appropriate class, it will call C<< $class->new($name, +%options) >> on that class. -=item B +=item B<< $attr->clone_and_inherit_options(%options) >> -Returns true if this meta-attribute should be initialized lazily through -the builder generated by lazy_build. Using C 1> will -make your attribute required and lazy. In addition it will set the builder, clearer -and predicate options for you using the following convention. +This method supports the C feature. It does various bits +of processing on the supplied C<%options> before ultimately calling +the C method. - #If your attribute name starts with an underscore: - has '_foo' => (lazy_build => 1); - #is the same as - has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo'); - # or - has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo}); +One of its main tasks is to make sure that the C<%options> provided +does not include the options returned by the +C method. - #If your attribute name does not start with an underscore: - has 'foo' => (lazy_build => 1); - #is the same as - has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo'); - # or - has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo}); +=item B<< $attr->illegal_options_for_inheritance >> -The reason for the different naming of the C is that the C -method is a private method while the C and C methods -are public methods. +This returns a blacklist of options that can not be overridden in a +subclass's attribute definition. -NOTE: This means your class should provide a method whose name matches the value -of the builder part, in this case _build__foo or _build_foo. +This exists to allow a custom metaclass to change or add to the list +of options which can not be changed. -=item B +=item B<< $attr->type_constraint >> -Returns true if this meta-attribute should perform type coercion. +Returns the L object for this attribute, +if it has one. -=item B +=item B<< $attr->has_type_constraint >> -Returns true if this meta-attribute should perform automatic -auto-dereferencing. +Returns true if this attribute has a type constraint. -NOTE: This can only be done for attributes whose type constraint is -either I or I. +=item B<< $attr->verify_against_type_constraint($value) >> -=item B +Given a value, this method returns true if the value is valid for the +attribute's type constraint. If the value is not valid, it throws an +error. -Returns true if this meta-attribute has a trigger set. +=item B<< $attr->handles >> -=item B +This returns the value of the C option passed to the +constructor. -This is a CODE reference which will be executed every time the -value of an attribute is assigned. The CODE ref will get two values, -the invocant and the new value. This can be used to handle I -bi-directional relations. +=item B<< $attr->has_handles >> -=item B +Returns true if this attribute performs delegation. -This is a string which contains the documentation for this attribute. -It serves no direct purpose right now, but it might in the future -in some kind of automated documentation system perhaps. +=item B<< $attr->is_weak_ref >> -=item B +Returns true if this attribute stores its value as a weak reference. -Returns true if this meta-attribute has any documentation. +=item B<< $attr->is_required >> -=item B +Returns true if this attribute is required to have a value. -This will return the ARRAY ref of all the traits applied to this -attribute, or if no traits have been applied, it returns C. +=item B<< $attr->is_lazy >> -=item B +Returns true if this attribute is lazy. -Returns true if this meta-attribute has any traits applied. +=item B<< $attr->is_lazy_build >> -=back +Returns true if the C option was true when passed to the +constructor. -=head1 BUGS +=item B<< $attr->should_coerce >> -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. +Returns true if the C option passed to the constructor was +true. -=head1 AUTHOR +=item B<< $attr->should_auto_deref >> -Stevan Little Estevan@iinteractive.comE +Returns true if the C option passed to the constructor was +true. -Yuval Kogman Enothingmuch@woobling.comE +=item B<< $attr->trigger >> -=head1 COPYRIGHT AND LICENSE +This is the subroutine reference that was in the C option +passed to the constructor, if any. -Copyright 2006-2009 by Infinity Interactive, Inc. +=item B<< $attr->has_trigger >> -L +Returns true if this attribute has a trigger set. + +=item B<< $attr->documentation >> + +Returns the value that was in the C option passed to +the constructor, if any. + +=item B<< $attr->has_documentation >> + +Returns true if this attribute has any documentation. + +=item B<< $attr->applied_traits >> + +This returns an array reference of all the traits which were applied +to this attribute. If none were applied, this returns C. + +=item B<< $attr->has_applied_traits >> + +Returns true if this attribute has any traits applied. + +=back + +=head1 BUGS -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +See L for details on reporting bugs. =cut