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

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',
    predicate => 'has_isa_metadata',    
));
__PACKAGE__->meta->add_attribute('does' => (
    reader    => 'does_metadata',
    predicate => 'has_does_metadata',    
));
__PACKAGE__->meta->add_attribute('is'   => (
    reader    => 'is_metadata',
    predicate => 'has_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);
	my $self = $class->SUPER::new($name, %options);    
    return $self;	
}

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;						
		}
		else {
		    confess "I do not understand this option (is => " . $options->{is} . ")"
		}			
	}
	
	# process and check trigger here ...
	
	
	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;
}

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 ($self->has_isa_metadata) {
        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 ($self->has_does_metadata) {
        # our role will always have 
        # a meta method
        return $self->does_metadata->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>

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