[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;
}

## Accessor inline subroutines

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_check_coercion {
    my $self = shift;
	return '' unless $self->should_coerce;
    return 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
}

sub _inline_check_required {
    my $self = shift;
	return '' unless $self->is_required;
    return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
}

sub _inline_check_lazy {
    my $self = shift;
	return '' unless $self->is_lazy;
    return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
         . 'unless exists $_[0]->{$attr_name};';
}


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->_inline_check_required
        . $attr->_inline_check_coercion
        . $attr->_inline_check_constraint($value_name)
		. $attr->_inline_store($inv, $value_name)
		. $attr->_inline_trigger($inv, $value_name)
    . ' }'
    . $attr->_inline_check_lazy
    . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
    . ' }';
    my $sub = eval $code;
    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->_inline_check_required
    . $attr->_inline_check_coercion
	. $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 $attr = shift;
    my $attr_name = $attr->slots;
    my $code = 'sub {'
    . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
    . $attr->_inline_check_lazy
    . 'return ' . $attr->_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<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<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.

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