2 package Moose::Meta::Attribute;
7 use Scalar::Util 'blessed', 'weaken', 'reftype';
10 our $VERSION = '0.06';
12 use Moose::Util::TypeConstraints ();
14 use base 'Class::MOP::Attribute';
16 # options which are not directly used
17 # but we store them for metadata purposes
18 __PACKAGE__->meta->add_attribute('isa' => (reader => '_isa_metadata'));
19 __PACKAGE__->meta->add_attribute('does' => (reader => '_does_metadata'));
20 __PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata'));
22 # these are actual options for the attrs
23 __PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
24 __PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
25 __PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' ));
26 __PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
27 __PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
28 __PACKAGE__->meta->add_attribute('type_constraint' => (
29 reader => 'type_constraint',
30 predicate => 'has_type_constraint',
32 __PACKAGE__->meta->add_attribute('trigger' => (
34 predicate => 'has_trigger',
36 __PACKAGE__->meta->add_attribute('handles' => (
38 predicate => 'has_handles',
42 my ($class, $name, %options) = @_;
43 $class->_process_options($name, \%options);
44 return $class->SUPER::new($name, %options);
47 sub clone_and_inherit_options {
48 my ($self, %options) = @_;
49 # you can change default, required and coerce
51 foreach my $legal_option (qw(default coerce required)) {
52 if (exists $options{$legal_option}) {
53 $actual_options{$legal_option} = $options{$legal_option};
54 delete $options{$legal_option};
57 # isa can be changed, but only if the
58 # new type is a subtype
61 if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
62 $type_constraint = $options{isa};
65 $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
66 (defined $type_constraint)
67 || confess "Could not find the type constraint '" . $options{isa} . "'";
69 ($type_constraint->is_subtype_of($self->type_constraint->name))
70 || confess "New type constraint setting must be a subtype of inherited one"
71 if $self->has_type_constraint;
72 $actual_options{type_constraint} = $type_constraint;
75 (scalar keys %options == 0)
76 || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
77 $self->clone(%actual_options);
80 sub _process_options {
81 my ($class, $name, $options) = @_;
83 if (exists $options->{is}) {
84 if ($options->{is} eq 'ro') {
85 $options->{reader} = $name;
86 (!exists $options->{trigger})
87 || confess "Cannot have a trigger on a read-only attribute";
89 elsif ($options->{is} eq 'rw') {
90 $options->{accessor} = $name;
91 ((reftype($options->{trigger}) || '') eq 'CODE')
92 || confess "Trigger must be a CODE ref"
93 if exists $options->{trigger};
96 confess "I do not understand this option (is => " . $options->{is} . ")"
100 if (exists $options->{isa}) {
102 if (exists $options->{does}) {
103 if (eval { $options->{isa}->can('does') }) {
104 ($options->{isa}->does($options->{does}))
105 || confess "Cannot have an isa option and a does option if the isa does not do the does";
108 confess "Cannot have an isa option which cannot ->does()";
112 # allow for anon-subtypes here ...
113 if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
114 $options->{type_constraint} = $options->{isa};
118 if ($options->{isa} =~ /\|/) {
119 my @type_constraints = split /\s*\|\s*/ => $options->{isa};
120 $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
125 # otherwise assume it is a constraint
126 my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
127 # if the constraing it not found ....
128 unless (defined $constraint) {
129 # assume it is a foreign class, and make
130 # an anon constraint for it
131 $constraint = Moose::Util::TypeConstraints::subtype(
133 Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
136 $options->{type_constraint} = $constraint;
140 elsif (exists $options->{does}) {
141 # allow for anon-subtypes here ...
142 if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
143 $options->{type_constraint} = $options->{isa};
146 # otherwise assume it is a constraint
147 my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
148 # if the constraing it not found ....
149 unless (defined $constraint) {
150 # assume it is a foreign class, and make
151 # an anon constraint for it
152 $constraint = Moose::Util::TypeConstraints::subtype(
154 Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
157 $options->{type_constraint} = $constraint;
161 if (exists $options->{coerce} && $options->{coerce}) {
162 (exists $options->{type_constraint})
163 || confess "You cannot have coercion without specifying a type constraint";
164 (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
165 || confess "You cannot have coercion with a type constraint union";
166 confess "You cannot have a weak reference to a coerced value"
167 if $options->{weak_ref};
170 if (exists $options->{auto_deref} && $options->{auto_deref}) {
171 (exists $options->{type_constraint})
172 || confess "You cannot auto-dereference without specifying a type constraint";
173 ($options->{type_constraint}->name =~ /^ArrayRef|HashRef$/)
174 || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
177 if (exists $options->{lazy} && $options->{lazy}) {
178 (exists $options->{default})
179 || confess "You cannot have lazy attribute without specifying a default value for it";
183 sub initialize_instance_slot {
184 my ($self, $meta_instance, $instance, $params) = @_;
185 my $init_arg = $self->init_arg();
186 # try to fetch the init arg from the %params ...
189 if (exists $params->{$init_arg}) {
190 $val = $params->{$init_arg};
193 # skip it if it's lazy
194 return if $self->is_lazy;
195 # and die if it's required and doesn't have a default value
196 confess "Attribute (" . $self->name . ") is required"
197 if $self->is_required && !$self->has_default;
200 # if nothing was in the %params, we can use the
201 # attribute's default value (if it has one)
202 if (!defined $val && $self->has_default) {
203 $val = $self->default($instance);
206 if ($self->has_type_constraint) {
207 my $type_constraint = $self->type_constraint;
208 if ($self->should_coerce && $type_constraint->has_coercion) {
209 $val = $type_constraint->coercion->coerce($val);
211 (defined($type_constraint->check($val)))
212 || confess "Attribute (" .
214 ") does not pass the type contraint (" .
215 $type_constraint->name .
220 $meta_instance->set_slot_value($instance, $self->name, $val);
221 $meta_instance->weaken_slot_value($instance, $self->name)
222 if ref $val && $self->is_weak_ref;
225 ## Accessor inline subroutines
227 sub _inline_check_constraint {
228 my ($self, $value) = @_;
229 return '' unless $self->has_type_constraint;
231 # FIXME - remove 'unless defined($value) - constraint Undef
232 return sprintf <<'EOF', $value, $value, $value, $value
233 defined($attr->type_constraint->check(%s))
234 || confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
235 . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
240 sub _inline_check_coercion {
242 return '' unless $self->should_coerce;
243 return 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
246 sub _inline_check_required {
248 return '' unless $self->is_required;
249 return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
252 sub _inline_check_lazy {
254 return '' unless $self->is_lazy;
255 return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
256 . 'unless exists $_[0]->{$attr_name};';
261 my ($self, $instance, $value) = @_;
263 my $mi = $self->associated_class->get_meta_instance;
264 my $slot_name = sprintf "'%s'", $self->slots;
266 my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
267 $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
268 if $self->is_weak_ref;
272 sub _inline_trigger {
273 my ($self, $instance, $value) = @_;
274 return '' unless $self->has_trigger;
275 return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
279 my ($self, $instance) = @_;
281 my $mi = $self->associated_class->get_meta_instance;
282 my $slot_name = sprintf "'%s'", $self->slots;
284 return $mi->inline_get_slot_value($instance, $slot_name);
287 sub _inline_auto_deref {
288 my ( $self, $ref_value ) = @_;
290 return $ref_value unless $self->should_auto_deref;
292 my $type = $self->type_constraint->name;
295 if ($type eq "ArrayRef") {
298 elsif ($type eq 'HashRef') {
302 confess "Can not auto de-reference the type constraint '$type'";
305 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
308 sub generate_accessor_method {
309 my ($attr, $attr_name) = @_;
310 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
311 my $mi = $attr->associated_class->get_meta_instance;
312 my $slot_name = sprintf "'%s'", $attr->slots;
315 . 'if (scalar(@_) == 2) {'
316 . $attr->_inline_check_required
317 . $attr->_inline_check_coercion
318 . $attr->_inline_check_constraint($value_name)
319 . $attr->_inline_store($inv, $value_name)
320 . $attr->_inline_trigger($inv, $value_name)
322 . $attr->_inline_check_lazy
323 . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
325 my $sub = eval $code;
326 confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
330 sub generate_writer_method {
331 my ($attr, $attr_name) = @_;
332 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
335 . $attr->_inline_check_required
336 . $attr->_inline_check_coercion
337 . $attr->_inline_check_constraint($value_name)
338 . $attr->_inline_store($inv, $value_name)
339 . $attr->_inline_trigger($inv, $value_name)
341 my $sub = eval $code;
342 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
346 sub generate_reader_method {
348 my $attr_name = $attr->slots;
350 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
351 . $attr->_inline_check_lazy
352 . 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
354 my $sub = eval $code;
355 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
359 sub install_accessors {
361 $self->SUPER::install_accessors(@_);
363 if ($self->has_handles) {
366 # Here we canonicalize the 'handles' option
367 # this will sort out any details and always
368 # return an hash of methods which we want
369 # to delagate to, see that method for details
370 my %handles = $self->_canonicalize_handles();
372 # find the name of the accessor for this attribute
373 my $accessor_name = $self->reader || $self->accessor;
374 (defined $accessor_name)
375 || confess "You cannot install delegation without a reader or accessor for the attribute";
377 # make sure we handle HASH accessors correctly
378 ($accessor_name) = keys %{$accessor_name}
379 if ref($accessor_name) eq 'HASH';
381 # install the delegation ...
382 my $associated_class = $self->associated_class;
383 foreach my $handle (keys %handles) {
384 my $method_to_call = $handles{$handle};
386 (!$associated_class->has_method($handle))
387 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
389 if ((reftype($method_to_call) || '') eq 'CODE') {
390 $associated_class->add_method($handle => $method_to_call);
393 $associated_class->add_method($handle => sub {
394 ((shift)->$accessor_name())->$method_to_call(@_);
403 # private methods to help delegation ...
405 sub _canonicalize_handles {
407 my $handles = $self->handles;
408 if (ref($handles) eq 'HASH') {
411 elsif (ref($handles) eq 'ARRAY') {
412 return map { $_ => $_ } @{$handles};
414 elsif (ref($handles) eq 'Regexp') {
415 ($self->has_type_constraint)
416 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
417 return map { ($_ => $_) }
418 grep { $handles } $self->_get_delegate_method_list;
420 elsif (ref($handles) eq 'CODE') {
421 return $handles->($self, $self->_find_delegate_metaclass);
424 confess "Unable to canonicalize the 'handles' option with $handles";
428 sub _find_delegate_metaclass {
430 if (my $class = $self->_isa_metadata) {
431 # if the class does have
432 # a meta method, use it
433 return $class->meta if $class->can('meta');
434 # otherwise we might be
435 # dealing with a non-Moose
436 # class, and need to make
438 return Moose::Meta::Class->initialize($class);
440 elsif (my $role = $self->_does_metadata) {
441 # our role will always have
446 confess "Cannot find delegate metaclass for attribute " . $self->name;
450 sub _get_delegate_method_list {
452 my $meta = $self->_find_delegate_metaclass;
453 if ($meta->isa('Class::MOP::Class')) {
454 return map { $_->{name} }
455 grep { $_->{class} ne 'Moose::Object' }
456 $meta->compute_all_applicable_methods;
458 elsif ($meta->isa('Moose::Meta::Role')) {
459 return $meta->get_method_list;
462 confess "Unable to recognize the delegate metaclass '$meta'";
474 Moose::Meta::Attribute - The Moose attribute metaclass
478 This is a subclass of L<Class::MOP::Attribute> with Moose specific
481 For the most part, the only time you will ever encounter an
482 instance of this class is if you are doing some serious deep
483 introspection. To really understand this class, you need to refer
484 to the L<Class::MOP::Attribute> documentation.
488 =head2 Overridden methods
490 These methods override methods in L<Class::MOP::Attribute> and add
491 Moose specific features. You can safely assume though that they
492 will behave just as L<Class::MOP::Attribute> does.
498 =item B<initialize_instance_slot>
500 =item B<generate_accessor_method>
502 =item B<generate_writer_method>
504 =item B<generate_reader_method>
506 =item B<install_accessors>
510 =head2 Additional Moose features
512 Moose attributes support type-contstraint checking, weak reference
513 creation and type coercion.
517 =item B<clone_and_inherit_options>
519 This is to support the C<has '+foo'> feature, it clones an attribute
520 from a superclass and allows a very specific set of changes to be made
523 =item B<has_type_constraint>
525 Returns true if this meta-attribute has a type constraint.
527 =item B<type_constraint>
529 A read-only accessor for this meta-attribute's type constraint. For
530 more information on what you can do with this, see the documentation
531 for L<Moose::Meta::TypeConstraint>.
535 Returns true if this meta-attribute performs delegation.
539 This returns the value which was passed into the handles option.
543 Returns true if this meta-attribute produces a weak reference.
547 Returns true if this meta-attribute is required to have a value.
551 Returns true if this meta-attribute should be initialized lazily.
553 NOTE: lazy attributes, B<must> have a C<default> field set.
555 =item B<should_coerce>
557 Returns true if this meta-attribute should perform type coercion.
559 =item B<should_auto_deref>
561 Returns true if this meta-attribute should perform automatic
564 NOTE: This can only be done for attributes whose type constraint is
565 either I<ArrayRef> or I<HashRef>.
569 Returns true if this meta-attribute has a trigger set.
573 This is a CODE reference which will be executed every time the
574 value of an attribute is assigned. The CODE ref will get two values,
575 the invocant and the new value. This can be used to handle I<basic>
576 bi-directional relations.
582 All complex software has bugs lurking in it, and this module is no
583 exception. If you find a bug please either email me, or add the bug
588 Stevan Little E<lt>stevan@iinteractive.comE<gt>
590 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
592 =head1 COPYRIGHT AND LICENSE
594 Copyright 2006 by Infinity Interactive, Inc.
596 L<http://www.iinteractive.com>
598 This library is free software; you can redistribute it and/or modify
599 it under the same terms as Perl itself.