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 sub _inline_check_constraint {
226 my ($self, $value) = @_;
227 return '' unless $self->has_type_constraint;
229 # FIXME - remove 'unless defined($value) - constraint Undef
230 return sprintf <<'EOF', $value, $value, $value, $value
231 defined($attr->type_constraint->check(%s))
232 || confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
233 . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
239 my ($self, $instance, $value) = @_;
241 my $mi = $self->associated_class->get_meta_instance;
242 my $slot_name = sprintf "'%s'", $self->slots;
244 my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
245 $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
246 if $self->is_weak_ref;
250 sub _inline_trigger {
251 my ($self, $instance, $value) = @_;
252 return '' unless $self->has_trigger;
253 return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
257 my ($self, $instance) = @_;
259 my $mi = $self->associated_class->get_meta_instance;
260 my $slot_name = sprintf "'%s'", $self->slots;
262 return $mi->inline_get_slot_value($instance, $slot_name);
265 sub _inline_auto_deref {
266 my ( $self, $ref_value ) = @_;
268 return $ref_value unless $self->should_auto_deref;
270 my $type = $self->type_constraint->name;
273 if ($type eq "ArrayRef") {
276 elsif ($type eq 'HashRef') {
280 confess "Can not auto de-reference the type constraint '$type'";
283 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
286 sub generate_accessor_method {
287 my ($attr, $attr_name) = @_;
288 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
289 my $mi = $attr->associated_class->get_meta_instance;
290 my $slot_name = sprintf "'%s'", $attr->slots;
293 . 'if (scalar(@_) == 2) {'
294 . ($attr->is_required ?
295 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
297 . ($attr->should_coerce ?
298 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
300 . $attr->_inline_check_constraint($value_name)
301 . $attr->_inline_store($inv, $value_name)
302 . $attr->_inline_trigger($inv, $value_name)
305 '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
306 . 'unless exists $_[0]->{$attr_name};'
308 . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
310 my $sub = eval $code;
311 warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
312 confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
316 sub generate_writer_method {
317 my ($attr, $attr_name) = @_;
318 my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
321 . ($attr->is_required ?
322 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
324 . ($attr->should_coerce ?
325 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
327 . $attr->_inline_check_constraint($value_name)
328 . $attr->_inline_store($inv, $value_name)
329 . $attr->_inline_trigger($inv, $value_name)
331 my $sub = eval $code;
332 confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
336 sub generate_reader_method {
338 my $attr_name = $self->slots;
340 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
342 '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
343 . 'unless exists $_[0]->{$attr_name};'
345 . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
347 my $sub = eval $code;
348 confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
352 sub install_accessors {
354 $self->SUPER::install_accessors(@_);
356 if ($self->has_handles) {
359 # Here we canonicalize the 'handles' option
360 # this will sort out any details and always
361 # return an hash of methods which we want
362 # to delagate to, see that method for details
363 my %handles = $self->_canonicalize_handles();
365 # find the name of the accessor for this attribute
366 my $accessor_name = $self->reader || $self->accessor;
367 (defined $accessor_name)
368 || confess "You cannot install delegation without a reader or accessor for the attribute";
370 # make sure we handle HASH accessors correctly
371 ($accessor_name) = keys %{$accessor_name}
372 if ref($accessor_name) eq 'HASH';
374 # install the delegation ...
375 my $associated_class = $self->associated_class;
376 foreach my $handle (keys %handles) {
377 my $method_to_call = $handles{$handle};
379 (!$associated_class->has_method($handle))
380 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
382 if ((reftype($method_to_call) || '') eq 'CODE') {
383 $associated_class->add_method($handle => $method_to_call);
386 $associated_class->add_method($handle => sub {
387 ((shift)->$accessor_name())->$method_to_call(@_);
396 # private methods to help delegation ...
398 sub _canonicalize_handles {
400 my $handles = $self->handles;
401 if (ref($handles) eq 'HASH') {
404 elsif (ref($handles) eq 'ARRAY') {
405 return map { $_ => $_ } @{$handles};
407 elsif (ref($handles) eq 'Regexp') {
408 ($self->has_type_constraint)
409 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
410 return map { ($_ => $_) }
411 grep { $handles } $self->_get_delegate_method_list;
413 elsif (ref($handles) eq 'CODE') {
414 return $handles->($self, $self->_find_delegate_metaclass);
417 confess "Unable to canonicalize the 'handles' option with $handles";
421 sub _find_delegate_metaclass {
423 if (my $class = $self->_isa_metadata) {
424 # if the class does have
425 # a meta method, use it
426 return $class->meta if $class->can('meta');
427 # otherwise we might be
428 # dealing with a non-Moose
429 # class, and need to make
431 return Moose::Meta::Class->initialize($class);
433 elsif (my $role = $self->_does_metadata) {
434 # our role will always have
439 confess "Cannot find delegate metaclass for attribute " . $self->name;
443 sub _get_delegate_method_list {
445 my $meta = $self->_find_delegate_metaclass;
446 if ($meta->isa('Class::MOP::Class')) {
447 return map { $_->{name} }
448 grep { $_->{class} ne 'Moose::Object' }
449 $meta->compute_all_applicable_methods;
451 elsif ($meta->isa('Moose::Meta::Role')) {
452 return $meta->get_method_list;
455 confess "Unable to recognize the delegate metaclass '$meta'";
467 Moose::Meta::Attribute - The Moose attribute metaclass
471 This is a subclass of L<Class::MOP::Attribute> with Moose specific
474 For the most part, the only time you will ever encounter an
475 instance of this class is if you are doing some serious deep
476 introspection. To really understand this class, you need to refer
477 to the L<Class::MOP::Attribute> documentation.
481 =head2 Overridden methods
483 These methods override methods in L<Class::MOP::Attribute> and add
484 Moose specific features. You can safely assume though that they
485 will behave just as L<Class::MOP::Attribute> does.
491 =item B<clone_and_inherit_options>
493 =item B<initialize_instance_slot>
495 =item B<generate_accessor_method>
497 =item B<generate_writer_method>
499 =item B<generate_reader_method>
501 =item B<install_accessors>
505 =head2 Additional Moose features
507 Moose attributes support type-contstraint checking, weak reference
508 creation and type coercion.
512 =item B<has_type_constraint>
514 Returns true if this meta-attribute has a type constraint.
516 =item B<type_constraint>
518 A read-only accessor for this meta-attribute's type constraint. For
519 more information on what you can do with this, see the documentation
520 for L<Moose::Meta::TypeConstraint>.
524 Returns true if this meta-attribute performs delegation.
528 This returns the value which was passed into the handles option.
532 Returns true if this meta-attribute produces a weak reference.
536 Returns true if this meta-attribute is required to have a value.
540 Returns true if this meta-attribute should be initialized lazily.
542 NOTE: lazy attributes, B<must> have a C<default> field set.
544 =item B<should_coerce>
546 Returns true if this meta-attribute should perform type coercion.
548 =item B<should_auto_deref>
550 Returns true if this meta-attribute should perform automatic
553 NOTE: This can only be done for attributes whose type constraint is
554 either I<ArrayRef> or I<HashRef>.
558 Returns true if this meta-attribute has a trigger set.
562 This is a CODE reference which will be executed every time the
563 value of an attribute is assigned. The CODE ref will get two values,
564 the invocant and the new value. This can be used to handle I<basic>
565 bi-directional relations.
571 All complex software has bugs lurking in it, and this module is no
572 exception. If you find a bug please either email me, or add the bug
577 Stevan Little E<lt>stevan@iinteractive.comE<gt>
579 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
581 =head1 COPYRIGHT AND LICENSE
583 Copyright 2006 by Infinity Interactive, Inc.
585 L<http://www.iinteractive.com>
587 This library is free software; you can redistribute it and/or modify
588 it under the same terms as Perl itself.