[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.08';

use Moose::Meta::Method::Accessor;
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} . "'";
		}
		# NOTE:
		# check here to see if the new type 
		# is a subtype of the old one
		($type_constraint->is_subtype_of($self->type_constraint->name))
		    || confess "New type constraint setting must be a subtype of inherited one"
		        # iff we have a type constraint that is ...
		        if $self->has_type_constraint;
		# then we use it :)
		$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";	        
        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}->is_a_type_of('ArrayRef') ||
         $options->{type_constraint}->is_a_type_of('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->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;
}

## Slot management

#sub set_value {
#    my ($self, $instance, $value) = @_;
#}
#
#sub get_value {
#    my ($self, $instance) = @_;
#}
#
#sub has_value {
#    my ($self, $instance) = @_;   
#}
#
#sub clear_value {
#    my ($self, $instance) = @_;   
#}

## installing accessors 

sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }

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<install_accessors>

=item B<accessor_metaclass>

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