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