2 package Moose::Meta::Attribute;
7 use Scalar::Util 'blessed', 'weaken', 'reftype';
10 our $VERSION = '0.08';
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} . "'";
70 # check here to see if the new type
71 # is a subtype of the old one
72 ($type_constraint->is_subtype_of($self->type_constraint->name))
73 || confess "New type constraint setting must be a subtype of inherited one"
74 # iff we have a type constraint that is ...
75 if $self->has_type_constraint;
77 $actual_options{type_constraint} = $type_constraint;
80 (scalar keys %options == 0)
81 || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
82 $self->clone(%actual_options);
85 sub _process_options {
86 my ($class, $name, $options) = @_;
88 if (exists $options->{is}) {
89 if ($options->{is} eq 'ro') {
90 $options->{reader} = $name;
91 (!exists $options->{trigger})
92 || confess "Cannot have a trigger on a read-only attribute";
94 elsif ($options->{is} eq 'rw') {
95 $options->{accessor} = $name;
96 ((reftype($options->{trigger}) || '') eq 'CODE')
97 || confess "Trigger must be a CODE ref"
98 if exists $options->{trigger};
101 confess "I do not understand this option (is => " . $options->{is} . ")"
105 if (exists $options->{isa}) {
107 if (exists $options->{does}) {
108 if (eval { $options->{isa}->can('does') }) {
109 ($options->{isa}->does($options->{does}))
110 || confess "Cannot have an isa option and a does option if the isa does not do the does";
113 confess "Cannot have an isa option which cannot ->does()";
117 # allow for anon-subtypes here ...
118 if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
119 $options->{type_constraint} = $options->{isa};
123 if ($options->{isa} =~ /\|/) {
124 my @type_constraints = split /\s*\|\s*/ => $options->{isa};
125 $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
130 # otherwise assume it is a constraint
131 my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
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(
138 Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
141 $options->{type_constraint} = $constraint;
145 elsif (exists $options->{does}) {
146 # allow for anon-subtypes here ...
147 if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
148 $options->{type_constraint} = $options->{isa};
151 # otherwise assume it is a constraint
152 my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
153 # if the constraing it not found ....
154 unless (defined $constraint) {
155 # assume it is a foreign class, and make
156 # an anon constraint for it
157 $constraint = Moose::Util::TypeConstraints::subtype(
159 Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
162 $options->{type_constraint} = $constraint;
166 if (exists $options->{coerce} && $options->{coerce}) {
167 (exists $options->{type_constraint})
168 || confess "You cannot have coercion without specifying a type constraint";
169 #(!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
170 # || confess "You cannot have coercion with a type constraint union";
171 confess "You cannot have a weak reference to a coerced value"
172 if $options->{weak_ref};
175 if (exists $options->{auto_deref} && $options->{auto_deref}) {
176 (exists $options->{type_constraint})
177 || confess "You cannot auto-dereference without specifying a type constraint";
178 ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
179 $options->{type_constraint}->is_a_type_of('HashRef'))
180 || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
183 if (exists $options->{type_constraint} &&
184 ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
185 $options->{type_constraint}->is_a_type_of('HashRef') )) {
186 unless (exists $options->{default}) {
187 $options->{default} = sub { [] } if $options->{type_constraint}->name eq 'ArrayRef';
188 $options->{default} = sub { {} } if $options->{type_constraint}->name eq 'HashRef';
192 if (exists $options->{lazy} && $options->{lazy}) {
193 (exists $options->{default})
194 || confess "You cannot have lazy attribute without specifying a default value for it";
198 sub initialize_instance_slot {
199 my ($self, $meta_instance, $instance, $params) = @_;
200 my $init_arg = $self->init_arg();
201 # try to fetch the init arg from the %params ...
204 if (exists $params->{$init_arg}) {
205 $val = $params->{$init_arg};
208 # skip it if it's lazy
209 return if $self->is_lazy;
210 # and die if it's required and doesn't have a default value
211 confess "Attribute (" . $self->name . ") is required"
212 if $self->is_required && !$self->has_default;
215 # if nothing was in the %params, we can use the
216 # attribute's default value (if it has one)
217 if (!defined $val && $self->has_default) {
218 $val = $self->default($instance);
221 if ($self->has_type_constraint) {
222 my $type_constraint = $self->type_constraint;
223 if ($self->should_coerce && $type_constraint->has_coercion) {
224 $val = $type_constraint->coerce($val);
226 (defined($type_constraint->check($val)))
227 || confess "Attribute (" .
229 ") does not pass the type constraint (" .
230 $type_constraint->name .
235 $meta_instance->set_slot_value($instance, $self->name, $val);
236 $meta_instance->weaken_slot_value($instance, $self->name)
237 if ref $val && $self->is_weak_ref;
240 ## Accessor inline subroutines
242 sub _inline_check_constraint {
243 my ($self, $value) = @_;
244 return '' unless $self->has_type_constraint;
246 # FIXME - remove 'unless defined($value) - constraint Undef
247 return sprintf <<'EOF', $value, $value, $value, $value
248 defined($attr->type_constraint->check(%s))
249 || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
250 . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
255 sub _inline_check_coercion {
257 return '' unless $self->should_coerce;
258 return 'my $val = $attr->type_constraint->coerce($_[1]);'
261 sub _inline_check_required {
263 return '' unless $self->is_required;
264 return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
267 sub _inline_check_lazy {
269 return '' unless $self->is_lazy;
270 if ($self->has_type_constraint) {
272 # this could probably be cleaned
273 # up and streamlined a little more
274 return 'unless (exists $_[0]->{$attr_name}) {' .
275 ' if ($attr->has_default) {' .
276 ' my $default = $attr->default($_[0]);' .
277 ' (defined($attr->type_constraint->check($default)))' .
278 ' || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
279 ' . $attr->type_constraint->name . ") with " . (defined($default) ? "\'$default\'" : "undef")' .
280 ' if defined($default);' .
281 ' $_[0]->{$attr_name} = $default; ' .
284 ' $_[0]->{$attr_name} = undef;' .
288 return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
289 . 'unless exists $_[0]->{$attr_name};';
294 my ($self, $instance, $value) = @_;
296 my $mi = $self->associated_class->get_meta_instance;
297 my $slot_name = sprintf "'%s'", $self->slots;
299 my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
300 $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
301 if $self->is_weak_ref;
305 sub _inline_trigger {
306 my ($self, $instance, $value) = @_;
307 return '' unless $self->has_trigger;
308 return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
312 my ($self, $instance) = @_;
314 my $mi = $self->associated_class->get_meta_instance;
315 my $slot_name = sprintf "'%s'", $self->slots;
317 return $mi->inline_get_slot_value($instance, $slot_name);
320 sub _inline_auto_deref {
321 my ( $self, $ref_value ) = @_;
323 return $ref_value unless $self->should_auto_deref;
325 my $type_constraint = $self->type_constraint;
328 if ($type_constraint->is_a_type_of('ArrayRef')) {
331 elsif ($type_constraint->is_a_type_of('HashRef')) {
335 confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
338 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
341 sub generate_accessor_method {
342 my ($attr, $attr_name) = @_;
343 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
344 my $mi = $attr->associated_class->get_meta_instance;
345 my $slot_name = sprintf "'%s'", $attr->slots;
348 . 'if (scalar(@_) == 2) {'
349 . $attr->_inline_check_required
350 . $attr->_inline_check_coercion
351 . $attr->_inline_check_constraint($value_name)
352 . $attr->_inline_store($inv, $value_name)
353 . $attr->_inline_trigger($inv, $value_name)
355 . $attr->_inline_check_lazy
356 . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
358 my $sub = eval $code;
359 confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
363 sub generate_writer_method {
364 my ($attr, $attr_name) = @_;
365 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
368 . $attr->_inline_check_required
369 . $attr->_inline_check_coercion
370 . $attr->_inline_check_constraint($value_name)
371 . $attr->_inline_store($inv, $value_name)
372 . $attr->_inline_trigger($inv, $value_name)
374 my $sub = eval $code;
375 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
379 sub generate_reader_method {
381 my $attr_name = $attr->slots;
383 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
384 . $attr->_inline_check_lazy
385 . 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
387 my $sub = eval $code;
388 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
392 sub install_accessors {
394 $self->SUPER::install_accessors(@_);
396 if ($self->has_handles) {
399 # Here we canonicalize the 'handles' option
400 # this will sort out any details and always
401 # return an hash of methods which we want
402 # to delagate to, see that method for details
403 my %handles = $self->_canonicalize_handles();
405 # find the name of the accessor for this attribute
406 my $accessor_name = $self->reader || $self->accessor;
407 (defined $accessor_name)
408 || confess "You cannot install delegation without a reader or accessor for the attribute";
410 # make sure we handle HASH accessors correctly
411 ($accessor_name) = keys %{$accessor_name}
412 if ref($accessor_name) eq 'HASH';
414 # install the delegation ...
415 my $associated_class = $self->associated_class;
416 foreach my $handle (keys %handles) {
417 my $method_to_call = $handles{$handle};
419 (!$associated_class->has_method($handle))
420 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
422 if ((reftype($method_to_call) || '') eq 'CODE') {
423 $associated_class->add_method($handle => $method_to_call);
426 $associated_class->add_method($handle => sub {
428 # we should check for lack of
429 # a callable return value from
431 ((shift)->$accessor_name())->$method_to_call(@_);
440 # private methods to help delegation ...
442 sub _canonicalize_handles {
444 my $handles = $self->handles;
445 if (ref($handles) eq 'HASH') {
448 elsif (ref($handles) eq 'ARRAY') {
449 return map { $_ => $_ } @{$handles};
451 elsif (ref($handles) eq 'Regexp') {
452 ($self->has_type_constraint)
453 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
454 return map { ($_ => $_) }
455 grep { $handles } $self->_get_delegate_method_list;
457 elsif (ref($handles) eq 'CODE') {
458 return $handles->($self, $self->_find_delegate_metaclass);
461 confess "Unable to canonicalize the 'handles' option with $handles";
465 sub _find_delegate_metaclass {
467 if (my $class = $self->_isa_metadata) {
468 # if the class does have
469 # a meta method, use it
470 return $class->meta if $class->can('meta');
471 # otherwise we might be
472 # dealing with a non-Moose
473 # class, and need to make
475 return Moose::Meta::Class->initialize($class);
477 elsif (my $role = $self->_does_metadata) {
478 # our role will always have
483 confess "Cannot find delegate metaclass for attribute " . $self->name;
487 sub _get_delegate_method_list {
489 my $meta = $self->_find_delegate_metaclass;
490 if ($meta->isa('Class::MOP::Class')) {
491 return map { $_->{name} } # NOTE: !never! delegate &meta
492 grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
493 $meta->compute_all_applicable_methods;
495 elsif ($meta->isa('Moose::Meta::Role')) {
496 return $meta->get_method_list;
499 confess "Unable to recognize the delegate metaclass '$meta'";
511 Moose::Meta::Attribute - The Moose attribute metaclass
515 This is a subclass of L<Class::MOP::Attribute> with Moose specific
518 For the most part, the only time you will ever encounter an
519 instance of this class is if you are doing some serious deep
520 introspection. To really understand this class, you need to refer
521 to the L<Class::MOP::Attribute> documentation.
525 =head2 Overridden methods
527 These methods override methods in L<Class::MOP::Attribute> and add
528 Moose specific features. You can safely assume though that they
529 will behave just as L<Class::MOP::Attribute> does.
535 =item B<initialize_instance_slot>
537 =item B<generate_accessor_method>
539 =item B<generate_writer_method>
541 =item B<generate_reader_method>
543 =item B<install_accessors>
547 =head2 Additional Moose features
549 Moose attributes support type-constraint checking, weak reference
550 creation and type coercion.
554 =item B<clone_and_inherit_options>
556 This is to support the C<has '+foo'> feature, it clones an attribute
557 from a superclass and allows a very specific set of changes to be made
560 =item B<has_type_constraint>
562 Returns true if this meta-attribute has a type constraint.
564 =item B<type_constraint>
566 A read-only accessor for this meta-attribute's type constraint. For
567 more information on what you can do with this, see the documentation
568 for L<Moose::Meta::TypeConstraint>.
572 Returns true if this meta-attribute performs delegation.
576 This returns the value which was passed into the handles option.
580 Returns true if this meta-attribute produces a weak reference.
584 Returns true if this meta-attribute is required to have a value.
588 Returns true if this meta-attribute should be initialized lazily.
590 NOTE: lazy attributes, B<must> have a C<default> field set.
592 =item B<should_coerce>
594 Returns true if this meta-attribute should perform type coercion.
596 =item B<should_auto_deref>
598 Returns true if this meta-attribute should perform automatic
601 NOTE: This can only be done for attributes whose type constraint is
602 either I<ArrayRef> or I<HashRef>.
606 Returns true if this meta-attribute has a trigger set.
610 This is a CODE reference which will be executed every time the
611 value of an attribute is assigned. The CODE ref will get two values,
612 the invocant and the new value. This can be used to handle I<basic>
613 bi-directional relations.
619 All complex software has bugs lurking in it, and this module is no
620 exception. If you find a bug please either email me, or add the bug
625 Stevan Little E<lt>stevan@iinteractive.comE<gt>
627 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
629 =head1 COPYRIGHT AND LICENSE
631 Copyright 2006 by Infinity Interactive, Inc.
633 L<http://www.iinteractive.com>
635 This library is free software; you can redistribute it and/or modify
636 it under the same terms as Perl itself.