[gitmo/Moose.git] / lib / Moose / Meta / Method / Accessor.pm


package Moose::Meta::Method::Accessor;

use strict;
use warnings;

use Carp 'confess';

our $VERSION   = '0.05';
our $AUTHORITY = 'cpan:STEVAN';

use base 'Moose::Meta::Method',
         'Class::MOP::Method::Accessor';

## Inline method generators

sub generate_accessor_method_inline {
    my $self        = $_[0];
    my $attr        = $self->associated_attribute; 
    my $attr_name   = $attr->name;
    my $inv         = '$_[0]';
    my $slot_access = $self->_inline_get($inv, $attr_name);
    my $value_name  = $attr->should_coerce ? '$val' : '$_[1]';

    my $code = 'sub { '
    . $self->_inline_pre_body(@_)
    . 'if (scalar(@_) == 2) {'
        . $self->_inline_check_required
        . $self->_inline_check_coercion
        . $self->_inline_check_constraint($value_name)
		. $self->_inline_store($inv, $value_name)
		. $self->_inline_trigger($inv, $value_name)
    . ' }'
    . $self->_inline_check_lazy
    . $self->_inline_post_body(@_)
    . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv))
    . ' }';
    
    # NOTE:
    # set up the environment
    my $type_constraint = $attr->type_constraint 
                                ? $attr->type_constraint->_compiled_type_constraint
                                : undef;
    
    my $sub = eval $code;
    confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;    
}

sub generate_writer_method_inline {
    my $self        = $_[0];
    my $attr        = $self->associated_attribute; 
    my $attr_name   = $attr->name;
    my $inv         = '$_[0]';
    my $slot_access = $self->_inline_get($inv, $attr_name);
    my $value_name  = $attr->should_coerce ? '$val' : '$_[1]';

    my $code = 'sub { '
    . $self->_inline_pre_body(@_)
    . $self->_inline_check_required
    . $self->_inline_check_coercion
	. $self->_inline_check_constraint($value_name)
	. $self->_inline_store($inv, $value_name)
	. $self->_inline_post_body(@_)
	. $self->_inline_trigger($inv, $value_name)
    . ' }';
    
    # NOTE:
    # set up the environment
    my $type_constraint = $attr->type_constraint 
                                ? $attr->type_constraint->_compiled_type_constraint
                                : undef;    
    
    my $sub = eval $code;
    confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;    
}

sub generate_reader_method_inline {
    my $self        = $_[0];
    my $attr        = $self->associated_attribute; 
    my $attr_name   = $attr->name;
    my $inv         = '$_[0]';
    my $slot_access = $self->_inline_get($inv, $attr_name);
    
    my $code = 'sub {'
    . $self->_inline_pre_body(@_)
    . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
    . $self->_inline_check_lazy
    . $self->_inline_post_body(@_)
    . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
    . '}';
    
    # NOTE:
    # set up the environment
    my $type_constraint = $attr->type_constraint 
                                ? $attr->type_constraint->_compiled_type_constraint
                                : undef;    
    
    my $sub = eval $code;
    confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
    return $sub;
}

sub generate_reader_method { shift->generate_reader_method_inline(@_) }
sub generate_writer_method { shift->generate_writer_method_inline(@_) }
sub generate_accessor_method { shift->generate_accessor_method_inline(@_) }

sub _inline_pre_body  { '' }
sub _inline_post_body { '' }

sub _inline_check_constraint {
	my ($self, $value) = @_;
	
	my $attr = $self->associated_attribute; 
	
	return '' unless $attr->has_type_constraint;
	
	# FIXME
	# This sprintf is insanely annoying, we should
	# fix it someday - SL
	return sprintf <<'EOF', $value, $value, $value, $value, $value, $value, $value
defined($type_constraint->(%s))
	|| confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
       . $attr->type_constraint->name . ") with " 
       . (defined(%s) ? (Scalar::Util::blessed(%s) && overload::Overloaded(%s) ? overload::StrVal(%s) : %s) : "undef")
  if defined(%s);
EOF
}

sub _inline_check_coercion {
	my $attr = (shift)->associated_attribute; 
	
	return '' unless $attr->should_coerce;
    return 'my $val = $attr->type_constraint->coerce($_[1]);'
}

sub _inline_check_required {
	my $attr = (shift)->associated_attribute; 
	
	return '' unless $attr->is_required;
    return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
}

sub _inline_check_lazy {
    my $self = $_[0];
    my $attr = $self->associated_attribute; 
	
	return '' unless $attr->is_lazy;
	
    my $inv         = '$_[0]';
    my $slot_access = $self->_inline_get($inv, $attr->name);	
	
	if ($attr->has_type_constraint) {
	    # NOTE:
	    # this could probably be cleaned 
	    # up and streamlined a little more
	    return 'unless (exists ' . $slot_access . ') {' .
	           '    if ($attr->has_default) {' .
	           '        my $default = $attr->default(' . $inv . ');' .
	           ($attr->should_coerce
	               ? '$default = $attr->type_constraint->coerce($default);'
	               : '') .
               '        (defined($type_constraint->($default)))' .
               '        	|| confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
               '               . $attr->type_constraint->name . ") with " . (defined($default) ? (Scalar::Util::blessed($default) && overload::Overloaded($default) ? overload::StrVal($default) : $default) : "undef")' .               
               '          if defined($default);' .	                
	           '        ' . $slot_access . ' = $default; ' .
	           '    }' .
	           '    else {' .
               '        ' . $slot_access . ' = undef;' .
	           '    }' .
	           '}';	    
	}
    return $slot_access . ' = ($attr->has_default ? $attr->default(' . $inv . ') : undef)'
         . 'unless exists ' . $slot_access . ';';
}


sub _inline_store {
	my ($self, $instance, $value) = @_;
	my $attr = $self->associated_attribute; 	

	my $mi = $attr->associated_class->get_meta_instance;
	my $slot_name = sprintf "'%s'", $attr->slots;

    my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
	$code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
	    if $attr->is_weak_ref;
    return $code;
}

sub _inline_trigger {
	my ($self, $instance, $value) = @_;
	my $attr = $self->associated_attribute; 	
	return '' unless $attr->has_trigger;
	return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
}

sub _inline_get {
	my ($self, $instance) = @_;
	my $attr = $self->associated_attribute; 	

	my $mi = $attr->associated_class->get_meta_instance;
	my $slot_name = sprintf "'%s'", $attr->slots;

    return $mi->inline_get_slot_value($instance, $slot_name);
}

sub _inline_auto_deref {
    my ( $self, $ref_value ) = @_;
	my $attr = $self->associated_attribute;     

    return $ref_value unless $attr->should_auto_deref;

    my $type_constraint = $attr->type_constraint;

    my $sigil;
    if ($type_constraint->is_a_type_of('ArrayRef')) {
        $sigil = '@';
    } 
    elsif ($type_constraint->is_a_type_of('HashRef')) {
        $sigil = '%';
    } 
    else {
        confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
    }

    "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
}

1;

__END__

=pod

=head1 NAME

Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors

=head1 DESCRIPTION

This is a subclass of L<Class::MOP::Method::Accessor> and it's primary 
responsibility is to generate the accessor methods for attributes. It 
can handle both closure based accessors, as well as inlined source based
accessors. 

This is a fairly new addition to the MOP, but this will play an important
role in the optimization strategy we are currently following.

=head1 METHODS

=over 4

=item B<generate_accessor_method>

=item B<generate_reader_method>

=item B<generate_writer_method>

=item B<generate_accessor_method_inline>

=item B<generate_reader_method_inline>

=item B<generate_writer_method_inline>

=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>

Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006, 2007 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
8ee73eeb	1
	2	package Moose::Meta::Method::Accessor;
	3
	4	use strict;
	5	use warnings;
	6
39b3bc94	7	use Carp 'confess';
39b3bc94	8
18ea2bcc	9	our $VERSION = '0.05';
d44714be	10	our $AUTHORITY = 'cpan:STEVAN';
8ee73eeb	11
39b3bc94	12	use base 'Moose::Meta::Method',
d617b644	13	'Class::MOP::Method::Accessor';
d617b644	14
946289d1	15	## Inline method generators
d617b644	16
946289d1	17	sub generate_accessor_method_inline {
3ccdc84a	18	my $self = $_[0];
	19	my $attr = $self->associated_attribute;
	20	my $attr_name = $attr->name;
	21	my $inv = '$_[0]';
	22	my $slot_access = $self->_inline_get($inv, $attr_name);
	23	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
d617b644	24
d617b644	25	my $code = 'sub { '
c350159f	26	. $self->_inline_pre_body(@_)
d617b644	27	. 'if (scalar(@_) == 2) {'
	28	. $self->_inline_check_required
	29	. $self->_inline_check_coercion
	30	. $self->_inline_check_constraint($value_name)
	31	. $self->_inline_store($inv, $value_name)
	32	. $self->_inline_trigger($inv, $value_name)
	33	. ' }'
	34	. $self->_inline_check_lazy
c350159f	35	. $self->_inline_post_body(@_)
d617b644	36	. 'return ' . $self->_inline_auto_deref($self->_inline_get($inv))
	37	. ' }';
	38
	39	# NOTE:
	40	# set up the environment
	41	my $type_constraint = $attr->type_constraint
	42	? $attr->type_constraint->_compiled_type_constraint
	43	: undef;
	44
	45	my $sub = eval $code;
	46	confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
	47	return $sub;
	48	}
	49
946289d1	50	sub generate_writer_method_inline {
3ccdc84a	51	my $self = $_[0];
	52	my $attr = $self->associated_attribute;
	53	my $attr_name = $attr->name;
	54	my $inv = '$_[0]';
	55	my $slot_access = $self->_inline_get($inv, $attr_name);
	56	my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
	57
d617b644	58	my $code = 'sub { '
c350159f	59	. $self->_inline_pre_body(@_)
d617b644	60	. $self->_inline_check_required
	61	. $self->_inline_check_coercion
	62	. $self->_inline_check_constraint($value_name)
	63	. $self->_inline_store($inv, $value_name)
c350159f	64	. $self->_inline_post_body(@_)
d617b644	65	. $self->_inline_trigger($inv, $value_name)
	66	. ' }';
	67
	68	# NOTE:
	69	# set up the environment
	70	my $type_constraint = $attr->type_constraint
	71	? $attr->type_constraint->_compiled_type_constraint
	72	: undef;
	73
	74	my $sub = eval $code;
	75	confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
	76	return $sub;
	77	}
	78
946289d1	79	sub generate_reader_method_inline {
3ccdc84a	80	my $self = $_[0];
	81	my $attr = $self->associated_attribute;
	82	my $attr_name = $attr->name;
	83	my $inv = '$_[0]';
	84	my $slot_access = $self->_inline_get($inv, $attr_name);
d617b644	85
d617b644	86	my $code = 'sub {'
c350159f	87	. $self->_inline_pre_body(@_)
d617b644	88	. 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
d617b644	89	. $self->_inline_check_lazy
c350159f	90	. $self->_inline_post_body(@_)
3ccdc84a	91	. 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
d617b644	92	. '}';
7bffa230	93
	94	# NOTE:
	95	# set up the environment
	96	my $type_constraint = $attr->type_constraint
	97	? $attr->type_constraint->_compiled_type_constraint
	98	: undef;
	99
d617b644	100	my $sub = eval $code;
	101	confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
	102	return $sub;
	103	}
	104
51308c23	105	sub generate_reader_method { shift->generate_reader_method_inline(@_) }
	106	sub generate_writer_method { shift->generate_writer_method_inline(@_) }
	107	sub generate_accessor_method { shift->generate_accessor_method_inline(@_) }
8ecb1fa0	108
3ccdc84a	109	sub _inline_pre_body { '' }
c350159f	110	sub _inline_post_body { '' }
c350159f	111
d617b644	112	sub _inline_check_constraint {
d617b644	113	my ($self, $value) = @_;
39b3bc94	114
	115	my $attr = $self->associated_attribute;
	116
	117	return '' unless $attr->has_type_constraint;
d617b644	118
3ccdc84a	119	# FIXME
	120	# This sprintf is insanely annoying, we should
	121	# fix it someday - SL
8ac5969a	122	return sprintf <<'EOF', $value, $value, $value, $value, $value, $value, $value
d617b644	123	defined($type_constraint->(%s))
d617b644	124	\|\| confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
a909a4df	125	. $attr->type_constraint->name . ") with "
8ac5969a	126	. (defined(%s) ? (Scalar::Util::blessed(%s) && overload::Overloaded(%s) ? overload::StrVal(%s) : %s) : "undef")
d617b644	127	if defined(%s);
	128	EOF
	129	}
	130
	131	sub _inline_check_coercion {
39b3bc94	132	my $attr = (shift)->associated_attribute;
	133
	134	return '' unless $attr->should_coerce;
d617b644	135	return 'my $val = $attr->type_constraint->coerce($_[1]);'
	136	}
	137
	138	sub _inline_check_required {
39b3bc94	139	my $attr = (shift)->associated_attribute;
	140
	141	return '' unless $attr->is_required;
d617b644	142	return 'defined($_[1]) \|\| confess "Attribute ($attr_name) is required, so cannot be set to undef";'
	143	}
	144
	145	sub _inline_check_lazy {
3ccdc84a	146	my $self = $_[0];
3ccdc84a	147	my $attr = $self->associated_attribute;
39b3bc94	148
	149	return '' unless $attr->is_lazy;
	150
3ccdc84a	151	my $inv = '$_[0]';
	152	my $slot_access = $self->_inline_get($inv, $attr->name);
	153
39b3bc94	154	if ($attr->has_type_constraint) {
d617b644	155	# NOTE:
	156	# this could probably be cleaned
	157	# up and streamlined a little more
3ccdc84a	158	return 'unless (exists ' . $slot_access . ') {' .
d617b644	159	' if ($attr->has_default) {' .
3ccdc84a	160	' my $default = $attr->default(' . $inv . ');' .
d7611a4a	161	($attr->should_coerce
	162	? '$default = $attr->type_constraint->coerce($default);'
	163	: '') .
d617b644	164	' (defined($type_constraint->($default)))' .
d617b644	165	' \|\| confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
8ac5969a	166	' . $attr->type_constraint->name . ") with " . (defined($default) ? (Scalar::Util::blessed($default) && overload::Overloaded($default) ? overload::StrVal($default) : $default) : "undef")' .
d617b644	167	' if defined($default);' .
3ccdc84a	168	' ' . $slot_access . ' = $default; ' .
d617b644	169	' }' .
d617b644	170	' else {' .
3ccdc84a	171	' ' . $slot_access . ' = undef;' .
d617b644	172	' }' .
	173	'}';
	174	}
3ccdc84a	175	return $slot_access . ' = ($attr->has_default ? $attr->default(' . $inv . ') : undef)'
3ccdc84a	176	. 'unless exists ' . $slot_access . ';';
d617b644	177	}
	178
	179
	180	sub _inline_store {
	181	my ($self, $instance, $value) = @_;
39b3bc94	182	my $attr = $self->associated_attribute;
d617b644	183
39b3bc94	184	my $mi = $attr->associated_class->get_meta_instance;
39b3bc94	185	my $slot_name = sprintf "'%s'", $attr->slots;
d617b644	186
	187	my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
	188	$code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
39b3bc94	189	if $attr->is_weak_ref;
d617b644	190	return $code;
	191	}
	192
	193	sub _inline_trigger {
	194	my ($self, $instance, $value) = @_;
39b3bc94	195	my $attr = $self->associated_attribute;
39b3bc94	196	return '' unless $attr->has_trigger;
d617b644	197	return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
	198	}
	199
	200	sub _inline_get {
	201	my ($self, $instance) = @_;
39b3bc94	202	my $attr = $self->associated_attribute;
d617b644	203
39b3bc94	204	my $mi = $attr->associated_class->get_meta_instance;
39b3bc94	205	my $slot_name = sprintf "'%s'", $attr->slots;
d617b644	206
	207	return $mi->inline_get_slot_value($instance, $slot_name);
	208	}
	209
	210	sub _inline_auto_deref {
	211	my ( $self, $ref_value ) = @_;
39b3bc94	212	my $attr = $self->associated_attribute;
d617b644	213
39b3bc94	214	return $ref_value unless $attr->should_auto_deref;
d617b644	215
39b3bc94	216	my $type_constraint = $attr->type_constraint;
d617b644	217
	218	my $sigil;
	219	if ($type_constraint->is_a_type_of('ArrayRef')) {
	220	$sigil = '@';
	221	}
	222	elsif ($type_constraint->is_a_type_of('HashRef')) {
	223	$sigil = '%';
	224	}
	225	else {
	226	confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
	227	}
	228
	229	"(wantarray() ? $sigil\{ ( $ref_value ) \|\| return } : ( $ref_value ) )";
	230	}
8ee73eeb	231
	232	1;
	233
	234	__END__
	235
	236	=pod
	237
39b3bc94	238	=head1 NAME
39b3bc94	239
ecb59493	240	Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
39b3bc94	241
	242	=head1 DESCRIPTION
	243
ecb59493	244	This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
	245	responsibility is to generate the accessor methods for attributes. It
	246	can handle both closure based accessors, as well as inlined source based
	247	accessors.
	248
	249	This is a fairly new addition to the MOP, but this will play an important
	250	role in the optimization strategy we are currently following.
	251
39b3bc94	252	=head1 METHODS
	253
	254	=over 4
	255
8ecb1fa0	256	=item B<generate_accessor_method>
	257
	258	=item B<generate_reader_method>
	259
	260	=item B<generate_writer_method>
	261
39b3bc94	262	=item B<generate_accessor_method_inline>
39b3bc94	263
39b3bc94	264	=item B<generate_reader_method_inline>
39b3bc94	265
39b3bc94	266	=item B<generate_writer_method_inline>
	267
	268	=back
	269
	270	=head1 BUGS
	271
	272	All complex software has bugs lurking in it, and this module is no
	273	exception. If you find a bug please either email me, or add the bug
	274	to cpan-RT.
	275
	276	=head1 AUTHOR
	277
	278	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	279
	280	Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
	281
	282	=head1 COPYRIGHT AND LICENSE
	283
b77fdbed	284	Copyright 2006, 2007 by Infinity Interactive, Inc.
39b3bc94	285
	286	L<http://www.iinteractive.com>
	287
	288	This library is free software; you can redistribute it and/or modify
	289	it under the same terms as Perl itself.
	290
51308c23	291	=cut