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} . "'";
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 return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
271 . 'unless exists $_[0]->{$attr_name};';
276 my ($self, $instance, $value) = @_;
278 my $mi = $self->associated_class->get_meta_instance;
279 my $slot_name = sprintf "'%s'", $self->slots;
281 my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
282 $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
283 if $self->is_weak_ref;
287 sub _inline_trigger {
288 my ($self, $instance, $value) = @_;
289 return '' unless $self->has_trigger;
290 return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
294 my ($self, $instance) = @_;
296 my $mi = $self->associated_class->get_meta_instance;
297 my $slot_name = sprintf "'%s'", $self->slots;
299 return $mi->inline_get_slot_value($instance, $slot_name);
302 sub _inline_auto_deref {
303 my ( $self, $ref_value ) = @_;
305 return $ref_value unless $self->should_auto_deref;
307 my $type_constraint = $self->type_constraint;
310 if ($type_constraint->is_a_type_of('ArrayRef')) {
313 elsif ($type_constraint->is_a_type_of('HashRef')) {
317 confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
320 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
323 sub generate_accessor_method {
324 my ($attr, $attr_name) = @_;
325 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
326 my $mi = $attr->associated_class->get_meta_instance;
327 my $slot_name = sprintf "'%s'", $attr->slots;
330 . 'if (scalar(@_) == 2) {'
331 . $attr->_inline_check_required
332 . $attr->_inline_check_coercion
333 . $attr->_inline_check_constraint($value_name)
334 . $attr->_inline_store($inv, $value_name)
335 . $attr->_inline_trigger($inv, $value_name)
337 . $attr->_inline_check_lazy
338 . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
340 my $sub = eval $code;
341 confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
345 sub generate_writer_method {
346 my ($attr, $attr_name) = @_;
347 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
350 . $attr->_inline_check_required
351 . $attr->_inline_check_coercion
352 . $attr->_inline_check_constraint($value_name)
353 . $attr->_inline_store($inv, $value_name)
354 . $attr->_inline_trigger($inv, $value_name)
356 my $sub = eval $code;
357 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
361 sub generate_reader_method {
363 my $attr_name = $attr->slots;
365 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
366 . $attr->_inline_check_lazy
367 . 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
369 my $sub = eval $code;
370 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
374 sub install_accessors {
376 $self->SUPER::install_accessors(@_);
378 if ($self->has_handles) {
381 # Here we canonicalize the 'handles' option
382 # this will sort out any details and always
383 # return an hash of methods which we want
384 # to delagate to, see that method for details
385 my %handles = $self->_canonicalize_handles();
387 # find the name of the accessor for this attribute
388 my $accessor_name = $self->reader || $self->accessor;
389 (defined $accessor_name)
390 || confess "You cannot install delegation without a reader or accessor for the attribute";
392 # make sure we handle HASH accessors correctly
393 ($accessor_name) = keys %{$accessor_name}
394 if ref($accessor_name) eq 'HASH';
396 # install the delegation ...
397 my $associated_class = $self->associated_class;
398 foreach my $handle (keys %handles) {
399 my $method_to_call = $handles{$handle};
401 (!$associated_class->has_method($handle))
402 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
404 if ((reftype($method_to_call) || '') eq 'CODE') {
405 $associated_class->add_method($handle => $method_to_call);
408 $associated_class->add_method($handle => sub {
410 # we should check for lack of
411 # a callable return value from
413 ((shift)->$accessor_name())->$method_to_call(@_);
422 # private methods to help delegation ...
424 sub _canonicalize_handles {
426 my $handles = $self->handles;
427 if (ref($handles) eq 'HASH') {
430 elsif (ref($handles) eq 'ARRAY') {
431 return map { $_ => $_ } @{$handles};
433 elsif (ref($handles) eq 'Regexp') {
434 ($self->has_type_constraint)
435 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
436 return map { ($_ => $_) }
437 grep { $handles } $self->_get_delegate_method_list;
439 elsif (ref($handles) eq 'CODE') {
440 return $handles->($self, $self->_find_delegate_metaclass);
443 confess "Unable to canonicalize the 'handles' option with $handles";
447 sub _find_delegate_metaclass {
449 if (my $class = $self->_isa_metadata) {
450 # if the class does have
451 # a meta method, use it
452 return $class->meta if $class->can('meta');
453 # otherwise we might be
454 # dealing with a non-Moose
455 # class, and need to make
457 return Moose::Meta::Class->initialize($class);
459 elsif (my $role = $self->_does_metadata) {
460 # our role will always have
465 confess "Cannot find delegate metaclass for attribute " . $self->name;
469 sub _get_delegate_method_list {
471 my $meta = $self->_find_delegate_metaclass;
472 if ($meta->isa('Class::MOP::Class')) {
473 return map { $_->{name} } # NOTE: !never! delegate &meta
474 grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
475 $meta->compute_all_applicable_methods;
477 elsif ($meta->isa('Moose::Meta::Role')) {
478 return $meta->get_method_list;
481 confess "Unable to recognize the delegate metaclass '$meta'";
493 Moose::Meta::Attribute - The Moose attribute metaclass
497 This is a subclass of L<Class::MOP::Attribute> with Moose specific
500 For the most part, the only time you will ever encounter an
501 instance of this class is if you are doing some serious deep
502 introspection. To really understand this class, you need to refer
503 to the L<Class::MOP::Attribute> documentation.
507 =head2 Overridden methods
509 These methods override methods in L<Class::MOP::Attribute> and add
510 Moose specific features. You can safely assume though that they
511 will behave just as L<Class::MOP::Attribute> does.
517 =item B<initialize_instance_slot>
519 =item B<generate_accessor_method>
521 =item B<generate_writer_method>
523 =item B<generate_reader_method>
525 =item B<install_accessors>
529 =head2 Additional Moose features
531 Moose attributes support type-constraint checking, weak reference
532 creation and type coercion.
536 =item B<clone_and_inherit_options>
538 This is to support the C<has '+foo'> feature, it clones an attribute
539 from a superclass and allows a very specific set of changes to be made
542 =item B<has_type_constraint>
544 Returns true if this meta-attribute has a type constraint.
546 =item B<type_constraint>
548 A read-only accessor for this meta-attribute's type constraint. For
549 more information on what you can do with this, see the documentation
550 for L<Moose::Meta::TypeConstraint>.
554 Returns true if this meta-attribute performs delegation.
558 This returns the value which was passed into the handles option.
562 Returns true if this meta-attribute produces a weak reference.
566 Returns true if this meta-attribute is required to have a value.
570 Returns true if this meta-attribute should be initialized lazily.
572 NOTE: lazy attributes, B<must> have a C<default> field set.
574 =item B<should_coerce>
576 Returns true if this meta-attribute should perform type coercion.
578 =item B<should_auto_deref>
580 Returns true if this meta-attribute should perform automatic
583 NOTE: This can only be done for attributes whose type constraint is
584 either I<ArrayRef> or I<HashRef>.
588 Returns true if this meta-attribute has a trigger set.
592 This is a CODE reference which will be executed every time the
593 value of an attribute is assigned. The CODE ref will get two values,
594 the invocant and the new value. This can be used to handle I<basic>
595 bi-directional relations.
601 All complex software has bugs lurking in it, and this module is no
602 exception. If you find a bug please either email me, or add the bug
607 Stevan Little E<lt>stevan@iinteractive.comE<gt>
609 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
611 =head1 COPYRIGHT AND LICENSE
613 Copyright 2006 by Infinity Interactive, Inc.
615 L<http://www.iinteractive.com>
617 This library is free software; you can redistribute it and/or modify
618 it under the same terms as Perl itself.