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

	return ( $self->is_weak_ref
		? $mi->inline_set_slot_value_weak( $instance, $slot_name, $value )
		: $mi->inline_set_slot_value( $instance, $slot_name, $value ) ) . ";";
}

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->name;

    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->name;
	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->name;
    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
	197	$meta_instance->set_slot_value( $instance, $self->name, $val );
	198	$meta_instance->weaken_slot_value( $instance, $self->name ) if ( ref $val && $self->is_weak_ref );
d500266f	199	}
d500266f	200
67ad26d9	201	sub _inline_check_constraint {
	202	my ( $self, $value ) = @_;
	203	return '' unless $self->has_type_constraint;
	204
	205	# FIXME - remove 'unless defined($value) - constraint Undef
	206	return sprintf <<'EOF', $value, $value, $value, $value
	207	defined($attr->type_constraint->check(%s))
	208	\|\| confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
	209	. $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
	210	if defined(%s);
	211	EOF
	212	}
	213
	214	sub _inline_store {
	215	my ( $self, $instance, $value ) = @_;
	216
	217	my $mi = $self->associated_class->get_meta_instance;
ddd0ec20	218	my $slot_name = sprintf "'%s'", $self->name;
67ad26d9	219
67ad26d9	220	return ( $self->is_weak_ref
ddd0ec20	221	? $mi->inline_set_slot_value_weak( $instance, $slot_name, $value )
67ad26d9	222	: $mi->inline_set_slot_value( $instance, $slot_name, $value ) ) . ";";
8a7a9c53	223	}
8a7a9c53	224
67ad26d9	225	sub _inline_trigger {
	226	my ( $self, $instance, $value ) = @_;
	227	return '' unless $self->has_trigger;
	228	return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
8a7a9c53	229	}
8a7a9c53	230
ddd0ec20	231	sub _inline_get {
	232	my ( $self, $instance ) = @_;
	233
	234	my $mi = $self->associated_class->get_meta_instance;
	235	my $slot_name = sprintf "'%s'", $self->name;
	236
	237	return $mi->inline_get_slot_value( $instance, $slot_name );
	238	}
	239
a15dff8d	240	sub generate_accessor_method {
67ad26d9	241	my ($attr, $attr_name) = @_;
	242	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	243	my $mi = $attr->associated_class->get_meta_instance;
ddd0ec20	244	my $slot_name = sprintf "'%s'", $attr->name;
67ad26d9	245	my $inv = '$_[0]';
ca01a97b	246	my $code = 'sub { '
ca01a97b	247	. 'if (scalar(@_) == 2) {'
67ad26d9	248	. ($attr->is_required ?
ca01a97b	249	'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
ca01a97b	250	: '')
67ad26d9	251	. ($attr->should_coerce ?
67ad26d9	252	'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
ca01a97b	253	: '')
67ad26d9	254	. $attr->_inline_check_constraint( $value_name )
	255	. $attr->_inline_store( $inv, $value_name )
	256	. $attr->_inline_trigger( $inv, $value_name )
ca01a97b	257	. ' }'
67ad26d9	258	. ($attr->is_lazy ?
67ad26d9	259	'$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
ca01a97b	260	. 'unless exists $_[0]->{$attr_name};'
ca01a97b	261	: '')
ddd0ec20	262	. 'return ' . $attr->_inline_get( $inv )
ca01a97b	263	. ' }';
ca01a97b	264	my $sub = eval $code;
67ad26d9	265	warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
67ad26d9	266	confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
ca01a97b	267	return $sub;
a15dff8d	268	}
	269
	270	sub generate_writer_method {
67ad26d9	271	my ($attr, $attr_name) = @_;
	272	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	273	my $inv = '$_[0]';
ca01a97b	274	my $code = 'sub { '
67ad26d9	275	. ($attr->is_required ?
ca01a97b	276	'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
ca01a97b	277	: '')
67ad26d9	278	. ($attr->should_coerce ?
67ad26d9	279	'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
ca01a97b	280	: '')
67ad26d9	281	. $attr->_inline_check_constraint( $value_name )
	282	. $attr->_inline_store( $inv, $value_name )
	283	. $attr->_inline_trigger( $inv, $value_name )
ca01a97b	284	. ' }';
	285	my $sub = eval $code;
	286	confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
	287	return $sub;
a15dff8d	288	}
c0e30cf5	289
d7f17ebb	290	sub generate_reader_method {
7e5ab379	291	my $self = shift;
7e5ab379	292	my $attr_name = $self->name;
ca01a97b	293	my $code = 'sub {'
	294	. 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
	295	. ($self->is_lazy ?
	296	'$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
	297	. 'unless exists $_[0]->{$attr_name};'
	298	: '')
7e5ab379	299	. 'return $_[0]->{$attr_name};'
ca01a97b	300	. '}';
	301	my $sub = eval $code;
	302	confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
	303	return $sub;
d7f17ebb	304	}
d7f17ebb	305
c0e30cf5	306	1;
	307
	308	__END__
	309
	310	=pod
	311
	312	=head1 NAME
	313
6ba6d68c	314	Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5	315
	316	=head1 DESCRIPTION
	317
e522431d	318	This is a subclass of L<Class::MOP::Attribute> with Moose specific
6ba6d68c	319	extensions.
	320
	321	For the most part, the only time you will ever encounter an
	322	instance of this class is if you are doing some serious deep
	323	introspection. To really understand this class, you need to refer
	324	to the L<Class::MOP::Attribute> documentation.
e522431d	325
c0e30cf5	326	=head1 METHODS
c0e30cf5	327
6ba6d68c	328	=head2 Overridden methods
	329
	330	These methods override methods in L<Class::MOP::Attribute> and add
	331	Moose specific features. You can safely assume though that they
	332	will behave just as L<Class::MOP::Attribute> does.
	333
c0e30cf5	334	=over 4
	335
	336	=item B<new>
	337
ce0e8d63	338	=item B<clone_and_inherit_options>
1d768fb1	339
d500266f	340	=item B<initialize_instance_slot>
d500266f	341
a15dff8d	342	=item B<generate_accessor_method>
	343
	344	=item B<generate_writer_method>
	345
d7f17ebb	346	=item B<generate_reader_method>
d7f17ebb	347
a15dff8d	348	=back
a15dff8d	349
6ba6d68c	350	=head2 Additional Moose features
	351
	352	Moose attributes support type-contstraint checking, weak reference
	353	creation and type coercion.
	354
a15dff8d	355	=over 4
	356
	357	=item B<has_type_constraint>
	358
6ba6d68c	359	Returns true if this meta-attribute has a type constraint.
6ba6d68c	360
a15dff8d	361	=item B<type_constraint>
a15dff8d	362
6ba6d68c	363	A read-only accessor for this meta-attribute's type constraint. For
	364	more information on what you can do with this, see the documentation
	365	for L<Moose::Meta::TypeConstraint>.
a15dff8d	366
6ba6d68c	367	=item B<is_weak_ref>
a15dff8d	368
02a0fb52	369	Returns true if this meta-attribute produces a weak reference.
4b598ea3	370
ca01a97b	371	=item B<is_required>
ca01a97b	372
02a0fb52	373	Returns true if this meta-attribute is required to have a value.
ca01a97b	374
	375	=item B<is_lazy>
	376
02a0fb52	377	Returns true if this meta-attribute should be initialized lazily.
ca01a97b	378
	379	NOTE: lazy attributes, B<must> have a C<default> field set.
	380
34a66aa3	381	=item B<should_coerce>
4b598ea3	382
02a0fb52	383	Returns true if this meta-attribute should perform type coercion.
6ba6d68c	384
8c9d74e7	385	=item B<has_trigger>
8c9d74e7	386
02a0fb52	387	Returns true if this meta-attribute has a trigger set.
02a0fb52	388
8c9d74e7	389	=item B<trigger>
8c9d74e7	390
02a0fb52	391	This is a CODE reference which will be executed every time the
	392	value of an attribute is assigned. The CODE ref will get two values,
	393	the invocant and the new value. This can be used to handle I<basic>
	394	bi-directional relations.
	395
c0e30cf5	396	=back
	397
	398	=head1 BUGS
	399
	400	All complex software has bugs lurking in it, and this module is no
	401	exception. If you find a bug please either email me, or add the bug
	402	to cpan-RT.
	403
c0e30cf5	404	=head1 AUTHOR
	405
	406	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	407
	408	=head1 COPYRIGHT AND LICENSE
	409
	410	Copyright 2006 by Infinity Interactive, Inc.
	411
	412	L<http://www.iinteractive.com>
	413
	414	This library is free software; you can redistribute it and/or modify
	415	it under the same terms as Perl itself.
	416
8a7a9c53	417	=cut