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 confess "You cannot have a weak reference to a coerced value"
170 if $options->{weak_ref};
173 if (exists $options->{auto_deref} && $options->{auto_deref}) {
174 (exists $options->{type_constraint})
175 || confess "You cannot auto-dereference without specifying a type constraint";
176 ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
177 $options->{type_constraint}->is_a_type_of('HashRef'))
178 || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
181 if (exists $options->{lazy} && $options->{lazy}) {
182 (exists $options->{default})
183 || confess "You cannot have lazy attribute without specifying a default value for it";
187 sub initialize_instance_slot {
188 my ($self, $meta_instance, $instance, $params) = @_;
189 my $init_arg = $self->init_arg();
190 # try to fetch the init arg from the %params ...
193 if (exists $params->{$init_arg}) {
194 $val = $params->{$init_arg};
197 # skip it if it's lazy
198 return if $self->is_lazy;
199 # and die if it's required and doesn't have a default value
200 confess "Attribute (" . $self->name . ") is required"
201 if $self->is_required && !$self->has_default;
204 # if nothing was in the %params, we can use the
205 # attribute's default value (if it has one)
206 if (!defined $val && $self->has_default) {
207 $val = $self->default($instance);
210 if ($self->has_type_constraint) {
211 my $type_constraint = $self->type_constraint;
212 if ($self->should_coerce && $type_constraint->has_coercion) {
213 $val = $type_constraint->coerce($val);
215 (defined($type_constraint->check($val)))
216 || confess "Attribute (" .
218 ") does not pass the type constraint (" .
219 $type_constraint->name .
224 $meta_instance->set_slot_value($instance, $self->name, $val);
225 $meta_instance->weaken_slot_value($instance, $self->name)
226 if ref $val && $self->is_weak_ref;
229 ## Accessor inline subroutines
231 sub _inline_check_constraint {
232 my ($self, $value) = @_;
233 return '' unless $self->has_type_constraint;
235 # FIXME - remove 'unless defined($value) - constraint Undef
236 return sprintf <<'EOF', $value, $value, $value, $value
237 defined($type_constraint->(%s))
238 || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
239 . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
244 sub _inline_check_coercion {
246 return '' unless $self->should_coerce;
247 return 'my $val = $attr->type_constraint->coerce($_[1]);'
250 sub _inline_check_required {
252 return '' unless $self->is_required;
253 return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
256 sub _inline_check_lazy {
258 return '' unless $self->is_lazy;
259 if ($self->has_type_constraint) {
261 # this could probably be cleaned
262 # up and streamlined a little more
263 return 'unless (exists $_[0]->{$attr_name}) {' .
264 ' if ($attr->has_default) {' .
265 ' my $default = $attr->default($_[0]);' .
266 ' (defined($type_constraint->($default)))' .
267 ' || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
268 ' . $attr->type_constraint->name . ") with " . (defined($default) ? "\'$default\'" : "undef")' .
269 ' if defined($default);' .
270 ' $_[0]->{$attr_name} = $default; ' .
273 ' $_[0]->{$attr_name} = undef;' .
277 return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
278 . 'unless exists $_[0]->{$attr_name};';
283 my ($self, $instance, $value) = @_;
285 my $mi = $self->associated_class->get_meta_instance;
286 my $slot_name = sprintf "'%s'", $self->slots;
288 my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
289 $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
290 if $self->is_weak_ref;
294 sub _inline_trigger {
295 my ($self, $instance, $value) = @_;
296 return '' unless $self->has_trigger;
297 return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
301 my ($self, $instance) = @_;
303 my $mi = $self->associated_class->get_meta_instance;
304 my $slot_name = sprintf "'%s'", $self->slots;
306 return $mi->inline_get_slot_value($instance, $slot_name);
309 sub _inline_auto_deref {
310 my ( $self, $ref_value ) = @_;
312 return $ref_value unless $self->should_auto_deref;
314 my $type_constraint = $self->type_constraint;
317 if ($type_constraint->is_a_type_of('ArrayRef')) {
320 elsif ($type_constraint->is_a_type_of('HashRef')) {
324 confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
327 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
330 sub generate_accessor_method {
331 my ($attr, $attr_name) = @_;
332 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
333 my $mi = $attr->associated_class->get_meta_instance;
334 my $slot_name = sprintf "'%s'", $attr->slots;
337 . 'if (scalar(@_) == 2) {'
338 . $attr->_inline_check_required
339 . $attr->_inline_check_coercion
340 . $attr->_inline_check_constraint($value_name)
341 . $attr->_inline_store($inv, $value_name)
342 . $attr->_inline_trigger($inv, $value_name)
344 . $attr->_inline_check_lazy
345 . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
349 # set up the environment
350 my $type_constraint = $attr->type_constraint
351 ? $attr->type_constraint->_compiled_type_constraint
354 my $sub = eval $code;
355 confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
359 sub generate_writer_method {
360 my ($attr, $attr_name) = @_;
361 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
364 . $attr->_inline_check_required
365 . $attr->_inline_check_coercion
366 . $attr->_inline_check_constraint($value_name)
367 . $attr->_inline_store($inv, $value_name)
368 . $attr->_inline_trigger($inv, $value_name)
372 # set up the environment
373 my $type_constraint = $attr->type_constraint
374 ? $attr->type_constraint->_compiled_type_constraint
377 my $sub = eval $code;
378 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
382 sub generate_reader_method {
384 my $attr_name = $attr->slots;
386 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
387 . $attr->_inline_check_lazy
388 . 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
390 my $sub = eval $code;
391 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
395 sub install_accessors {
397 $self->SUPER::install_accessors(@_);
399 if ($self->has_handles) {
402 # Here we canonicalize the 'handles' option
403 # this will sort out any details and always
404 # return an hash of methods which we want
405 # to delagate to, see that method for details
406 my %handles = $self->_canonicalize_handles();
408 # find the name of the accessor for this attribute
409 my $accessor_name = $self->reader || $self->accessor;
410 (defined $accessor_name)
411 || confess "You cannot install delegation without a reader or accessor for the attribute";
413 # make sure we handle HASH accessors correctly
414 ($accessor_name) = keys %{$accessor_name}
415 if ref($accessor_name) eq 'HASH';
417 # install the delegation ...
418 my $associated_class = $self->associated_class;
419 foreach my $handle (keys %handles) {
420 my $method_to_call = $handles{$handle};
422 (!$associated_class->has_method($handle))
423 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
425 if ((reftype($method_to_call) || '') eq 'CODE') {
426 $associated_class->add_method($handle => $method_to_call);
429 $associated_class->add_method($handle => sub {
431 # we should check for lack of
432 # a callable return value from
434 ((shift)->$accessor_name())->$method_to_call(@_);
443 # private methods to help delegation ...
445 sub _canonicalize_handles {
447 my $handles = $self->handles;
448 if (ref($handles) eq 'HASH') {
451 elsif (ref($handles) eq 'ARRAY') {
452 return map { $_ => $_ } @{$handles};
454 elsif (ref($handles) eq 'Regexp') {
455 ($self->has_type_constraint)
456 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
457 return map { ($_ => $_) }
458 grep { $handles } $self->_get_delegate_method_list;
460 elsif (ref($handles) eq 'CODE') {
461 return $handles->($self, $self->_find_delegate_metaclass);
464 confess "Unable to canonicalize the 'handles' option with $handles";
468 sub _find_delegate_metaclass {
470 if (my $class = $self->_isa_metadata) {
471 # if the class does have
472 # a meta method, use it
473 return $class->meta if $class->can('meta');
474 # otherwise we might be
475 # dealing with a non-Moose
476 # class, and need to make
478 return Moose::Meta::Class->initialize($class);
480 elsif (my $role = $self->_does_metadata) {
481 # our role will always have
486 confess "Cannot find delegate metaclass for attribute " . $self->name;
490 sub _get_delegate_method_list {
492 my $meta = $self->_find_delegate_metaclass;
493 if ($meta->isa('Class::MOP::Class')) {
494 return map { $_->{name} } # NOTE: !never! delegate &meta
495 grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
496 $meta->compute_all_applicable_methods;
498 elsif ($meta->isa('Moose::Meta::Role')) {
499 return $meta->get_method_list;
502 confess "Unable to recognize the delegate metaclass '$meta'";
514 Moose::Meta::Attribute - The Moose attribute metaclass
518 This is a subclass of L<Class::MOP::Attribute> with Moose specific
521 For the most part, the only time you will ever encounter an
522 instance of this class is if you are doing some serious deep
523 introspection. To really understand this class, you need to refer
524 to the L<Class::MOP::Attribute> documentation.
528 =head2 Overridden methods
530 These methods override methods in L<Class::MOP::Attribute> and add
531 Moose specific features. You can safely assume though that they
532 will behave just as L<Class::MOP::Attribute> does.
538 =item B<initialize_instance_slot>
540 =item B<generate_accessor_method>
542 =item B<generate_writer_method>
544 =item B<generate_reader_method>
546 =item B<install_accessors>
550 =head2 Additional Moose features
552 Moose attributes support type-constraint checking, weak reference
553 creation and type coercion.
557 =item B<clone_and_inherit_options>
559 This is to support the C<has '+foo'> feature, it clones an attribute
560 from a superclass and allows a very specific set of changes to be made
563 =item B<has_type_constraint>
565 Returns true if this meta-attribute has a type constraint.
567 =item B<type_constraint>
569 A read-only accessor for this meta-attribute's type constraint. For
570 more information on what you can do with this, see the documentation
571 for L<Moose::Meta::TypeConstraint>.
575 Returns true if this meta-attribute performs delegation.
579 This returns the value which was passed into the handles option.
583 Returns true if this meta-attribute produces a weak reference.
587 Returns true if this meta-attribute is required to have a value.
591 Returns true if this meta-attribute should be initialized lazily.
593 NOTE: lazy attributes, B<must> have a C<default> field set.
595 =item B<should_coerce>
597 Returns true if this meta-attribute should perform type coercion.
599 =item B<should_auto_deref>
601 Returns true if this meta-attribute should perform automatic
604 NOTE: This can only be done for attributes whose type constraint is
605 either I<ArrayRef> or I<HashRef>.
609 Returns true if this meta-attribute has a trigger set.
613 This is a CODE reference which will be executed every time the
614 value of an attribute is assigned. The CODE ref will get two values,
615 the invocant and the new value. This can be used to handle I<basic>
616 bi-directional relations.
622 All complex software has bugs lurking in it, and this module is no
623 exception. If you find a bug please either email me, or add the bug
628 Stevan Little E<lt>stevan@iinteractive.comE<gt>
630 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
632 =head1 COPYRIGHT AND LICENSE
634 Copyright 2006 by Infinity Interactive, Inc.
636 L<http://www.iinteractive.com>
638 This library is free software; you can redistribute it and/or modify
639 it under the same terms as Perl itself.