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

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