[gitmo/Moose.git] / lib / Moose / Meta / Attribute.pm


package Moose::Meta::Attribute;

use strict;
use warnings;

use Scalar::Util 'weaken', 'reftype';
use Carp         'confess';

our $VERSION = '0.02';

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_before_method_modifier('new' => sub {
	my (undef, undef, %options) = @_;
	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";	    
	}	
});

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