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