[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.06';

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',
));

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 and coerce 
    my %actual_options;
    foreach my $legal_option (qw(default coerce required)) {
        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} . "'";
		}
		($type_constraint->is_subtype_of($self->type_constraint->name))
		    || confess "New type constraint setting must be a subtype of inherited one"
		        if $self->has_type_constraint;
		$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";
	    (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
	        || confess "You cannot have coercion with a type constraint union";	        
        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}->name =~ /^ArrayRef|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->coercion->coerce($val);
		    }	
            (defined($type_constraint->check($val))) 
                || confess "Attribute (" . 
                           $self->name . 
                           ") does not pass the type contraint (" . 
                           $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;
}

sub _inline_check_constraint {
	my ($self, $value) = @_;
	return '' unless $self->has_type_constraint;
	
	# FIXME - remove 'unless defined($value) - constraint Undef
	return sprintf <<'EOF', $value, $value, $value, $value
defined($attr->type_constraint->check(%s))
	|| confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
       . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
  if defined(%s);
EOF
}

sub _inline_store {
	my ($self, $instance, $value) = @_;

	my $mi = $self->associated_class->get_meta_instance;
	my $slot_name = sprintf "'%s'", $self->slots;

    my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
	$code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
	    if $self->is_weak_ref;
    return $code;
}

sub _inline_trigger {
	my ($self, $instance, $value) = @_;
	return '' unless $self->has_trigger;
	return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
}

sub _inline_get {
	my ($self, $instance) = @_;

	my $mi = $self->associated_class->get_meta_instance;
	my $slot_name = sprintf "'%s'", $self->slots;

    return $mi->inline_get_slot_value($instance, $slot_name);
}

sub _inline_auto_deref {
    my ( $self, $ref_value ) = @_;

    return $ref_value unless $self->should_auto_deref;

    my $type = $self->type_constraint->name;

    my $sigil;
    if ($type eq "ArrayRef") {
        $sigil = '@';
    } 
    elsif ($type eq 'HashRef') {
        $sigil = '%';
    } 
    else {
        confess "Can not auto de-reference the type constraint '$type'";
    }

    "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
}

sub generate_accessor_method {
    my ($attr, $attr_name) = @_;
    my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	my $mi = $attr->associated_class->get_meta_instance;
	my $slot_name = sprintf "'%s'", $attr->slots;
	my $inv = '$_[0]';
    my $code = 'sub { '
    . 'if (scalar(@_) == 2) {'
        . ($attr->is_required ? 
            'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' 
            : '')
        . ($attr->should_coerce ? 
            'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
            : '')
        . $attr->_inline_check_constraint($value_name)
		. $attr->_inline_store($inv, $value_name)
		. $attr->_inline_trigger($inv, $value_name)
    . ' }'
    . ($attr->is_lazy ? 
            '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
            . 'unless exists $_[0]->{$attr_name};'
            : '')    
    . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
    . ' }';
    my $sub = eval $code;
    warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
    confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;    
}

sub generate_writer_method {
    my ($attr, $attr_name) = @_; 
    my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	my $inv = '$_[0]';
    my $code = 'sub { '
    . ($attr->is_required ? 
        'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' 
        : '')
    . ($attr->should_coerce ? 
        'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
        : '')
	. $attr->_inline_check_constraint($value_name)
	. $attr->_inline_store($inv, $value_name)
	. $attr->_inline_trigger($inv, $value_name)
    . ' }';
    my $sub = eval $code;
    confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;    
}

sub generate_reader_method {
    my $self = shift;
    my $attr_name = $self->slots;
    my $code = 'sub {'
    . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
    . ($self->is_lazy ? 
            '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
            . 'unless exists $_[0]->{$attr_name};'
            : '')
    . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
    . '}';
    my $sub = eval $code;
    confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;
}

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";
            
            if ((reftype($method_to_call) || '') eq 'CODE') {
                $associated_class->add_method($handle => $method_to_call);                
            }
            else {
                $associated_class->add_method($handle => sub {
                    ((shift)->$accessor_name())->$method_to_call(@_);
                });
            }
        }
    }
    
    return;
}

# private methods to help delegation ...

sub _canonicalize_handles {
    my $self    = shift;
    my $handles = $self->handles;
    if (ref($handles) eq 'HASH') {
        return %{$handles};
    }
    elsif (ref($handles) eq 'ARRAY') {
        return map { $_ => $_ } @{$handles};
    }
    elsif (ref($handles) 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 (ref($handles) eq 'CODE') {
        return $handles->($self, $self->_find_delegate_metaclass);
    }
    else {
        confess "Unable to canonicalize the 'handles' option with $handles";
    }
}

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}                     } 
               grep { $_->{class} ne 'Moose::Object' } 
                    $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<clone_and_inherit_options>

=item B<initialize_instance_slot>

=item B<generate_accessor_method>

=item B<generate_writer_method>

=item B<generate_reader_method>

=item B<install_accessors>

=back

=head2 Additional Moose features

Moose attributes support type-contstraint checking, weak reference 
creation and type coercion.  

=over 4

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

=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 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
db1ab48d	10	our $VERSION = '0.06';
78cd1d3b	11
a3c7e2fe	12	use Moose::Util::TypeConstraints ();
bc1e29b5	13
c0e30cf5	14	use base 'Class::MOP::Attribute';
c0e30cf5	15
452bac1b	16	# options which are not directly used
452bac1b	17	# but we store them for metadata purposes
98aae381	18	__PACKAGE__->meta->add_attribute('isa' => (reader => '_isa_metadata'));
	19	__PACKAGE__->meta->add_attribute('does' => (reader => '_does_metadata'));
	20	__PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata'));
452bac1b	21
452bac1b	22	# these are actual options for the attrs
1a563243	23	__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
	24	__PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
	25	__PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' ));
	26	__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
	27	__PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
82168dbb	28	__PACKAGE__->meta->add_attribute('type_constraint' => (
	29	reader => 'type_constraint',
	30	predicate => 'has_type_constraint',
	31	));
8c9d74e7	32	__PACKAGE__->meta->add_attribute('trigger' => (
	33	reader => 'trigger',
	34	predicate => 'has_trigger',
	35	));
452bac1b	36	__PACKAGE__->meta->add_attribute('handles' => (
	37	reader => 'handles',
	38	predicate => 'has_handles',
	39	));
82168dbb	40
78cd1d3b	41	sub new {
78cd1d3b	42	my ($class, $name, %options) = @_;
1d768fb1	43	$class->_process_options($name, \%options);
98aae381	44	return $class->SUPER::new($name, %options);
1d768fb1	45	}
1d768fb1	46
ce0e8d63	47	sub clone_and_inherit_options {
	48	my ($self, %options) = @_;
	49	# you can change default, required and coerce
	50	my %actual_options;
	51	foreach my $legal_option (qw(default coerce required)) {
	52	if (exists $options{$legal_option}) {
	53	$actual_options{$legal_option} = $options{$legal_option};
	54	delete $options{$legal_option};
	55	}
	56	}
fcb7afc2	57	# isa can be changed, but only if the
fcb7afc2	58	# new type is a subtype
ce0e8d63	59	if ($options{isa}) {
	60	my $type_constraint;
	61	if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
	62	$type_constraint = $options{isa};
	63	}
	64	else {
	65	$type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
	66	(defined $type_constraint)
	67	\|\| confess "Could not find the type constraint '" . $options{isa} . "'";
	68	}
	69	($type_constraint->is_subtype_of($self->type_constraint->name))
	70	\|\| confess "New type constraint setting must be a subtype of inherited one"
	71	if $self->has_type_constraint;
	72	$actual_options{type_constraint} = $type_constraint;
	73	delete $options{isa};
	74	}
	75	(scalar keys %options == 0)
	76	\|\| confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
	77	$self->clone(%actual_options);
1d768fb1	78	}
	79
	80	sub _process_options {
	81	my ($class, $name, $options) = @_;
452bac1b	82
1d768fb1	83	if (exists $options->{is}) {
	84	if ($options->{is} eq 'ro') {
	85	$options->{reader} = $name;
	86	(!exists $options->{trigger})
8c9d74e7	87	\|\| confess "Cannot have a trigger on a read-only attribute";
78cd1d3b	88	}
1d768fb1	89	elsif ($options->{is} eq 'rw') {
452bac1b	90	$options->{accessor} = $name;
98aae381	91	((reftype($options->{trigger}) \|\| '') eq 'CODE')
	92	\|\| confess "Trigger must be a CODE ref"
	93	if exists $options->{trigger};
452bac1b	94	}
	95	else {
	96	confess "I do not understand this option (is => " . $options->{is} . ")"
78cd1d3b	97	}
	98	}
	99
1d768fb1	100	if (exists $options->{isa}) {
02a0fb52	101
1d768fb1	102	if (exists $options->{does}) {
	103	if (eval { $options->{isa}->can('does') }) {
	104	($options->{isa}->does($options->{does}))
02a0fb52	105	\|\| confess "Cannot have an isa option and a does option if the isa does not do the does";
02a0fb52	106	}
7eaef7ad	107	else {
	108	confess "Cannot have an isa option which cannot ->does()";
	109	}
02a0fb52	110	}
02a0fb52	111
78cd1d3b	112	# allow for anon-subtypes here ...
1d768fb1	113	if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
1d768fb1	114	$options->{type_constraint} = $options->{isa};
78cd1d3b	115	}
78cd1d3b	116	else {
c07af9d2	117
1d768fb1	118	if ($options->{isa} =~ /\\|/) {
	119	my @type_constraints = split /\s\\|\s/ => $options->{isa};
	120	$options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
c07af9d2	121	@type_constraints
78cd1d3b	122	);
c07af9d2	123	}
	124	else {
	125	# otherwise assume it is a constraint
1d768fb1	126	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
c07af9d2	127	# if the constraing it not found ....
	128	unless (defined $constraint) {
	129	# assume it is a foreign class, and make
	130	# an anon constraint for it
	131	$constraint = Moose::Util::TypeConstraints::subtype(
	132	'Object',
1d768fb1	133	Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
c07af9d2	134	);
c07af9d2	135	}
1d768fb1	136	$options->{type_constraint} = $constraint;
c07af9d2	137	}
78cd1d3b	138	}
78cd1d3b	139	}
1d768fb1	140	elsif (exists $options->{does}) {
02a0fb52	141	# allow for anon-subtypes here ...
1d768fb1	142	if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
1d768fb1	143	$options->{type_constraint} = $options->{isa};
02a0fb52	144	}
	145	else {
	146	# otherwise assume it is a constraint
1d768fb1	147	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
02a0fb52	148	# if the constraing it not found ....
	149	unless (defined $constraint) {
	150	# assume it is a foreign class, and make
	151	# an anon constraint for it
	152	$constraint = Moose::Util::TypeConstraints::subtype(
	153	'Role',
1d768fb1	154	Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
02a0fb52	155	);
02a0fb52	156	}
1d768fb1	157	$options->{type_constraint} = $constraint;
02a0fb52	158	}
02a0fb52	159	}
78cd1d3b	160
1d768fb1	161	if (exists $options->{coerce} && $options->{coerce}) {
1d768fb1	162	(exists $options->{type_constraint})
4b598ea3	163	\|\| confess "You cannot have coercion without specifying a type constraint";
1d768fb1	164	(!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
c07af9d2	165	\|\| confess "You cannot have coercion with a type constraint union";
4b598ea3	166	confess "You cannot have a weak reference to a coerced value"
1d768fb1	167	if $options->{weak_ref};
ca01a97b	168	}
78cd1d3b	169
536f0b17	170	if (exists $options->{auto_deref} && $options->{auto_deref}) {
	171	(exists $options->{type_constraint})
	172	\|\| confess "You cannot auto-dereference without specifying a type constraint";
	173	($options->{type_constraint}->name =~ /^ArrayRef\|HashRef$/)
	174	\|\| confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
	175	}
	176
1d768fb1	177	if (exists $options->{lazy} && $options->{lazy}) {
1d768fb1	178	(exists $options->{default})
ca01a97b	179	\|\| confess "You cannot have lazy attribute without specifying a default value for it";
1d768fb1	180	}
78cd1d3b	181	}
c0e30cf5	182
d500266f	183	sub initialize_instance_slot {
ddd0ec20	184	my ($self, $meta_instance, $instance, $params) = @_;
d500266f	185	my $init_arg = $self->init_arg();
d500266f	186	# try to fetch the init arg from the %params ...
ddd0ec20	187
d500266f	188	my $val;
	189	if (exists $params->{$init_arg}) {
	190	$val = $params->{$init_arg};
	191	}
	192	else {
	193	# skip it if it's lazy
	194	return if $self->is_lazy;
	195	# and die if it's required and doesn't have a default value
	196	confess "Attribute (" . $self->name . ") is required"
	197	if $self->is_required && !$self->has_default;
	198	}
ddd0ec20	199
d500266f	200	# if nothing was in the %params, we can use the
	201	# attribute's default value (if it has one)
	202	if (!defined $val && $self->has_default) {
	203	$val = $self->default($instance);
	204	}
	205	if (defined $val) {
	206	if ($self->has_type_constraint) {
c07af9d2	207	my $type_constraint = $self->type_constraint;
	208	if ($self->should_coerce && $type_constraint->has_coercion) {
	209	$val = $type_constraint->coercion->coerce($val);
d500266f	210	}
c07af9d2	211	(defined($type_constraint->check($val)))
	212	\|\| confess "Attribute (" .
	213	$self->name .
	214	") does not pass the type contraint (" .
	215	$type_constraint->name .
	216	") with '$val'";
d500266f	217	}
d500266f	218	}
ddd0ec20	219
ac1ef2f9	220	$meta_instance->set_slot_value($instance, $self->name, $val);
	221	$meta_instance->weaken_slot_value($instance, $self->name)
	222	if ref $val && $self->is_weak_ref;
d500266f	223	}
d500266f	224
67ad26d9	225	sub _inline_check_constraint {
ac1ef2f9	226	my ($self, $value) = @_;
67ad26d9	227	return '' unless $self->has_type_constraint;
	228
	229	# FIXME - remove 'unless defined($value) - constraint Undef
	230	return sprintf <<'EOF', $value, $value, $value, $value
	231	defined($attr->type_constraint->check(%s))
	232	\|\| confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
	233	. $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
	234	if defined(%s);
	235	EOF
	236	}
	237
	238	sub _inline_store {
ac1ef2f9	239	my ($self, $instance, $value) = @_;
67ad26d9	240
67ad26d9	241	my $mi = $self->associated_class->get_meta_instance;
ac1ef2f9	242	my $slot_name = sprintf "'%s'", $self->slots;
67ad26d9	243
ac1ef2f9	244	my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
	245	$code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
	246	if $self->is_weak_ref;
	247	return $code;
8a7a9c53	248	}
8a7a9c53	249
67ad26d9	250	sub _inline_trigger {
ac1ef2f9	251	my ($self, $instance, $value) = @_;
67ad26d9	252	return '' unless $self->has_trigger;
67ad26d9	253	return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
8a7a9c53	254	}
8a7a9c53	255
ddd0ec20	256	sub _inline_get {
ac1ef2f9	257	my ($self, $instance) = @_;
ddd0ec20	258
ddd0ec20	259	my $mi = $self->associated_class->get_meta_instance;
ac1ef2f9	260	my $slot_name = sprintf "'%s'", $self->slots;
ddd0ec20	261
ac1ef2f9	262	return $mi->inline_get_slot_value($instance, $slot_name);
ddd0ec20	263	}
ddd0ec20	264
1a563243	265	sub _inline_auto_deref {
	266	my ( $self, $ref_value ) = @_;
	267
	268	return $ref_value unless $self->should_auto_deref;
	269
536f0b17	270	my $type = $self->type_constraint->name;
1a563243	271
536f0b17	272	my $sigil;
536f0b17	273	if ($type eq "ArrayRef") {
1a563243	274	$sigil = '@';
536f0b17	275	}
536f0b17	276	elsif ($type eq 'HashRef') {
1a563243	277	$sigil = '%';
536f0b17	278	}
	279	else {
	280	confess "Can not auto de-reference the type constraint '$type'";
1a563243	281	}
	282
	283	"(wantarray() ? $sigil\{ ( $ref_value ) \|\| return } : ( $ref_value ) )";
	284	}
	285
a15dff8d	286	sub generate_accessor_method {
67ad26d9	287	my ($attr, $attr_name) = @_;
	288	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	289	my $mi = $attr->associated_class->get_meta_instance;
ac1ef2f9	290	my $slot_name = sprintf "'%s'", $attr->slots;
67ad26d9	291	my $inv = '$_[0]';
ca01a97b	292	my $code = 'sub { '
ca01a97b	293	. 'if (scalar(@_) == 2) {'
67ad26d9	294	. ($attr->is_required ?
ca01a97b	295	'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
ca01a97b	296	: '')
67ad26d9	297	. ($attr->should_coerce ?
67ad26d9	298	'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
ca01a97b	299	: '')
ac1ef2f9	300	. $attr->_inline_check_constraint($value_name)
	301	. $attr->_inline_store($inv, $value_name)
	302	. $attr->_inline_trigger($inv, $value_name)
ca01a97b	303	. ' }'
67ad26d9	304	. ($attr->is_lazy ?
67ad26d9	305	'$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
ca01a97b	306	. 'unless exists $_[0]->{$attr_name};'
ca01a97b	307	: '')
536f0b17	308	. 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
ca01a97b	309	. ' }';
ca01a97b	310	my $sub = eval $code;
67ad26d9	311	warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
67ad26d9	312	confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
ca01a97b	313	return $sub;
a15dff8d	314	}
	315
	316	sub generate_writer_method {
67ad26d9	317	my ($attr, $attr_name) = @_;
	318	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	319	my $inv = '$_[0]';
ca01a97b	320	my $code = 'sub { '
67ad26d9	321	. ($attr->is_required ?
ca01a97b	322	'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
ca01a97b	323	: '')
67ad26d9	324	. ($attr->should_coerce ?
67ad26d9	325	'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
ca01a97b	326	: '')
ac1ef2f9	327	. $attr->_inline_check_constraint($value_name)
	328	. $attr->_inline_store($inv, $value_name)
	329	. $attr->_inline_trigger($inv, $value_name)
ca01a97b	330	. ' }';
	331	my $sub = eval $code;
	332	confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
	333	return $sub;
a15dff8d	334	}
c0e30cf5	335
d7f17ebb	336	sub generate_reader_method {
7e5ab379	337	my $self = shift;
ac1ef2f9	338	my $attr_name = $self->slots;
ca01a97b	339	my $code = 'sub {'
	340	. 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
	341	. ($self->is_lazy ?
	342	'$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
	343	. 'unless exists $_[0]->{$attr_name};'
	344	: '')
1a563243	345	. 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
ca01a97b	346	. '}';
	347	my $sub = eval $code;
	348	confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
	349	return $sub;
d7f17ebb	350	}
d7f17ebb	351
452bac1b	352	sub install_accessors {
	353	my $self = shift;
	354	$self->SUPER::install_accessors(@_);
	355
	356	if ($self->has_handles) {
	357
	358	# NOTE:
	359	# Here we canonicalize the 'handles' option
	360	# this will sort out any details and always
	361	# return an hash of methods which we want
	362	# to delagate to, see that method for details
	363	my %handles = $self->_canonicalize_handles();
	364
	365	# find the name of the accessor for this attribute
	366	my $accessor_name = $self->reader \|\| $self->accessor;
	367	(defined $accessor_name)
	368	\|\| confess "You cannot install delegation without a reader or accessor for the attribute";
	369
	370	# make sure we handle HASH accessors correctly
	371	($accessor_name) = keys %{$accessor_name}
	372	if ref($accessor_name) eq 'HASH';
	373
	374	# install the delegation ...
	375	my $associated_class = $self->associated_class;
	376	foreach my $handle (keys %handles) {
	377	my $method_to_call = $handles{$handle};
	378
	379	(!$associated_class->has_method($handle))
	380	\|\| confess "You cannot overwrite a locally defined method ($handle) with a delegation";
	381
	382	if ((reftype($method_to_call) \|\| '') eq 'CODE') {
	383	$associated_class->add_method($handle => $method_to_call);
	384	}
	385	else {
	386	$associated_class->add_method($handle => sub {
	387	((shift)->$accessor_name())->$method_to_call(@_);
	388	});
	389	}
	390	}
	391	}
	392
	393	return;
	394	}
	395
98aae381	396	# private methods to help delegation ...
98aae381	397
452bac1b	398	sub _canonicalize_handles {
	399	my $self = shift;
	400	my $handles = $self->handles;
	401	if (ref($handles) eq 'HASH') {
	402	return %{$handles};
	403	}
	404	elsif (ref($handles) eq 'ARRAY') {
	405	return map { $_ => $_ } @{$handles};
	406	}
	407	elsif (ref($handles) eq 'Regexp') {
	408	($self->has_type_constraint)
	409	\|\| confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
	410	return map { ($_ => $_) }
	411	grep { $handles } $self->_get_delegate_method_list;
	412	}
	413	elsif (ref($handles) eq 'CODE') {
	414	return $handles->($self, $self->_find_delegate_metaclass);
	415	}
	416	else {
	417	confess "Unable to canonicalize the 'handles' option with $handles";
	418	}
	419	}
	420
	421	sub _find_delegate_metaclass {
	422	my $self = shift;
98aae381	423	if (my $class = $self->_isa_metadata) {
452bac1b	424	# if the class does have
	425	# a meta method, use it
	426	return $class->meta if $class->can('meta');
	427	# otherwise we might be
	428	# dealing with a non-Moose
	429	# class, and need to make
	430	# our own metaclass
	431	return Moose::Meta::Class->initialize($class);
	432	}
98aae381	433	elsif (my $role = $self->_does_metadata) {
452bac1b	434	# our role will always have
452bac1b	435	# a meta method
98aae381	436	return $role->meta;
452bac1b	437	}
	438	else {
	439	confess "Cannot find delegate metaclass for attribute " . $self->name;
	440	}
	441	}
	442
	443	sub _get_delegate_method_list {
	444	my $self = shift;
	445	my $meta = $self->_find_delegate_metaclass;
	446	if ($meta->isa('Class::MOP::Class')) {
	447	return map { $_->{name} }
	448	grep { $_->{class} ne 'Moose::Object' }
	449	$meta->compute_all_applicable_methods;
	450	}
	451	elsif ($meta->isa('Moose::Meta::Role')) {
	452	return $meta->get_method_list;
	453	}
	454	else {
	455	confess "Unable to recognize the delegate metaclass '$meta'";
	456	}
	457	}
	458
c0e30cf5	459	1;
	460
	461	__END__
	462
	463	=pod
	464
	465	=head1 NAME
	466
6ba6d68c	467	Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5	468
	469	=head1 DESCRIPTION
	470
e522431d	471	This is a subclass of L<Class::MOP::Attribute> with Moose specific
6ba6d68c	472	extensions.
	473
	474	For the most part, the only time you will ever encounter an
	475	instance of this class is if you are doing some serious deep
	476	introspection. To really understand this class, you need to refer
	477	to the L<Class::MOP::Attribute> documentation.
e522431d	478
c0e30cf5	479	=head1 METHODS
c0e30cf5	480
6ba6d68c	481	=head2 Overridden methods
	482
	483	These methods override methods in L<Class::MOP::Attribute> and add
	484	Moose specific features. You can safely assume though that they
	485	will behave just as L<Class::MOP::Attribute> does.
	486
c0e30cf5	487	=over 4
	488
	489	=item B<new>
	490
ce0e8d63	491	=item B<clone_and_inherit_options>
1d768fb1	492
d500266f	493	=item B<initialize_instance_slot>
d500266f	494
a15dff8d	495	=item B<generate_accessor_method>
	496
	497	=item B<generate_writer_method>
	498
d7f17ebb	499	=item B<generate_reader_method>
d7f17ebb	500
452bac1b	501	=item B<install_accessors>
452bac1b	502
a15dff8d	503	=back
a15dff8d	504
6ba6d68c	505	=head2 Additional Moose features
	506
	507	Moose attributes support type-contstraint checking, weak reference
	508	creation and type coercion.
	509
a15dff8d	510	=over 4
	511
	512	=item B<has_type_constraint>
	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
c0e30cf5	567	=back
	568
	569	=head1 BUGS
	570
	571	All complex software has bugs lurking in it, and this module is no
	572	exception. If you find a bug please either email me, or add the bug
	573	to cpan-RT.
	574
c0e30cf5	575	=head1 AUTHOR
	576
	577	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	578
98aae381	579	Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
98aae381	580
c0e30cf5	581	=head1 COPYRIGHT AND LICENSE
	582
	583	Copyright 2006 by Infinity Interactive, Inc.
	584
	585	L<http://www.iinteractive.com>
	586
	587	This library is free software; you can redistribute it and/or modify
	588	it under the same terms as Perl itself.
	589
8a7a9c53	590	=cut