[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, $class, $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'";			
        }
	}
    $instance->{$self->name} = $val;
    if (defined $val && $self->is_weak_ref) {
        weaken($instance->{$self->name});
    }    
}

sub generate_accessor_method {
    my ($self, $attr_name) = @_;
    my $value_name = $self->should_coerce ? '$val' : '$_[1]';
    my $code = 'sub { '
    . 'if (scalar(@_) == 2) {'
        . ($self->is_required ? 
            'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' 
            : '')
        . ($self->should_coerce ? 
            'my $val = $self->type_constraint->coercion->coerce($_[1]);'
            : '')
        . ($self->has_type_constraint ? 
            ('(defined $self->type_constraint->check(' . $value_name . '))'
            	. '|| confess "Attribute ($attr_name) does not pass the type contraint (" . $self->type_constraint->name . ") with \'' . $value_name . '\'"'
            		. 'if defined ' . $value_name . ';')
            : '')
        . '$_[0]->{$attr_name} = ' . $value_name . ';'
        . ($self->is_weak_ref ?
            'weaken($_[0]->{$attr_name});'
            : '')
        . ($self->has_trigger ?
            '$self->trigger->($_[0], ' . $value_name . ', $self);'
            : '')            
    . ' }'
    . ($self->is_lazy ? 
            '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
            . 'unless exists $_[0]->{$attr_name};'
            : '')    
    . ' $_[0]->{$attr_name};'
    . ' }';
    my $sub = eval $code;
    confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;    
}

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