2 package Moose::Meta::Attribute;
7 use Scalar::Util 'blessed', 'weaken', 'reftype';
10 our $VERSION = '0.08';
12 use Moose::Meta::Method::Accessor;
13 use Moose::Util::TypeConstraints ();
15 use base 'Class::MOP::Attribute';
17 # options which are not directly used
18 # but we store them for metadata purposes
19 __PACKAGE__->meta->add_attribute('isa' => (reader => '_isa_metadata'));
20 __PACKAGE__->meta->add_attribute('does' => (reader => '_does_metadata'));
21 __PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata'));
23 # these are actual options for the attrs
24 __PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
25 __PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
26 __PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' ));
27 __PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
28 __PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
29 __PACKAGE__->meta->add_attribute('type_constraint' => (
30 reader => 'type_constraint',
31 predicate => 'has_type_constraint',
33 __PACKAGE__->meta->add_attribute('trigger' => (
35 predicate => 'has_trigger',
37 __PACKAGE__->meta->add_attribute('handles' => (
39 predicate => 'has_handles',
43 my ($class, $name, %options) = @_;
44 $class->_process_options($name, \%options);
45 return $class->SUPER::new($name, %options);
48 sub clone_and_inherit_options {
49 my ($self, %options) = @_;
50 # you can change default, required and coerce
52 foreach my $legal_option (qw(default coerce required)) {
53 if (exists $options{$legal_option}) {
54 $actual_options{$legal_option} = $options{$legal_option};
55 delete $options{$legal_option};
58 # isa can be changed, but only if the
59 # new type is a subtype
62 if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
63 $type_constraint = $options{isa};
66 $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
67 (defined $type_constraint)
68 || confess "Could not find the type constraint '" . $options{isa} . "'";
71 # check here to see if the new type
72 # is a subtype of the old one
73 ($type_constraint->is_subtype_of($self->type_constraint->name))
74 || confess "New type constraint setting must be a subtype of inherited one"
75 # iff we have a type constraint that is ...
76 if $self->has_type_constraint;
78 $actual_options{type_constraint} = $type_constraint;
81 (scalar keys %options == 0)
82 || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
83 $self->clone(%actual_options);
86 sub _process_options {
87 my ($class, $name, $options) = @_;
89 if (exists $options->{is}) {
90 if ($options->{is} eq 'ro') {
91 $options->{reader} = $name;
92 (!exists $options->{trigger})
93 || confess "Cannot have a trigger on a read-only attribute";
95 elsif ($options->{is} eq 'rw') {
96 $options->{accessor} = $name;
97 ((reftype($options->{trigger}) || '') eq 'CODE')
98 || confess "Trigger must be a CODE ref"
99 if exists $options->{trigger};
102 confess "I do not understand this option (is => " . $options->{is} . ")"
106 if (exists $options->{isa}) {
108 if (exists $options->{does}) {
109 if (eval { $options->{isa}->can('does') }) {
110 ($options->{isa}->does($options->{does}))
111 || confess "Cannot have an isa option and a does option if the isa does not do the does";
114 confess "Cannot have an isa option which cannot ->does()";
118 # allow for anon-subtypes here ...
119 if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
120 $options->{type_constraint} = $options->{isa};
124 if ($options->{isa} =~ /\|/) {
125 my @type_constraints = split /\s*\|\s*/ => $options->{isa};
126 $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
131 # otherwise assume it is a constraint
132 my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
133 # if the constraing it not found ....
134 unless (defined $constraint) {
135 # assume it is a foreign class, and make
136 # an anon constraint for it
137 $constraint = Moose::Util::TypeConstraints::subtype(
139 Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
142 $options->{type_constraint} = $constraint;
146 elsif (exists $options->{does}) {
147 # allow for anon-subtypes here ...
148 if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
149 $options->{type_constraint} = $options->{isa};
152 # otherwise assume it is a constraint
153 my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
154 # if the constraing it not found ....
155 unless (defined $constraint) {
156 # assume it is a foreign class, and make
157 # an anon constraint for it
158 $constraint = Moose::Util::TypeConstraints::subtype(
160 Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
163 $options->{type_constraint} = $constraint;
167 if (exists $options->{coerce} && $options->{coerce}) {
168 (exists $options->{type_constraint})
169 || confess "You cannot have coercion without specifying a type constraint";
170 confess "You cannot have a weak reference to a coerced value"
171 if $options->{weak_ref};
174 if (exists $options->{auto_deref} && $options->{auto_deref}) {
175 (exists $options->{type_constraint})
176 || confess "You cannot auto-dereference without specifying a type constraint";
177 ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
178 $options->{type_constraint}->is_a_type_of('HashRef'))
179 || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
182 if (exists $options->{lazy} && $options->{lazy}) {
183 (exists $options->{default})
184 || confess "You cannot have lazy attribute without specifying a default value for it";
188 sub initialize_instance_slot {
189 my ($self, $meta_instance, $instance, $params) = @_;
190 my $init_arg = $self->init_arg();
191 # try to fetch the init arg from the %params ...
194 if (exists $params->{$init_arg}) {
195 $val = $params->{$init_arg};
198 # skip it if it's lazy
199 return if $self->is_lazy;
200 # and die if it's required and doesn't have a default value
201 confess "Attribute (" . $self->name . ") is required"
202 if $self->is_required && !$self->has_default;
205 # if nothing was in the %params, we can use the
206 # attribute's default value (if it has one)
207 if (!defined $val && $self->has_default) {
208 $val = $self->default($instance);
211 if ($self->has_type_constraint) {
212 my $type_constraint = $self->type_constraint;
213 if ($self->should_coerce && $type_constraint->has_coercion) {
214 $val = $type_constraint->coerce($val);
216 (defined($type_constraint->check($val)))
217 || confess "Attribute (" .
219 ") does not pass the type constraint (" .
220 $type_constraint->name .
225 $meta_instance->set_slot_value($instance, $self->name, $val);
226 $meta_instance->weaken_slot_value($instance, $self->name)
227 if ref $val && $self->is_weak_ref;
233 my ($self, $instance, $value) = @_;
235 my $attr_name = $self->name;
237 if ($self->is_required) {
239 || confess "Attribute ($attr_name) is required, so cannot be set to undef";
242 if ($self->has_type_constraint) {
244 my $type_constraint = $self->type_constraint;
246 if ($self->should_coerce) {
247 $value = $type_constraint->coerce($value);
249 defined($type_constraint->_compiled_type_constraint->($value))
250 || confess "Attribute ($attr_name) does not pass the type constraint ("
251 . $type_constraint->name . ") with " . (defined($value) ? ("'" . $value . "'") : "undef")
255 my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
258 $meta_instance->set_slot_value($instance, $attr_name, $value);
260 if (ref $value && $self->is_weak_ref) {
261 $meta_instance->weaken_slot_value($instance, $attr_name);
264 if ($self->has_trigger) {
265 $self->trigger->($instance, $value, $self);
270 my ($self, $instance) = @_;
272 if ($self->is_lazy) {
273 unless ($self->has_value($instance)) {
274 if ($self->has_default) {
275 my $default = $self->default($instance);
276 $self->set_value($instance, $default);
279 $self->set_value($instance, undef);
284 if ($self->should_auto_deref) {
286 my $type_constraint = $self->type_constraint;
288 if ($type_constraint->is_a_type_of('ArrayRef')) {
289 my $rv = $self->SUPER::get_value($instance);
290 return unless defined $rv;
291 return wantarray ? @{ $rv } : $rv;
293 elsif ($type_constraint->is_a_type_of('HashRef')) {
294 my $rv = $self->SUPER::get_value($instance);
295 return unless defined $rv;
296 return wantarray ? %{ $rv } : $rv;
299 confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
305 return $self->SUPER::get_value($instance);
309 ## installing accessors
311 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
313 sub install_accessors {
315 $self->SUPER::install_accessors(@_);
317 if ($self->has_handles) {
320 # Here we canonicalize the 'handles' option
321 # this will sort out any details and always
322 # return an hash of methods which we want
323 # to delagate to, see that method for details
324 my %handles = $self->_canonicalize_handles();
326 # find the name of the accessor for this attribute
327 my $accessor_name = $self->reader || $self->accessor;
328 (defined $accessor_name)
329 || confess "You cannot install delegation without a reader or accessor for the attribute";
331 # make sure we handle HASH accessors correctly
332 ($accessor_name) = keys %{$accessor_name}
333 if ref($accessor_name) eq 'HASH';
335 # install the delegation ...
336 my $associated_class = $self->associated_class;
337 foreach my $handle (keys %handles) {
338 my $method_to_call = $handles{$handle};
340 (!$associated_class->has_method($handle))
341 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
343 if ((reftype($method_to_call) || '') eq 'CODE') {
344 $associated_class->add_method($handle => $method_to_call);
347 $associated_class->add_method($handle => sub {
349 # we should check for lack of
350 # a callable return value from
352 ((shift)->$accessor_name())->$method_to_call(@_);
361 # private methods to help delegation ...
363 sub _canonicalize_handles {
365 my $handles = $self->handles;
366 if (ref($handles) eq 'HASH') {
369 elsif (ref($handles) eq 'ARRAY') {
370 return map { $_ => $_ } @{$handles};
372 elsif (ref($handles) eq 'Regexp') {
373 ($self->has_type_constraint)
374 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
375 return map { ($_ => $_) }
376 grep { $handles } $self->_get_delegate_method_list;
378 elsif (ref($handles) eq 'CODE') {
379 return $handles->($self, $self->_find_delegate_metaclass);
382 confess "Unable to canonicalize the 'handles' option with $handles";
386 sub _find_delegate_metaclass {
388 if (my $class = $self->_isa_metadata) {
389 # if the class does have
390 # a meta method, use it
391 return $class->meta if $class->can('meta');
392 # otherwise we might be
393 # dealing with a non-Moose
394 # class, and need to make
396 return Moose::Meta::Class->initialize($class);
398 elsif (my $role = $self->_does_metadata) {
399 # our role will always have
404 confess "Cannot find delegate metaclass for attribute " . $self->name;
408 sub _get_delegate_method_list {
410 my $meta = $self->_find_delegate_metaclass;
411 if ($meta->isa('Class::MOP::Class')) {
412 return map { $_->{name} } # NOTE: !never! delegate &meta
413 grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
414 $meta->compute_all_applicable_methods;
416 elsif ($meta->isa('Moose::Meta::Role')) {
417 return $meta->get_method_list;
420 confess "Unable to recognize the delegate metaclass '$meta'";
432 Moose::Meta::Attribute - The Moose attribute metaclass
436 This is a subclass of L<Class::MOP::Attribute> with Moose specific
439 For the most part, the only time you will ever encounter an
440 instance of this class is if you are doing some serious deep
441 introspection. To really understand this class, you need to refer
442 to the L<Class::MOP::Attribute> documentation.
446 =head2 Overridden methods
448 These methods override methods in L<Class::MOP::Attribute> and add
449 Moose specific features. You can safely assume though that they
450 will behave just as L<Class::MOP::Attribute> does.
456 =item B<initialize_instance_slot>
458 =item B<install_accessors>
460 =item B<accessor_metaclass>
468 =head2 Additional Moose features
470 Moose attributes support type-constraint checking, weak reference
471 creation and type coercion.
475 =item B<clone_and_inherit_options>
477 This is to support the C<has '+foo'> feature, it clones an attribute
478 from a superclass and allows a very specific set of changes to be made
481 =item B<has_type_constraint>
483 Returns true if this meta-attribute has a type constraint.
485 =item B<type_constraint>
487 A read-only accessor for this meta-attribute's type constraint. For
488 more information on what you can do with this, see the documentation
489 for L<Moose::Meta::TypeConstraint>.
493 Returns true if this meta-attribute performs delegation.
497 This returns the value which was passed into the handles option.
501 Returns true if this meta-attribute produces a weak reference.
505 Returns true if this meta-attribute is required to have a value.
509 Returns true if this meta-attribute should be initialized lazily.
511 NOTE: lazy attributes, B<must> have a C<default> field set.
513 =item B<should_coerce>
515 Returns true if this meta-attribute should perform type coercion.
517 =item B<should_auto_deref>
519 Returns true if this meta-attribute should perform automatic
522 NOTE: This can only be done for attributes whose type constraint is
523 either I<ArrayRef> or I<HashRef>.
527 Returns true if this meta-attribute has a trigger set.
531 This is a CODE reference which will be executed every time the
532 value of an attribute is assigned. The CODE ref will get two values,
533 the invocant and the new value. This can be used to handle I<basic>
534 bi-directional relations.
540 All complex software has bugs lurking in it, and this module is no
541 exception. If you find a bug please either email me, or add the bug
546 Stevan Little E<lt>stevan@iinteractive.comE<gt>
548 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
550 =head1 COPYRIGHT AND LICENSE
552 Copyright 2006, 2007 by Infinity Interactive, Inc.
554 L<http://www.iinteractive.com>
556 This library is free software; you can redistribute it and/or modify
557 it under the same terms as Perl itself.