[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) = @_;
    
    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
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
946289d1	232	sub set_value {
	233	my ($self, $instance, $value) = @_;
	234
	235	my $attr_name = $self->name;
	236
	237	if ($self->is_required) {
	238	defined($value)
	239	\|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";
	240	}
	241
	242	if ($self->has_type_constraint) {
	243
	244	my $type_constraint = $self->type_constraint;
	245
	246	if ($self->should_coerce) {
	247	$value = $type_constraint->coerce($value);
	248	}
	249	defined($type_constraint->_compiled_type_constraint->($value))
	250	\|\| confess "Attribute ($attr_name) does not pass the type constraint ("
	251	. $type_constraint->name . ") with " . (defined($value) ? ("'" . $value . "'") : "undef")
	252	if defined($value);
	253	}
	254
	255	my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
	256	->get_meta_instance;
	257
	258	$meta_instance->set_slot_value($instance, $attr_name, $value);
	259
	260	if (ref $value && $self->is_weak_ref) {
	261	$meta_instance->weaken_slot_value($instance, $attr_name);
	262	}
	263
	264	if ($self->has_trigger) {
	265	$self->trigger->($instance, $value, $self);
	266	}
	267	}
	268
	269	sub get_value {
	270	my ($self, $instance) = @_;
	271
	272	if ($self->is_lazy) {
	273	unless ($self->has_value($instance)) {
	274	if ($self->has_default) {
	275	my $default = $self->default($instance);
	276	$self->set_value($instance, $default);
	277	}
	278	else {
	279	$self->set_value($instance, undef);
	280	}
	281	}
	282	}
	283
	284	if ($self->should_auto_deref) {
	285
	286	my $type_constraint = $self->type_constraint;
	287
	288	if ($type_constraint->is_a_type_of('ArrayRef')) {
	289	my $rv = $self->SUPER::get_value($instance);
	290	return unless defined $rv;
	291	return wantarray ? @{ $rv } : $rv;
	292	}
	293	elsif ($type_constraint->is_a_type_of('HashRef')) {
	294	my $rv = $self->SUPER::get_value($instance);
	295	return unless defined $rv;
296	return wantarray ? %{ $rv } : $rv;
297	}
298	else {
299	confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
300	}
301
302	}
303	else {
304
305	return $self->SUPER::get_value($instance);
306	}
307	}
a15dff8d	308
d617b644	309	## installing accessors
c0e30cf5	310
d617b644	311	sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
d7f17ebb	312
452bac1b	313	sub install_accessors {
	314	my $self = shift;
	315	$self->SUPER::install_accessors(@_);
	316
	317	if ($self->has_handles) {
	318
	319	# NOTE:
	320	# Here we canonicalize the 'handles' option
	321	# this will sort out any details and always
	322	# return an hash of methods which we want
	323	# to delagate to, see that method for details
	324	my %handles = $self->_canonicalize_handles();
	325
	326	# find the name of the accessor for this attribute
	327	my $accessor_name = $self->reader \|\| $self->accessor;
	328	(defined $accessor_name)
	329	\|\| confess "You cannot install delegation without a reader or accessor for the attribute";
	330
	331	# make sure we handle HASH accessors correctly
	332	($accessor_name) = keys %{$accessor_name}
	333	if ref($accessor_name) eq 'HASH';
	334
	335	# install the delegation ...
	336	my $associated_class = $self->associated_class;
	337	foreach my $handle (keys %handles) {
	338	my $method_to_call = $handles{$handle};
	339
	340	(!$associated_class->has_method($handle))
	341	\|\| confess "You cannot overwrite a locally defined method ($handle) with a delegation";
	342
	343	if ((reftype($method_to_call) \|\| '') eq 'CODE') {
	344	$associated_class->add_method($handle => $method_to_call);
	345	}
	346	else {
	347	$associated_class->add_method($handle => sub {
b805c70c	348	# FIXME
	349	# we should check for lack of
	350	# a callable return value from
	351	# the accessor here
452bac1b	352	((shift)->$accessor_name())->$method_to_call(@_);
	353	});
	354	}
	355	}
	356	}
	357
	358	return;
	359	}
	360
98aae381	361	# private methods to help delegation ...
98aae381	362
452bac1b	363	sub _canonicalize_handles {
	364	my $self = shift;
	365	my $handles = $self->handles;
	366	if (ref($handles) eq 'HASH') {
	367	return %{$handles};
	368	}
	369	elsif (ref($handles) eq 'ARRAY') {
	370	return map { $_ => $_ } @{$handles};
	371	}
	372	elsif (ref($handles) eq 'Regexp') {
	373	($self->has_type_constraint)
	374	\|\| confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
	375	return map { ($_ => $_) }
	376	grep { $handles } $self->_get_delegate_method_list;
	377	}
	378	elsif (ref($handles) eq 'CODE') {
	379	return $handles->($self, $self->_find_delegate_metaclass);
	380	}
	381	else {
	382	confess "Unable to canonicalize the 'handles' option with $handles";
	383	}
	384	}
	385
	386	sub _find_delegate_metaclass {
	387	my $self = shift;
98aae381	388	if (my $class = $self->_isa_metadata) {
452bac1b	389	# if the class does have
	390	# a meta method, use it
	391	return $class->meta if $class->can('meta');
	392	# otherwise we might be
	393	# dealing with a non-Moose
	394	# class, and need to make
	395	# our own metaclass
	396	return Moose::Meta::Class->initialize($class);
	397	}
98aae381	398	elsif (my $role = $self->_does_metadata) {
452bac1b	399	# our role will always have
452bac1b	400	# a meta method
98aae381	401	return $role->meta;
452bac1b	402	}
	403	else {
	404	confess "Cannot find delegate metaclass for attribute " . $self->name;
	405	}
	406	}
	407
	408	sub _get_delegate_method_list {
	409	my $self = shift;
	410	my $meta = $self->_find_delegate_metaclass;
	411	if ($meta->isa('Class::MOP::Class')) {
093b12c2	412	return map { $_->{name} } # NOTE: !never! delegate &meta
093b12c2	413	grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
452bac1b	414	$meta->compute_all_applicable_methods;
	415	}
	416	elsif ($meta->isa('Moose::Meta::Role')) {
	417	return $meta->get_method_list;
	418	}
	419	else {
	420	confess "Unable to recognize the delegate metaclass '$meta'";
	421	}
	422	}
	423
c0e30cf5	424	1;
	425
	426	__END__
	427
	428	=pod
	429
	430	=head1 NAME
	431
6ba6d68c	432	Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5	433
	434	=head1 DESCRIPTION
	435
e522431d	436	This is a subclass of L<Class::MOP::Attribute> with Moose specific
6ba6d68c	437	extensions.
	438
	439	For the most part, the only time you will ever encounter an
	440	instance of this class is if you are doing some serious deep
	441	introspection. To really understand this class, you need to refer
	442	to the L<Class::MOP::Attribute> documentation.
e522431d	443
c0e30cf5	444	=head1 METHODS
c0e30cf5	445
6ba6d68c	446	=head2 Overridden methods
	447
	448	These methods override methods in L<Class::MOP::Attribute> and add
	449	Moose specific features. You can safely assume though that they
	450	will behave just as L<Class::MOP::Attribute> does.
	451
c0e30cf5	452	=over 4
	453
	454	=item B<new>
	455
d500266f	456	=item B<initialize_instance_slot>
d500266f	457
452bac1b	458	=item B<install_accessors>
452bac1b	459
39b3bc94	460	=item B<accessor_metaclass>
39b3bc94	461
946289d1	462	=item B<get_value>
	463
	464	=item B<set_value>
	465
a15dff8d	466	=back
a15dff8d	467
6ba6d68c	468	=head2 Additional Moose features
6ba6d68c	469
8449e6e7	470	Moose attributes support type-constraint checking, weak reference
6ba6d68c	471	creation and type coercion.
6ba6d68c	472
a15dff8d	473	=over 4
a15dff8d	474
9e93dd19	475	=item B<clone_and_inherit_options>
	476
	477	This is to support the C<has '+foo'> feature, it clones an attribute
	478	from a superclass and allows a very specific set of changes to be made
	479	to the attribute.
	480
a15dff8d	481	=item B<has_type_constraint>
a15dff8d	482
6ba6d68c	483	Returns true if this meta-attribute has a type constraint.
6ba6d68c	484
a15dff8d	485	=item B<type_constraint>
a15dff8d	486
6ba6d68c	487	A read-only accessor for this meta-attribute's type constraint. For
	488	more information on what you can do with this, see the documentation
	489	for L<Moose::Meta::TypeConstraint>.
a15dff8d	490
452bac1b	491	=item B<has_handles>
	492
	493	Returns true if this meta-attribute performs delegation.
	494
	495	=item B<handles>
	496
	497	This returns the value which was passed into the handles option.
	498
6ba6d68c	499	=item B<is_weak_ref>
a15dff8d	500
02a0fb52	501	Returns true if this meta-attribute produces a weak reference.
4b598ea3	502
ca01a97b	503	=item B<is_required>
ca01a97b	504
02a0fb52	505	Returns true if this meta-attribute is required to have a value.
ca01a97b	506
	507	=item B<is_lazy>
	508
02a0fb52	509	Returns true if this meta-attribute should be initialized lazily.
ca01a97b	510
	511	NOTE: lazy attributes, B<must> have a C<default> field set.
	512
34a66aa3	513	=item B<should_coerce>
4b598ea3	514
02a0fb52	515	Returns true if this meta-attribute should perform type coercion.
6ba6d68c	516
536f0b17	517	=item B<should_auto_deref>
	518
	519	Returns true if this meta-attribute should perform automatic
	520	auto-dereferencing.
	521
	522	NOTE: This can only be done for attributes whose type constraint is
	523	either I<ArrayRef> or I<HashRef>.
	524
8c9d74e7	525	=item B<has_trigger>
8c9d74e7	526
02a0fb52	527	Returns true if this meta-attribute has a trigger set.
02a0fb52	528
8c9d74e7	529	=item B<trigger>
8c9d74e7	530
02a0fb52	531	This is a CODE reference which will be executed every time the
	532	value of an attribute is assigned. The CODE ref will get two values,
	533	the invocant and the new value. This can be used to handle I<basic>
	534	bi-directional relations.
	535
c0e30cf5	536	=back
	537
	538	=head1 BUGS
	539
	540	All complex software has bugs lurking in it, and this module is no
	541	exception. If you find a bug please either email me, or add the bug
	542	to cpan-RT.
	543
c0e30cf5	544	=head1 AUTHOR
	545
	546	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	547
98aae381	548	Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
98aae381	549
c0e30cf5	550	=head1 COPYRIGHT AND LICENSE
c0e30cf5	551
b77fdbed	552	Copyright 2006, 2007 by Infinity Interactive, Inc.
c0e30cf5	553
	554	L<http://www.iinteractive.com>
	555
	556	This library is free software; you can redistribute it and/or modify
	557	it under the same terms as Perl itself.
	558
8a7a9c53	559	=cut