2 package Moose::Meta::Attribute;
8 use Class::Load qw(is_class_loaded load_class);
9 use Scalar::Util 'blessed', 'weaken';
10 use List::MoreUtils 'any';
14 use Moose::Deprecated;
15 use Moose::Meta::Method::Accessor;
16 use Moose::Meta::Method::Delegation;
18 use Moose::Util::TypeConstraints ();
19 use Class::MOP::MiniTrait;
21 use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
23 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
25 __PACKAGE__->meta->add_attribute('traits' => (
26 reader => 'applied_traits',
27 predicate => 'has_applied_traits',
28 Class::MOP::_definition_context(),
31 # we need to have a ->does method in here to
32 # more easily support traits, and the introspection
33 # of those traits. We extend the does check to look
34 # for metatrait aliases.
36 my ($self, $role_name) = @_;
38 Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
40 return 0 if !defined($name); # failed to load class
41 return $self->Moose::Object::does($name);
46 require Moose::Meta::Class;
47 ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
52 my $inv = $self->_error_thrower;
53 unshift @_, "message" if @_ % 2 == 1;
54 unshift @_, attr => $self if ref $self;
56 my $handler = $inv->can("throw_error"); # to avoid incrementing depth by 1
60 sub _inline_throw_error {
61 my ( $self, $msg, $args ) = @_;
63 my $inv = $self->_error_thrower;
65 $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error');
68 my $class = $self->associated_class;
70 my $class_name = B::perlstring($class->name);
71 my $attr_name = B::perlstring($self->name);
72 $args = 'attr => Class::MOP::class_of(' . $class_name . ')'
73 . '->find_attribute_by_name(' . $attr_name . '), '
74 . (defined $args ? $args : '');
77 return $inv->_inline_throw_error($msg, $args)
81 my ($class, $name, %options) = @_;
82 $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
84 delete $options{__hack_no_process_options};
89 map { $_->init_arg() }
90 $class->meta()->get_all_attributes()
93 my @bad = sort grep { ! $attrs{$_} } keys %options;
97 my $s = @bad > 1 ? 's' : '';
98 my $list = join "', '", @bad;
100 my $package = $options{definition_context}{package};
101 my $context = $options{definition_context}{context}
102 || 'attribute constructor';
103 my $type = $options{definition_context}{type} || 'class';
106 if (defined($package)) {
108 $location .= "$type " if $type;
109 $location .= $package;
112 Carp::cluck "Found unknown argument$s '$list' in the $context for '$name'$location";
115 return $class->SUPER::new($name, %options);
118 sub interpolate_class_and_new {
119 my ($class, $name, %args) = @_;
121 my ( $new_class, @traits ) = $class->interpolate_class(\%args);
123 $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
126 sub interpolate_class {
127 my ($class, $options) = @_;
129 $class = ref($class) || $class;
131 if ( my $metaclass_name = delete $options->{metaclass} ) {
132 my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
134 if ( $class ne $new_class ) {
135 if ( $new_class->can("interpolate_class") ) {
136 return $new_class->interpolate_class($options);
145 if (my $traits = $options->{traits}) {
147 my $has_foreign_options = 0;
149 while ($i < @$traits) {
150 my $trait = $traits->[$i++];
151 next if ref($trait); # options to a trait we discarded
153 $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
156 next if $class->does($trait);
158 push @traits, $trait;
161 if ($traits->[$i] && ref($traits->[$i])) {
162 $has_foreign_options = 1
163 if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] };
165 push @traits, $traits->[$i++];
171 superclasses => [ $class ],
172 roles => [ @traits ],
175 if ($has_foreign_options) {
176 $options{weaken} = 0;
182 my $anon_class = Moose::Meta::Class->create_anon_class(%options);
183 $class = $anon_class->name;
187 return ( wantarray ? ( $class, @traits ) : $class );
192 # method-generating options shouldn't be overridden
193 sub illegal_options_for_inheritance {
194 qw(reader writer accessor clearer predicate)
198 # This method *must* be able to handle
199 # Class::MOP::Attribute instances as
200 # well. Yes, I know that is wrong, but
201 # apparently we didn't realize it was
202 # doing that and now we have some code
203 # which is dependent on it. The real
204 # solution of course is to push this
205 # feature back up into Class::MOP::Attribute
206 # but I not right now, I am too lazy.
207 # However if you are reading this and
208 # looking for something to do,.. please
211 sub clone_and_inherit_options {
212 my ($self, %options) = @_;
215 # we may want to extends a Class::MOP::Attribute
216 # in which case we need to be able to use the
217 # core set of legal options that have always
218 # been here. But we allows Moose::Meta::Attribute
219 # instances to changes them.
221 my @illegal_options = $self->can('illegal_options_for_inheritance')
222 ? $self->illegal_options_for_inheritance
225 my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options;
226 (scalar @found_illegal_options == 0)
227 || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);
231 if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
232 $type_constraint = $options{isa};
235 $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}, { package_defined_in => $options{definition_context}->{package} });
236 (defined $type_constraint)
237 || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
240 $options{type_constraint} = $type_constraint;
243 if ($options{does}) {
245 if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
246 $type_constraint = $options{does};
249 $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}, { package_defined_in => $options{definition_context}->{package} });
250 (defined $type_constraint)
251 || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
254 $options{type_constraint} = $type_constraint;
258 # this doesn't apply to Class::MOP::Attributes,
259 # so we can ignore it for them.
261 if ($self->can('interpolate_class')) {
262 ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
265 my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
266 $options{traits} = \@all_traits if @all_traits;
269 # This method can be called on a CMOP::Attribute object, so we need to
270 # make sure we can call this method.
271 $self->_process_lazy_build_option( $self->name, \%options )
272 if $self->can('_process_lazy_build_option');
274 $self->clone(%options);
278 my ( $self, %params ) = @_;
280 my $class = delete $params{metaclass} || ref $self;
282 my ( @init, @non_init );
284 foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
285 push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
288 my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
290 my $name = delete $new_params{name};
292 my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
294 foreach my $attr ( @non_init ) {
295 $attr->set_value($clone, $attr->get_value($self));
301 sub _process_options {
302 my ( $class, $name, $options ) = @_;
304 $class->_process_is_option( $name, $options );
305 $class->_process_isa_option( $name, $options );
306 $class->_process_does_option( $name, $options );
307 $class->_process_coerce_option( $name, $options );
308 $class->_process_trigger_option( $name, $options );
309 $class->_process_auto_deref_option( $name, $options );
310 $class->_process_lazy_build_option( $name, $options );
311 $class->_process_lazy_option( $name, $options );
312 $class->_process_required_option( $name, $options );
315 sub _process_is_option {
316 my ( $class, $name, $options ) = @_;
318 return unless $options->{is};
320 ### -------------------------
321 ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before
322 ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
323 ## is => rw, accessor => _foo # turns into (accessor => _foo)
324 ## is => ro, accessor => _foo # error, accesor is rw
325 ### -------------------------
327 if ( $options->{is} eq 'ro' ) {
329 "Cannot define an accessor name on a read-only attribute, accessors are read/write",
331 if exists $options->{accessor};
332 $options->{reader} ||= $name;
334 elsif ( $options->{is} eq 'rw' ) {
335 if ( $options->{writer} ) {
336 $options->{reader} ||= $name;
339 $options->{accessor} ||= $name;
342 elsif ( $options->{is} eq 'bare' ) {
344 # do nothing, but don't complain (later) about missing methods
347 $class->throw_error( "I do not understand this option (is => "
349 . ") on attribute ($name)", data => $options->{is} );
353 sub _process_isa_option {
354 my ( $class, $name, $options ) = @_;
356 return unless exists $options->{isa};
358 if ( exists $options->{does} ) {
359 if ( try { $options->{isa}->can('does') } ) {
360 ( $options->{isa}->does( $options->{does} ) )
361 || $class->throw_error(
362 "Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)",
367 "Cannot have an isa option which cannot ->does() on attribute ($name)",
372 # allow for anon-subtypes here ...
373 if ( blessed( $options->{isa} )
374 && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) {
375 $options->{type_constraint} = $options->{isa};
378 $options->{type_constraint}
379 = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint(
381 { package_defined_in => $options->{definition_context}->{package} }
386 sub _process_does_option {
387 my ( $class, $name, $options ) = @_;
389 return unless exists $options->{does} && ! exists $options->{isa};
391 # allow for anon-subtypes here ...
392 if ( blessed( $options->{does} )
393 && $options->{does}->isa('Moose::Meta::TypeConstraint') ) {
394 $options->{type_constraint} = $options->{does};
397 $options->{type_constraint}
398 = Moose::Util::TypeConstraints::find_or_create_does_type_constraint(
400 { package_defined_in => $options->{definition_context}->{package} }
405 sub _process_coerce_option {
406 my ( $class, $name, $options ) = @_;
408 return unless $options->{coerce};
410 ( exists $options->{type_constraint} )
411 || $class->throw_error(
412 "You cannot have coercion without specifying a type constraint on attribute ($name)",
416 "You cannot have a weak reference to a coerced value on attribute ($name)",
418 if $options->{weak_ref};
420 unless ( $options->{type_constraint}->has_coercion ) {
421 my $type = $options->{type_constraint}->name;
423 Moose::Deprecated::deprecated(
424 feature => 'coerce without coercion',
426 "You cannot coerce an attribute ($name) unless its type ($type) has a coercion"
431 sub _process_trigger_option {
432 my ( $class, $name, $options ) = @_;
434 return unless exists $options->{trigger};
436 ( 'CODE' eq ref $options->{trigger} )
437 || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
440 sub _process_auto_deref_option {
441 my ( $class, $name, $options ) = @_;
443 return unless $options->{auto_deref};
445 ( exists $options->{type_constraint} )
446 || $class->throw_error(
447 "You cannot auto-dereference without specifying a type constraint on attribute ($name)",
450 ( $options->{type_constraint}->is_a_type_of('ArrayRef')
451 || $options->{type_constraint}->is_a_type_of('HashRef') )
452 || $class->throw_error(
453 "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)",
457 sub _process_lazy_build_option {
458 my ( $class, $name, $options ) = @_;
460 return unless $options->{lazy_build};
463 "You can not use lazy_build and default for the same attribute ($name)",
465 if exists $options->{default};
467 $options->{lazy} = 1;
468 $options->{builder} ||= "_build_${name}";
470 if ( $name =~ /^_/ ) {
471 $options->{clearer} ||= "_clear${name}";
472 $options->{predicate} ||= "_has${name}";
475 $options->{clearer} ||= "clear_${name}";
476 $options->{predicate} ||= "has_${name}";
480 sub _process_lazy_option {
481 my ( $class, $name, $options ) = @_;
483 return unless $options->{lazy};
485 ( exists $options->{default} || defined $options->{builder} )
486 || $class->throw_error(
487 "You cannot have a lazy attribute ($name) without specifying a default value for it",
491 sub _process_required_option {
492 my ( $class, $name, $options ) = @_;
497 ( !exists $options->{init_arg} || defined $options->{init_arg} )
498 || exists $options->{default}
499 || defined $options->{builder}
503 "You cannot have a required attribute ($name) without a default, builder, or an init_arg",
508 sub initialize_instance_slot {
509 my ($self, $meta_instance, $instance, $params) = @_;
510 my $init_arg = $self->init_arg();
511 # try to fetch the init arg from the %params ...
515 if ( defined($init_arg) and exists $params->{$init_arg}) {
516 $val = $params->{$init_arg};
520 # skip it if it's lazy
521 return if $self->is_lazy;
522 # and die if it's required and doesn't have a default value
523 $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
524 if $self->is_required && !$self->has_default && !$self->has_builder;
526 # if nothing was in the %params, we can use the
527 # attribute's default value (if it has one)
528 if ($self->has_default) {
529 $val = $self->default($instance);
532 elsif ($self->has_builder) {
533 $val = $self->_call_builder($instance);
538 return unless $value_is_set;
540 $val = $self->_coerce_and_verify( $val, $instance );
542 $self->set_initial_value($instance, $val);
544 if ( ref $val && $self->is_weak_ref ) {
545 $self->_weaken_value($instance);
550 my ( $self, $instance ) = @_;
552 my $builder = $self->builder();
554 return $instance->$builder()
555 if $instance->can( $self->builder );
557 $self->throw_error( blessed($instance)
558 . " does not support builder method '"
560 . "' for attribute '"
569 sub _make_initializer_writer_callback {
571 my ($meta_instance, $instance, $slot_name) = @_;
572 my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_);
574 $old_callback->($self->_coerce_and_verify($_[0], $instance));
579 my ($self, $instance, @args) = @_;
580 my $value = $args[0];
582 my $attr_name = quotemeta($self->name);
584 if ($self->is_required and not @args) {
585 $self->throw_error("Attribute ($attr_name) is required", object => $instance);
588 $value = $self->_coerce_and_verify( $value, $instance );
591 if ( $self->has_trigger && $self->has_value($instance) ) {
592 @old = $self->get_value($instance, 'for trigger');
595 $self->SUPER::set_value($instance, $value);
597 if ( ref $value && $self->is_weak_ref ) {
598 $self->_weaken_value($instance);
601 if ($self->has_trigger) {
602 $self->trigger->($instance, $value, @old);
606 sub _inline_set_value {
608 my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_;
612 $tc ||= '$type_constraint';
613 $coercion ||= '$type_coercion';
614 $message ||= '$type_message';
617 if ($self->_writer_value_needs_copy) {
618 push @code, $self->_inline_copy_value($value, $copy);
622 # constructors already handle required checks
623 push @code, $self->_inline_check_required
624 unless $for_constructor;
626 push @code, $self->_inline_tc_code($value, $tc, $coercion, $message);
628 # constructors do triggers all at once at the end
629 push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
630 unless $for_constructor;
633 $self->SUPER::_inline_set_value($instance, $value),
634 $self->_inline_weaken_value($instance, $value),
637 # constructors do triggers all at once at the end
638 push @code, $self->_inline_trigger($instance, $value, $old)
639 unless $for_constructor;
644 sub _writer_value_needs_copy {
646 return $self->should_coerce;
649 sub _inline_copy_value {
651 my ($value, $copy) = @_;
653 return 'my ' . $copy . ' = ' . $value . ';'
656 sub _inline_check_required {
659 return unless $self->is_required;
661 my $attr_name = quotemeta($self->name);
665 $self->_inline_throw_error(
666 '"Attribute (' . $attr_name . ') is required"'
672 sub _inline_tc_code {
674 my ($value, $tc, $coercion, $message, $is_lazy) = @_;
676 $self->_inline_check_coercion(
677 $value, $tc, $coercion, $is_lazy,
679 $self->_inline_check_constraint(
680 $value, $tc, $message, $is_lazy,
685 sub _inline_check_coercion {
687 my ($value, $tc, $coercion) = @_;
689 return unless $self->should_coerce && $self->type_constraint->has_coercion;
691 if ( $self->type_constraint->can_be_inlined ) {
693 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
694 $value . ' = ' . $coercion . '->(' . $value . ');',
700 'if (!' . $tc . '->(' . $value . ')) {',
701 $value . ' = ' . $coercion . '->(' . $value . ');',
707 sub _inline_check_constraint {
709 my ($value, $tc, $message) = @_;
711 return unless $self->has_type_constraint;
713 my $attr_name = quotemeta($self->name);
715 if ( $self->type_constraint->can_be_inlined ) {
717 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
718 $self->_inline_throw_error(
719 '"Attribute (' . $attr_name . ') does not pass the type '
720 . 'constraint because: " . '
721 . 'do { local $_ = ' . $value . '; '
722 . $message . '->(' . $value . ')'
731 'if (!' . $tc . '->(' . $value . ')) {',
732 $self->_inline_throw_error(
733 '"Attribute (' . $attr_name . ') does not pass the type '
734 . 'constraint because: " . '
735 . 'do { local $_ = ' . $value . '; '
736 . $message . '->(' . $value . ')'
745 sub _inline_get_old_value_for_trigger {
747 my ($instance, $old) = @_;
749 return unless $self->has_trigger;
752 'my ' . $old . ' = ' . $self->_inline_instance_has($instance),
753 '? ' . $self->_inline_instance_get($instance),
758 sub _inline_weaken_value {
760 my ($instance, $value) = @_;
762 return unless $self->is_weak_ref;
764 my $mi = $self->associated_class->get_meta_instance;
766 $mi->inline_weaken_slot_value($instance, $self->name),
767 'if ref ' . $value . ';',
771 sub _inline_trigger {
773 my ($instance, $value, $old) = @_;
775 return unless $self->has_trigger;
777 return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
780 sub _eval_environment {
785 $env->{'$trigger'} = \($self->trigger)
786 if $self->has_trigger;
787 $env->{'$attr_default'} = \($self->default)
788 if $self->has_default;
790 if ($self->has_type_constraint) {
791 my $tc_obj = $self->type_constraint;
793 $env->{'$type_constraint'} = \(
794 $tc_obj->_compiled_type_constraint
795 ) unless $tc_obj->can_be_inlined;
796 # these two could probably get inlined versions too
797 $env->{'$type_coercion'} = \(
798 $tc_obj->coercion->_compiled_type_coercion
799 ) if $tc_obj->has_coercion;
800 $env->{'$type_message'} = \(
801 $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message
804 $env = { %$env, %{ $tc_obj->inline_environment } };
808 $env->{'$attr'} = \$self
809 if $self->has_initializer && $self->is_lazy;
810 # pretty sure this is only going to be closed over if you use a custom
811 # error class at this point, but we should still get rid of this
813 $env->{'$meta'} = \($self->associated_class);
819 my ( $self, $instance ) = @_;
821 my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
824 $meta_instance->weaken_slot_value( $instance, $self->name );
828 my ($self, $instance, $for_trigger) = @_;
830 if ($self->is_lazy) {
831 unless ($self->has_value($instance)) {
833 if ($self->has_default) {
834 $value = $self->default($instance);
835 } elsif ( $self->has_builder ) {
836 $value = $self->_call_builder($instance);
839 $value = $self->_coerce_and_verify( $value, $instance );
841 $self->set_initial_value($instance, $value);
843 if ( ref $value && $self->is_weak_ref ) {
844 $self->_weaken_value($instance);
849 if ( $self->should_auto_deref && ! $for_trigger ) {
851 my $type_constraint = $self->type_constraint;
853 if ($type_constraint->is_a_type_of('ArrayRef')) {
854 my $rv = $self->SUPER::get_value($instance);
855 return unless defined $rv;
856 return wantarray ? @{ $rv } : $rv;
858 elsif ($type_constraint->is_a_type_of('HashRef')) {
859 my $rv = $self->SUPER::get_value($instance);
860 return unless defined $rv;
861 return wantarray ? %{ $rv } : $rv;
864 $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
870 return $self->SUPER::get_value($instance);
874 sub _inline_get_value {
876 my ($instance, $tc, $coercion, $message) = @_;
878 my $slot_access = $self->_inline_instance_get($instance);
879 $tc ||= '$type_constraint';
880 $coercion ||= '$type_coercion';
881 $message ||= '$type_message';
884 $self->_inline_check_lazy($instance, $tc, $coercion, $message),
885 $self->_inline_return_auto_deref($slot_access),
889 sub _inline_check_lazy {
891 my ($instance, $tc, $coercion, $message) = @_;
893 return unless $self->is_lazy;
895 my $slot_exists = $self->_inline_instance_has($instance);
898 'if (!' . $slot_exists . ') {',
899 $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'),
904 sub _inline_init_from_default {
906 my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_;
908 if (!($self->has_default || $self->has_builder)) {
910 'You cannot have a lazy attribute '
911 . '(' . $self->name . ') '
912 . 'without specifying a default value for it',
918 $self->_inline_generate_default($instance, $default),
919 # intentionally not using _inline_tc_code, since that can be overridden
920 # to do things like possibly only do member tc checks, which isn't
921 # appropriate for checking the result of a default
922 $self->has_type_constraint
923 ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy),
924 $self->_inline_check_constraint($default, $tc, $message, $for_lazy))
926 $self->_inline_init_slot($instance, $default),
927 $self->_inline_weaken_value($instance, $default),
931 sub _inline_generate_default {
933 my ($instance, $default) = @_;
935 if ($self->has_default) {
936 my $source = 'my ' . $default . ' = $attr_default';
937 $source .= '->(' . $instance . ')'
938 if $self->is_default_a_coderef;
939 return $source . ';';
941 elsif ($self->has_builder) {
942 my $builder = B::perlstring($self->builder);
943 my $builder_str = quotemeta($self->builder);
944 my $attr_name_str = quotemeta($self->name);
946 'my ' . $default . ';',
947 'if (my $builder = ' . $instance . '->can(' . $builder . ')) {',
948 $default . ' = ' . $instance . '->$builder;',
951 'my $class = ref(' . $instance . ') || ' . $instance . ';',
952 $self->_inline_throw_error(
953 '"$class does not support builder method '
954 . '\'' . $builder_str . '\' for attribute '
955 . '\'' . $attr_name_str . '\'"'
962 "Can't generate a default for " . $self->name
963 . " since no default or builder was specified"
968 sub _inline_init_slot {
970 my ($inv, $value) = @_;
972 if ($self->has_initializer) {
973 return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
976 return $self->_inline_instance_set($inv, $value) . ';';
980 sub _inline_return_auto_deref {
983 return 'return ' . $self->_auto_deref(@_) . ';';
988 my ($ref_value) = @_;
990 return $ref_value unless $self->should_auto_deref;
992 my $type_constraint = $self->type_constraint;
995 if ($type_constraint->is_a_type_of('ArrayRef')) {
998 elsif ($type_constraint->is_a_type_of('HashRef')) {
1003 'Can not auto de-reference the type constraint \''
1004 . $type_constraint->name
1006 type_constraint => $type_constraint,
1011 . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
1012 . ': (' . $ref_value . ')';
1015 ## installing accessors
1017 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
1019 sub install_accessors {
1021 $self->SUPER::install_accessors(@_);
1022 $self->install_delegation if $self->has_handles;
1026 sub _check_associated_methods {
1029 @{ $self->associated_methods }
1030 || ($self->_is_metadata || '') eq 'bare'
1033 'Attribute (' . $self->name . ') of class '
1034 . $self->associated_class->name
1035 . ' has no associated methods'
1036 . ' (did you mean to provide an "is" argument?)'
1042 sub _process_accessors {
1044 my ($type, $accessor, $generate_as_inline_methods) = @_;
1046 $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH';
1047 my $method = $self->associated_class->get_method($accessor);
1050 && $method->isa('Class::MOP::Method::Accessor')
1051 && $method->associated_attribute->name ne $self->name ) {
1053 my $other_attr_name = $method->associated_attribute->name;
1054 my $name = $self->name;
1057 "You are overwriting an accessor ($accessor) for the $other_attr_name attribute"
1058 . " with a new accessor method for the $name attribute" );
1063 && !$method->is_stub
1064 && !$method->isa('Class::MOP::Method::Accessor')
1065 && ( !$self->definition_context
1066 || $method->package_name eq $self->definition_context->{package} )
1070 "You are overwriting a locally defined method ($accessor) with "
1074 if ( !$self->associated_class->has_method($accessor)
1075 && $self->associated_class->has_package_symbol( '&' . $accessor ) ) {
1078 "You are overwriting a locally defined function ($accessor) with "
1082 $self->SUPER::_process_accessors(@_);
1085 sub remove_accessors {
1087 $self->SUPER::remove_accessors(@_);
1088 $self->remove_delegation if $self->has_handles;
1092 sub install_delegation {
1096 # Here we canonicalize the 'handles' option
1097 # this will sort out any details and always
1098 # return an hash of methods which we want
1099 # to delagate to, see that method for details
1100 my %handles = $self->_canonicalize_handles;
1103 # install the delegation ...
1104 my $associated_class = $self->associated_class;
1105 foreach my $handle (sort keys %handles) {
1106 my $method_to_call = $handles{$handle};
1107 my $class_name = $associated_class->name;
1108 my $name = "${class_name}::${handle}";
1110 if ( my $method = $associated_class->get_method($handle) ) {
1112 "You cannot overwrite a locally defined method ($handle) with a delegation",
1113 method_name => $handle
1114 ) unless $method->is_stub;
1118 # handles is not allowed to delegate
1119 # any of these methods, as they will
1120 # override the ones in your class, which
1121 # is almost certainly not what you want.
1123 # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
1124 #cluck("Not delegating method '$handle' because it is a core method") and
1125 next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
1127 my $method = $self->_make_delegation_method($handle, $method_to_call);
1129 $self->associated_class->add_method($method->name, $method);
1130 $self->associate_method($method);
1134 sub remove_delegation {
1136 my %handles = $self->_canonicalize_handles;
1137 my $associated_class = $self->associated_class;
1138 foreach my $handle (keys %handles) {
1139 next unless any { $handle eq $_ }
1141 @{ $self->associated_methods };
1142 $self->associated_class->remove_method($handle);
1146 # private methods to help delegation ...
1148 sub _canonicalize_handles {
1150 my $handles = $self->handles;
1151 if (my $handle_type = ref($handles)) {
1152 if ($handle_type eq 'HASH') {
1155 elsif ($handle_type eq 'ARRAY') {
1156 return map { $_ => $_ } @{$handles};
1158 elsif ($handle_type eq 'Regexp') {
1159 ($self->has_type_constraint)
1160 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
1161 return map { ($_ => $_) }
1162 grep { /$handles/ } $self->_get_delegate_method_list;
1164 elsif ($handle_type eq 'CODE') {
1165 return $handles->($self, $self->_find_delegate_metaclass);
1167 elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
1168 return map { $_ => $_ } @{ $handles->methods };
1170 elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
1171 $handles = $handles->role;
1174 $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
1178 load_class($handles);
1179 my $role_meta = Class::MOP::class_of($handles);
1181 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
1182 || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
1184 return map { $_ => $_ }
1186 grep { !$_->isa('Class::MOP::Method::Meta') } (
1187 $role_meta->_get_local_methods,
1188 $role_meta->get_required_method_list,
1192 sub _get_delegate_method_list {
1194 my $meta = $self->_find_delegate_metaclass;
1195 if ($meta->isa('Class::MOP::Class')) {
1196 return map { $_->name } # NOTE: !never! delegate &meta
1197 grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
1198 $meta->get_all_methods;
1200 elsif ($meta->isa('Moose::Meta::Role')) {
1201 return $meta->get_method_list;
1204 $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
1208 sub _find_delegate_metaclass {
1210 if (my $class = $self->_isa_metadata) {
1211 unless ( is_class_loaded($class) ) {
1214 'The %s attribute is trying to delegate to a class which has not been loaded - %s',
1219 # we might be dealing with a non-Moose class,
1220 # and need to make our own metaclass. if there's
1221 # already a metaclass, it will be returned
1222 return Class::MOP::Class->initialize($class);
1224 elsif (my $role = $self->_does_metadata) {
1225 unless ( is_class_loaded($class) ) {
1228 'The %s attribute is trying to delegate to a role which has not been loaded - %s',
1234 return Class::MOP::class_of($role);
1237 $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
1241 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
1243 sub _make_delegation_method {
1244 my ( $self, $handle_name, $method_to_call ) = @_;
1246 my @curried_arguments;
1248 ($method_to_call, @curried_arguments) = @$method_to_call
1249 if 'ARRAY' eq ref($method_to_call);
1251 return $self->delegation_metaclass->new(
1252 name => $handle_name,
1253 package_name => $self->associated_class->name,
1255 delegate_to_method => $method_to_call,
1256 curried_arguments => \@curried_arguments,
1260 sub _coerce_and_verify {
1263 my $instance = shift;
1265 return $val unless $self->has_type_constraint;
1267 $val = $self->type_constraint->coerce($val)
1268 if $self->should_coerce && $self->type_constraint->has_coercion;
1270 $self->verify_against_type_constraint($val, instance => $instance);
1275 sub verify_against_type_constraint {
1279 return 1 if !$self->has_type_constraint;
1281 my $type_constraint = $self->type_constraint;
1283 $type_constraint->check($val)
1284 || $self->throw_error("Attribute ("
1286 . ") does not pass the type constraint because: "
1287 . $type_constraint->get_message($val), data => $val, @_);
1290 package Moose::Meta::Attribute::Custom::Moose;
1291 sub register_implementation { 'Moose::Meta::Attribute' }
1295 # ABSTRACT: The Moose attribute metaclass
1303 This class is a subclass of L<Class::MOP::Attribute> that provides
1304 additional Moose-specific functionality.
1306 To really understand this class, you will need to start with the
1307 L<Class::MOP::Attribute> documentation. This class can be understood
1308 as a set of additional features on top of the basic feature provided
1309 by that parent class.
1313 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
1317 Many of the documented below override methods in
1318 L<Class::MOP::Attribute> and add Moose specific features.
1324 =item B<< Moose::Meta::Attribute->new($name, %options) >>
1326 This method overrides the L<Class::MOP::Attribute> constructor.
1328 Many of the options below are described in more detail in the
1329 L<Moose::Manual::Attributes> document.
1331 It adds the following options to the constructor:
1335 =item * is => 'ro', 'rw', 'bare'
1337 This provides a shorthand for specifying the C<reader>, C<writer>, or
1338 C<accessor> names. If the attribute is read-only ('ro') then it will
1339 have a C<reader> method with the same attribute as the name.
1341 If it is read-write ('rw') then it will have an C<accessor> method
1342 with the same name. If you provide an explicit C<writer> for a
1343 read-write attribute, then you will have a C<reader> with the same
1344 name as the attribute, and a C<writer> with the name you provided.
1346 Use 'bare' when you are deliberately not installing any methods
1347 (accessor, reader, etc.) associated with this attribute; otherwise,
1348 Moose will issue a deprecation warning when this attribute is added to a
1351 =item * isa => $type
1353 This option accepts a type. The type can be a string, which should be
1354 a type name. If the type name is unknown, it is assumed to be a class
1357 This option can also accept a L<Moose::Meta::TypeConstraint> object.
1359 If you I<also> provide a C<does> option, then your C<isa> option must
1360 be a class name, and that class must do the role specified with
1363 =item * does => $role
1365 This is short-hand for saying that the attribute's type must be an
1366 object which does the named role.
1368 =item * coerce => $bool
1370 This option is only valid for objects with a type constraint
1371 (C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
1372 this attribute is set.
1374 You can make both this and the C<weak_ref> option true.
1376 =item * trigger => $sub
1378 This option accepts a subroutine reference, which will be called after
1379 the attribute is set.
1381 =item * required => $bool
1383 An attribute which is required must be provided to the constructor. An
1384 attribute which is required can also have a C<default> or C<builder>,
1385 which will satisfy its required-ness.
1387 A required attribute must have a C<default>, C<builder> or a
1388 non-C<undef> C<init_arg>
1390 =item * lazy => $bool
1392 A lazy attribute must have a C<default> or C<builder>. When an
1393 attribute is lazy, the default value will not be calculated until the
1396 =item * weak_ref => $bool
1398 If this is true, the attribute's value will be stored as a weak
1401 =item * auto_deref => $bool
1403 If this is true, then the reader will dereference the value when it is
1404 called. The attribute must have a type constraint which defines the
1405 attribute as an array or hash reference.
1407 =item * lazy_build => $bool
1409 Setting this to true makes the attribute lazy and provides a number of
1417 is equivalent to this:
1422 builder => '_build_size',
1423 clearer => 'clear_size',
1424 predicate => 'has_size',
1428 If your attribute name starts with an underscore (C<_>), then the clearer
1429 and predicate will as well:
1441 builder => '_build__size',
1442 clearer => '_clear_size',
1443 predicate => '_has_size',
1446 Note the doubled underscore in the builder name. Internally, Moose
1447 simply prepends the attribute name with "_build_" to come up with the
1450 =item * documentation
1452 An arbitrary string that can be retrieved later by calling C<<
1453 $attr->documentation >>.
1457 =item B<< $attr->clone(%options) >>
1459 This creates a new attribute based on attribute being cloned. You must
1460 supply a C<name> option to provide a new name for the attribute.
1462 The C<%options> can only specify options handled by
1463 L<Class::MOP::Attribute>.
1467 =head2 Value management
1471 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
1473 This method is used internally to initialize the attribute's slot in
1474 the object C<$instance>.
1476 This overrides the L<Class::MOP::Attribute> method to handle lazy
1477 attributes, weak references, and type constraints.
1483 eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
1488 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
1490 Before setting the value, a check is made on the type constraint of
1491 the attribute, if it has one, to see if the value passes it. If the
1492 value fails to pass, the set operation dies.
1494 Any coercion to convert values is done before checking the type constraint.
1496 To check a value against a type constraint before setting it, fetch the
1497 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
1498 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
1499 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Company_Subtypes>
1504 =head2 Attribute Accessor generation
1508 =item B<< $attr->install_accessors >>
1510 This method overrides the parent to also install delegation methods.
1512 If, after installing all methods, the attribute object has no associated
1513 methods, it throws an error unless C<< is => 'bare' >> was passed to the
1514 attribute constructor. (Trying to add an attribute that has no associated
1515 methods is almost always an error.)
1517 =item B<< $attr->remove_accessors >>
1519 This method overrides the parent to also remove delegation methods.
1521 =item B<< $attr->inline_set($instance_var, $value_var) >>
1523 This method return a code snippet suitable for inlining the relevant
1524 operation. It expect strings containing variable names to be used in the
1525 inlining, like C<'$self'> or C<'$_[1]'>.
1527 =item B<< $attr->install_delegation >>
1529 This method adds its delegation methods to the attribute's associated
1530 class, if it has any to add.
1532 =item B<< $attr->remove_delegation >>
1534 This method remove its delegation methods from the attribute's
1537 =item B<< $attr->accessor_metaclass >>
1539 Returns the accessor metaclass name, which defaults to
1540 L<Moose::Meta::Method::Accessor>.
1542 =item B<< $attr->delegation_metaclass >>
1544 Returns the delegation metaclass name, which defaults to
1545 L<Moose::Meta::Method::Delegation>.
1549 =head2 Additional Moose features
1551 These methods are not found in the superclass. They support features
1556 =item B<< $attr->does($role) >>
1558 This indicates whether the I<attribute itself> does the given
1559 role. The role can be given as a full class name, or as a resolvable
1562 Note that this checks the attribute itself, not its type constraint,
1563 so it is checking the attribute's metaclass and any traits applied to
1566 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1568 This is an alternate constructor that handles the C<metaclass> and
1571 Effectively, this method is a factory that finds or creates the
1572 appropriate class for the given C<metaclass> and/or C<traits>.
1574 Once it has the appropriate class, it will call C<< $class->new($name,
1575 %options) >> on that class.
1577 =item B<< $attr->clone_and_inherit_options(%options) >>
1579 This method supports the C<has '+foo'> feature. It does various bits
1580 of processing on the supplied C<%options> before ultimately calling
1581 the C<clone> method.
1583 One of its main tasks is to make sure that the C<%options> provided
1584 does not include the options returned by the
1585 C<illegal_options_for_inheritance> method.
1587 =item B<< $attr->illegal_options_for_inheritance >>
1589 This returns a blacklist of options that can not be overridden in a
1590 subclass's attribute definition.
1592 This exists to allow a custom metaclass to change or add to the list
1593 of options which can not be changed.
1595 =item B<< $attr->type_constraint >>
1597 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1600 =item B<< $attr->has_type_constraint >>
1602 Returns true if this attribute has a type constraint.
1604 =item B<< $attr->verify_against_type_constraint($value) >>
1606 Given a value, this method returns true if the value is valid for the
1607 attribute's type constraint. If the value is not valid, it throws an
1610 =item B<< $attr->handles >>
1612 This returns the value of the C<handles> option passed to the
1615 =item B<< $attr->has_handles >>
1617 Returns true if this attribute performs delegation.
1619 =item B<< $attr->is_weak_ref >>
1621 Returns true if this attribute stores its value as a weak reference.
1623 =item B<< $attr->is_required >>
1625 Returns true if this attribute is required to have a value.
1627 =item B<< $attr->is_lazy >>
1629 Returns true if this attribute is lazy.
1631 =item B<< $attr->is_lazy_build >>
1633 Returns true if the C<lazy_build> option was true when passed to the
1636 =item B<< $attr->should_coerce >>
1638 Returns true if the C<coerce> option passed to the constructor was
1641 =item B<< $attr->should_auto_deref >>
1643 Returns true if the C<auto_deref> option passed to the constructor was
1646 =item B<< $attr->trigger >>
1648 This is the subroutine reference that was in the C<trigger> option
1649 passed to the constructor, if any.
1651 =item B<< $attr->has_trigger >>
1653 Returns true if this attribute has a trigger set.
1655 =item B<< $attr->documentation >>
1657 Returns the value that was in the C<documentation> option passed to
1658 the constructor, if any.
1660 =item B<< $attr->has_documentation >>
1662 Returns true if this attribute has any documentation.
1664 =item B<< $attr->applied_traits >>
1666 This returns an array reference of all the traits which were applied
1667 to this attribute. If none were applied, this returns C<undef>.
1669 =item B<< $attr->has_applied_traits >>
1671 Returns true if this attribute has any traits applied.
1677 See L<Moose/BUGS> for details on reporting bugs.