[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.09';
our $AUTHORITY = 'cpan:STEVAN';

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) = @_;
    
    my $attr_name = $self->name;
    
    if ($self->is_required) {
        defined($value) 
            || confess "Attribute ($attr_name) is required, so cannot be set to undef";
    }
    
    if ($self->has_type_constraint) {
        
        my $type_constraint = $self->type_constraint;
        
        if ($self->should_coerce) {
            $value = $type_constraint->coerce($value);           
        }
        defined($type_constraint->_compiled_type_constraint->($value))
        	|| confess "Attribute ($attr_name) does not pass the type constraint ("
               . $type_constraint->name . ") with " . (defined($value) ? ("'" . $value . "'") : "undef")
          if defined($value);
    }
    
    my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
                                         ->get_meta_instance;
                                         
    $meta_instance->set_slot_value($instance, $attr_name, $value);  
      
    if (ref $value && $self->is_weak_ref) {
        $meta_instance->weaken_slot_value($instance, $attr_name);            
    }
    
    if ($self->has_trigger) {
        $self->trigger->($instance, $value, $self);
    }
}

sub get_value {
    my ($self, $instance) = @_;
    
    if ($self->is_lazy) {
	    unless ($self->has_value($instance)) {
	        if ($self->has_default) {
	            my $default = $self->default($instance);
	            $self->set_value($instance, $default);
	        }
	        else {
                $self->set_value($instance, undef);
	        }
	    }   
    }
    
    if ($self->should_auto_deref) {
        
        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 {
            confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
        }
               
    }
    else {
        
        return $self->SUPER::get_value($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>

=item B<get_value>

=item B<set_value>

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