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=fe6193a3e5c686e118617182c43d5f5063d4e68a;hpb=684323b3669a4d2f774e5e4482e25ca9dd90d818;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index fe6193a..56f3bc9 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -4,54 +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 = '0.92'; -our $AUTHORITY = 'cpan:STEVAN'; - +use Moose::Deprecated; use Moose::Meta::Method::Accessor; use Moose::Meta::Method::Delegation; use Moose::Util (); use Moose::Util::TypeConstraints (); +use Class::MOP::MiniTrait; + +use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); -use base 'Class::MOP::Attribute'; - -# options which are not directly used -# but we store them for metadata purposes -__PACKAGE__->meta->add_attribute('isa' => (reader => '_isa_metadata')); -__PACKAGE__->meta->add_attribute('does' => (reader => '_does_metadata')); -__PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata')); - -# these are actual options for the attrs -__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' )); -__PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' )); -__PACKAGE__->meta->add_attribute('lazy_build' => (reader => 'is_lazy_build' )); -__PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' )); -__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' )); -__PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref')); -__PACKAGE__->meta->add_attribute('type_constraint' => ( - reader => 'type_constraint', - predicate => 'has_type_constraint', -)); -__PACKAGE__->meta->add_attribute('trigger' => ( - reader => 'trigger', - predicate => 'has_trigger', -)); -__PACKAGE__->meta->add_attribute('handles' => ( - reader => 'handles', - writer => '_set_handles', - predicate => 'has_handles', -)); -__PACKAGE__->meta->add_attribute('documentation' => ( - reader => 'documentation', - predicate => 'has_documentation', -)); __PACKAGE__->meta->add_attribute('traits' => ( reader => 'applied_traits', predicate => 'has_applied_traits', + Class::MOP::_definition_context(), )); # we need to have a ->does method in here to @@ -67,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 = @@ -129,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 @@ -141,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; } } @@ -161,15 +174,10 @@ sub interpolate_class { # ... -my @legal_options_for_inheritance = qw( - default coerce required - documentation lazy handles - builder type_constraint - definition_context - lazy_build weak_ref -); - -sub legal_options_for_inheritance { @legal_options_for_inheritance } +# method-generating options shouldn't be overridden +sub illegal_options_for_inheritance { + qw(reader writer accessor clearer predicate) +} # NOTE/TODO # This method *must* be able to handle @@ -188,10 +196,6 @@ sub legal_options_for_inheritance { @legal_options_for_inheritance } sub clone_and_inherit_options { my ($self, %options) = @_; - my %copy = %options; - - my %actual_options; - # NOTE: # we may want to extends a Class::MOP::Attribute # in which case we need to be able to use the @@ -199,16 +203,13 @@ sub clone_and_inherit_options { # been here. But we allows Moose::Meta::Attribute # instances to changes them. # - SL - my @legal_options = $self->can('legal_options_for_inheritance') - ? $self->legal_options_for_inheritance - : @legal_options_for_inheritance; - - foreach my $legal_option (@legal_options) { - if (exists $options{$legal_option}) { - $actual_options{$legal_option} = $options{$legal_option}; - delete $options{$legal_option}; - } - } + my @illegal_options = $self->can('illegal_options_for_inheritance') + ? $self->illegal_options_for_inheritance + : (); + + my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options; + (scalar @found_illegal_options == 0) + || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options); if ($options{isa}) { my $type_constraint; @@ -216,13 +217,12 @@ 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}) { @@ -231,13 +231,12 @@ 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}); } - $actual_options{type_constraint} = $type_constraint; - delete $options{does}; + $options{type_constraint} = $type_constraint; } # NOTE: @@ -245,20 +244,19 @@ sub clone_and_inherit_options { # so we can ignore it for them. # - SL if ($self->can('interpolate_class')) { - ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(\%options); + ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options); my %seen; my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits; - $actual_options{traits} = \@all_traits if @all_traits; - - delete @options{qw(metaclass traits)}; + $options{traits} = \@all_traits if @all_traits; } - (scalar keys %options == 0) - || $self->throw_error("Illegal inherited options => (" . (join ', ' => keys %options) . ")", data => \%options); + # 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 { @@ -286,111 +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 ) = @_; - # 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->{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}; + + unless ( $options->{type_constraint}->has_coercion ) { + my $type = $options->{type_constraint}->name; - 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); + 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}; - 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); + ( 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 { @@ -454,42 +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 ($type_constraint, $can_coerce); - if ($self->has_type_constraint) { - $type_constraint = $self->type_constraint; - $can_coerce = ($self->should_coerce && $type_constraint->has_coercion); - } - - my $callback = sub { - my $val = $self->_coerce_and_verify( shift, $instance );; - - $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); @@ -513,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 ) = @_; @@ -537,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); + } } } @@ -565,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' } @@ -595,16 +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 ) ) { + + Carp::cluck( + "You are overwriting a locally defined function ($accessor) with " + . "an accessor" ); } + $self->SUPER::_process_accessors(@_); } @@ -628,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 @@ -689,39 +1152,26 @@ sub _canonicalize_handles { elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) { return map { $_ => $_ } @{ $handles->methods }; } + elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) { + $handles = $handles->role; + } else { $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles); } } - else { - Class::MOP::load_class($handles); - my $role_meta = Class::MOP::class_of($handles); - (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) - || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles); + load_class($handles); + my $role_meta = Class::MOP::class_of($handles); - return map { $_ => $_ } - grep { $_ ne 'meta' } ( - $role_meta->get_method_list, - map { $_->name } $role_meta->get_required_method_list, - ); - } -} + (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) + || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles); -sub _find_delegate_metaclass { - my $self = shift; - if (my $class = $self->_isa_metadata) { - # we might be dealing with a non-Moose class, - # and need to make our own metaclass. if there's - # already a metaclass, it will be returned - return Moose::Meta::Class->initialize($class); - } - elsif (my $role = $self->_does_metadata) { - return Class::MOP::class_of($role); - } - else { - $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name); - } + 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 { @@ -729,7 +1179,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')) { @@ -740,6 +1190,39 @@ 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 { @@ -766,10 +1249,8 @@ sub _coerce_and_verify { return $val unless $self->has_type_constraint; - my $type_constraint = $self->type_constraint; - if ($self->should_coerce && $type_constraint->has_coercion) { - $val = $type_constraint->coerce($val); - } + $val = $self->type_constraint->coerce($val) + if $self->should_coerce && $self->type_constraint->has_coercion; $self->verify_against_type_constraint($val, instance => $instance); @@ -796,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 @@ -827,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. @@ -874,7 +1353,7 @@ object which does the named role. =item * coerce => $bool This option is only valid for objects with a type constraint -(C). If this is true, then coercions will be applied whenever +(C) that defined a coercion. If this is true, then coercions will be applied whenever this attribute is set. You can make both this and the C option true. @@ -930,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<< @@ -972,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 @@ -1001,6 +1503,12 @@ methods is almost always an error.) This method overrides the parent to also remove delegation methods. +=item B<< $attr->inline_set($instance_var, $value_var) >> + +This method return a code snippet suitable for inlining the relevant +operation. It expect strings containing variable names to be used in the +inlining, like C<'$self'> or C<'$_[1]'>. + =item B<< $attr->install_delegation >> This method adds its delegation methods to the attribute's associated @@ -1058,16 +1566,16 @@ of processing on the supplied C<%options> before ultimately calling the C method. One of its main tasks is to make sure that the C<%options> provided -only includes the options returned by the -C method. +does not include the options returned by the +C method. -=item B<< $attr->legal_options_for_inheritance >> +=item B<< $attr->illegal_options_for_inheritance >> -This returns a whitelist of options that can be overridden in a +This returns a blacklist of options that can not be overridden in a subclass's attribute definition. This exists to allow a custom metaclass to change or add to the list -of options which can be changed. +of options which can not be changed. =item B<< $attr->type_constraint >> @@ -1151,23 +1659,6 @@ Returns true if this attribute has any traits applied. =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. - -=head1 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -Yuval Kogman Enothingmuch@woobling.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2009 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. +See L for details on reporting bugs. =cut