Moose::Meta::Attribute - The Moose attribute metaclass

package Moose::Meta::Attribute;
BEGIN {
  $Moose::Meta::Attribute::AUTHORITY = 'cpan:STEVAN';
}
BEGIN {
  $Moose::Meta::Attribute::VERSION = '2.0010';
}

use strict;
use warnings;

use Class::MOP ();
use Scalar::Util 'blessed', 'weaken';
use List::MoreUtils 'any';
use Try::Tiny;
use overload     ();

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',
));

# 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 throw_error {
    my $self = shift;
    my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
    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
    goto $handler;
}

sub _inline_throw_error {
    my ( $self, $msg, $args ) = @_;
    "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
}

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)
    {
        Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
    }

    return $class->SUPER::new($name, %options);
}

sub interpolate_class_and_new {
    my ($class, $name, %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;
        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?
            push @traits, $traits->[$i++]
                if $traits->[$i] && ref($traits->[$i]);
        }

        if (@traits) {
            my $anon_class = Moose::Meta::Class->create_anon_class(
                superclasses => [ $class ],
                roles        => [ @traits ],
                cache        => 1,
            );

            $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)
        || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);

    if ($options{isa}) {
        my $type_constraint;
        if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
            $type_constraint = $options{isa};
        }
        else {
            $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
            (defined $type_constraint)
                || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
        }

        $options{type_constraint} = $type_constraint;
    }

    if ($options{does}) {
        my $type_constraint;
        if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
            $type_constraint = $options{does};
        }
        else {
            $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
            (defined $type_constraint)
                || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
        }

        $options{type_constraint} = $type_constraint;
    }

    # 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' ) {
        $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;
        }
        else {
            $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} );
    }
}

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} ) )
                || $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 );
        }
    }

    # 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} );
    }
}

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} );
    }
}

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;

        Moose::Deprecated::deprecated(
            feature => 'coerce without coercion',
            message =>
                "You cannot coerce an attribute ($name) unless its type ($type) has a coercion"
        );
    }
}

sub _process_trigger_option {
    my ( $class, $name, $options ) = @_;

    return unless exists $options->{trigger};

    ( 'CODE' eq ref $options->{trigger} )
        || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
}

sub _process_auto_deref_option {
    my ( $class, $name, $options ) = @_;

    return unless $options->{auto_deref};

    ( exists $options->{type_constraint} )
        || $class->throw_error(
        "You cannot auto-dereference without specifying a type constraint on attribute ($name)",
        data => $options );

    ( $options->{type_constraint}->is_a_type_of('ArrayRef')
      || $options->{type_constraint}->is_a_type_of('HashRef') )
        || $class->throw_error(
        "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)",
        data => $options );
}

sub _process_lazy_build_option {
    my ( $class, $name, $options ) = @_;

    return unless $options->{lazy_build};

    $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 {
    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
        $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $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 );

    $self->throw_error(  blessed($instance)
            . " does not support builder method '"
            . $self->builder
            . "' for attribute '"
            . $self->name
            . "'",
            object => $instance,
     );
}

## 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 = $self->name;

    if ($self->is_required and not @args) {
        $self->throw_error("Attribute ($attr_name) is required", object => $instance);
    }

    $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, $tc_obj, $for_constructor) = @_;

    my $old   = '@old';
    my $copy  = '$val';
    $tc     ||= '$type_constraint';
    $tc_obj ||= '$type_constraint_obj';

    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, $tc_obj);

    # 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, so cannot '
              . 'be set to undef"' # defined $_[1] is not good enough
            ) . ';',
        '}',
    );
}

sub _inline_tc_code {
    my $self = shift;
    return (
        $self->_inline_check_coercion(@_),
        $self->_inline_check_constraint(@_),
    );
}

sub _inline_check_coercion {
    my $self = shift;
    my ($value, $tc, $tc_obj) = @_;

    return unless $self->should_coerce && $self->type_constraint->has_coercion;

    return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
}

sub _inline_check_constraint {
    my $self = shift;
    my ($value, $tc, $tc_obj) = @_;

    return unless $self->has_type_constraint;

    my $attr_name = quotemeta($self->name);

    return (
        'if (!' . $tc . '->(' . $value . ')) {',
            $self->_inline_throw_error(
                '"Attribute (' . $attr_name . ') does not pass the type '
              . 'constraint because: " . '
              . $tc_obj . '->get_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, $value),
            'if ref ' . $value . ';',
    );
}

sub _inline_trigger {
    my $self = shift;
    my ($instance, $value, $old) = @_;

    return unless $self->has_trigger;

    return '$attr->trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
}

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 ( $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 {
            $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
        }

    }
    else {

        return $self->SUPER::get_value($instance);
    }
}

sub _inline_get_value {
    my $self = shift;
    my ($instance, $tc, $tc_obj) = @_;

    my $slot_access = $self->_inline_instance_get($instance);
    $tc           ||= '$type_constraint';
    $tc_obj       ||= '$type_constraint_obj';

    return (
        $self->_inline_check_lazy($instance, $tc, $tc_obj),
        $self->_inline_return_auto_deref($slot_access),
    );
}

sub _inline_check_lazy {
    my $self = shift;
    my ($instance, $tc, $tc_obj) = @_;

    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, $tc_obj, 'lazy'),
        '}',
    );
}

sub _inline_init_from_default {
    my $self = shift;
    my ($instance, $default, $tc, $tc_obj, $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, $tc_obj, $for_lazy),
               $self->_inline_check_constraint($default, $tc, $tc_obj, $for_lazy))
            : (),
        $self->_inline_init_slot($instance, $default),
    );
}

sub _inline_generate_default {
    my $self = shift;
    my ($instance, $default) = @_;

    if ($self->has_default) {
        return 'my ' . $default . ' = $attr->default(' . $instance . ');';
    }
    elsif ($self->has_builder) {
        return (
            'my ' . $default . ';',
            'if (my $builder = ' . $instance . '->can($attr->builder)) {',
                $default . ' = ' . $instance . '->$builder;',
            '}',
            'else {',
                'my $class = ref(' . $instance . ') || ' . $instance . ';',
                'my $builder_name = $attr->builder;',
                'my $attr_name = $attr->name;',
                $self->_inline_throw_error(
                    '"$class does not support builder method '
                  . '\'$builder_name\' for attribute \'$attr_name\'"'
                ) . ';',
            '}',
        );
    }
    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' }

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->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;
    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);

        # 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)
                || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
            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 {
            $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
        }
    }

    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);

    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 {
        $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
    }
}

sub _find_delegate_metaclass {
    my $self = shift;
    if (my $class = $self->_isa_metadata) {
        unless ( Class::MOP::is_class_loaded($class) ) {
            $self->throw_error(
                sprintf(
                    'The %s attribute is trying to delegate to a class which has not been loaded - %s',
                    $self->name, $class
                )
            );
        }
        # we might be dealing with a non-Moose class,
        # and need to make our own metaclass. if there's
        # already a metaclass, it will be returned
        return Class::MOP::Class->initialize($class);
    }
    elsif (my $role = $self->_does_metadata) {
        unless ( Class::MOP::is_class_loaded($class) ) {
            $self->throw_error(
                sprintf(
                    'The %s attribute is trying to delegate to a role which has not been loaded - %s',
                    $self->name, $role
                )
            );
        }

        return Class::MOP::class_of($role);
    }
    else {
        $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
    }
}

sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }

sub _make_delegation_method {
    my ( $self, $handle_name, $method_to_call ) = @_;

    my @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)
        || $self->throw_error("Attribute ("
                 . $self->name
                 . ") does not pass the type constraint because: "
                 . $type_constraint->get_message($val), data => $val, @_);
}

package Moose::Meta::Attribute::Custom::Moose;
BEGIN {
  $Moose::Meta::Attribute::Custom::Moose::AUTHORITY = 'cpan:STEVAN';
}
BEGIN {
  $Moose::Meta::Attribute::Custom::Moose::VERSION = '2.0010';
}
sub register_implementation { 'Moose::Meta::Attribute' }

1;

# ABSTRACT: The Moose attribute metaclass

__END__