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

__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('type_constraint' => (
    reader    => 'type_constraint',
    predicate => 'has_type_constraint',
));
__PACKAGE__->meta->add_attribute('trigger' => (
    reader    => 'trigger',
    predicate => 'has_trigger',
));

sub new {
	my ($class, $name, %options) = @_;
	$class->_process_options($name, \%options);
	$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 "A trigger must be a CODE reference"
			        if exists $options->{trigger};			
		}			
	}
	
	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->{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 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_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 $_[0]->{$attr_name};'
    . '}';
    my $sub = eval $code;
    confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;
}

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>

=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<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<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
ca01a97b	16	__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
ca01a97b	17	__PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
6ba6d68c	18	__PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce'));
6ba6d68c	19	__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
82168dbb	20	__PACKAGE__->meta->add_attribute('type_constraint' => (
	21	reader => 'type_constraint',
	22	predicate => 'has_type_constraint',
	23	));
8c9d74e7	24	__PACKAGE__->meta->add_attribute('trigger' => (
	25	reader => 'trigger',
	26	predicate => 'has_trigger',
	27	));
82168dbb	28
78cd1d3b	29	sub new {
78cd1d3b	30	my ($class, $name, %options) = @_;
1d768fb1	31	$class->_process_options($name, \%options);
	32	$class->SUPER::new($name, %options);
	33	}
	34
ce0e8d63	35	sub clone_and_inherit_options {
	36	my ($self, %options) = @_;
	37	# you can change default, required and coerce
	38	my %actual_options;
	39	foreach my $legal_option (qw(default coerce required)) {
	40	if (exists $options{$legal_option}) {
	41	$actual_options{$legal_option} = $options{$legal_option};
	42	delete $options{$legal_option};
	43	}
	44	}
fcb7afc2	45	# isa can be changed, but only if the
fcb7afc2	46	# new type is a subtype
ce0e8d63	47	if ($options{isa}) {
	48	my $type_constraint;
	49	if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
	50	$type_constraint = $options{isa};
	51	}
	52	else {
	53	$type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
	54	(defined $type_constraint)
	55	\|\| confess "Could not find the type constraint '" . $options{isa} . "'";
	56	}
	57	($type_constraint->is_subtype_of($self->type_constraint->name))
	58	\|\| confess "New type constraint setting must be a subtype of inherited one"
	59	if $self->has_type_constraint;
	60	$actual_options{type_constraint} = $type_constraint;
	61	delete $options{isa};
	62	}
	63	(scalar keys %options == 0)
	64	\|\| confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
	65	$self->clone(%actual_options);
1d768fb1	66	}
	67
	68	sub _process_options {
	69	my ($class, $name, $options) = @_;
	70	if (exists $options->{is}) {
	71	if ($options->{is} eq 'ro') {
	72	$options->{reader} = $name;
	73	(!exists $options->{trigger})
8c9d74e7	74	\|\| confess "Cannot have a trigger on a read-only attribute";
78cd1d3b	75	}
1d768fb1	76	elsif ($options->{is} eq 'rw') {
	77	$options->{accessor} = $name;
	78	((reftype($options->{trigger}) \|\| '') eq 'CODE')
8c9d74e7	79	\|\| confess "A trigger must be a CODE reference"
1d768fb1	80	if exists $options->{trigger};
78cd1d3b	81	}
	82	}
	83
1d768fb1	84	if (exists $options->{isa}) {
02a0fb52	85
1d768fb1	86	if (exists $options->{does}) {
	87	if (eval { $options->{isa}->can('does') }) {
	88	($options->{isa}->does($options->{does}))
02a0fb52	89	\|\| confess "Cannot have an isa option and a does option if the isa does not do the does";
02a0fb52	90	}
7eaef7ad	91	else {
	92	confess "Cannot have an isa option which cannot ->does()";
	93	}
02a0fb52	94	}
02a0fb52	95
78cd1d3b	96	# allow for anon-subtypes here ...
1d768fb1	97	if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
1d768fb1	98	$options->{type_constraint} = $options->{isa};
78cd1d3b	99	}
78cd1d3b	100	else {
c07af9d2	101
1d768fb1	102	if ($options->{isa} =~ /\\|/) {
	103	my @type_constraints = split /\s\\|\s/ => $options->{isa};
	104	$options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
c07af9d2	105	@type_constraints
78cd1d3b	106	);
c07af9d2	107	}
	108	else {
	109	# otherwise assume it is a constraint
1d768fb1	110	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
c07af9d2	111	# if the constraing it not found ....
	112	unless (defined $constraint) {
	113	# assume it is a foreign class, and make
	114	# an anon constraint for it
	115	$constraint = Moose::Util::TypeConstraints::subtype(
	116	'Object',
1d768fb1	117	Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
c07af9d2	118	);
c07af9d2	119	}
1d768fb1	120	$options->{type_constraint} = $constraint;
c07af9d2	121	}
78cd1d3b	122	}
78cd1d3b	123	}
1d768fb1	124	elsif (exists $options->{does}) {
02a0fb52	125	# allow for anon-subtypes here ...
1d768fb1	126	if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
1d768fb1	127	$options->{type_constraint} = $options->{isa};
02a0fb52	128	}
	129	else {
	130	# otherwise assume it is a constraint
1d768fb1	131	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
02a0fb52	132	# if the constraing it not found ....
	133	unless (defined $constraint) {
	134	# assume it is a foreign class, and make
	135	# an anon constraint for it
	136	$constraint = Moose::Util::TypeConstraints::subtype(
	137	'Role',
1d768fb1	138	Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
02a0fb52	139	);
02a0fb52	140	}
1d768fb1	141	$options->{type_constraint} = $constraint;
02a0fb52	142	}
02a0fb52	143	}
78cd1d3b	144
1d768fb1	145	if (exists $options->{coerce} && $options->{coerce}) {
1d768fb1	146	(exists $options->{type_constraint})
4b598ea3	147	\|\| confess "You cannot have coercion without specifying a type constraint";
1d768fb1	148	(!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
c07af9d2	149	\|\| confess "You cannot have coercion with a type constraint union";
4b598ea3	150	confess "You cannot have a weak reference to a coerced value"
1d768fb1	151	if $options->{weak_ref};
ca01a97b	152	}
78cd1d3b	153
1d768fb1	154	if (exists $options->{lazy} && $options->{lazy}) {
1d768fb1	155	(exists $options->{default})
ca01a97b	156	\|\| confess "You cannot have lazy attribute without specifying a default value for it";
1d768fb1	157	}
78cd1d3b	158	}
c0e30cf5	159
d500266f	160	sub initialize_instance_slot {
ddd0ec20	161	my ($self, $meta_instance, $instance, $params) = @_;
d500266f	162	my $init_arg = $self->init_arg();
d500266f	163	# try to fetch the init arg from the %params ...
ddd0ec20	164
d500266f	165	my $val;
	166	if (exists $params->{$init_arg}) {
	167	$val = $params->{$init_arg};
	168	}
	169	else {
	170	# skip it if it's lazy
	171	return if $self->is_lazy;
	172	# and die if it's required and doesn't have a default value
	173	confess "Attribute (" . $self->name . ") is required"
	174	if $self->is_required && !$self->has_default;
	175	}
ddd0ec20	176
d500266f	177	# if nothing was in the %params, we can use the
	178	# attribute's default value (if it has one)
	179	if (!defined $val && $self->has_default) {
	180	$val = $self->default($instance);
	181	}
	182	if (defined $val) {
	183	if ($self->has_type_constraint) {
c07af9d2	184	my $type_constraint = $self->type_constraint;
	185	if ($self->should_coerce && $type_constraint->has_coercion) {
	186	$val = $type_constraint->coercion->coerce($val);
d500266f	187	}
c07af9d2	188	(defined($type_constraint->check($val)))
	189	\|\| confess "Attribute (" .
	190	$self->name .
	191	") does not pass the type contraint (" .
	192	$type_constraint->name .
	193	") with '$val'";
d500266f	194	}
d500266f	195	}
ddd0ec20	196
ac1ef2f9	197	$meta_instance->set_slot_value($instance, $self->name, $val);
	198	$meta_instance->weaken_slot_value($instance, $self->name)
	199	if ref $val && $self->is_weak_ref;
d500266f	200	}
d500266f	201
67ad26d9	202	sub _inline_check_constraint {
ac1ef2f9	203	my ($self, $value) = @_;
67ad26d9	204	return '' unless $self->has_type_constraint;
	205
	206	# FIXME - remove 'unless defined($value) - constraint Undef
	207	return sprintf <<'EOF', $value, $value, $value, $value
	208	defined($attr->type_constraint->check(%s))
	209	\|\| confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
	210	. $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
	211	if defined(%s);
	212	EOF
	213	}
	214
	215	sub _inline_store {
ac1ef2f9	216	my ($self, $instance, $value) = @_;
67ad26d9	217
67ad26d9	218	my $mi = $self->associated_class->get_meta_instance;
ac1ef2f9	219	my $slot_name = sprintf "'%s'", $self->slots;
67ad26d9	220
ac1ef2f9	221	my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
	222	$code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
	223	if $self->is_weak_ref;
	224	return $code;
8a7a9c53	225	}
8a7a9c53	226
67ad26d9	227	sub _inline_trigger {
ac1ef2f9	228	my ($self, $instance, $value) = @_;
67ad26d9	229	return '' unless $self->has_trigger;
67ad26d9	230	return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
8a7a9c53	231	}
8a7a9c53	232
ddd0ec20	233	sub _inline_get {
ac1ef2f9	234	my ($self, $instance) = @_;
ddd0ec20	235
ddd0ec20	236	my $mi = $self->associated_class->get_meta_instance;
ac1ef2f9	237	my $slot_name = sprintf "'%s'", $self->slots;
ddd0ec20	238
ac1ef2f9	239	return $mi->inline_get_slot_value($instance, $slot_name);
ddd0ec20	240	}
ddd0ec20	241
a15dff8d	242	sub generate_accessor_method {
67ad26d9	243	my ($attr, $attr_name) = @_;
	244	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	245	my $mi = $attr->associated_class->get_meta_instance;
ac1ef2f9	246	my $slot_name = sprintf "'%s'", $attr->slots;
67ad26d9	247	my $inv = '$_[0]';
ca01a97b	248	my $code = 'sub { '
ca01a97b	249	. 'if (scalar(@_) == 2) {'
67ad26d9	250	. ($attr->is_required ?
ca01a97b	251	'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
ca01a97b	252	: '')
67ad26d9	253	. ($attr->should_coerce ?
67ad26d9	254	'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
ca01a97b	255	: '')
ac1ef2f9	256	. $attr->_inline_check_constraint($value_name)
	257	. $attr->_inline_store($inv, $value_name)
	258	. $attr->_inline_trigger($inv, $value_name)
ca01a97b	259	. ' }'
67ad26d9	260	. ($attr->is_lazy ?
67ad26d9	261	'$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
ca01a97b	262	. 'unless exists $_[0]->{$attr_name};'
ca01a97b	263	: '')
ddd0ec20	264	. 'return ' . $attr->_inline_get( $inv )
ca01a97b	265	. ' }';
ca01a97b	266	my $sub = eval $code;
67ad26d9	267	warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
67ad26d9	268	confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
ca01a97b	269	return $sub;
a15dff8d	270	}
	271
	272	sub generate_writer_method {
67ad26d9	273	my ($attr, $attr_name) = @_;
	274	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	275	my $inv = '$_[0]';
ca01a97b	276	my $code = 'sub { '
67ad26d9	277	. ($attr->is_required ?
ca01a97b	278	'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
ca01a97b	279	: '')
67ad26d9	280	. ($attr->should_coerce ?
67ad26d9	281	'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
ca01a97b	282	: '')
ac1ef2f9	283	. $attr->_inline_check_constraint($value_name)
	284	. $attr->_inline_store($inv, $value_name)
	285	. $attr->_inline_trigger($inv, $value_name)
ca01a97b	286	. ' }';
	287	my $sub = eval $code;
	288	confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
	289	return $sub;
a15dff8d	290	}
c0e30cf5	291
d7f17ebb	292	sub generate_reader_method {
7e5ab379	293	my $self = shift;
ac1ef2f9	294	my $attr_name = $self->slots;
ca01a97b	295	my $code = 'sub {'
	296	. 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
	297	. ($self->is_lazy ?
	298	'$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
	299	. 'unless exists $_[0]->{$attr_name};'
	300	: '')
7e5ab379	301	. 'return $_[0]->{$attr_name};'
ca01a97b	302	. '}';
	303	my $sub = eval $code;
	304	confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
	305	return $sub;
d7f17ebb	306	}
d7f17ebb	307
c0e30cf5	308	1;
	309
	310	__END__
	311
	312	=pod
	313
	314	=head1 NAME
	315
6ba6d68c	316	Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5	317
	318	=head1 DESCRIPTION
	319
e522431d	320	This is a subclass of L<Class::MOP::Attribute> with Moose specific
6ba6d68c	321	extensions.
	322
	323	For the most part, the only time you will ever encounter an
	324	instance of this class is if you are doing some serious deep
	325	introspection. To really understand this class, you need to refer
	326	to the L<Class::MOP::Attribute> documentation.
e522431d	327
c0e30cf5	328	=head1 METHODS
c0e30cf5	329
6ba6d68c	330	=head2 Overridden methods
	331
	332	These methods override methods in L<Class::MOP::Attribute> and add
	333	Moose specific features. You can safely assume though that they
	334	will behave just as L<Class::MOP::Attribute> does.
	335
c0e30cf5	336	=over 4
	337
	338	=item B<new>
	339
ce0e8d63	340	=item B<clone_and_inherit_options>
1d768fb1	341
d500266f	342	=item B<initialize_instance_slot>
d500266f	343
a15dff8d	344	=item B<generate_accessor_method>
	345
	346	=item B<generate_writer_method>
	347
d7f17ebb	348	=item B<generate_reader_method>
d7f17ebb	349
a15dff8d	350	=back
a15dff8d	351
6ba6d68c	352	=head2 Additional Moose features
	353
	354	Moose attributes support type-contstraint checking, weak reference
	355	creation and type coercion.
	356
a15dff8d	357	=over 4
	358
	359	=item B<has_type_constraint>
	360
6ba6d68c	361	Returns true if this meta-attribute has a type constraint.
6ba6d68c	362
a15dff8d	363	=item B<type_constraint>
a15dff8d	364
6ba6d68c	365	A read-only accessor for this meta-attribute's type constraint. For
	366	more information on what you can do with this, see the documentation
	367	for L<Moose::Meta::TypeConstraint>.
a15dff8d	368
6ba6d68c	369	=item B<is_weak_ref>
a15dff8d	370
02a0fb52	371	Returns true if this meta-attribute produces a weak reference.
4b598ea3	372
ca01a97b	373	=item B<is_required>
ca01a97b	374
02a0fb52	375	Returns true if this meta-attribute is required to have a value.
ca01a97b	376
	377	=item B<is_lazy>
	378
02a0fb52	379	Returns true if this meta-attribute should be initialized lazily.
ca01a97b	380
	381	NOTE: lazy attributes, B<must> have a C<default> field set.
	382
34a66aa3	383	=item B<should_coerce>
4b598ea3	384
02a0fb52	385	Returns true if this meta-attribute should perform type coercion.
6ba6d68c	386
8c9d74e7	387	=item B<has_trigger>
8c9d74e7	388
02a0fb52	389	Returns true if this meta-attribute has a trigger set.
02a0fb52	390
8c9d74e7	391	=item B<trigger>
8c9d74e7	392
02a0fb52	393	This is a CODE reference which will be executed every time the
	394	value of an attribute is assigned. The CODE ref will get two values,
	395	the invocant and the new value. This can be used to handle I<basic>
	396	bi-directional relations.
	397
c0e30cf5	398	=back
	399
	400	=head1 BUGS
	401
	402	All complex software has bugs lurking in it, and this module is no
	403	exception. If you find a bug please either email me, or add the bug
	404	to cpan-RT.
	405
c0e30cf5	406	=head1 AUTHOR
	407
	408	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	409
	410	=head1 COPYRIGHT AND LICENSE
	411
	412	Copyright 2006 by Infinity Interactive, Inc.
	413
	414	L<http://www.iinteractive.com>
	415
	416	This library is free software; you can redistribute it and/or modify
	417	it under the same terms as Perl itself.
	418
8a7a9c53	419	=cut