[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 and documentation 
    my %actual_options;
    foreach my $legal_option (qw(default coerce required documentation)) {
        if (exists $options{$legal_option}) {
            $actual_options{$legal_option} = $options{$legal_option};
            delete $options{$legal_option};
        }
    }
    # isa can be changed, but only if the 
    # new type is a subtype    
    if ($options{isa}) {
        my $type_constraint;
	    if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
			$type_constraint = $options{isa};
		}        
		else {
		    $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
		    (defined $type_constraint)
		        || confess "Could not find the type constraint '" . $options{isa} . "'";
		}
		# NOTE:
		# check here to see if the new type 
		# is a subtype of the old one
		($type_constraint->is_subtype_of($self->type_constraint->name))
		    || confess "New type constraint setting must be a subtype of inherited one"
		        # iff we have a type constraint that is ...
		        if $self->has_type_constraint;
		# then we use it :)
		$actual_options{type_constraint} = $type_constraint;
        delete $options{isa};
    }
    (scalar keys %options == 0) 
        || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
    $self->clone(%actual_options);
}

sub _process_options {
    my ($class, $name, $options) = @_;
    
	if (exists $options->{is}) {
		if ($options->{is} eq 'ro') {
			$options->{reader} ||= $name;
			(!exists $options->{trigger})
			    || confess "Cannot have a trigger on a read-only attribute";
		}
		elsif ($options->{is} eq 'rw') {
			$options->{accessor} = $name;						
    	    ((reftype($options->{trigger}) || '') eq 'CODE')
    	        || confess "Trigger must be a CODE ref"
    	            if exists $options->{trigger};			
		}
		else {
		    confess "I do not understand this option (is => " . $options->{is} . ")"
		}			
	}
	
	if (exists $options->{isa}) {
	    
	    if (exists $options->{does}) {
	        if (eval { $options->{isa}->can('does') }) {
	            ($options->{isa}->does($options->{does}))	            
	                || confess "Cannot have an isa option and a does option if the isa does not do the does";
	        }
	        else {
	            confess "Cannot have an isa option which cannot ->does()";
	        }
	    }	    
	    
	    # allow for anon-subtypes here ...
	    if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
			$options->{type_constraint} = $options->{isa};
		}
		else {
		    
		    if ($options->{isa} =~ /\|/) {
		        my @type_constraints = split /\s*\|\s*/ => $options->{isa};
		        $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
		            @type_constraints
		        );
		    }
		    else {
    		    # otherwise assume it is a constraint
    		    my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});	    
    		    # if the constraing it not found ....
    		    unless (defined $constraint) {
    		        # assume it is a foreign class, and make 
    		        # an anon constraint for it 
    		        $constraint = Moose::Util::TypeConstraints::subtype(
    		            'Object', 
    		            Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
    		        );
    		    }			    
                $options->{type_constraint} = $constraint;
            }
		}
	}	
	elsif (exists $options->{does}) {	    
	    # allow for anon-subtypes here ...
	    if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
			$options->{type_constraint} = $options->{isa};
		}
		else {
		    # otherwise assume it is a constraint
		    my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});	      
		    # if the constraing it not found ....
		    unless (defined $constraint) {	  		        
		        # assume it is a foreign class, and make 
		        # an anon constraint for it 
		        $constraint = Moose::Util::TypeConstraints::subtype(
		            'Role', 
		            Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
		        );
		    }			    
            $options->{type_constraint} = $constraint;
		}	    
	}
	
	if (exists $options->{coerce} && $options->{coerce}) {
	    (exists $options->{type_constraint})
	        || confess "You cannot have coercion without specifying a type constraint";	        
        confess "You cannot have a weak reference to a coerced value"
            if $options->{weak_ref};	        
	}	
	
	if (exists $options->{auto_deref} && $options->{auto_deref}) {
	    (exists $options->{type_constraint})
	        || confess "You cannot auto-dereference without specifying a type constraint";	    
	    ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
         $options->{type_constraint}->is_a_type_of('HashRef'))
	        || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";	        
	}
	
	if (exists $options->{lazy} && $options->{lazy}) {
	    (exists $options->{default})
	        || confess "You cannot have lazy attribute without specifying a default value for it";	    
	}    
}

sub initialize_instance_slot {
    my ($self, $meta_instance, $instance, $params) = @_;
    my $init_arg = $self->init_arg();
    # try to fetch the init arg from the %params ...

    my $val;        
    if (exists $params->{$init_arg}) {
        $val = $params->{$init_arg};
    }
    else {
        # skip it if it's lazy
        return if $self->is_lazy;
        # and die if it's required and doesn't have a default value
        confess "Attribute (" . $self->name . ") is required" 
            if $self->is_required && !$self->has_default;
    }

    # if nothing was in the %params, we can use the 
    # attribute's default value (if it has one)
    if (!defined $val && $self->has_default) {
        $val = $self->default($instance); 
    }
    
	if (defined $val) {
	    if ($self->has_type_constraint) {
	        my $type_constraint = $self->type_constraint;
		    if ($self->should_coerce && $type_constraint->has_coercion) {
		        $val = $type_constraint->coerce($val);
		    }	
            (defined($type_constraint->check($val))) 
                || confess "Attribute (" . 
                           $self->name . 
                           ") does not pass the type constraint (" . 
                           $type_constraint->name .
                           ") with '$val'";			
        }
	}

    $meta_instance->set_slot_value($instance, $self->name, $val);
    $meta_instance->weaken_slot_value($instance, $self->name) 
        if ref $val && $self->is_weak_ref;
}

## Slot management

sub set_value {
    my ($self, $instance, $value) = @_;
    
    my $attr_name = $self->name;
    
    if ($self->is_required) {
        defined($value) 
            || confess "Attribute ($attr_name) is required, so cannot be set to undef";
    }
    
    if ($self->has_type_constraint) {
        
        my $type_constraint = $self->type_constraint;
        
        if ($self->should_coerce) {
            $value = $type_constraint->coerce($value);           
        }
        defined($type_constraint->_compiled_type_constraint->($value))
        	|| confess "Attribute ($attr_name) does not pass the type constraint ("
               . $type_constraint->name . ") with " . (defined($value) ? ("'" . $value . "'") : "undef")
          if defined($value);
    }
    
    my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
                                         ->get_meta_instance;
                                         
    $meta_instance->set_slot_value($instance, $attr_name, $value);  
      
    if (ref $value && $self->is_weak_ref) {
        $meta_instance->weaken_slot_value($instance, $attr_name);            
    }
    
    if ($self->has_trigger) {
        $self->trigger->($instance, $value, $self);
    }
}

sub get_value {
    my ($self, $instance) = @_;
    
    if ($self->is_lazy) {
	    unless ($self->has_value($instance)) {
	        if ($self->has_default) {
	            my $default = $self->default($instance);
	            $self->set_value($instance, $default);
	        }
	        else {
                $self->set_value($instance, undef);
	        }
	    }   
    }
    
    if ($self->should_auto_deref) {
        
        my $type_constraint = $self->type_constraint;

        if ($type_constraint->is_a_type_of('ArrayRef')) {
            my $rv = $self->SUPER::get_value($instance);
            return unless defined $rv;
            return wantarray ? @{ $rv } : $rv;
        } 
        elsif ($type_constraint->is_a_type_of('HashRef')) {
            my $rv = $self->SUPER::get_value($instance);
            return unless defined $rv;
            return wantarray ? %{ $rv } : $rv;
        } 
        else {
            confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
        }
               
    }
    else {
        
        return $self->SUPER::get_value($instance);
    }    
}

## installing accessors 

sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }

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