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