X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=56f3bc90b43ffd0ce47748d09ff9caa9079c6d03;hb=9f4682583eaf20565077ca8e95ba55a9cb6496a2;hp=443b31a5b8e813cadd124fb863df4cd9d6a2e083;hpb=d67398abd3303d2fb8ed67d78313a202dec7283b;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 443b31a..56f3bc9 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -4,25 +4,28 @@ 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 = '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'); + __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 @@ -38,20 +41,46 @@ sub does { 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 = @@ -100,6 +129,8 @@ sub interpolate_class { 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 @@ -112,17 +143,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; } } @@ -175,7 +217,7 @@ 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}); } @@ -189,7 +231,7 @@ sub clone_and_inherit_options { $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}); } @@ -209,6 +251,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); } @@ -237,121 +284,210 @@ 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 ); +} + +sub _process_is_option { + my ( $class, $name, $options ) = @_; - if (exists $options->{is}) { + 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 - ### ------------------------- + ### ------------------------- + ## 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}; + 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}, + { package_defined_in => $options->{definition_context}->{package} } + ); + } +} - 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; + return unless exists $options->{does} && ! exists $options->{isa}; - Moose::Deprecated::deprecated( - feature => 'coerce without coercion', - message => - "You cannot coerce an attribute ($name) unless its type ($type) has a coercion" - ); - } + # allow for anon-subtypes here ... + if ( blessed( $options->{does} ) + && $options->{does}->isa('Moose::Meta::TypeConstraint') ) { + $options->{type_constraint} = $options->{does}; } - - 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_does_type_constraint( + $options->{does}, + { 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_coerce_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->{builder} ||= "_build_${name}"; - if ($name =~ /^_/) { - $options->{clearer} ||= "_clear${name}"; - $options->{predicate} ||= "_has${name}"; - } - else { - $options->{clearer} ||= "clear_${name}"; - $options->{predicate} ||= "has_${name}"; - } - } + return unless $options->{coerce}; - 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); + ( 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" + ); } +} - 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_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}; + + $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 { @@ -415,36 +551,20 @@ 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 $callback = sub { - my $val = $self->_coerce_and_verify( shift, $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); @@ -468,6 +588,218 @@ sub set_value { } } +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); + + 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, + ), + ); +} + +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 . ');', + '}', + ); + } +} + +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 ) = @_; @@ -492,6 +824,10 @@ sub get_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); + } } } @@ -520,6 +856,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' } @@ -550,23 +1027,43 @@ 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->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" - ); + . "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(@_); } @@ -577,46 +1074,6 @@ sub remove_accessors { return; } -sub inline_get { - my $self = shift; - my ($instance) = @_; - - return $self->associated_class->get_meta_instance->inline_get_slot_value( - $instance, $self->slots ); -} - -sub inline_access { - my $self = shift; - my ($instance) = @_; - - return $self->associated_class->get_meta_instance->inline_slot_access( - $instance, $self->slots ); -} - -sub inline_has { - my $self = shift; - my ($instance) = @_; - - $self->associated_class->get_meta_instance->inline_is_slot_initialized( - $instance, $self->slots ); -} - -sub inline_store { - 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 $self->is_weak_ref; - - return $code; -} - sub install_delegation { my $self = shift; @@ -630,13 +1087,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 @@ -699,28 +1160,62 @@ sub _canonicalize_handles { } } - Class::MOP::load_class($handles); + 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 { $_ => $_ } - 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 ( 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 { @@ -728,22 +1223,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 { @@ -798,14 +1277,12 @@ sub register_implementation { 'Moose::Meta::Attribute' } 1; +# ABSTRACT: The Moose attribute metaclass + __END__ =pod -=head1 NAME - -Moose::Meta::Attribute - The Moose attribute metaclass - =head1 DESCRIPTION This class is a subclass of L that provides @@ -829,7 +1306,7 @@ L and add Moose specific features. =over 4 -=item B<< Moose::Meta::Attribute->new(%options) >> +=item B<< Moose::Meta::Attribute->new($name, %options) >> This method overrides the L constructor. @@ -932,6 +1409,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<< @@ -974,14 +1474,14 @@ 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 @@ -1003,13 +1503,11 @@ methods is almost always an error.) This method overrides the parent to also remove delegation methods. -=item B<< $attr->inline_get >> +=item B<< $attr->inline_set($instance_var, $value_var) >> -=item B<< $attr->inline_access >> - -=item B<< $attr->inline_has >> - -=item B<< $attr->inline_store >> +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 >> @@ -1163,19 +1661,4 @@ Returns true if this attribute has any traits applied. See L for details on reporting bugs. -=head1 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -Yuval Kogman Enothingmuch@woobling.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2010 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - =cut