diff options
Diffstat (limited to 'lib/Moose/Meta/Attribute.pm')
| -rw-r--r-- | lib/Moose/Meta/Attribute.pm | 1734 |
1 files changed, 1734 insertions, 0 deletions
diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm new file mode 100644 index 0000000..0c91693 --- /dev/null +++ b/lib/Moose/Meta/Attribute.pm @@ -0,0 +1,1734 @@ +use strict; +use warnings; +package Moose::Meta::Attribute; +our $VERSION = '2.1405'; + +use B (); +use Scalar::Util 'blessed'; +use List::Util 1.33 'any'; +use Try::Tiny; +use overload (); + +use Moose::Deprecated; +use Moose::Meta::Method::Accessor; +use Moose::Meta::Method::Delegation; +use Moose::Util 'throw_exception'; +use Moose::Util::TypeConstraints (); +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore'; + +use Carp 'confess'; + +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 +# 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 = 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 _inline_throw_exception { + my ( $self, $exception_type, $throw_args ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::' . $exception_type . '")->new(' . ($throw_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 = shift; + my $name = shift; + + throw_exception( MustPassEvenNumberOfAttributeOptions => attribute_name => $name, + options => \@_ + ) + if @_ % 2 == 1; + + my %args = @_; + + my ( $new_class, @traits ) = $class->interpolate_class(\%args); + $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) ); +} + +sub interpolate_class { + my ($class, $options) = @_; + + $class = ref($class) || $class; + + 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); + } else { + $class = $new_class; + } + } + } + + my @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 + + $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait) + || $trait; + + next if $class->does($trait); + + push @traits, $trait; + + # are there options? + 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 %options = ( + superclasses => [ $class ], + roles => [ @traits ], + ); + + 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; + } + } + + return ( wantarray ? ( $class, @traits ) : $class ); +} + +# ... + +# 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 +# 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 +# be my guest. +# - stevan +sub clone_and_inherit_options { + my ($self, %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 + # been here. But we allows Moose::Meta::Attribute + # instances to changes them. + # - SL + 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) + || throw_exception( IllegalInheritedOptions => illegal_options => \@found_illegal_options, + params => \%options + ); + + $self->_process_isa_option( $self->name, \%options ); + $self->_process_does_option( $self->name, \%options ); + + # NOTE: + # this doesn't apply to Class::MOP::Attributes, + # so we can ignore it for them. + # - SL + if ($self->can('interpolate_class')) { + ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options); + + my %seen; + my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits; + $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); +} + +sub clone { + my ( $self, %params ) = @_; + + my $class = delete $params{metaclass} || ref $self; + + my ( @init, @non_init ); + + 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 %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params ); + + my $name = delete $new_params{name}; + + my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 ); + + foreach my $attr ( @non_init ) { + $attr->set_value($clone, $attr->get_value($self)); + } + + return $clone; +} + +sub _process_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 ) = @_; + + 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' ) { + throw_exception("AccessorMustReadWrite" => attribute_name => $name, + params => $options, + ) + if exists $options->{accessor}; + $options->{reader} ||= $name; + } + elsif ( $options->{is} eq 'rw' ) { + if ( $options->{writer} ) { + $options->{reader} ||= $name; + } + else { + $options->{accessor} ||= $name; + } + } + elsif ( $options->{is} eq 'bare' ) { + return; + # do nothing, but don't complain (later) about missing methods + } + else { + throw_exception( InvalidValueForIs => attribute_name => $name, + params => $options, + ); + } +} + +sub _process_isa_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{isa}; + + if ( exists $options->{does} ) { + if ( try { $options->{isa}->can('does') } ) { + ( $options->{isa}->does( $options->{does} ) ) + || throw_exception( IsaDoesNotDoTheRole => attribute_name => $name, + params => $options, + ); + } + else { + throw_exception( IsaLacksDoesMethod => attribute_name => $name, + params => $options, + ); + } + } + + # allow for anon-subtypes here ... + # + # Checking for Specio explicitly is completely revolting. At some point + # this needs to be refactored so that Moose core defines a standard type + # API that all types must implement. Unfortunately, the current core API + # is _not_ the right API, so we probably need to A) come up with the new + # API (Specio is a good start); B) refactor the core types to implement + # that API; C) do duck type checking on type objects. + if ( blessed( $options->{isa} ) + && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) { + $options->{type_constraint} = $options->{isa}; + } + elsif ( + blessed( $options->{isa} ) + && $options->{isa}->can('does') + && $options->{isa}->does('Specio::Constraint::Role::Interface') + ) { + $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} } + ); + } +} + +sub _process_does_option { + my ( $class, $name, $options ) = @_; + + 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} ) + || throw_exception( CoercionNeedsTypeConstraint => attribute_name => $name, + params => $options, + ); + + throw_exception( CannotCoerceAWeakRef => attribute_name => $name, + params => $options, + ) + if $options->{weak_ref}; + + unless ( $options->{type_constraint}->has_coercion ) { + my $type = $options->{type_constraint}->name; + + throw_exception( CannotCoerceAttributeWhichHasNoCoercion => attribute_name => $name, + type_name => $type, + params => $options + ); + } +} + +sub _process_trigger_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{trigger}; + + ( 'CODE' eq ref $options->{trigger} ) + || throw_exception( TriggerMustBeACodeRef => attribute_name => $name, + params => $options, + ); +} + +sub _process_auto_deref_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{auto_deref}; + + ( exists $options->{type_constraint} ) + || throw_exception( CannotAutoDerefWithoutIsa => attribute_name => $name, + params => $options, + ); + + ( $options->{type_constraint}->is_a_type_of('ArrayRef') + || $options->{type_constraint}->is_a_type_of('HashRef') ) + || throw_exception( AutoDeRefNeedsArrayRefOrHashRef => attribute_name => $name, + params => $options, + ); +} + +sub _process_lazy_build_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{lazy_build}; + + throw_exception( CannotUseLazyBuildAndDefaultSimultaneously => attribute_name => $name, + params => $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} ) + || throw_exception( LazyAttributeNeedsADefault => params => $options, + attribute_name => $name, + ); +} + +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} + ) + ) { + throw_exception( RequiredAttributeNeedsADefault => params => $options, + attribute_name => $name, + ); + } +} + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + my $init_arg = $self->init_arg(); + # try to fetch the init arg from the %params ... + + my $val; + my $value_is_set; + if ( defined($init_arg) and exists $params->{$init_arg}) { + $val = $params->{$init_arg}; + $value_is_set = 1; + } + else { + # skip it if it's lazy + return if $self->is_lazy; + # and die if it's required and doesn't have a default value + my $class_name = blessed( $instance ); + throw_exception(AttributeIsRequired => attribute_name => $self->name, + class_name => $class_name, + params => $params, + ) + if $self->is_required && !$self->has_default && !$self->has_builder; + + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + 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; + } + } + + return unless $value_is_set; + + $val = $self->_coerce_and_verify( $val, $instance ); + + $self->set_initial_value($instance, $val); + + if ( ref $val && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } +} + +sub _call_builder { + my ( $self, $instance ) = @_; + + my $builder = $self->builder(); + + return $instance->$builder() + if $instance->can( $self->builder ); + + throw_exception( BuilderDoesNotExist => instance => $instance, + attribute => $self, + ); +} + +## Slot management + +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)); + }; +} + +sub set_value { + my ($self, $instance, @args) = @_; + my $value = $args[0]; + + my $attr_name = quotemeta($self->name); + + my $class_name = blessed( $instance ); + if ($self->is_required and not @args) { + throw_exception( AttributeIsRequired => attribute_name => $self->name, + class_name => $class_name, + ); + } + + $value = $self->_coerce_and_verify( $value, $instance ); + + my @old; + if ( $self->has_trigger && $self->has_value($instance) ) { + @old = $self->get_value($instance, 'for trigger'); + } + + $self->SUPER::set_value($instance, $value); + + if ( ref $value && $self->is_weak_ref ) { + $self->_weaken_value($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); + + return ( + 'if (@_ < 2) {', + $self->_inline_throw_exception( AttributeIsRequired => + 'attribute_name => "'.$attr_name.'",'. + 'class_name => $class_name' + ) . ';', + '}', + ); +} + +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) . ')) {', + 'my $msg = do { local $_ = ' . $value . '; ' + . $message . '->(' . $value . ');' + . '};'. + $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint => + 'type_constraint_message => $msg , '. + 'class_name => $class_name, '. + 'attribute_name => "'.$attr_name.'",'. + 'value => '.$value + ).';', + '}', + ); + } + else { + return ( + 'if (!' . $tc . '->(' . $value . ')) {', + 'my $msg = do { local $_ = ' . $value . '; ' + . $message . '->(' . $value . ');' + . '};'. + $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint => + 'type_constraint_message => $msg , '. + 'class_name => $class_name, '. + 'attribute_name => "'.$attr_name.'",'. + 'value => '.$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 } }; + } + + $env->{'$class_name'} = \($self->associated_class->name); + + # 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, $for_trigger) = @_; + + if ($self->is_lazy) { + unless ($self->has_value($instance)) { + my $value; + if ($self->has_default) { + $value = $self->default($instance); + } elsif ( $self->has_builder ) { + $value = $self->_call_builder($instance); + } + + $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 && ! $for_trigger ) { + + my $type_constraint = $self->type_constraint; + + if ($type_constraint->is_a_type_of('ArrayRef')) { + my $rv = $self->SUPER::get_value($instance); + return unless defined $rv; + return wantarray ? @{ $rv } : $rv; + } + elsif ($type_constraint->is_a_type_of('HashRef')) { + my $rv = $self->SUPER::get_value($instance); + return unless defined $rv; + return wantarray ? %{ $rv } : $rv; + } + else { + throw_exception( CannotAutoDereferenceTypeConstraint => type_name => $type_constraint->name, + instance => $instance, + attribute => $self + ); + } + + } + else { + + return $self->SUPER::get_value($instance); + } +} + +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)) { + throw_exception( LazyAttributeNeedsADefault => attribute => $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_exception( + BuilderMethodNotSupportedForInlineAttribute => + 'class_name => $class,'. + 'attribute_name => "'.$attr_name_str.'",'. + 'instance => '.$instance.','. + 'builder => "'.$builder_str.'"' + ) . ';', + '}', + ); + } + else { + confess( + "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 { + confess( + 'Can not auto de-reference the type constraint \'' + . $type_constraint->name + . '\'' + ); + } + + return 'wantarray ' + . '? ' . $sigil . '{ (' . $ref_value . ') || return } ' + . ': (' . $ref_value . ')'; +} + +## installing accessors + +sub accessor_metaclass { 'Moose::Meta::Method::Accessor' } + +sub install_accessors { + my $self = shift; + $self->SUPER::install_accessors(@_); + $self->install_delegation if $self->has_handles; + 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(@_); + $self->remove_delegation if $self->has_handles; + return; +} + +sub install_delegation { + my $self = shift; + + # NOTE: + # Here we canonicalize the 'handles' option + # this will sort out any details and always + # return an hash of methods which we want + # to delagate to, see that method for details + my %handles = $self->_canonicalize_handles; + + # install the delegation ... + my $associated_class = $self->associated_class; + my $class_name = $associated_class->name; + + foreach my $handle ( sort keys %handles ) { + my $method_to_call = $handles{$handle}; + my $name = "${class_name}::${handle}"; + + if ( my $method = $associated_class->get_method($handle) ) { + throw_exception( + CannotDelegateLocalMethodIsPresent => attribute => $self, + method => $method, + ) unless $method->is_stub; + } + + # NOTE: + # handles is not allowed to delegate + # any of these methods, as they will + # override the ones in your class, which + # is almost certainly not what you want. + + # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something + #cluck("Not delegating method '$handle' because it is a core method") and + next + if $class_name->isa("Moose::Object") + and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle); + + 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 { + my $self = shift; + 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); + } +} + +# private methods to help delegation ... + +sub _canonicalize_handles { + my $self = shift; + my $handles = $self->handles; + if (my $handle_type = ref($handles)) { + if ($handle_type eq 'HASH') { + return %{$handles}; + } + elsif ($handle_type eq 'ARRAY') { + return map { $_ => $_ } @{$handles}; + } + elsif ($handle_type eq 'Regexp') { + ($self->has_type_constraint) + || throw_exception( CannotDelegateWithoutIsa => attribute => $self ); + return map { ($_ => $_) } + grep { /$handles/ } $self->_get_delegate_method_list; + } + 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 { + throw_exception( UnableToCanonicalizeHandles => attribute => $self, + handles => $handles + ); + } + } + + Moose::Util::_load_user_class($handles); + my $role_meta = Class::MOP::class_of($handles); + + (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) + || throw_exception( UnableToCanonicalizeNonRolePackage => attribute => $self, + handles => $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 { + 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 { + throw_exception( UnableToRecognizeDelegateMetaclass => attribute => $self, + delegate_metaclass => $meta + ); + } +} + +sub _find_delegate_metaclass { + my $self = shift; + my $class = $self->_isa_metadata; + my $role = $self->_does_metadata; + + if ( $class ) { + # make sure isa is actually a class + unless ( $self->type_constraint->isa("Moose::Meta::TypeConstraint::Class") ) { + throw_exception( DelegationToATypeWhichIsNotAClass => attribute => $self ); + } + + # make sure the class is loaded + unless ( Moose::Util::_is_package_loaded($class) ) { + throw_exception( DelegationToAClassWhichIsNotLoaded => attribute => $self, + class_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 ( $role ) { + unless ( Moose::Util::_is_package_loaded($role) ) { + throw_exception( DelegationToARoleWhichIsNotLoaded => attribute => $self, + role_name => $role + ); + } + + return Class::MOP::class_of($role); + } + else { + throw_exception( CannotFindDelegateMetaclass => attribute => $self ); + } +} + +sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } + +sub _make_delegation_method { + my ( $self, $handle_name, $method_to_call ) = @_; + + my @curried_arguments; + + ($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; + + return 1 if !$self->has_type_constraint; + + my $type_constraint = $self->type_constraint; + + $type_constraint->check($val) + || throw_exception( ValidationFailedForTypeConstraint => type => $type_constraint, + value => $val, + attribute => $self, + ); +} + +package Moose::Meta::Attribute::Custom::Moose; +our $VERSION = '2.1403'; + +sub register_implementation { 'Moose::Meta::Attribute' } +1; + +# ABSTRACT: The Moose attribute metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute - The Moose attribute metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Attribute> that provides +additional Moose-specific functionality. + +To really understand this class, you will need to start with the +L<Class::MOP::Attribute> documentation. This class can be understood +as a set of additional features on top of the basic feature provided +by that parent class. + +=head1 INHERITANCE + +C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>. + +=head1 METHODS + +Many of the documented below override methods in +L<Class::MOP::Attribute> and add Moose specific features. + +=head2 Creation + +=over 4 + +=item B<< Moose::Meta::Attribute->new($name, %options) >> + +This method overrides the L<Class::MOP::Attribute> constructor. + +Many of the options below are described in more detail in the +L<Moose::Manual::Attributes> document. + +It adds the following options to the constructor: + +=over 8 + +=item * is => 'ro', 'rw', 'bare' + +This provides a shorthand for specifying the C<reader>, C<writer>, or +C<accessor> names. If the attribute is read-only ('ro') then it will +have a C<reader> method with the same attribute as the name. + +If it is read-write ('rw') then it will have an C<accessor> method +with the same name. If you provide an explicit C<writer> for a +read-write attribute, then you will have a C<reader> with the same +name as the attribute, and a C<writer> 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 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<Moose::Meta::TypeConstraint> object. + +If you I<also> provide a C<does> option, then your C<isa> option must +be a class name, and that class must do the role specified with +C<does>. + +=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<isa>) that defined a coercion. If this is true, then coercions will be applied whenever +this attribute is set. + +You cannot make both this and the C<weak_ref> option true. + +=item * trigger => $sub + +This option accepts a subroutine reference, which will be called after +the attribute is set. + +=item * required => $bool + +An attribute which is required must be provided to the constructor. An +attribute which is required can also have a C<default> or C<builder>, +which will satisfy its required-ness. + +A required attribute must have a C<default>, C<builder> or a +non-C<undef> C<init_arg> + +=item * lazy => $bool + +A lazy attribute must have a C<default> or C<builder>. When an +attribute is lazy, the default value will not be calculated until the +attribute is read. + +=item * weak_ref => $bool + +If this is true, the attribute's value will be stored as a weak +reference. + +=item * documentation + +An arbitrary string that can be retrieved later by calling C<< +$attr->documentation >>. + +=item * auto_deref => $bool + +B<Note that in cases where you want this feature you are often better served +by using a L<Moose::Meta::Attribute::Native> trait instead>. + +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 + +B<Note that use of this feature is strongly discouraged.> Some documentation +used to encourage use of this feature as a best practice, but we have changed +our minds. + +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. + +=back + +=item B<< $attr->clone(%options) >> + +This creates a new attribute based on attribute being cloned. You must +supply a C<name> option to provide a new name for the attribute. + +The C<%options> can only specify options handled by +L<Class::MOP::Attribute>. + +=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<Class::MOP::Attribute> method to handle lazy +attributes, weak references, and type constraints. + +=item B<get_value> + +=item B<set_value> + + eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') }; + if($@) { + print "Oops: $@\n"; + } + +I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'> + +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. + +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<Class::MOP::Class/find_attribute_by_name>, +fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint> +and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Company_Subtypes> +for an example. + +=back + +=head2 Attribute Accessor generation + +=over 4 + +=item B<< $attr->install_accessors >> + +This method overrides the parent to also install delegation methods. + +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<< $attr->remove_accessors >> + +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 +class, if it has any to add. + +=item B<< $attr->remove_delegation >> + +This method remove its delegation methods from the attribute's +associated class. + +=item B<< $attr->accessor_metaclass >> + +Returns the accessor metaclass name, which defaults to +L<Moose::Meta::Method::Accessor>. + +=item B<< $attr->delegation_metaclass >> + +Returns the delegation metaclass name, which defaults to +L<Moose::Meta::Method::Delegation>. + +=back + +=head2 Additional Moose features + +These methods are not found in the superclass. They support features +provided by Moose. + +=over 4 + +=item B<< $attr->does($role) >> + +This indicates whether the I<attribute itself> does the given +role. The role can be given as a full class name, or as a resolvable +trait name. + +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. + +=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >> + +This is an alternate constructor that handles the C<metaclass> and +C<traits> options. + +Effectively, this method is a factory that finds or creates the +appropriate class for the given C<metaclass> and/or C<traits>. + +Once it has the appropriate class, it will call C<< $class->new($name, +%options) >> on that class. + +=item B<< $attr->clone_and_inherit_options(%options) >> + +This method supports the C<has '+foo'> feature. It does various bits +of processing on the supplied C<%options> before ultimately calling +the C<clone> method. + +One of its main tasks is to make sure that the C<%options> provided +does not include the options returned by the +C<illegal_options_for_inheritance> method. + +=item B<< $attr->illegal_options_for_inheritance >> + +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 not be changed. + +=item B<< $attr->type_constraint >> + +Returns the L<Moose::Meta::TypeConstraint> object for this attribute, +if it has one. + +=item B<< $attr->has_type_constraint >> + +Returns true if this attribute has a type constraint. + +=item B<< $attr->verify_against_type_constraint($value) >> + +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. + +=item B<< $attr->handles >> + +This returns the value of the C<handles> option passed to the +constructor. + +=item B<< $attr->has_handles >> + +Returns true if this attribute performs delegation. + +=item B<< $attr->is_weak_ref >> + +Returns true if this attribute stores its value as a weak reference. + +=item B<< $attr->is_required >> + +Returns true if this attribute is required to have a value. + +=item B<< $attr->is_lazy >> + +Returns true if this attribute is lazy. + +=item B<< $attr->is_lazy_build >> + +Returns true if the C<lazy_build> option was true when passed to the +constructor. + +=item B<< $attr->should_coerce >> + +Returns true if the C<coerce> option passed to the constructor was +true. + +=item B<< $attr->should_auto_deref >> + +Returns true if the C<auto_deref> option passed to the constructor was +true. + +=item B<< $attr->trigger >> + +This is the subroutine reference that was in the C<trigger> option +passed to the constructor, if any. + +=item B<< $attr->has_trigger >> + +Returns true if this attribute has a trigger set. + +=item B<< $attr->documentation >> + +Returns the value that was in the C<documentation> 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<undef>. + +=item B<< $attr->has_applied_traits >> + +Returns true if this attribute has any traits applied. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut |