[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.11';
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 {
		    
		    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";
            
            # 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>

=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';
a15dff8d	9
c84f324f	10	our $VERSION = '0.11';
d44714be	11	our $AUTHORITY = 'cpan:STEVAN';
78cd1d3b	12
8ee73eeb	13	use Moose::Meta::Method::Accessor;
a3c7e2fe	14	use Moose::Util::TypeConstraints ();
bc1e29b5	15
c0e30cf5	16	use base 'Class::MOP::Attribute';
c0e30cf5	17
452bac1b	18	# options which are not directly used
452bac1b	19	# but we store them for metadata purposes
98aae381	20	__PACKAGE__->meta->add_attribute('isa' => (reader => '_isa_metadata'));
	21	__PACKAGE__->meta->add_attribute('does' => (reader => '_does_metadata'));
	22	__PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata'));
452bac1b	23
452bac1b	24	# these are actual options for the attrs
1a563243	25	__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
	26	__PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
	27	__PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' ));
	28	__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
	29	__PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
82168dbb	30	__PACKAGE__->meta->add_attribute('type_constraint' => (
	31	reader => 'type_constraint',
	32	predicate => 'has_type_constraint',
	33	));
8c9d74e7	34	__PACKAGE__->meta->add_attribute('trigger' => (
	35	reader => 'trigger',
	36	predicate => 'has_trigger',
	37	));
452bac1b	38	__PACKAGE__->meta->add_attribute('handles' => (
	39	reader => 'handles',
	40	predicate => 'has_handles',
	41	));
ddbdc0cb	42	__PACKAGE__->meta->add_attribute('documentation' => (
	43	reader => 'documentation',
	44	predicate => 'has_documentation',
	45	));
82168dbb	46
78cd1d3b	47	sub new {
78cd1d3b	48	my ($class, $name, %options) = @_;
1d768fb1	49	$class->_process_options($name, \%options);
98aae381	50	return $class->SUPER::new($name, %options);
1d768fb1	51	}
1d768fb1	52
ce0e8d63	53	sub clone_and_inherit_options {
ce0e8d63	54	my ($self, %options) = @_;
83cc9094	55	# you can change default, required, coerce, documentation and lazy
ce0e8d63	56	my %actual_options;
83cc9094	57	foreach my $legal_option (qw(default coerce required documentation lazy)) {
ce0e8d63	58	if (exists $options{$legal_option}) {
	59	$actual_options{$legal_option} = $options{$legal_option};
	60	delete $options{$legal_option};
	61	}
	62	}
83cc9094	63
	64	# handles can only be added, not changed
	65	if ($options{handles}) {
	66	confess "You can only add the 'handles' option, you cannot change it"
	67	if $self->has_handles;
	68	$actual_options{handles} = $options{handles};
	69	delete $options{handles};
	70	}
	71
fcb7afc2	72	# isa can be changed, but only if the
fcb7afc2	73	# new type is a subtype
ce0e8d63	74	if ($options{isa}) {
	75	my $type_constraint;
	76	if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
	77	$type_constraint = $options{isa};
	78	}
	79	else {
	80	$type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
	81	(defined $type_constraint)
	82	\|\| confess "Could not find the type constraint '" . $options{isa} . "'";
	83	}
2a0f3bd3	84	# NOTE:
	85	# check here to see if the new type
	86	# is a subtype of the old one
ce0e8d63	87	($type_constraint->is_subtype_of($self->type_constraint->name))
ce0e8d63	88	\|\| confess "New type constraint setting must be a subtype of inherited one"
2a0f3bd3	89	# iff we have a type constraint that is ...
ce0e8d63	90	if $self->has_type_constraint;
2a0f3bd3	91	# then we use it :)
ce0e8d63	92	$actual_options{type_constraint} = $type_constraint;
	93	delete $options{isa};
	94	}
	95	(scalar keys %options == 0)
	96	\|\| confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
	97	$self->clone(%actual_options);
1d768fb1	98	}
	99
	100	sub _process_options {
	101	my ($class, $name, $options) = @_;
452bac1b	102
1d768fb1	103	if (exists $options->{is}) {
1d768fb1	104	if ($options->{is} eq 'ro') {
df492bba	105	$options->{reader} \|\|= $name;
1d768fb1	106	(!exists $options->{trigger})
8c9d74e7	107	\|\| confess "Cannot have a trigger on a read-only attribute";
78cd1d3b	108	}
1d768fb1	109	elsif ($options->{is} eq 'rw') {
452bac1b	110	$options->{accessor} = $name;
98aae381	111	((reftype($options->{trigger}) \|\| '') eq 'CODE')
	112	\|\| confess "Trigger must be a CODE ref"
	113	if exists $options->{trigger};
452bac1b	114	}
	115	else {
	116	confess "I do not understand this option (is => " . $options->{is} . ")"
78cd1d3b	117	}
	118	}
	119
1d768fb1	120	if (exists $options->{isa}) {
02a0fb52	121
1d768fb1	122	if (exists $options->{does}) {
	123	if (eval { $options->{isa}->can('does') }) {
	124	($options->{isa}->does($options->{does}))
02a0fb52	125	\|\| confess "Cannot have an isa option and a does option if the isa does not do the does";
02a0fb52	126	}
7eaef7ad	127	else {
	128	confess "Cannot have an isa option which cannot ->does()";
	129	}
02a0fb52	130	}
02a0fb52	131
78cd1d3b	132	# allow for anon-subtypes here ...
1d768fb1	133	if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
1d768fb1	134	$options->{type_constraint} = $options->{isa};
78cd1d3b	135	}
78cd1d3b	136	else {
c07af9d2	137
1d768fb1	138	if ($options->{isa} =~ /\\|/) {
	139	my @type_constraints = split /\s\\|\s/ => $options->{isa};
	140	$options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
c07af9d2	141	@type_constraints
78cd1d3b	142	);
c07af9d2	143	}
	144	else {
	145	# otherwise assume it is a constraint
1d768fb1	146	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
c07af9d2	147	# if the constraing it not found ....
	148	unless (defined $constraint) {
	149	# assume it is a foreign class, and make
	150	# an anon constraint for it
	151	$constraint = Moose::Util::TypeConstraints::subtype(
	152	'Object',
1d768fb1	153	Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
c07af9d2	154	);
c07af9d2	155	}
1d768fb1	156	$options->{type_constraint} = $constraint;
c07af9d2	157	}
78cd1d3b	158	}
78cd1d3b	159	}
1d768fb1	160	elsif (exists $options->{does}) {
02a0fb52	161	# allow for anon-subtypes here ...
1d768fb1	162	if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
1d768fb1	163	$options->{type_constraint} = $options->{isa};
02a0fb52	164	}
	165	else {
	166	# otherwise assume it is a constraint
1d768fb1	167	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
02a0fb52	168	# if the constraing it not found ....
	169	unless (defined $constraint) {
	170	# assume it is a foreign class, and make
	171	# an anon constraint for it
	172	$constraint = Moose::Util::TypeConstraints::subtype(
	173	'Role',
1d768fb1	174	Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
02a0fb52	175	);
02a0fb52	176	}
1d768fb1	177	$options->{type_constraint} = $constraint;
02a0fb52	178	}
02a0fb52	179	}
78cd1d3b	180
1d768fb1	181	if (exists $options->{coerce} && $options->{coerce}) {
1d768fb1	182	(exists $options->{type_constraint})
3ec7b7a3	183	\|\| confess "You cannot have coercion without specifying a type constraint";
4b598ea3	184	confess "You cannot have a weak reference to a coerced value"
1d768fb1	185	if $options->{weak_ref};
ca01a97b	186	}
78cd1d3b	187
536f0b17	188	if (exists $options->{auto_deref} && $options->{auto_deref}) {
	189	(exists $options->{type_constraint})
	190	\|\| confess "You cannot auto-dereference without specifying a type constraint";
94b8bbb8	191	($options->{type_constraint}->is_a_type_of('ArrayRef') \|\|
94b8bbb8	192	$options->{type_constraint}->is_a_type_of('HashRef'))
536f0b17	193	\|\| confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
	194	}
	195
1d768fb1	196	if (exists $options->{lazy} && $options->{lazy}) {
1d768fb1	197	(exists $options->{default})
ca01a97b	198	\|\| confess "You cannot have lazy attribute without specifying a default value for it";
1d768fb1	199	}
78cd1d3b	200	}
c0e30cf5	201
d500266f	202	sub initialize_instance_slot {
ddd0ec20	203	my ($self, $meta_instance, $instance, $params) = @_;
d500266f	204	my $init_arg = $self->init_arg();
d500266f	205	# try to fetch the init arg from the %params ...
ddd0ec20	206
d500266f	207	my $val;
	208	if (exists $params->{$init_arg}) {
	209	$val = $params->{$init_arg};
	210	}
	211	else {
	212	# skip it if it's lazy
	213	return if $self->is_lazy;
	214	# and die if it's required and doesn't have a default value
	215	confess "Attribute (" . $self->name . ") is required"
	216	if $self->is_required && !$self->has_default;
	217	}
ddd0ec20	218
d500266f	219	# if nothing was in the %params, we can use the
	220	# attribute's default value (if it has one)
	221	if (!defined $val && $self->has_default) {
	222	$val = $self->default($instance);
	223	}
d7611a4a	224
d500266f	225	if (defined $val) {
d500266f	226	if ($self->has_type_constraint) {
c07af9d2	227	my $type_constraint = $self->type_constraint;
c07af9d2	228	if ($self->should_coerce && $type_constraint->has_coercion) {
0a5bd159	229	$val = $type_constraint->coerce($val);
d500266f	230	}
c07af9d2	231	(defined($type_constraint->check($val)))
	232	\|\| confess "Attribute (" .
	233	$self->name .
8449e6e7	234	") does not pass the type constraint (" .
c07af9d2	235	$type_constraint->name .
c07af9d2	236	") with '$val'";
d500266f	237	}
d500266f	238	}
ddd0ec20	239
ac1ef2f9	240	$meta_instance->set_slot_value($instance, $self->name, $val);
	241	$meta_instance->weaken_slot_value($instance, $self->name)
	242	if ref $val && $self->is_weak_ref;
d500266f	243	}
d500266f	244
d617b644	245	## Slot management
9e93dd19	246
946289d1	247	sub set_value {
	248	my ($self, $instance, $value) = @_;
	249
	250	my $attr_name = $self->name;
	251
	252	if ($self->is_required) {
	253	defined($value)
	254	\|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";
	255	}
	256
	257	if ($self->has_type_constraint) {
	258
	259	my $type_constraint = $self->type_constraint;
	260
	261	if ($self->should_coerce) {
	262	$value = $type_constraint->coerce($value);
	263	}
	264	defined($type_constraint->_compiled_type_constraint->($value))
	265	\|\| confess "Attribute ($attr_name) does not pass the type constraint ("
	266	. $type_constraint->name . ") with " . (defined($value) ? ("'" . $value . "'") : "undef")
	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
a15dff8d	506	=back
a15dff8d	507
6ba6d68c	508	=head2 Additional Moose features
6ba6d68c	509
8449e6e7	510	Moose attributes support type-constraint checking, weak reference
6ba6d68c	511	creation and type coercion.
6ba6d68c	512
a15dff8d	513	=over 4
a15dff8d	514
9e93dd19	515	=item B<clone_and_inherit_options>
	516
	517	This is to support the C<has '+foo'> feature, it clones an attribute
	518	from a superclass and allows a very specific set of changes to be made
	519	to the attribute.
	520
a15dff8d	521	=item B<has_type_constraint>
a15dff8d	522
6ba6d68c	523	Returns true if this meta-attribute has a type constraint.
6ba6d68c	524
a15dff8d	525	=item B<type_constraint>
a15dff8d	526
6ba6d68c	527	A read-only accessor for this meta-attribute's type constraint. For
	528	more information on what you can do with this, see the documentation
	529	for L<Moose::Meta::TypeConstraint>.
a15dff8d	530
452bac1b	531	=item B<has_handles>
	532
	533	Returns true if this meta-attribute performs delegation.
	534
	535	=item B<handles>
	536
	537	This returns the value which was passed into the handles option.
	538
6ba6d68c	539	=item B<is_weak_ref>
a15dff8d	540
02a0fb52	541	Returns true if this meta-attribute produces a weak reference.
4b598ea3	542
ca01a97b	543	=item B<is_required>
ca01a97b	544
02a0fb52	545	Returns true if this meta-attribute is required to have a value.
ca01a97b	546
	547	=item B<is_lazy>
	548
02a0fb52	549	Returns true if this meta-attribute should be initialized lazily.
ca01a97b	550
	551	NOTE: lazy attributes, B<must> have a C<default> field set.
	552
34a66aa3	553	=item B<should_coerce>
4b598ea3	554
02a0fb52	555	Returns true if this meta-attribute should perform type coercion.
6ba6d68c	556
536f0b17	557	=item B<should_auto_deref>
	558
	559	Returns true if this meta-attribute should perform automatic
	560	auto-dereferencing.
	561
	562	NOTE: This can only be done for attributes whose type constraint is
	563	either I<ArrayRef> or I<HashRef>.
	564
8c9d74e7	565	=item B<has_trigger>
8c9d74e7	566
02a0fb52	567	Returns true if this meta-attribute has a trigger set.
02a0fb52	568
8c9d74e7	569	=item B<trigger>
8c9d74e7	570
02a0fb52	571	This is a CODE reference which will be executed every time the
	572	value of an attribute is assigned. The CODE ref will get two values,
	573	the invocant and the new value. This can be used to handle I<basic>
	574	bi-directional relations.
	575
ddbdc0cb	576	=item B<documentation>
	577
	578	This is a string which contains the documentation for this attribute.
	579	It serves no direct purpose right now, but it might in the future
	580	in some kind of automated documentation system perhaps.
	581
	582	=item B<has_documentation>
	583
	584	Returns true if this meta-attribute has any documentation.
	585
c0e30cf5	586	=back
	587
	588	=head1 BUGS
	589
	590	All complex software has bugs lurking in it, and this module is no
	591	exception. If you find a bug please either email me, or add the bug
	592	to cpan-RT.
	593
c0e30cf5	594	=head1 AUTHOR
	595
	596	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	597
98aae381	598	Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
98aae381	599
c0e30cf5	600	=head1 COPYRIGHT AND LICENSE
c0e30cf5	601
b77fdbed	602	Copyright 2006, 2007 by Infinity Interactive, Inc.
c0e30cf5	603
	604	L<http://www.iinteractive.com>
	605
	606	This library is free software; you can redistribute it and/or modify
	607	it under the same terms as Perl itself.
	608
8a7a9c53	609	=cut