2 use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/trunk/lib';
4 package Moose::Meta::Method::Accessor;
11 our $VERSION = '0.01';
13 use base 'Moose::Meta::Method',
14 'Class::MOP::Method::Accessor';
18 sub generate_accessor_method {
20 my $attr = $self->associated_attribute;
21 my $attr_name = $attr->name;
23 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
24 my $mi = $attr->associated_class->get_meta_instance;
25 my $slot_name = sprintf "'%s'", $attr->slots;
28 . 'if (scalar(@_) == 2) {'
29 . $self->_inline_check_required
30 . $self->_inline_check_coercion
31 . $self->_inline_check_constraint($value_name)
32 . $self->_inline_store($inv, $value_name)
33 . $self->_inline_trigger($inv, $value_name)
35 . $self->_inline_check_lazy
36 . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv))
40 # set up the environment
41 my $type_constraint = $attr->type_constraint
42 ? $attr->type_constraint->_compiled_type_constraint
46 confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
50 sub generate_writer_method {
52 my $attr = $self->associated_attribute;
53 my $attr_name = $attr->name;
55 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
58 . $self->_inline_check_required
59 . $self->_inline_check_coercion
60 . $self->_inline_check_constraint($value_name)
61 . $self->_inline_store($inv, $value_name)
62 . $self->_inline_trigger($inv, $value_name)
66 # set up the environment
67 my $type_constraint = $attr->type_constraint
68 ? $attr->type_constraint->_compiled_type_constraint
72 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
76 sub generate_reader_method {
78 my $attr = $self->associated_attribute;
79 my $attr_name = $attr->name;
82 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
83 . $self->_inline_check_lazy
84 . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
87 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
91 #sub generate_predicate_method {
93 # my $attr = $self->associated_attribute;
94 # my $attr_name = $attr->name;
97 #sub generate_clearer_method {
99 # my $attr = $self->associated_attribute;
100 # my $attr_name = $attr->name;
105 *generate_accessor_method_inline = \&generate_accessor_method;
106 *generate_reader_method_inline = \&generate_reader_method;
107 *generate_writer_method_inline = \&generate_writer_method;
108 #*generate_predicate_method_inline = \&generate_predicate_method;
109 #*generate_clearer_method_inline = \&generate_clearer_method;
111 ## ... private helpers
113 sub _inline_check_constraint {
114 my ($self, $value) = @_;
116 my $attr = $self->associated_attribute;
118 return '' unless $attr->has_type_constraint;
120 # FIXME - remove 'unless defined($value) - constraint Undef
121 return sprintf <<'EOF', $value, $value, $value, $value
122 defined($type_constraint->(%s))
123 || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
124 . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
129 sub _inline_check_coercion {
130 my $attr = (shift)->associated_attribute;
132 return '' unless $attr->should_coerce;
133 return 'my $val = $attr->type_constraint->coerce($_[1]);'
136 sub _inline_check_required {
137 my $attr = (shift)->associated_attribute;
139 return '' unless $attr->is_required;
140 return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
143 sub _inline_check_lazy {
144 my $attr = (shift)->associated_attribute;
146 return '' unless $attr->is_lazy;
148 if ($attr->has_type_constraint) {
150 # this could probably be cleaned
151 # up and streamlined a little more
152 return 'unless (exists $_[0]->{$attr_name}) {' .
153 ' if ($attr->has_default) {' .
154 ' my $default = $attr->default($_[0]);' .
155 ' (defined($type_constraint->($default)))' .
156 ' || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
157 ' . $attr->type_constraint->name . ") with " . (defined($default) ? "\'$default\'" : "undef")' .
158 ' if defined($default);' .
159 ' $_[0]->{$attr_name} = $default; ' .
162 ' $_[0]->{$attr_name} = undef;' .
166 return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
167 . 'unless exists $_[0]->{$attr_name};';
172 my ($self, $instance, $value) = @_;
173 my $attr = $self->associated_attribute;
175 my $mi = $attr->associated_class->get_meta_instance;
176 my $slot_name = sprintf "'%s'", $attr->slots;
178 my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
179 $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
180 if $attr->is_weak_ref;
184 sub _inline_trigger {
185 my ($self, $instance, $value) = @_;
186 my $attr = $self->associated_attribute;
187 return '' unless $attr->has_trigger;
188 return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
192 my ($self, $instance) = @_;
193 my $attr = $self->associated_attribute;
195 my $mi = $attr->associated_class->get_meta_instance;
196 my $slot_name = sprintf "'%s'", $attr->slots;
198 return $mi->inline_get_slot_value($instance, $slot_name);
201 sub _inline_auto_deref {
202 my ( $self, $ref_value ) = @_;
203 my $attr = $self->associated_attribute;
205 return $ref_value unless $attr->should_auto_deref;
207 my $type_constraint = $attr->type_constraint;
210 if ($type_constraint->is_a_type_of('ArrayRef')) {
213 elsif ($type_constraint->is_a_type_of('HashRef')) {
217 confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
220 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
239 =item B<generate_accessor_method>
241 =item B<generate_accessor_method_inline>
243 =item B<generate_reader_method>
245 =item B<generate_reader_method_inline>
247 =item B<generate_writer_method>
249 =item B<generate_writer_method_inline>
255 All complex software has bugs lurking in it, and this module is no
256 exception. If you find a bug please either email me, or add the bug
261 Stevan Little E<lt>stevan@iinteractive.comE<gt>
263 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
265 =head1 COPYRIGHT AND LICENSE
267 Copyright 2006 by Infinity Interactive, Inc.
269 L<http://www.iinteractive.com>
271 This library is free software; you can redistribute it and/or modify
272 it under the same terms as Perl itself.