2 package Moose::Meta::Attribute;
7 use Scalar::Util 'blessed', 'weaken', 'reftype';
10 our $VERSION = '0.07';
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}->is_a_type_of('ArrayRef') ||
174 $options->{type_constraint}->is_a_type_of('HashRef'))
175 || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
178 if (exists $options->{type_constraint} &&
179 ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
180 $options->{type_constraint}->is_a_type_of('HashRef') )) {
181 unless (exists $options->{default}) {
182 $options->{default} = sub { [] } if $options->{type_constraint}->name eq 'ArrayRef';
183 $options->{default} = sub { {} } if $options->{type_constraint}->name eq 'HashRef';
187 if (exists $options->{lazy} && $options->{lazy}) {
188 (exists $options->{default})
189 || confess "You cannot have lazy attribute without specifying a default value for it";
193 sub initialize_instance_slot {
194 my ($self, $meta_instance, $instance, $params) = @_;
195 my $init_arg = $self->init_arg();
196 # try to fetch the init arg from the %params ...
199 if (exists $params->{$init_arg}) {
200 $val = $params->{$init_arg};
203 # skip it if it's lazy
204 return if $self->is_lazy;
205 # and die if it's required and doesn't have a default value
206 confess "Attribute (" . $self->name . ") is required"
207 if $self->is_required && !$self->has_default;
210 # if nothing was in the %params, we can use the
211 # attribute's default value (if it has one)
212 if (!defined $val && $self->has_default) {
213 $val = $self->default($instance);
216 if ($self->has_type_constraint) {
217 my $type_constraint = $self->type_constraint;
218 if ($self->should_coerce && $type_constraint->has_coercion) {
219 $val = $type_constraint->coerce($val);
221 (defined($type_constraint->check($val)))
222 || confess "Attribute (" .
224 ") does not pass the type constraint (" .
225 $type_constraint->name .
230 $meta_instance->set_slot_value($instance, $self->name, $val);
231 $meta_instance->weaken_slot_value($instance, $self->name)
232 if ref $val && $self->is_weak_ref;
235 ## Accessor inline subroutines
237 sub _inline_check_constraint {
238 my ($self, $value) = @_;
239 return '' unless $self->has_type_constraint;
241 # FIXME - remove 'unless defined($value) - constraint Undef
242 return sprintf <<'EOF', $value, $value, $value, $value
243 defined($attr->type_constraint->check(%s))
244 || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
245 . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
250 sub _inline_check_coercion {
252 return '' unless $self->should_coerce;
253 return 'my $val = $attr->type_constraint->coerce($_[1]);'
256 sub _inline_check_required {
258 return '' unless $self->is_required;
259 return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
262 sub _inline_check_lazy {
264 return '' unless $self->is_lazy;
265 return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
266 . 'unless exists $_[0]->{$attr_name};';
271 my ($self, $instance, $value) = @_;
273 my $mi = $self->associated_class->get_meta_instance;
274 my $slot_name = sprintf "'%s'", $self->slots;
276 my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
277 $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
278 if $self->is_weak_ref;
282 sub _inline_trigger {
283 my ($self, $instance, $value) = @_;
284 return '' unless $self->has_trigger;
285 return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
289 my ($self, $instance) = @_;
291 my $mi = $self->associated_class->get_meta_instance;
292 my $slot_name = sprintf "'%s'", $self->slots;
294 return $mi->inline_get_slot_value($instance, $slot_name);
297 sub _inline_auto_deref {
298 my ( $self, $ref_value ) = @_;
300 return $ref_value unless $self->should_auto_deref;
302 my $type_constraint = $self->type_constraint;
305 if ($type_constraint->is_a_type_of('ArrayRef')) {
308 elsif ($type_constraint->is_a_type_of('HashRef')) {
312 confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
315 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
318 sub generate_accessor_method {
319 my ($attr, $attr_name) = @_;
320 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
321 my $mi = $attr->associated_class->get_meta_instance;
322 my $slot_name = sprintf "'%s'", $attr->slots;
325 . 'if (scalar(@_) == 2) {'
326 . $attr->_inline_check_required
327 . $attr->_inline_check_coercion
328 . $attr->_inline_check_constraint($value_name)
329 . $attr->_inline_store($inv, $value_name)
330 . $attr->_inline_trigger($inv, $value_name)
332 . $attr->_inline_check_lazy
333 . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
335 my $sub = eval $code;
336 confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
340 sub generate_writer_method {
341 my ($attr, $attr_name) = @_;
342 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
345 . $attr->_inline_check_required
346 . $attr->_inline_check_coercion
347 . $attr->_inline_check_constraint($value_name)
348 . $attr->_inline_store($inv, $value_name)
349 . $attr->_inline_trigger($inv, $value_name)
351 my $sub = eval $code;
352 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
356 sub generate_reader_method {
358 my $attr_name = $attr->slots;
360 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
361 . $attr->_inline_check_lazy
362 . 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
364 my $sub = eval $code;
365 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
369 sub install_accessors {
371 $self->SUPER::install_accessors(@_);
373 if ($self->has_handles) {
376 # Here we canonicalize the 'handles' option
377 # this will sort out any details and always
378 # return an hash of methods which we want
379 # to delagate to, see that method for details
380 my %handles = $self->_canonicalize_handles();
382 # find the name of the accessor for this attribute
383 my $accessor_name = $self->reader || $self->accessor;
384 (defined $accessor_name)
385 || confess "You cannot install delegation without a reader or accessor for the attribute";
387 # make sure we handle HASH accessors correctly
388 ($accessor_name) = keys %{$accessor_name}
389 if ref($accessor_name) eq 'HASH';
391 # install the delegation ...
392 my $associated_class = $self->associated_class;
393 foreach my $handle (keys %handles) {
394 my $method_to_call = $handles{$handle};
396 (!$associated_class->has_method($handle))
397 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
399 if ((reftype($method_to_call) || '') eq 'CODE') {
400 $associated_class->add_method($handle => $method_to_call);
403 $associated_class->add_method($handle => sub {
405 # we should check for lack of
406 # a callable return value from
408 ((shift)->$accessor_name())->$method_to_call(@_);
417 # private methods to help delegation ...
419 sub _canonicalize_handles {
421 my $handles = $self->handles;
422 if (ref($handles) eq 'HASH') {
425 elsif (ref($handles) eq 'ARRAY') {
426 return map { $_ => $_ } @{$handles};
428 elsif (ref($handles) eq 'Regexp') {
429 ($self->has_type_constraint)
430 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
431 return map { ($_ => $_) }
432 grep { $handles } $self->_get_delegate_method_list;
434 elsif (ref($handles) eq 'CODE') {
435 return $handles->($self, $self->_find_delegate_metaclass);
438 confess "Unable to canonicalize the 'handles' option with $handles";
442 sub _find_delegate_metaclass {
444 if (my $class = $self->_isa_metadata) {
445 # if the class does have
446 # a meta method, use it
447 return $class->meta if $class->can('meta');
448 # otherwise we might be
449 # dealing with a non-Moose
450 # class, and need to make
452 return Moose::Meta::Class->initialize($class);
454 elsif (my $role = $self->_does_metadata) {
455 # our role will always have
460 confess "Cannot find delegate metaclass for attribute " . $self->name;
464 sub _get_delegate_method_list {
466 my $meta = $self->_find_delegate_metaclass;
467 if ($meta->isa('Class::MOP::Class')) {
468 return map { $_->{name} } # NOTE: !never! delegate &meta
469 grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
470 $meta->compute_all_applicable_methods;
472 elsif ($meta->isa('Moose::Meta::Role')) {
473 return $meta->get_method_list;
476 confess "Unable to recognize the delegate metaclass '$meta'";
488 Moose::Meta::Attribute - The Moose attribute metaclass
492 This is a subclass of L<Class::MOP::Attribute> with Moose specific
495 For the most part, the only time you will ever encounter an
496 instance of this class is if you are doing some serious deep
497 introspection. To really understand this class, you need to refer
498 to the L<Class::MOP::Attribute> documentation.
502 =head2 Overridden methods
504 These methods override methods in L<Class::MOP::Attribute> and add
505 Moose specific features. You can safely assume though that they
506 will behave just as L<Class::MOP::Attribute> does.
512 =item B<initialize_instance_slot>
514 =item B<generate_accessor_method>
516 =item B<generate_writer_method>
518 =item B<generate_reader_method>
520 =item B<install_accessors>
524 =head2 Additional Moose features
526 Moose attributes support type-constraint checking, weak reference
527 creation and type coercion.
531 =item B<clone_and_inherit_options>
533 This is to support the C<has '+foo'> feature, it clones an attribute
534 from a superclass and allows a very specific set of changes to be made
537 =item B<has_type_constraint>
539 Returns true if this meta-attribute has a type constraint.
541 =item B<type_constraint>
543 A read-only accessor for this meta-attribute's type constraint. For
544 more information on what you can do with this, see the documentation
545 for L<Moose::Meta::TypeConstraint>.
549 Returns true if this meta-attribute performs delegation.
553 This returns the value which was passed into the handles option.
557 Returns true if this meta-attribute produces a weak reference.
561 Returns true if this meta-attribute is required to have a value.
565 Returns true if this meta-attribute should be initialized lazily.
567 NOTE: lazy attributes, B<must> have a C<default> field set.
569 =item B<should_coerce>
571 Returns true if this meta-attribute should perform type coercion.
573 =item B<should_auto_deref>
575 Returns true if this meta-attribute should perform automatic
578 NOTE: This can only be done for attributes whose type constraint is
579 either I<ArrayRef> or I<HashRef>.
583 Returns true if this meta-attribute has a trigger set.
587 This is a CODE reference which will be executed every time the
588 value of an attribute is assigned. The CODE ref will get two values,
589 the invocant and the new value. This can be used to handle I<basic>
590 bi-directional relations.
596 All complex software has bugs lurking in it, and this module is no
597 exception. If you find a bug please either email me, or add the bug
602 Stevan Little E<lt>stevan@iinteractive.comE<gt>
604 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
606 =head1 COPYRIGHT AND LICENSE
608 Copyright 2006 by Infinity Interactive, Inc.
610 L<http://www.iinteractive.com>
612 This library is free software; you can redistribute it and/or modify
613 it under the same terms as Perl itself.