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