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

use Moose::Util::TypeConstraints '-no-export';

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',
));

sub new {
	my ($class, $name, %options) = @_;
	
	if (exists $options{is}) {
		if ($options{is} eq 'ro') {
			$options{reader} = $name;
		}
		elsif ($options{is} eq 'rw') {
			$options{accessor} = $name;				
		}			
	}
	
	if (exists $options{isa}) {
	    # allow for anon-subtypes here ...
	    if (blessed($options{isa}) && $options{isa}->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{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;
		}
	}	
	
	if (exists $options{coerce} && $options{coerce}) {
	    (exists $options{type_constraint})
	        || confess "You cannot have coercion without specifying a type constraint";
        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";	    
	}
	
	$class->SUPER::new($name, %options);	
}

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 with \'' . $value_name . '\'"'
            		. 'if defined ' . $value_name . ';')
            : '')
        . '$_[0]->{$attr_name} = ' . $value_name . ';'
        . ($self->is_weak_ref ?
            'weaken($_[0]->{$attr_name});'
            : '')
    . ' }'
    . ($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 with \'' . $value_name . '\'"'
        		. 'if defined ' . $value_name . ';')
        : '')
    . '$_[0]->{$attr_name} = ' . $value_name . ';'
    . ($self->is_weak_ref ?
        'weaken($_[0]->{$attr_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, $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<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 of this meta-attribute produces a weak reference.

=item B<is_required>

Returns true of this meta-attribute is required to have a value.

=item B<is_lazy>

Returns true of this meta-attribute should be initialized lazily.

NOTE: lazy attributes, B<must> have a C<default> field set.

=item B<should_coerce>

Returns true of this meta-attribute should perform type coercion.

=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
78cd1d3b	10	our $VERSION = '0.03';
	11
	12	use Moose::Util::TypeConstraints '-no-export';
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	));
	24
78cd1d3b	25	sub new {
	26	my ($class, $name, %options) = @_;
	27
	28	if (exists $options{is}) {
	29	if ($options{is} eq 'ro') {
	30	$options{reader} = $name;
	31	}
	32	elsif ($options{is} eq 'rw') {
	33	$options{accessor} = $name;
	34	}
	35	}
	36
	37	if (exists $options{isa}) {
	38	# allow for anon-subtypes here ...
	39	if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
	40	$options{type_constraint} = $options{isa};
	41	}
	42	else {
	43	# otherwise assume it is a constraint
446e850f	44	my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
78cd1d3b	45	# if the constraing it not found ....
	46	unless (defined $constraint) {
	47	# assume it is a foreign class, and make
	48	# an anon constraint for it
	49	$constraint = Moose::Util::TypeConstraints::subtype(
	50	'Object',
	51	Moose::Util::TypeConstraints::where { $_->isa($options{isa}) }
	52	);
	53	}
	54	$options{type_constraint} = $constraint;
	55	}
	56	}
	57
4b598ea3	58	if (exists $options{coerce} && $options{coerce}) {
	59	(exists $options{type_constraint})
	60	\|\| confess "You cannot have coercion without specifying a type constraint";
	61	confess "You cannot have a weak reference to a coerced value"
	62	if $options{weak_ref};
ca01a97b	63	}
78cd1d3b	64
ca01a97b	65	if (exists $options{lazy} && $options{lazy}) {
	66	(exists $options{default})
	67	\|\| confess "You cannot have lazy attribute without specifying a default value for it";
78cd1d3b	68	}
	69
	70	$class->SUPER::new($name, %options);
	71	}
c0e30cf5	72
a15dff8d	73	sub generate_accessor_method {
a15dff8d	74	my ($self, $attr_name) = @_;
ca01a97b	75	my $value_name = $self->should_coerce ? '$val' : '$_[1]';
	76	my $code = 'sub { '
	77	. 'if (scalar(@_) == 2) {'
	78	. ($self->is_required ?
	79	'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
	80	: '')
	81	. ($self->should_coerce ?
	82	'my $val = $self->type_constraint->coercion->coerce($_[1]);'
	83	: '')
	84	. ($self->has_type_constraint ?
	85	('(defined $self->type_constraint->check(' . $value_name . '))'
	86	. '\|\| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"'
	87	. 'if defined ' . $value_name . ';')
	88	: '')
	89	. '$_[0]->{$attr_name} = ' . $value_name . ';'
	90	. ($self->is_weak_ref ?
	91	'weaken($_[0]->{$attr_name});'
	92	: '')
	93	. ' }'
	94	. ($self->is_lazy ?
	95	'$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
	96	. 'unless exists $_[0]->{$attr_name};'
	97	: '')
	98	. ' $_[0]->{$attr_name};'
	99	. ' }';
	100	my $sub = eval $code;
	101	confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
	102	return $sub;
a15dff8d	103	}
	104
	105	sub generate_writer_method {
	106	my ($self, $attr_name) = @_;
ca01a97b	107	my $value_name = $self->should_coerce ? '$val' : '$_[1]';
	108	my $code = 'sub { '
	109	. ($self->is_required ?
	110	'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
	111	: '')
	112	. ($self->should_coerce ?
	113	'my $val = $self->type_constraint->coercion->coerce($_[1]);'
	114	: '')
	115	. ($self->has_type_constraint ?
	116	('(defined $self->type_constraint->check(' . $value_name . '))'
	117	. '\|\| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"'
	118	. 'if defined ' . $value_name . ';')
	119	: '')
	120	. '$_[0]->{$attr_name} = ' . $value_name . ';'
	121	. ($self->is_weak_ref ?
	122	'weaken($_[0]->{$attr_name});'
	123	: '')
	124	. ' }';
	125	my $sub = eval $code;
	126	confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
	127	return $sub;
a15dff8d	128	}
c0e30cf5	129
d7f17ebb	130	sub generate_reader_method {
d7f17ebb	131	my ($self, $attr_name) = @_;
ca01a97b	132	my $code = 'sub {'
	133	. 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
	134	. ($self->is_lazy ?
	135	'$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
	136	. 'unless exists $_[0]->{$attr_name};'
	137	: '')
	138	. '$_[0]->{$attr_name};'
	139	. '}';
	140	my $sub = eval $code;
	141	confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
	142	return $sub;
d7f17ebb	143	}
d7f17ebb	144
c0e30cf5	145	1;
	146
	147	__END__
	148
	149	=pod
	150
	151	=head1 NAME
	152
6ba6d68c	153	Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5	154
	155	=head1 DESCRIPTION
	156
e522431d	157	This is a subclass of L<Class::MOP::Attribute> with Moose specific
6ba6d68c	158	extensions.
	159
	160	For the most part, the only time you will ever encounter an
	161	instance of this class is if you are doing some serious deep
	162	introspection. To really understand this class, you need to refer
	163	to the L<Class::MOP::Attribute> documentation.
e522431d	164
c0e30cf5	165	=head1 METHODS
c0e30cf5	166
6ba6d68c	167	=head2 Overridden methods
	168
	169	These methods override methods in L<Class::MOP::Attribute> and add
	170	Moose specific features. You can safely assume though that they
	171	will behave just as L<Class::MOP::Attribute> does.
	172
c0e30cf5	173	=over 4
	174
	175	=item B<new>
	176
a15dff8d	177	=item B<generate_accessor_method>
	178
	179	=item B<generate_writer_method>
	180
d7f17ebb	181	=item B<generate_reader_method>
d7f17ebb	182
a15dff8d	183	=back
a15dff8d	184
6ba6d68c	185	=head2 Additional Moose features
	186
	187	Moose attributes support type-contstraint checking, weak reference
	188	creation and type coercion.
	189
a15dff8d	190	=over 4
	191
	192	=item B<has_type_constraint>
	193
6ba6d68c	194	Returns true if this meta-attribute has a type constraint.
6ba6d68c	195
a15dff8d	196	=item B<type_constraint>
a15dff8d	197
6ba6d68c	198	A read-only accessor for this meta-attribute's type constraint. For
	199	more information on what you can do with this, see the documentation
	200	for L<Moose::Meta::TypeConstraint>.
a15dff8d	201
6ba6d68c	202	=item B<is_weak_ref>
a15dff8d	203
6ba6d68c	204	Returns true of this meta-attribute produces a weak reference.
4b598ea3	205
ca01a97b	206	=item B<is_required>
	207
	208	Returns true of this meta-attribute is required to have a value.
	209
	210	=item B<is_lazy>
	211
	212	Returns true of this meta-attribute should be initialized lazily.
	213
	214	NOTE: lazy attributes, B<must> have a C<default> field set.
	215
34a66aa3	216	=item B<should_coerce>
4b598ea3	217
6ba6d68c	218	Returns true of this meta-attribute should perform type coercion.
6ba6d68c	219
c0e30cf5	220	=back
	221
	222	=head1 BUGS
	223
	224	All complex software has bugs lurking in it, and this module is no
	225	exception. If you find a bug please either email me, or add the bug
	226	to cpan-RT.
	227
c0e30cf5	228	=head1 AUTHOR
	229
	230	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	231
	232	=head1 COPYRIGHT AND LICENSE
	233
	234	Copyright 2006 by Infinity Interactive, Inc.
	235
	236	L<http://www.iinteractive.com>
	237
	238	This library is free software; you can redistribute it and/or modify
	239	it under the same terms as Perl itself.
	240
	241	=cut