[gitmo/Moose.git] / lib / Moose / Meta / Attribute.pm


package Moose::Meta::Attribute;

use strict;
use warnings;

use Scalar::Util 'blessed', 'weaken', 'reftype';
use Carp         'confess';

our $VERSION = '0.06';

use Moose::Util::TypeConstraints ();

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('coerce'     => (reader => 'should_coerce'    ));
__PACKAGE__->meta->add_attribute('weak_ref'   => (reader => 'is_weak_ref'      ));
__PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
__PACKAGE__->meta->add_attribute('type_constraint' => (
    reader    => 'type_constraint',
    predicate => 'has_type_constraint',
));
__PACKAGE__->meta->add_attribute('trigger' => (
    reader    => 'trigger',
    predicate => 'has_trigger',
));
__PACKAGE__->meta->add_attribute('handles' => (
    reader    => 'handles',
    predicate => 'has_handles',
));

sub new {
	my ($class, $name, %options) = @_;
	$class->_process_options($name, \%options);
	return $class->SUPER::new($name, %options);    
}

sub clone_and_inherit_options {
    my ($self, %options) = @_;
    # you can change default, required and coerce 
    my %actual_options;
    foreach my $legal_option (qw(default coerce required)) {
        if (exists $options{$legal_option}) {
            $actual_options{$legal_option} = $options{$legal_option};
            delete $options{$legal_option};
        }
    }
    # isa can be changed, but only if the 
    # new type is a subtype    
    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_type_constraint($options{isa});
		    (defined $type_constraint)
		        || confess "Could not find the type constraint '" . $options{isa} . "'";
		}
		($type_constraint->is_subtype_of($self->type_constraint->name))
		    || confess "New type constraint setting must be a subtype of inherited one"
		        if $self->has_type_constraint;
		$actual_options{type_constraint} = $type_constraint;
        delete $options{isa};
    }
    (scalar keys %options == 0) 
        || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
    $self->clone(%actual_options);
}

sub _process_options {
    my ($class, $name, $options) = @_;
    
	if (exists $options->{is}) {
		if ($options->{is} eq 'ro') {
			$options->{reader} = $name;
			(!exists $options->{trigger})
			    || confess "Cannot have a trigger on a read-only attribute";
		}
		elsif ($options->{is} eq 'rw') {
			$options->{accessor} = $name;						
    	    ((reftype($options->{trigger}) || '') eq 'CODE')
    	        || confess "Trigger must be a CODE ref"
    	            if exists $options->{trigger};			
		}
		else {
		    confess "I do not understand this option (is => " . $options->{is} . ")"
		}			
	}
	
	if (exists $options->{isa}) {
	    
	    if (exists $options->{does}) {
	        if (eval { $options->{isa}->can('does') }) {
	            ($options->{isa}->does($options->{does}))	            
	                || confess "Cannot have an isa option and a does option if the isa does not do the does";
	        }
	        else {
	            confess "Cannot have an isa option which cannot ->does()";
	        }
	    }	    
	    
	    # allow for anon-subtypes here ...
	    if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
			$options->{type_constraint} = $options->{isa};
		}
		else {
		    
		    if ($options->{isa} =~ /\|/) {
		        my @type_constraints = split /\s*\|\s*/ => $options->{isa};
		        $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
		            @type_constraints
		        );
		    }
		    else {
    		    # otherwise assume it is a constraint
    		    my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});	    
    		    # if the constraing it not found ....
    		    unless (defined $constraint) {
    		        # assume it is a foreign class, and make 
    		        # an anon constraint for it 
    		        $constraint = Moose::Util::TypeConstraints::subtype(
    		            'Object', 
    		            Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
    		        );
    		    }			    
                $options->{type_constraint} = $constraint;
            }
		}
	}	
	elsif (exists $options->{does}) {	    
	    # allow for anon-subtypes here ...
	    if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
			$options->{type_constraint} = $options->{isa};
		}
		else {
		    # otherwise assume it is a constraint
		    my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});	      
		    # if the constraing it not found ....
		    unless (defined $constraint) {	  		        
		        # assume it is a foreign class, and make 
		        # an anon constraint for it 
		        $constraint = Moose::Util::TypeConstraints::subtype(
		            'Role', 
		            Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
		        );
		    }			    
            $options->{type_constraint} = $constraint;
		}	    
	}
	
	if (exists $options->{coerce} && $options->{coerce}) {
	    (exists $options->{type_constraint})
	        || confess "You cannot have coercion without specifying a type constraint";
	    (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
	        || confess "You cannot have coercion with a type constraint union";	        
        confess "You cannot have a weak reference to a coerced value"
            if $options->{weak_ref};	        
	}	
	
	if (exists $options->{auto_deref} && $options->{auto_deref}) {
	    (exists $options->{type_constraint})
	        || confess "You cannot auto-dereference without specifying a type constraint";	    
	    ($options->{type_constraint}->name =~ /^ArrayRef|HashRef$/)
	        || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";	        
	}
	
	if (exists $options->{lazy} && $options->{lazy}) {
	    (exists $options->{default})
	        || confess "You cannot have lazy attribute without specifying a default value for it";	    
	}    
}

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;        
    if (exists $params->{$init_arg}) {
        $val = $params->{$init_arg};
    }
    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
        confess "Attribute (" . $self->name . ") is required" 
            if $self->is_required && !$self->has_default;
    }

    # if nothing was in the %params, we can use the 
    # attribute's default value (if it has one)
    if (!defined $val && $self->has_default) {
        $val = $self->default($instance); 
    }
	if (defined $val) {
	    if ($self->has_type_constraint) {
	        my $type_constraint = $self->type_constraint;
		    if ($self->should_coerce && $type_constraint->has_coercion) {
		        $val = $type_constraint->coercion->coerce($val);
		    }	
            (defined($type_constraint->check($val))) 
                || confess "Attribute (" . 
                           $self->name . 
                           ") does not pass the type constraint (" . 
                           $type_constraint->name .
                           ") with '$val'";			
        }
	}

    $meta_instance->set_slot_value($instance, $self->name, $val);
    $meta_instance->weaken_slot_value($instance, $self->name) 
        if ref $val && $self->is_weak_ref;
}

## Accessor inline subroutines

sub _inline_check_constraint {
	my ($self, $value) = @_;
	return '' unless $self->has_type_constraint;
	
	# FIXME - remove 'unless defined($value) - constraint Undef
	return sprintf <<'EOF', $value, $value, $value, $value
defined($attr->type_constraint->check(%s))
	|| confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
       . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
  if defined(%s);
EOF
}

sub _inline_check_coercion {
    my $self = shift;
	return '' unless $self->should_coerce;
    return 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
}

sub _inline_check_required {
    my $self = shift;
	return '' unless $self->is_required;
    return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
}

sub _inline_check_lazy {
    my $self = shift;
	return '' unless $self->is_lazy;
    return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
         . 'unless exists $_[0]->{$attr_name};';
}


sub _inline_store {
	my ($self, $instance, $value) = @_;

	my $mi = $self->associated_class->get_meta_instance;
	my $slot_name = sprintf "'%s'", $self->slots;

    my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
	$code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
	    if $self->is_weak_ref;
    return $code;
}

sub _inline_trigger {
	my ($self, $instance, $value) = @_;
	return '' unless $self->has_trigger;
	return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
}

sub _inline_get {
	my ($self, $instance) = @_;

	my $mi = $self->associated_class->get_meta_instance;
	my $slot_name = sprintf "'%s'", $self->slots;

    return $mi->inline_get_slot_value($instance, $slot_name);
}

sub _inline_auto_deref {
    my ( $self, $ref_value ) = @_;

    return $ref_value unless $self->should_auto_deref;

    my $type = $self->type_constraint->name;

    my $sigil;
    if ($type eq "ArrayRef") {
        $sigil = '@';
    } 
    elsif ($type eq 'HashRef') {
        $sigil = '%';
    } 
    else {
        confess "Can not auto de-reference the type constraint '$type'";
    }

    "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
}

sub generate_accessor_method {
    my ($attr, $attr_name) = @_;
    my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	my $mi = $attr->associated_class->get_meta_instance;
	my $slot_name = sprintf "'%s'", $attr->slots;
	my $inv = '$_[0]';
    my $code = 'sub { '
    . 'if (scalar(@_) == 2) {'
        . $attr->_inline_check_required
        . $attr->_inline_check_coercion
        . $attr->_inline_check_constraint($value_name)
		. $attr->_inline_store($inv, $value_name)
		. $attr->_inline_trigger($inv, $value_name)
    . ' }'
    . $attr->_inline_check_lazy
    . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
    . ' }';
    my $sub = eval $code;
    confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;    
}

sub generate_writer_method {
    my ($attr, $attr_name) = @_; 
    my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	my $inv = '$_[0]';
    my $code = 'sub { '
    . $attr->_inline_check_required
    . $attr->_inline_check_coercion
	. $attr->_inline_check_constraint($value_name)
	. $attr->_inline_store($inv, $value_name)
	. $attr->_inline_trigger($inv, $value_name)
    . ' }';
    my $sub = eval $code;
    confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;    
}

sub generate_reader_method {
    my $attr = shift;
    my $attr_name = $attr->slots;
    my $code = 'sub {'
    . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
    . $attr->_inline_check_lazy
    . 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
    . '}';
    my $sub = eval $code;
    confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;
}

sub install_accessors {
    my $self = shift;
    $self->SUPER::install_accessors(@_);   
    
    if ($self->has_handles) {
        
        # 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();
        
        # find the name of the accessor for this attribute
        my $accessor_name = $self->reader || $self->accessor;
        (defined $accessor_name)
            || confess "You cannot install delegation without a reader or accessor for the attribute";
        
        # make sure we handle HASH accessors correctly
        ($accessor_name) = keys %{$accessor_name}
            if ref($accessor_name) eq 'HASH';
        
        # install the delegation ...
        my $associated_class = $self->associated_class;
        foreach my $handle (keys %handles) {
            my $method_to_call = $handles{$handle};
            
            (!$associated_class->has_method($handle))
                || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
            
            if ((reftype($method_to_call) || '') eq 'CODE') {
                $associated_class->add_method($handle => $method_to_call);                
            }
            else {
                $associated_class->add_method($handle => sub {
                    # FIXME
                    # we should check for lack of 
                    # a callable return value from 
                    # the accessor here 
                    ((shift)->$accessor_name())->$method_to_call(@_);
                });
            }
        }
    }
    
    return;
}

# private methods to help delegation ...

sub _canonicalize_handles {
    my $self    = shift;
    my $handles = $self->handles;
    if (ref($handles) eq 'HASH') {
        return %{$handles};
    }
    elsif (ref($handles) eq 'ARRAY') {
        return map { $_ => $_ } @{$handles};
    }
    elsif (ref($handles) eq 'Regexp') {
        ($self->has_type_constraint)
            || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
        return map  { ($_ => $_) } 
               grep {  $handles  } $self->_get_delegate_method_list;
    }
    elsif (ref($handles) eq 'CODE') {
        return $handles->($self, $self->_find_delegate_metaclass);
    }
    else {
        confess "Unable to canonicalize the 'handles' option with $handles";
    }
}

sub _find_delegate_metaclass {
    my $self = shift;
    if (my $class = $self->_isa_metadata) {
        # if the class does have 
        # a meta method, use it
        return $class->meta if $class->can('meta');
        # otherwise we might be 
        # dealing with a non-Moose
        # class, and need to make 
        # our own metaclass
        return Moose::Meta::Class->initialize($class);
    }
    elsif (my $role = $self->_does_metadata) {
        # our role will always have 
        # a meta method
        return $role->meta;
    }
    else {
        confess "Cannot find delegate metaclass for attribute " . $self->name;
    }
}

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 { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' } 
                    $meta->compute_all_applicable_methods;
    }
    elsif ($meta->isa('Moose::Meta::Role')) {
        return $meta->get_method_list;        
    }
    else {
        confess "Unable to recognize the delegate metaclass '$meta'";
    }
}

1;

__END__

=pod

=head1 NAME

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

=head1 DESCRIPTION

This is a subclass of L<Class::MOP::Attribute> with Moose specific 
extensions. 

For the most part, the only time you will ever encounter an 
instance of this class is if you are doing some serious deep 
introspection. To really understand this class, you need to refer 
to the L<Class::MOP::Attribute> documentation.

=head1 METHODS

=head2 Overridden methods

These methods override methods in L<Class::MOP::Attribute> and add 
Moose specific features. You can safely assume though that they 
will behave just as L<Class::MOP::Attribute> does.

=over 4

=item B<new>

=item B<initialize_instance_slot>

=item B<generate_accessor_method>

=item B<generate_writer_method>

=item B<generate_reader_method>

=item B<install_accessors>

=back

=head2 Additional Moose features

Moose attributes support type-constraint checking, weak reference 
creation and type coercion.  

=over 4

=item B<clone_and_inherit_options>

This is to support the C<has '+foo'> feature, it clones an attribute 
from a superclass and allows a very specific set of changes to be made 
to the attribute.

=item B<has_type_constraint>

Returns true if this meta-attribute has a type constraint.

=item B<type_constraint>

A read-only accessor for this meta-attribute's type constraint. For 
more information on what you can do with this, see the documentation 
for L<Moose::Meta::TypeConstraint>.

=item B<has_handles>

Returns true if this meta-attribute performs delegation.

=item B<handles>

This returns the value which was passed into the handles option.

=item B<is_weak_ref>

Returns true if this meta-attribute produces a weak reference.

=item B<is_required>

Returns true if this meta-attribute is required to have a value.

=item B<is_lazy>

Returns true if this meta-attribute should be initialized lazily.

NOTE: lazy attributes, B<must> have a C<default> field set.

=item B<should_coerce>

Returns true if this meta-attribute should perform type coercion.

=item B<should_auto_deref>

Returns true if this meta-attribute should perform automatic 
auto-dereferencing. 

NOTE: This can only be done for attributes whose type constraint is 
either I<ArrayRef> or I<HashRef>.

=item B<has_trigger>

Returns true if this meta-attribute has a trigger set.

=item B<trigger>

This is a CODE reference which will be executed every time the 
value of an attribute is assigned. The CODE ref will get two values, 
the invocant and the new value. This can be used to handle I<basic> 
bi-directional relations.

=back

=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 E<lt>stevan@iinteractive.comE<gt>

Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut
Commit	Line	Data
c0e30cf5	1
	2	package Moose::Meta::Attribute;
	3
	4	use strict;
	5	use warnings;
	6
78cd1d3b	7	use Scalar::Util 'blessed', 'weaken', 'reftype';
a15dff8d	8	use Carp 'confess';
a15dff8d	9
db1ab48d	10	our $VERSION = '0.06';
78cd1d3b	11
a3c7e2fe	12	use Moose::Util::TypeConstraints ();
bc1e29b5	13
c0e30cf5	14	use base 'Class::MOP::Attribute';
c0e30cf5	15
452bac1b	16	# options which are not directly used
452bac1b	17	# but we store them for metadata purposes
98aae381	18	__PACKAGE__->meta->add_attribute('isa' => (reader => '_isa_metadata'));
	19	__PACKAGE__->meta->add_attribute('does' => (reader => '_does_metadata'));
	20	__PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata'));
452bac1b	21
452bac1b	22	# these are actual options for the attrs
1a563243	23	__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
	24	__PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
	25	__PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' ));
	26	__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
	27	__PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
82168dbb	28	__PACKAGE__->meta->add_attribute('type_constraint' => (
	29	reader => 'type_constraint',
	30	predicate => 'has_type_constraint',
	31	));
8c9d74e7	32	__PACKAGE__->meta->add_attribute('trigger' => (
	33	reader => 'trigger',
	34	predicate => 'has_trigger',
	35	));
452bac1b	36	__PACKAGE__->meta->add_attribute('handles' => (
	37	reader => 'handles',
	38	predicate => 'has_handles',
	39	));
82168dbb	40
78cd1d3b	41	sub new {
78cd1d3b	42	my ($class, $name, %options) = @_;
1d768fb1	43	$class->_process_options($name, \%options);
98aae381	44	return $class->SUPER::new($name, %options);
1d768fb1	45	}
1d768fb1	46
ce0e8d63	47	sub clone_and_inherit_options {
	48	my ($self, %options) = @_;
	49	# you can change default, required and coerce
	50	my %actual_options;
	51	foreach my $legal_option (qw(default coerce required)) {
	52	if (exists $options{$legal_option}) {
	53	$actual_options{$legal_option} = $options{$legal_option};
	54	delete $options{$legal_option};
	55	}
	56	}
fcb7afc2	57	# isa can be changed, but only if the
fcb7afc2	58	# new type is a subtype
ce0e8d63	59	if ($options{isa}) {
	60	my $type_constraint;
	61	if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
	62	$type_constraint = $options{isa};
	63	}
	64	else {
	65	$type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
	66	(defined $type_constraint)
	67	\|\| confess "Could not find the type constraint '" . $options{isa} . "'";
	68	}
	69	($type_constraint->is_subtype_of($self->type_constraint->name))
	70	\|\| confess "New type constraint setting must be a subtype of inherited one"
	71	if $self->has_type_constraint;
	72	$actual_options{type_constraint} = $type_constraint;
	73	delete $options{isa};
	74	}
	75	(scalar keys %options == 0)
	76	\|\| confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
	77	$self->clone(%actual_options);
1d768fb1	78	}
	79
	80	sub _process_options {
	81	my ($class, $name, $options) = @_;
452bac1b	82
1d768fb1	83	if (exists $options->{is}) {
	84	if ($options->{is} eq 'ro') {
	85	$options->{reader} = $name;
	86	(!exists $options->{trigger})
8c9d74e7	87	\|\| confess "Cannot have a trigger on a read-only attribute";
78cd1d3b	88	}
1d768fb1	89	elsif ($options->{is} eq 'rw') {
452bac1b	90	$options->{accessor} = $name;
98aae381	91	((reftype($options->{trigger}) \|\| '') eq 'CODE')
	92	\|\| confess "Trigger must be a CODE ref"
	93	if exists $options->{trigger};
452bac1b	94	}
	95	else {
	96	confess "I do not understand this option (is => " . $options->{is} . ")"
78cd1d3b	97	}
	98	}
	99
1d768fb1	100	if (exists $options->{isa}) {
02a0fb52	101
1d768fb1	102	if (exists $options->{does}) {
	103	if (eval { $options->{isa}->can('does') }) {
	104	($options->{isa}->does($options->{does}))
02a0fb52	105	\|\| confess "Cannot have an isa option and a does option if the isa does not do the does";
02a0fb52	106	}
7eaef7ad	107	else {
	108	confess "Cannot have an isa option which cannot ->does()";
	109	}
02a0fb52	110	}
02a0fb52	111
78cd1d3b	112	# allow for anon-subtypes here ...
1d768fb1	113	if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
1d768fb1	114	$options->{type_constraint} = $options->{isa};
78cd1d3b	115	}
78cd1d3b	116	else {
c07af9d2	117
1d768fb1	118	if ($options->{isa} =~ /\\|/) {
	119	my @type_constraints = split /\s\\|\s/ => $options->{isa};
	120	$options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
c07af9d2	121	@type_constraints
78cd1d3b	122	);
c07af9d2	123	}
	124	else {
	125	# otherwise assume it is a constraint
1d768fb1	126	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
c07af9d2	127	# if the constraing it not found ....
	128	unless (defined $constraint) {
	129	# assume it is a foreign class, and make
	130	# an anon constraint for it
	131	$constraint = Moose::Util::TypeConstraints::subtype(
	132	'Object',
1d768fb1	133	Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
c07af9d2	134	);
c07af9d2	135	}
1d768fb1	136	$options->{type_constraint} = $constraint;
c07af9d2	137	}
78cd1d3b	138	}
78cd1d3b	139	}
1d768fb1	140	elsif (exists $options->{does}) {
02a0fb52	141	# allow for anon-subtypes here ...
1d768fb1	142	if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
1d768fb1	143	$options->{type_constraint} = $options->{isa};
02a0fb52	144	}
	145	else {
	146	# otherwise assume it is a constraint
1d768fb1	147	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
02a0fb52	148	# if the constraing it not found ....
	149	unless (defined $constraint) {
	150	# assume it is a foreign class, and make
	151	# an anon constraint for it
	152	$constraint = Moose::Util::TypeConstraints::subtype(
	153	'Role',
1d768fb1	154	Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
02a0fb52	155	);
02a0fb52	156	}
1d768fb1	157	$options->{type_constraint} = $constraint;
02a0fb52	158	}
02a0fb52	159	}
78cd1d3b	160
1d768fb1	161	if (exists $options->{coerce} && $options->{coerce}) {
1d768fb1	162	(exists $options->{type_constraint})
4b598ea3	163	\|\| confess "You cannot have coercion without specifying a type constraint";
1d768fb1	164	(!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
c07af9d2	165	\|\| confess "You cannot have coercion with a type constraint union";
4b598ea3	166	confess "You cannot have a weak reference to a coerced value"
1d768fb1	167	if $options->{weak_ref};
ca01a97b	168	}
78cd1d3b	169
536f0b17	170	if (exists $options->{auto_deref} && $options->{auto_deref}) {
	171	(exists $options->{type_constraint})
	172	\|\| confess "You cannot auto-dereference without specifying a type constraint";
	173	($options->{type_constraint}->name =~ /^ArrayRef\|HashRef$/)
	174	\|\| confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
	175	}
	176
1d768fb1	177	if (exists $options->{lazy} && $options->{lazy}) {
1d768fb1	178	(exists $options->{default})
ca01a97b	179	\|\| confess "You cannot have lazy attribute without specifying a default value for it";
1d768fb1	180	}
78cd1d3b	181	}
c0e30cf5	182
d500266f	183	sub initialize_instance_slot {
ddd0ec20	184	my ($self, $meta_instance, $instance, $params) = @_;
d500266f	185	my $init_arg = $self->init_arg();
d500266f	186	# try to fetch the init arg from the %params ...
ddd0ec20	187
d500266f	188	my $val;
	189	if (exists $params->{$init_arg}) {
	190	$val = $params->{$init_arg};
	191	}
	192	else {
	193	# skip it if it's lazy
	194	return if $self->is_lazy;
	195	# and die if it's required and doesn't have a default value
	196	confess "Attribute (" . $self->name . ") is required"
	197	if $self->is_required && !$self->has_default;
	198	}
ddd0ec20	199
d500266f	200	# if nothing was in the %params, we can use the
	201	# attribute's default value (if it has one)
	202	if (!defined $val && $self->has_default) {
	203	$val = $self->default($instance);
	204	}
	205	if (defined $val) {
	206	if ($self->has_type_constraint) {
c07af9d2	207	my $type_constraint = $self->type_constraint;
	208	if ($self->should_coerce && $type_constraint->has_coercion) {
	209	$val = $type_constraint->coercion->coerce($val);
d500266f	210	}
c07af9d2	211	(defined($type_constraint->check($val)))
	212	\|\| confess "Attribute (" .
	213	$self->name .
8449e6e7	214	") does not pass the type constraint (" .
c07af9d2	215	$type_constraint->name .
c07af9d2	216	") with '$val'";
d500266f	217	}
d500266f	218	}
ddd0ec20	219
ac1ef2f9	220	$meta_instance->set_slot_value($instance, $self->name, $val);
	221	$meta_instance->weaken_slot_value($instance, $self->name)
	222	if ref $val && $self->is_weak_ref;
d500266f	223	}
d500266f	224
9e93dd19	225	## Accessor inline subroutines
9e93dd19	226
67ad26d9	227	sub _inline_check_constraint {
ac1ef2f9	228	my ($self, $value) = @_;
67ad26d9	229	return '' unless $self->has_type_constraint;
	230
	231	# FIXME - remove 'unless defined($value) - constraint Undef
	232	return sprintf <<'EOF', $value, $value, $value, $value
	233	defined($attr->type_constraint->check(%s))
8449e6e7	234	\|\| confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
67ad26d9	235	. $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
	236	if defined(%s);
	237	EOF
	238	}
	239
9e93dd19	240	sub _inline_check_coercion {
	241	my $self = shift;
	242	return '' unless $self->should_coerce;
	243	return 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
	244	}
	245
	246	sub _inline_check_required {
	247	my $self = shift;
	248	return '' unless $self->is_required;
	249	return 'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
	250	}
	251
	252	sub _inline_check_lazy {
	253	my $self = shift;
	254	return '' unless $self->is_lazy;
	255	return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
	256	. 'unless exists $_[0]->{$attr_name};';
	257	}
	258
	259
67ad26d9	260	sub _inline_store {
ac1ef2f9	261	my ($self, $instance, $value) = @_;
67ad26d9	262
67ad26d9	263	my $mi = $self->associated_class->get_meta_instance;
ac1ef2f9	264	my $slot_name = sprintf "'%s'", $self->slots;
67ad26d9	265
ac1ef2f9	266	my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
	267	$code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
	268	if $self->is_weak_ref;
	269	return $code;
8a7a9c53	270	}
8a7a9c53	271
67ad26d9	272	sub _inline_trigger {
ac1ef2f9	273	my ($self, $instance, $value) = @_;
67ad26d9	274	return '' unless $self->has_trigger;
67ad26d9	275	return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
8a7a9c53	276	}
8a7a9c53	277
ddd0ec20	278	sub _inline_get {
ac1ef2f9	279	my ($self, $instance) = @_;
ddd0ec20	280
ddd0ec20	281	my $mi = $self->associated_class->get_meta_instance;
ac1ef2f9	282	my $slot_name = sprintf "'%s'", $self->slots;
ddd0ec20	283
ac1ef2f9	284	return $mi->inline_get_slot_value($instance, $slot_name);
ddd0ec20	285	}
ddd0ec20	286
1a563243	287	sub _inline_auto_deref {
	288	my ( $self, $ref_value ) = @_;
	289
	290	return $ref_value unless $self->should_auto_deref;
	291
536f0b17	292	my $type = $self->type_constraint->name;
1a563243	293
536f0b17	294	my $sigil;
536f0b17	295	if ($type eq "ArrayRef") {
1a563243	296	$sigil = '@';
536f0b17	297	}
536f0b17	298	elsif ($type eq 'HashRef') {
1a563243	299	$sigil = '%';
536f0b17	300	}
	301	else {
	302	confess "Can not auto de-reference the type constraint '$type'";
1a563243	303	}
	304
	305	"(wantarray() ? $sigil\{ ( $ref_value ) \|\| return } : ( $ref_value ) )";
	306	}
	307
a15dff8d	308	sub generate_accessor_method {
67ad26d9	309	my ($attr, $attr_name) = @_;
	310	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	311	my $mi = $attr->associated_class->get_meta_instance;
ac1ef2f9	312	my $slot_name = sprintf "'%s'", $attr->slots;
67ad26d9	313	my $inv = '$_[0]';
ca01a97b	314	my $code = 'sub { '
ca01a97b	315	. 'if (scalar(@_) == 2) {'
9e93dd19	316	. $attr->_inline_check_required
9e93dd19	317	. $attr->_inline_check_coercion
ac1ef2f9	318	. $attr->_inline_check_constraint($value_name)
	319	. $attr->_inline_store($inv, $value_name)
	320	. $attr->_inline_trigger($inv, $value_name)
ca01a97b	321	. ' }'
9e93dd19	322	. $attr->_inline_check_lazy
536f0b17	323	. 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
ca01a97b	324	. ' }';
ca01a97b	325	my $sub = eval $code;
67ad26d9	326	confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
ca01a97b	327	return $sub;
a15dff8d	328	}
	329
	330	sub generate_writer_method {
67ad26d9	331	my ($attr, $attr_name) = @_;
	332	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	333	my $inv = '$_[0]';
ca01a97b	334	my $code = 'sub { '
9e93dd19	335	. $attr->_inline_check_required
9e93dd19	336	. $attr->_inline_check_coercion
ac1ef2f9	337	. $attr->_inline_check_constraint($value_name)
	338	. $attr->_inline_store($inv, $value_name)
	339	. $attr->_inline_trigger($inv, $value_name)
ca01a97b	340	. ' }';
	341	my $sub = eval $code;
	342	confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
	343	return $sub;
a15dff8d	344	}
c0e30cf5	345
d7f17ebb	346	sub generate_reader_method {
9e93dd19	347	my $attr = shift;
9e93dd19	348	my $attr_name = $attr->slots;
ca01a97b	349	my $code = 'sub {'
ca01a97b	350	. 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
9e93dd19	351	. $attr->_inline_check_lazy
9e93dd19	352	. 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
ca01a97b	353	. '}';
	354	my $sub = eval $code;
	355	confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
	356	return $sub;
d7f17ebb	357	}
d7f17ebb	358
452bac1b	359	sub install_accessors {
	360	my $self = shift;
	361	$self->SUPER::install_accessors(@_);
	362
	363	if ($self->has_handles) {
	364
	365	# NOTE:
	366	# Here we canonicalize the 'handles' option
	367	# this will sort out any details and always
	368	# return an hash of methods which we want
	369	# to delagate to, see that method for details
	370	my %handles = $self->_canonicalize_handles();
	371
	372	# find the name of the accessor for this attribute
	373	my $accessor_name = $self->reader \|\| $self->accessor;
	374	(defined $accessor_name)
	375	\|\| confess "You cannot install delegation without a reader or accessor for the attribute";
	376
	377	# make sure we handle HASH accessors correctly
	378	($accessor_name) = keys %{$accessor_name}
	379	if ref($accessor_name) eq 'HASH';
	380
	381	# install the delegation ...
	382	my $associated_class = $self->associated_class;
	383	foreach my $handle (keys %handles) {
	384	my $method_to_call = $handles{$handle};
	385
	386	(!$associated_class->has_method($handle))
	387	\|\| confess "You cannot overwrite a locally defined method ($handle) with a delegation";
	388
	389	if ((reftype($method_to_call) \|\| '') eq 'CODE') {
	390	$associated_class->add_method($handle => $method_to_call);
	391	}
	392	else {
	393	$associated_class->add_method($handle => sub {
b805c70c	394	# FIXME
	395	# we should check for lack of
	396	# a callable return value from
	397	# the accessor here
452bac1b	398	((shift)->$accessor_name())->$method_to_call(@_);
	399	});
	400	}
	401	}
	402	}
	403
	404	return;
	405	}
	406
98aae381	407	# private methods to help delegation ...
98aae381	408
452bac1b	409	sub _canonicalize_handles {
	410	my $self = shift;
	411	my $handles = $self->handles;
	412	if (ref($handles) eq 'HASH') {
	413	return %{$handles};
	414	}
	415	elsif (ref($handles) eq 'ARRAY') {
	416	return map { $_ => $_ } @{$handles};
	417	}
	418	elsif (ref($handles) eq 'Regexp') {
	419	($self->has_type_constraint)
	420	\|\| confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
	421	return map { ($_ => $_) }
	422	grep { $handles } $self->_get_delegate_method_list;
	423	}
	424	elsif (ref($handles) eq 'CODE') {
	425	return $handles->($self, $self->_find_delegate_metaclass);
	426	}
	427	else {
	428	confess "Unable to canonicalize the 'handles' option with $handles";
	429	}
	430	}
	431
	432	sub _find_delegate_metaclass {
	433	my $self = shift;
98aae381	434	if (my $class = $self->_isa_metadata) {
452bac1b	435	# if the class does have
	436	# a meta method, use it
	437	return $class->meta if $class->can('meta');
	438	# otherwise we might be
	439	# dealing with a non-Moose
	440	# class, and need to make
	441	# our own metaclass
	442	return Moose::Meta::Class->initialize($class);
	443	}
98aae381	444	elsif (my $role = $self->_does_metadata) {
452bac1b	445	# our role will always have
452bac1b	446	# a meta method
98aae381	447	return $role->meta;
452bac1b	448	}
	449	else {
	450	confess "Cannot find delegate metaclass for attribute " . $self->name;
	451	}
	452	}
	453
	454	sub _get_delegate_method_list {
	455	my $self = shift;
	456	my $meta = $self->_find_delegate_metaclass;
	457	if ($meta->isa('Class::MOP::Class')) {
093b12c2	458	return map { $_->{name} } # NOTE: !never! delegate &meta
093b12c2	459	grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
452bac1b	460	$meta->compute_all_applicable_methods;
	461	}
	462	elsif ($meta->isa('Moose::Meta::Role')) {
	463	return $meta->get_method_list;
	464	}
	465	else {
	466	confess "Unable to recognize the delegate metaclass '$meta'";
	467	}
	468	}
	469
c0e30cf5	470	1;
	471
	472	__END__
	473
	474	=pod
	475
	476	=head1 NAME
	477
6ba6d68c	478	Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5	479
	480	=head1 DESCRIPTION
	481
e522431d	482	This is a subclass of L<Class::MOP::Attribute> with Moose specific
6ba6d68c	483	extensions.
	484
	485	For the most part, the only time you will ever encounter an
	486	instance of this class is if you are doing some serious deep
	487	introspection. To really understand this class, you need to refer
	488	to the L<Class::MOP::Attribute> documentation.
e522431d	489
c0e30cf5	490	=head1 METHODS
c0e30cf5	491
6ba6d68c	492	=head2 Overridden methods
	493
	494	These methods override methods in L<Class::MOP::Attribute> and add
	495	Moose specific features. You can safely assume though that they
	496	will behave just as L<Class::MOP::Attribute> does.
	497
c0e30cf5	498	=over 4
	499
	500	=item B<new>
	501
d500266f	502	=item B<initialize_instance_slot>
d500266f	503
a15dff8d	504	=item B<generate_accessor_method>
	505
	506	=item B<generate_writer_method>
	507
d7f17ebb	508	=item B<generate_reader_method>
d7f17ebb	509
452bac1b	510	=item B<install_accessors>
452bac1b	511
a15dff8d	512	=back
a15dff8d	513
6ba6d68c	514	=head2 Additional Moose features
6ba6d68c	515
8449e6e7	516	Moose attributes support type-constraint checking, weak reference
6ba6d68c	517	creation and type coercion.
6ba6d68c	518
a15dff8d	519	=over 4
a15dff8d	520
9e93dd19	521	=item B<clone_and_inherit_options>
	522
	523	This is to support the C<has '+foo'> feature, it clones an attribute
	524	from a superclass and allows a very specific set of changes to be made
	525	to the attribute.
	526
a15dff8d	527	=item B<has_type_constraint>
a15dff8d	528
6ba6d68c	529	Returns true if this meta-attribute has a type constraint.
6ba6d68c	530
a15dff8d	531	=item B<type_constraint>
a15dff8d	532
6ba6d68c	533	A read-only accessor for this meta-attribute's type constraint. For
	534	more information on what you can do with this, see the documentation
	535	for L<Moose::Meta::TypeConstraint>.
a15dff8d	536
452bac1b	537	=item B<has_handles>
	538
	539	Returns true if this meta-attribute performs delegation.
	540
	541	=item B<handles>
	542
	543	This returns the value which was passed into the handles option.
	544
6ba6d68c	545	=item B<is_weak_ref>
a15dff8d	546
02a0fb52	547	Returns true if this meta-attribute produces a weak reference.
4b598ea3	548
ca01a97b	549	=item B<is_required>
ca01a97b	550
02a0fb52	551	Returns true if this meta-attribute is required to have a value.
ca01a97b	552
	553	=item B<is_lazy>
	554
02a0fb52	555	Returns true if this meta-attribute should be initialized lazily.
ca01a97b	556
	557	NOTE: lazy attributes, B<must> have a C<default> field set.
	558
34a66aa3	559	=item B<should_coerce>
4b598ea3	560
02a0fb52	561	Returns true if this meta-attribute should perform type coercion.
6ba6d68c	562
536f0b17	563	=item B<should_auto_deref>
	564
	565	Returns true if this meta-attribute should perform automatic
	566	auto-dereferencing.
	567
	568	NOTE: This can only be done for attributes whose type constraint is
	569	either I<ArrayRef> or I<HashRef>.
	570
8c9d74e7	571	=item B<has_trigger>
8c9d74e7	572
02a0fb52	573	Returns true if this meta-attribute has a trigger set.
02a0fb52	574
8c9d74e7	575	=item B<trigger>
8c9d74e7	576
02a0fb52	577	This is a CODE reference which will be executed every time the
	578	value of an attribute is assigned. The CODE ref will get two values,
	579	the invocant and the new value. This can be used to handle I<basic>
	580	bi-directional relations.
	581
c0e30cf5	582	=back
	583
	584	=head1 BUGS
	585
	586	All complex software has bugs lurking in it, and this module is no
	587	exception. If you find a bug please either email me, or add the bug
	588	to cpan-RT.
	589
c0e30cf5	590	=head1 AUTHOR
	591
	592	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	593
98aae381	594	Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
98aae381	595
c0e30cf5	596	=head1 COPYRIGHT AND LICENSE
	597
	598	Copyright 2006 by Infinity Interactive, Inc.
	599
	600	L<http://www.iinteractive.com>
	601
	602	This library is free software; you can redistribute it and/or modify
	603	it under the same terms as Perl itself.
	604
8a7a9c53	605	=cut