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'; |
9 | |
4c4fbe56 |
10 | our $VERSION = '0.05'; |
78cd1d3b |
11 | |
a3c7e2fe |
12 | use Moose::Util::TypeConstraints (); |
bc1e29b5 |
13 | |
c0e30cf5 |
14 | use base 'Class::MOP::Attribute'; |
15 | |
ca01a97b |
16 | __PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' )); |
17 | __PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' )); |
6ba6d68c |
18 | __PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce')); |
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) = @_; |
1d768fb1 |
31 | $class->_process_options($name, \%options); |
32 | $class->SUPER::new($name, %options); |
33 | } |
34 | |
ce0e8d63 |
35 | sub clone_and_inherit_options { |
36 | my ($self, %options) = @_; |
37 | # you can change default, required and coerce |
38 | my %actual_options; |
39 | foreach my $legal_option (qw(default coerce required)) { |
40 | if (exists $options{$legal_option}) { |
41 | $actual_options{$legal_option} = $options{$legal_option}; |
42 | delete $options{$legal_option}; |
43 | } |
44 | } |
fcb7afc2 |
45 | # isa can be changed, but only if the |
46 | # new type is a subtype |
ce0e8d63 |
47 | if ($options{isa}) { |
48 | my $type_constraint; |
49 | if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { |
50 | $type_constraint = $options{isa}; |
51 | } |
52 | else { |
53 | $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); |
54 | (defined $type_constraint) |
55 | || confess "Could not find the type constraint '" . $options{isa} . "'"; |
56 | } |
57 | ($type_constraint->is_subtype_of($self->type_constraint->name)) |
58 | || confess "New type constraint setting must be a subtype of inherited one" |
59 | if $self->has_type_constraint; |
60 | $actual_options{type_constraint} = $type_constraint; |
61 | delete $options{isa}; |
62 | } |
63 | (scalar keys %options == 0) |
64 | || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")"; |
65 | $self->clone(%actual_options); |
1d768fb1 |
66 | } |
67 | |
68 | sub _process_options { |
69 | my ($class, $name, $options) = @_; |
70 | if (exists $options->{is}) { |
71 | if ($options->{is} eq 'ro') { |
72 | $options->{reader} = $name; |
73 | (!exists $options->{trigger}) |
8c9d74e7 |
74 | || confess "Cannot have a trigger on a read-only attribute"; |
78cd1d3b |
75 | } |
1d768fb1 |
76 | elsif ($options->{is} eq 'rw') { |
77 | $options->{accessor} = $name; |
78 | ((reftype($options->{trigger}) || '') eq 'CODE') |
8c9d74e7 |
79 | || confess "A trigger must be a CODE reference" |
1d768fb1 |
80 | if exists $options->{trigger}; |
78cd1d3b |
81 | } |
82 | } |
83 | |
1d768fb1 |
84 | if (exists $options->{isa}) { |
02a0fb52 |
85 | |
1d768fb1 |
86 | if (exists $options->{does}) { |
87 | if (eval { $options->{isa}->can('does') }) { |
88 | ($options->{isa}->does($options->{does})) |
02a0fb52 |
89 | || confess "Cannot have an isa option and a does option if the isa does not do the does"; |
90 | } |
7eaef7ad |
91 | else { |
92 | confess "Cannot have an isa option which cannot ->does()"; |
93 | } |
02a0fb52 |
94 | } |
95 | |
78cd1d3b |
96 | # allow for anon-subtypes here ... |
1d768fb1 |
97 | if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { |
98 | $options->{type_constraint} = $options->{isa}; |
78cd1d3b |
99 | } |
100 | else { |
c07af9d2 |
101 | |
1d768fb1 |
102 | if ($options->{isa} =~ /\|/) { |
103 | my @type_constraints = split /\s*\|\s*/ => $options->{isa}; |
104 | $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union( |
c07af9d2 |
105 | @type_constraints |
78cd1d3b |
106 | ); |
c07af9d2 |
107 | } |
108 | else { |
109 | # otherwise assume it is a constraint |
1d768fb1 |
110 | my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa}); |
c07af9d2 |
111 | # if the constraing it not found .... |
112 | unless (defined $constraint) { |
113 | # assume it is a foreign class, and make |
114 | # an anon constraint for it |
115 | $constraint = Moose::Util::TypeConstraints::subtype( |
116 | 'Object', |
1d768fb1 |
117 | Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) } |
c07af9d2 |
118 | ); |
119 | } |
1d768fb1 |
120 | $options->{type_constraint} = $constraint; |
c07af9d2 |
121 | } |
78cd1d3b |
122 | } |
123 | } |
1d768fb1 |
124 | elsif (exists $options->{does}) { |
02a0fb52 |
125 | # allow for anon-subtypes here ... |
1d768fb1 |
126 | if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { |
127 | $options->{type_constraint} = $options->{isa}; |
02a0fb52 |
128 | } |
129 | else { |
130 | # otherwise assume it is a constraint |
1d768fb1 |
131 | my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does}); |
02a0fb52 |
132 | # if the constraing it not found .... |
133 | unless (defined $constraint) { |
134 | # assume it is a foreign class, and make |
135 | # an anon constraint for it |
136 | $constraint = Moose::Util::TypeConstraints::subtype( |
137 | 'Role', |
1d768fb1 |
138 | Moose::Util::TypeConstraints::where { $_->does($options->{does}) } |
02a0fb52 |
139 | ); |
140 | } |
1d768fb1 |
141 | $options->{type_constraint} = $constraint; |
02a0fb52 |
142 | } |
143 | } |
78cd1d3b |
144 | |
1d768fb1 |
145 | if (exists $options->{coerce} && $options->{coerce}) { |
146 | (exists $options->{type_constraint}) |
4b598ea3 |
147 | || confess "You cannot have coercion without specifying a type constraint"; |
1d768fb1 |
148 | (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union')) |
c07af9d2 |
149 | || confess "You cannot have coercion with a type constraint union"; |
4b598ea3 |
150 | confess "You cannot have a weak reference to a coerced value" |
1d768fb1 |
151 | if $options->{weak_ref}; |
ca01a97b |
152 | } |
78cd1d3b |
153 | |
1d768fb1 |
154 | if (exists $options->{lazy} && $options->{lazy}) { |
155 | (exists $options->{default}) |
ca01a97b |
156 | || confess "You cannot have lazy attribute without specifying a default value for it"; |
1d768fb1 |
157 | } |
78cd1d3b |
158 | } |
c0e30cf5 |
159 | |
d500266f |
160 | sub initialize_instance_slot { |
ddd0ec20 |
161 | my ($self, $meta_instance, $instance, $params) = @_; |
d500266f |
162 | my $init_arg = $self->init_arg(); |
163 | # try to fetch the init arg from the %params ... |
ddd0ec20 |
164 | |
d500266f |
165 | my $val; |
166 | if (exists $params->{$init_arg}) { |
167 | $val = $params->{$init_arg}; |
168 | } |
169 | else { |
170 | # skip it if it's lazy |
171 | return if $self->is_lazy; |
172 | # and die if it's required and doesn't have a default value |
173 | confess "Attribute (" . $self->name . ") is required" |
174 | if $self->is_required && !$self->has_default; |
175 | } |
ddd0ec20 |
176 | |
d500266f |
177 | # if nothing was in the %params, we can use the |
178 | # attribute's default value (if it has one) |
179 | if (!defined $val && $self->has_default) { |
180 | $val = $self->default($instance); |
181 | } |
182 | if (defined $val) { |
183 | if ($self->has_type_constraint) { |
c07af9d2 |
184 | my $type_constraint = $self->type_constraint; |
185 | if ($self->should_coerce && $type_constraint->has_coercion) { |
186 | $val = $type_constraint->coercion->coerce($val); |
d500266f |
187 | } |
c07af9d2 |
188 | (defined($type_constraint->check($val))) |
189 | || confess "Attribute (" . |
190 | $self->name . |
191 | ") does not pass the type contraint (" . |
192 | $type_constraint->name . |
193 | ") with '$val'"; |
d500266f |
194 | } |
195 | } |
ddd0ec20 |
196 | |
197 | $meta_instance->set_slot_value( $instance, $self->name, $val ); |
198 | $meta_instance->weaken_slot_value( $instance, $self->name ) if ( ref $val && $self->is_weak_ref ); |
d500266f |
199 | } |
200 | |
67ad26d9 |
201 | sub _inline_check_constraint { |
202 | my ( $self, $value ) = @_; |
203 | return '' unless $self->has_type_constraint; |
204 | |
205 | # FIXME - remove 'unless defined($value) - constraint Undef |
206 | return sprintf <<'EOF', $value, $value, $value, $value |
207 | defined($attr->type_constraint->check(%s)) |
208 | || confess "Attribute (" . $attr->name . ") does not pass the type contraint (" |
209 | . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef") |
210 | if defined(%s); |
211 | EOF |
212 | } |
213 | |
214 | sub _inline_store { |
215 | my ( $self, $instance, $value ) = @_; |
216 | |
217 | my $mi = $self->associated_class->get_meta_instance; |
ddd0ec20 |
218 | my $slot_name = sprintf "'%s'", $self->name; |
67ad26d9 |
219 | |
220 | return ( $self->is_weak_ref |
ddd0ec20 |
221 | ? $mi->inline_set_slot_value_weak( $instance, $slot_name, $value ) |
67ad26d9 |
222 | : $mi->inline_set_slot_value( $instance, $slot_name, $value ) ) . ";"; |
8a7a9c53 |
223 | } |
224 | |
67ad26d9 |
225 | sub _inline_trigger { |
226 | my ( $self, $instance, $value ) = @_; |
227 | return '' unless $self->has_trigger; |
228 | return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value); |
8a7a9c53 |
229 | } |
230 | |
ddd0ec20 |
231 | sub _inline_get { |
232 | my ( $self, $instance ) = @_; |
233 | |
234 | my $mi = $self->associated_class->get_meta_instance; |
235 | my $slot_name = sprintf "'%s'", $self->name; |
236 | |
237 | return $mi->inline_get_slot_value( $instance, $slot_name ); |
238 | } |
239 | |
a15dff8d |
240 | sub generate_accessor_method { |
67ad26d9 |
241 | my ($attr, $attr_name) = @_; |
242 | my $value_name = $attr->should_coerce ? '$val' : '$_[1]'; |
243 | my $mi = $attr->associated_class->get_meta_instance; |
ddd0ec20 |
244 | my $slot_name = sprintf "'%s'", $attr->name; |
67ad26d9 |
245 | my $inv = '$_[0]'; |
ca01a97b |
246 | my $code = 'sub { ' |
247 | . 'if (scalar(@_) == 2) {' |
67ad26d9 |
248 | . ($attr->is_required ? |
ca01a97b |
249 | 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' |
250 | : '') |
67ad26d9 |
251 | . ($attr->should_coerce ? |
252 | 'my $val = $attr->type_constraint->coercion->coerce($_[1]);' |
ca01a97b |
253 | : '') |
67ad26d9 |
254 | . $attr->_inline_check_constraint( $value_name ) |
255 | . $attr->_inline_store( $inv, $value_name ) |
256 | . $attr->_inline_trigger( $inv, $value_name ) |
ca01a97b |
257 | . ' }' |
67ad26d9 |
258 | . ($attr->is_lazy ? |
259 | '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)' |
ca01a97b |
260 | . 'unless exists $_[0]->{$attr_name};' |
261 | : '') |
ddd0ec20 |
262 | . 'return ' . $attr->_inline_get( $inv ) |
ca01a97b |
263 | . ' }'; |
264 | my $sub = eval $code; |
67ad26d9 |
265 | warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@; |
266 | confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@; |
ca01a97b |
267 | return $sub; |
a15dff8d |
268 | } |
269 | |
270 | sub generate_writer_method { |
67ad26d9 |
271 | my ($attr, $attr_name) = @_; |
272 | my $value_name = $attr->should_coerce ? '$val' : '$_[1]'; |
273 | my $inv = '$_[0]'; |
ca01a97b |
274 | my $code = 'sub { ' |
67ad26d9 |
275 | . ($attr->is_required ? |
ca01a97b |
276 | 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' |
277 | : '') |
67ad26d9 |
278 | . ($attr->should_coerce ? |
279 | 'my $val = $attr->type_constraint->coercion->coerce($_[1]);' |
ca01a97b |
280 | : '') |
67ad26d9 |
281 | . $attr->_inline_check_constraint( $value_name ) |
282 | . $attr->_inline_store( $inv, $value_name ) |
283 | . $attr->_inline_trigger( $inv, $value_name ) |
ca01a97b |
284 | . ' }'; |
285 | my $sub = eval $code; |
286 | confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@; |
287 | return $sub; |
a15dff8d |
288 | } |
c0e30cf5 |
289 | |
d7f17ebb |
290 | sub generate_reader_method { |
7e5ab379 |
291 | my $self = shift; |
292 | my $attr_name = $self->name; |
ca01a97b |
293 | my $code = 'sub {' |
294 | . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;' |
295 | . ($self->is_lazy ? |
296 | '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)' |
297 | . 'unless exists $_[0]->{$attr_name};' |
298 | : '') |
7e5ab379 |
299 | . 'return $_[0]->{$attr_name};' |
ca01a97b |
300 | . '}'; |
301 | my $sub = eval $code; |
302 | confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@; |
303 | return $sub; |
d7f17ebb |
304 | } |
305 | |
c0e30cf5 |
306 | 1; |
307 | |
308 | __END__ |
309 | |
310 | =pod |
311 | |
312 | =head1 NAME |
313 | |
6ba6d68c |
314 | Moose::Meta::Attribute - The Moose attribute metaclass |
c0e30cf5 |
315 | |
316 | =head1 DESCRIPTION |
317 | |
e522431d |
318 | This is a subclass of L<Class::MOP::Attribute> with Moose specific |
6ba6d68c |
319 | extensions. |
320 | |
321 | For the most part, the only time you will ever encounter an |
322 | instance of this class is if you are doing some serious deep |
323 | introspection. To really understand this class, you need to refer |
324 | to the L<Class::MOP::Attribute> documentation. |
e522431d |
325 | |
c0e30cf5 |
326 | =head1 METHODS |
327 | |
6ba6d68c |
328 | =head2 Overridden methods |
329 | |
330 | These methods override methods in L<Class::MOP::Attribute> and add |
331 | Moose specific features. You can safely assume though that they |
332 | will behave just as L<Class::MOP::Attribute> does. |
333 | |
c0e30cf5 |
334 | =over 4 |
335 | |
336 | =item B<new> |
337 | |
ce0e8d63 |
338 | =item B<clone_and_inherit_options> |
1d768fb1 |
339 | |
d500266f |
340 | =item B<initialize_instance_slot> |
341 | |
a15dff8d |
342 | =item B<generate_accessor_method> |
343 | |
344 | =item B<generate_writer_method> |
345 | |
d7f17ebb |
346 | =item B<generate_reader_method> |
347 | |
a15dff8d |
348 | =back |
349 | |
6ba6d68c |
350 | =head2 Additional Moose features |
351 | |
352 | Moose attributes support type-contstraint checking, weak reference |
353 | creation and type coercion. |
354 | |
a15dff8d |
355 | =over 4 |
356 | |
357 | =item B<has_type_constraint> |
358 | |
6ba6d68c |
359 | Returns true if this meta-attribute has a type constraint. |
360 | |
a15dff8d |
361 | =item B<type_constraint> |
362 | |
6ba6d68c |
363 | A read-only accessor for this meta-attribute's type constraint. For |
364 | more information on what you can do with this, see the documentation |
365 | for L<Moose::Meta::TypeConstraint>. |
a15dff8d |
366 | |
6ba6d68c |
367 | =item B<is_weak_ref> |
a15dff8d |
368 | |
02a0fb52 |
369 | Returns true if this meta-attribute produces a weak reference. |
4b598ea3 |
370 | |
ca01a97b |
371 | =item B<is_required> |
372 | |
02a0fb52 |
373 | Returns true if this meta-attribute is required to have a value. |
ca01a97b |
374 | |
375 | =item B<is_lazy> |
376 | |
02a0fb52 |
377 | Returns true if this meta-attribute should be initialized lazily. |
ca01a97b |
378 | |
379 | NOTE: lazy attributes, B<must> have a C<default> field set. |
380 | |
34a66aa3 |
381 | =item B<should_coerce> |
4b598ea3 |
382 | |
02a0fb52 |
383 | Returns true if this meta-attribute should perform type coercion. |
6ba6d68c |
384 | |
8c9d74e7 |
385 | =item B<has_trigger> |
386 | |
02a0fb52 |
387 | Returns true if this meta-attribute has a trigger set. |
388 | |
8c9d74e7 |
389 | =item B<trigger> |
390 | |
02a0fb52 |
391 | This is a CODE reference which will be executed every time the |
392 | value of an attribute is assigned. The CODE ref will get two values, |
393 | the invocant and the new value. This can be used to handle I<basic> |
394 | bi-directional relations. |
395 | |
c0e30cf5 |
396 | =back |
397 | |
398 | =head1 BUGS |
399 | |
400 | All complex software has bugs lurking in it, and this module is no |
401 | exception. If you find a bug please either email me, or add the bug |
402 | to cpan-RT. |
403 | |
c0e30cf5 |
404 | =head1 AUTHOR |
405 | |
406 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
407 | |
408 | =head1 COPYRIGHT AND LICENSE |
409 | |
410 | Copyright 2006 by Infinity Interactive, Inc. |
411 | |
412 | L<http://www.iinteractive.com> |
413 | |
414 | This library is free software; you can redistribute it and/or modify |
415 | it under the same terms as Perl itself. |
416 | |
8a7a9c53 |
417 | =cut |