[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';
use overload     ();

our $VERSION   = '0.12';
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',
));
__PACKAGE__->meta->add_attribute('documentation' => (
    reader    => 'documentation',
    predicate => 'has_documentation',
));

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, coerce, documentation and lazy
    my %actual_options;
    foreach my $legal_option (qw(default coerce required documentation lazy)) {
        if (exists $options{$legal_option}) {
            $actual_options{$legal_option} = $options{$legal_option};
            delete $options{$legal_option};
        }
    }
    
    # handles can only be added, not changed
    if ($options{handles}) {
        confess "You can only add the 'handles' option, you cannot change it"
            if $self->has_handles;
        $actual_options{handles} = $options{handles};
        delete $options{handles};
    }
    
    # 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 {
		    $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
		        $options->{isa},
		        {
		            parent     => Moose::Util::TypeConstraints::find_type_constraint('Object'), 
	                constraint => sub { $_[0]->isa($options->{isa}) }
	            }		        
		    );
		}
	}	
	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 {
		    $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
		        $options->{does},
		        {
		            parent     => Moose::Util::TypeConstraints::find_type_constraint('Role'), 
	                constraint => sub { $_[0]->does($options->{does}) }
	            }
		    );
		}	    
	}
	
	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};
        
        if (!defined $val && $self->is_required) {
            confess "Attribute (" . $self->name . ") is required and cannot be undef";             
        }
    }
    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 || $self->has_default) {
	    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 '" . 
                           (defined $val 
                               ? (blessed($val) && overload::Overloaded($val) 
                                    ? overload::StrVal($val) 
                                    : $val) 
                               : 'undef') . 
                           "'";			
        }
	}

    $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) 
                    ? ("'" . 
                        (blessed($value) && overload::Overloaded($value) 
                            ? overload::StrVal($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";
            
            # NOTE:
            # handles is not allowed to delegate
            # any of these methods, as they will 
            # override the ones in your class, which 
            # is almost certainly not what you want.
            next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
            
            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 
                    my $proxy = (shift)->$accessor_name();
                    @_ = ($proxy, @_);
                    goto &{ $proxy->can($method_to_call)};
                });
            }
        }
    }
    
    return;
}

# private methods to help delegation ...

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

        (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
            || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
        
        return map { $_ => $_ } (
            $role_meta->get_method_list, 
            $role_meta->get_required_method_list
        );
    }
}

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>

  eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
  if($@) {
    print "Oops: $@\n";
  }

I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>

Before setting the value, a check is made on the type constraint of
the attribute, if it has one, to see if the value passes it. If the
value fails to pass, the set operation dies with a L<Carp/confess>.

Any coercion to convert values is done before checking the type constraint.

To check a value against a type constraint before setting it, fetch the
attribute instance using L<Moose::Meta::Attribute/find_attribute_by_name>,
fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
for an example.

=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.

=item B<documentation>

This is a string which contains the documentation for this attribute. 
It serves no direct purpose right now, but it might in the future
in some kind of automated documentation system perhaps.

=item B<has_documentation>

Returns true if this meta-attribute has any documentation.

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