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);
86 map { $_->init_arg() }
87 $class->meta()->get_all_attributes()
90 my @bad = sort grep { ! $attrs{$_} } keys %options;
94 Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
97 return $class->SUPER::new($name, %options);
100 sub interpolate_class_and_new {
101 my ($class, $name, %args) = @_;
103 my ( $new_class, @traits ) = $class->interpolate_class(\%args);
105 $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
108 sub interpolate_class {
109 my ($class, $options) = @_;
111 $class = ref($class) || $class;
113 if ( my $metaclass_name = delete $options->{metaclass} ) {
114 my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
116 if ( $class ne $new_class ) {
117 if ( $new_class->can("interpolate_class") ) {
118 return $new_class->interpolate_class($options);
127 if (my $traits = $options->{traits}) {
129 my $has_foreign_options = 0;
131 while ($i < @$traits) {
132 my $trait = $traits->[$i++];
133 next if ref($trait); # options to a trait we discarded
135 $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
138 next if $class->does($trait);
140 push @traits, $trait;
143 if ($traits->[$i] && ref($traits->[$i])) {
144 $has_foreign_options = 1
145 if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] };
147 push @traits, $traits->[$i++];
153 superclasses => [ $class ],
154 roles => [ @traits ],
157 if ($has_foreign_options) {
158 $options{weaken} = 0;
164 my $anon_class = Moose::Meta::Class->create_anon_class(%options);
165 $class = $anon_class->name;
169 return ( wantarray ? ( $class, @traits ) : $class );
174 # method-generating options shouldn't be overridden
175 sub illegal_options_for_inheritance {
176 qw(reader writer accessor clearer predicate)
180 # This method *must* be able to handle
181 # Class::MOP::Attribute instances as
182 # well. Yes, I know that is wrong, but
183 # apparently we didn't realize it was
184 # doing that and now we have some code
185 # which is dependent on it. The real
186 # solution of course is to push this
187 # feature back up into Class::MOP::Attribute
188 # but I not right now, I am too lazy.
189 # However if you are reading this and
190 # looking for something to do,.. please
193 sub clone_and_inherit_options {
194 my ($self, %options) = @_;
197 # we may want to extends a Class::MOP::Attribute
198 # in which case we need to be able to use the
199 # core set of legal options that have always
200 # been here. But we allows Moose::Meta::Attribute
201 # instances to changes them.
203 my @illegal_options = $self->can('illegal_options_for_inheritance')
204 ? $self->illegal_options_for_inheritance
207 my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options;
208 (scalar @found_illegal_options == 0)
209 || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);
213 # this doesn't apply to Class::MOP::Attributes,
214 # so we can ignore it for them.
216 if ($self->can('interpolate_class')) {
217 ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
220 my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
221 $options{traits} = \@all_traits if @all_traits;
225 $self->clone(%options);
229 my ( $self, %params ) = @_;
231 my $class = delete $params{metaclass} || ref $self;
233 my ( @init, @non_init );
235 foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
236 push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
239 my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
241 my $name = delete $new_params{name};
243 my $clone = $class->new($name, %new_params);
245 foreach my $attr ( @non_init ) {
246 $attr->set_value($clone, $attr->get_value($self));
252 sub _process_options {
253 my ( $class, $name, $options ) = @_;
255 $class->_process_isa_option( $name, $options );
256 $class->_process_does_option( $name, $options );
257 $class->_process_is_option( $name, $options );
258 $class->_process_coerce_option( $name, $options );
259 $class->_process_trigger_option( $name, $options );
260 $class->_process_auto_deref_option( $name, $options );
261 $class->_process_lazy_build_option( $name, $options );
262 $class->_process_lazy_option( $name, $options );
263 $class->_process_required_option( $name, $options );
267 sub _process_is_option {
268 my ( $class, $name, $options ) = @_;
270 return unless $options->{is};
272 ### -------------------------
273 ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before
274 ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
275 ## is => rw, accessor => _foo # turns into (accessor => _foo)
276 ## is => ro, accessor => _foo # error, accesor is rw
277 ### -------------------------
279 if ( $options->{is} eq 'ro' ) {
281 "Cannot define an accessor name on a read-only attribute, accessors are read/write",
283 if exists $options->{accessor};
284 $options->{reader} ||= $name;
286 elsif ( $options->{is} eq 'rw' ) {
287 if ( $options->{writer} ) {
288 $options->{reader} ||= $name;
291 $options->{accessor} ||= $name;
294 elsif ( $options->{is} eq 'bare' ) {
296 # do nothing, but don't complain (later) about missing methods
299 $class->throw_error( "I do not understand this option (is => "
301 . ") on attribute ($name)", data => $options->{is} );
305 sub _process_isa_option {
306 my ( $class, $name, $options ) = @_;
308 return unless exists $options->{isa};
310 if ( exists $options->{does} ) {
311 if ( try { $options->{isa}->can('does') } ) {
312 ( $options->{isa}->does( $options->{does} ) )
313 || $class->throw_error(
314 "Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)",
319 "Cannot have an isa option which cannot ->does() on attribute ($name)",
324 # allow for anon-subtypes here ...
325 if ( blessed( $options->{isa} )
326 && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) {
327 $options->{type_constraint} = $options->{isa};
330 $options->{type_constraint}
331 = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint(
333 { package_defined_in => $options->{definition_context}->{package} }
338 sub _process_does_option {
339 my ( $class, $name, $options ) = @_;
341 return unless exists $options->{does} && ! exists $options->{isa};
343 # allow for anon-subtypes here ...
344 if ( blessed( $options->{does} )
345 && $options->{does}->isa('Moose::Meta::TypeConstraint') ) {
346 $options->{type_constraint} = $options->{does};
349 $options->{type_constraint}
350 = Moose::Util::TypeConstraints::find_or_create_does_type_constraint(
352 { package_defined_in => $options->{definition_context}->{package} }
357 sub _process_coerce_option {
358 my ( $class, $name, $options ) = @_;
360 return unless $options->{coerce};
362 ( exists $options->{type_constraint} )
363 || $class->throw_error(
364 "You cannot have coercion without specifying a type constraint on attribute ($name)",
368 "You cannot have a weak reference to a coerced value on attribute ($name)",
370 if $options->{weak_ref};
372 unless ( $options->{type_constraint}->has_coercion ) {
373 my $type = $options->{type_constraint}->name;
375 Moose::Deprecated::deprecated(
376 feature => 'coerce without coercion',
378 "You cannot coerce an attribute ($name) unless its type ($type) has a coercion"
383 sub _process_trigger_option {
384 my ( $class, $name, $options ) = @_;
386 return unless exists $options->{trigger};
388 ( 'CODE' eq ref $options->{trigger} )
389 || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
392 sub _process_auto_deref_option {
393 my ( $class, $name, $options ) = @_;
395 return unless $options->{auto_deref};
397 ( exists $options->{type_constraint} )
398 || $class->throw_error(
399 "You cannot auto-dereference without specifying a type constraint on attribute ($name)",
402 ( $options->{type_constraint}->is_a_type_of('ArrayRef')
403 || $options->{type_constraint}->is_a_type_of('HashRef') )
404 || $class->throw_error(
405 "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)",
409 sub _process_lazy_build_option {
410 my ( $class, $name, $options ) = @_;
412 return unless $options->{lazy_build};
415 "You can not use lazy_build and default for the same attribute ($name)",
417 if exists $options->{default};
419 $options->{lazy} = 1;
420 $options->{builder} ||= "_build_${name}";
422 if ( $name =~ /^_/ ) {
423 $options->{clearer} ||= "_clear${name}";
424 $options->{predicate} ||= "_has${name}";
427 $options->{clearer} ||= "clear_${name}";
428 $options->{predicate} ||= "has_${name}";
432 sub _process_lazy_option {
433 my ( $class, $name, $options ) = @_;
435 return unless $options->{lazy};
437 ( exists $options->{default} || defined $options->{builder} )
438 || $class->throw_error(
439 "You cannot have a lazy attribute ($name) without specifying a default value for it",
443 sub _process_required_option {
444 my ( $class, $name, $options ) = @_;
449 ( !exists $options->{init_arg} || defined $options->{init_arg} )
450 || exists $options->{default}
451 || defined $options->{builder}
455 "You cannot have a required attribute ($name) without a default, builder, or an init_arg",
460 sub initialize_instance_slot {
461 my ($self, $meta_instance, $instance, $params) = @_;
462 my $init_arg = $self->init_arg();
463 # try to fetch the init arg from the %params ...
467 if ( defined($init_arg) and exists $params->{$init_arg}) {
468 $val = $params->{$init_arg};
472 # skip it if it's lazy
473 return if $self->is_lazy;
474 # and die if it's required and doesn't have a default value
475 $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
476 if $self->is_required && !$self->has_default && !$self->has_builder;
478 # if nothing was in the %params, we can use the
479 # attribute's default value (if it has one)
480 if ($self->has_default) {
481 $val = $self->default($instance);
484 elsif ($self->has_builder) {
485 $val = $self->_call_builder($instance);
490 return unless $value_is_set;
492 $val = $self->_coerce_and_verify( $val, $instance );
494 $self->set_initial_value($instance, $val);
496 if ( ref $val && $self->is_weak_ref ) {
497 $self->_weaken_value($instance);
502 my ( $self, $instance ) = @_;
504 my $builder = $self->builder();
506 return $instance->$builder()
507 if $instance->can( $self->builder );
509 $self->throw_error( blessed($instance)
510 . " does not support builder method '"
512 . "' for attribute '"
521 sub _make_initializer_writer_callback {
523 my ($meta_instance, $instance, $slot_name) = @_;
524 my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_);
526 $old_callback->($self->_coerce_and_verify($_[0], $instance));
531 my ($self, $instance, @args) = @_;
532 my $value = $args[0];
534 my $attr_name = quotemeta($self->name);
536 if ($self->is_required and not @args) {
537 $self->throw_error("Attribute ($attr_name) is required", object => $instance);
540 $value = $self->_coerce_and_verify( $value, $instance );
543 if ( $self->has_trigger && $self->has_value($instance) ) {
544 @old = $self->get_value($instance, 'for trigger');
547 $self->SUPER::set_value($instance, $value);
549 if ( ref $value && $self->is_weak_ref ) {
550 $self->_weaken_value($instance);
553 if ($self->has_trigger) {
554 $self->trigger->($instance, $value, @old);
558 sub _inline_set_value {
560 my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_;
564 $tc ||= '$type_constraint';
565 $coercion ||= '$type_coercion';
566 $message ||= '$type_message';
569 if ($self->_writer_value_needs_copy) {
570 push @code, $self->_inline_copy_value($value, $copy);
574 # constructors already handle required checks
575 push @code, $self->_inline_check_required
576 unless $for_constructor;
578 push @code, $self->_inline_tc_code($value, $tc, $coercion, $message);
580 # constructors do triggers all at once at the end
581 push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
582 unless $for_constructor;
585 $self->SUPER::_inline_set_value($instance, $value),
586 $self->_inline_weaken_value($instance, $value),
589 # constructors do triggers all at once at the end
590 push @code, $self->_inline_trigger($instance, $value, $old)
591 unless $for_constructor;
596 sub _writer_value_needs_copy {
598 return $self->should_coerce;
601 sub _inline_copy_value {
603 my ($value, $copy) = @_;
605 return 'my ' . $copy . ' = ' . $value . ';'
608 sub _inline_check_required {
611 return unless $self->is_required;
613 my $attr_name = quotemeta($self->name);
617 $self->_inline_throw_error(
618 '"Attribute (' . $attr_name . ') is required, so cannot '
619 . 'be set to undef"' # defined $_[1] is not good enough
625 sub _inline_tc_code {
627 my ($value, $tc, $coercion, $message, $is_lazy) = @_;
629 $self->_inline_check_coercion(
630 $value, $tc, $coercion, $is_lazy,
632 $self->_inline_check_constraint(
633 $value, $tc, $message, $is_lazy,
638 sub _inline_check_coercion {
640 my ($value, $tc, $coercion) = @_;
642 return unless $self->should_coerce && $self->type_constraint->has_coercion;
644 if ( $self->type_constraint->can_be_inlined ) {
646 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
647 $value . ' = ' . $coercion . '->(' . $value . ');',
653 'if (!' . $tc . '->(' . $value . ')) {',
654 $value . ' = ' . $coercion . '->(' . $value . ');',
660 sub _inline_check_constraint {
662 my ($value, $tc, $message) = @_;
664 return unless $self->has_type_constraint;
666 my $attr_name = quotemeta($self->name);
668 if ( $self->type_constraint->can_be_inlined ) {
670 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
671 $self->_inline_throw_error(
672 '"Attribute (' . $attr_name . ') does not pass the type '
673 . 'constraint because: " . '
674 . 'do { local $_ = ' . $value . '; '
675 . $message . '->(' . $value . ')'
684 'if (!' . $tc . '->(' . $value . ')) {',
685 $self->_inline_throw_error(
686 '"Attribute (' . $attr_name . ') does not pass the type '
687 . 'constraint because: " . '
688 . 'do { local $_ = ' . $value . '; '
689 . $message . '->(' . $value . ')'
698 sub _inline_get_old_value_for_trigger {
700 my ($instance, $old) = @_;
702 return unless $self->has_trigger;
705 'my ' . $old . ' = ' . $self->_inline_instance_has($instance),
706 '? ' . $self->_inline_instance_get($instance),
711 sub _inline_weaken_value {
713 my ($instance, $value) = @_;
715 return unless $self->is_weak_ref;
717 my $mi = $self->associated_class->get_meta_instance;
719 $mi->inline_weaken_slot_value($instance, $self->name, $value),
720 'if ref ' . $value . ';',
724 sub _inline_trigger {
726 my ($instance, $value, $old) = @_;
728 return unless $self->has_trigger;
730 return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
733 sub _eval_environment {
738 $env->{'$trigger'} = \($self->trigger)
739 if $self->has_trigger;
740 $env->{'$attr_default'} = \($self->default)
741 if $self->has_default;
743 if ($self->has_type_constraint) {
744 my $tc_obj = $self->type_constraint;
746 $env->{'$type_constraint'} = \(
747 $tc_obj->_compiled_type_constraint
748 ) unless $tc_obj->can_be_inlined;
749 # these two could probably get inlined versions too
750 $env->{'$type_coercion'} = \(
751 $tc_obj->coercion->_compiled_type_coercion
752 ) if $tc_obj->has_coercion;
753 $env->{'$type_message'} = \(
754 $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message
757 $env = { %$env, %{ $tc_obj->inline_environment } };
761 $env->{'$attr'} = \$self
762 if $self->has_initializer && $self->is_lazy;
763 # pretty sure this is only going to be closed over if you use a custom
764 # error class at this point, but we should still get rid of this
766 $env->{'$meta'} = \($self->associated_class);
772 my ( $self, $instance ) = @_;
774 my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
777 $meta_instance->weaken_slot_value( $instance, $self->name );
781 my ($self, $instance, $for_trigger) = @_;
783 if ($self->is_lazy) {
784 unless ($self->has_value($instance)) {
786 if ($self->has_default) {
787 $value = $self->default($instance);
788 } elsif ( $self->has_builder ) {
789 $value = $self->_call_builder($instance);
792 $value = $self->_coerce_and_verify( $value, $instance );
794 $self->set_initial_value($instance, $value);
798 if ( $self->should_auto_deref && ! $for_trigger ) {
800 my $type_constraint = $self->type_constraint;
802 if ($type_constraint->is_a_type_of('ArrayRef')) {
803 my $rv = $self->SUPER::get_value($instance);
804 return unless defined $rv;
805 return wantarray ? @{ $rv } : $rv;
807 elsif ($type_constraint->is_a_type_of('HashRef')) {
808 my $rv = $self->SUPER::get_value($instance);
809 return unless defined $rv;
810 return wantarray ? %{ $rv } : $rv;
813 $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
819 return $self->SUPER::get_value($instance);
823 sub _inline_get_value {
825 my ($instance, $tc, $coercion, $message) = @_;
827 my $slot_access = $self->_inline_instance_get($instance);
828 $tc ||= '$type_constraint';
829 $coercion ||= '$type_coercion';
830 $message ||= '$type_message';
833 $self->_inline_check_lazy($instance, $tc, $coercion, $message),
834 $self->_inline_return_auto_deref($slot_access),
838 sub _inline_check_lazy {
840 my ($instance, $tc, $coercion, $message) = @_;
842 return unless $self->is_lazy;
844 my $slot_exists = $self->_inline_instance_has($instance);
847 'if (!' . $slot_exists . ') {',
848 $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'),
853 sub _inline_init_from_default {
855 my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_;
857 if (!($self->has_default || $self->has_builder)) {
859 'You cannot have a lazy attribute '
860 . '(' . $self->name . ') '
861 . 'without specifying a default value for it',
867 $self->_inline_generate_default($instance, $default),
868 # intentionally not using _inline_tc_code, since that can be overridden
869 # to do things like possibly only do member tc checks, which isn't
870 # appropriate for checking the result of a default
871 $self->has_type_constraint
872 ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy),
873 $self->_inline_check_constraint($default, $tc, $message, $for_lazy))
875 $self->_inline_init_slot($instance, $default),
879 sub _inline_generate_default {
881 my ($instance, $default) = @_;
883 if ($self->has_default) {
884 my $source = 'my ' . $default . ' = $attr_default';
885 $source .= '->(' . $instance . ')'
886 if $self->is_default_a_coderef;
887 return $source . ';';
889 elsif ($self->has_builder) {
890 my $builder = B::perlstring($self->builder);
891 my $builder_str = quotemeta($self->builder);
892 my $attr_name_str = quotemeta($self->name);
894 'my ' . $default . ';',
895 'if (my $builder = ' . $instance . '->can(' . $builder . ')) {',
896 $default . ' = ' . $instance . '->$builder;',
899 'my $class = ref(' . $instance . ') || ' . $instance . ';',
900 $self->_inline_throw_error(
901 '"$class does not support builder method '
902 . '\'' . $builder_str . '\' for attribute '
903 . '\'' . $attr_name_str . '\'"'
910 "Can't generate a default for " . $self->name
911 . " since no default or builder was specified"
916 sub _inline_init_slot {
918 my ($inv, $value) = @_;
920 if ($self->has_initializer) {
921 return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
924 return $self->_inline_instance_set($inv, $value) . ';';
928 sub _inline_return_auto_deref {
931 return 'return ' . $self->_auto_deref(@_) . ';';
936 my ($ref_value) = @_;
938 return $ref_value unless $self->should_auto_deref;
940 my $type_constraint = $self->type_constraint;
943 if ($type_constraint->is_a_type_of('ArrayRef')) {
946 elsif ($type_constraint->is_a_type_of('HashRef')) {
951 'Can not auto de-reference the type constraint \''
952 . $type_constraint->name
954 type_constraint => $type_constraint,
959 . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
960 . ': (' . $ref_value . ')';
963 ## installing accessors
965 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
967 sub install_accessors {
969 $self->SUPER::install_accessors(@_);
970 $self->install_delegation if $self->has_handles;
974 sub _check_associated_methods {
977 @{ $self->associated_methods }
978 || ($self->_is_metadata || '') eq 'bare'
981 'Attribute (' . $self->name . ') of class '
982 . $self->associated_class->name
983 . ' has no associated methods'
984 . ' (did you mean to provide an "is" argument?)'
990 sub _process_accessors {
992 my ($type, $accessor, $generate_as_inline_methods) = @_;
994 $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH';
995 my $method = $self->associated_class->get_method($accessor);
998 && $method->isa('Class::MOP::Method::Accessor')
999 && $method->associated_attribute->name ne $self->name ) {
1001 my $other_attr_name = $method->associated_attribute->name;
1002 my $name = $self->name;
1005 "You are overwriting an accessor ($accessor) for the $other_attr_name attribute"
1006 . " with a new accessor method for the $name attribute" );
1011 && !$method->is_stub
1012 && !$method->isa('Class::MOP::Method::Accessor')
1013 && ( !$self->definition_context
1014 || $method->package_name eq $self->definition_context->{package} )
1018 "You are overwriting a locally defined method ($accessor) with "
1022 if ( !$self->associated_class->has_method($accessor)
1023 && $self->associated_class->has_package_symbol( '&' . $accessor ) ) {
1026 "You are overwriting a locally defined function ($accessor) with "
1030 $self->SUPER::_process_accessors(@_);
1033 sub remove_accessors {
1035 $self->SUPER::remove_accessors(@_);
1036 $self->remove_delegation if $self->has_handles;
1040 sub install_delegation {
1044 # Here we canonicalize the 'handles' option
1045 # this will sort out any details and always
1046 # return an hash of methods which we want
1047 # to delagate to, see that method for details
1048 my %handles = $self->_canonicalize_handles;
1051 # install the delegation ...
1052 my $associated_class = $self->associated_class;
1053 foreach my $handle (sort keys %handles) {
1054 my $method_to_call = $handles{$handle};
1055 my $class_name = $associated_class->name;
1056 my $name = "${class_name}::${handle}";
1058 if ( my $method = $associated_class->get_method($handle) ) {
1060 "You cannot overwrite a locally defined method ($handle) with a delegation",
1061 method_name => $handle
1062 ) unless $method->is_stub;
1066 # handles is not allowed to delegate
1067 # any of these methods, as they will
1068 # override the ones in your class, which
1069 # is almost certainly not what you want.
1071 # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
1072 #cluck("Not delegating method '$handle' because it is a core method") and
1073 next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
1075 my $method = $self->_make_delegation_method($handle, $method_to_call);
1077 $self->associated_class->add_method($method->name, $method);
1078 $self->associate_method($method);
1082 sub remove_delegation {
1084 my %handles = $self->_canonicalize_handles;
1085 my $associated_class = $self->associated_class;
1086 foreach my $handle (keys %handles) {
1087 next unless any { $handle eq $_ }
1089 @{ $self->associated_methods };
1090 $self->associated_class->remove_method($handle);
1094 # private methods to help delegation ...
1096 sub _canonicalize_handles {
1098 my $handles = $self->handles;
1099 if (my $handle_type = ref($handles)) {
1100 if ($handle_type eq 'HASH') {
1103 elsif ($handle_type eq 'ARRAY') {
1104 return map { $_ => $_ } @{$handles};
1106 elsif ($handle_type eq 'Regexp') {
1107 ($self->has_type_constraint)
1108 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
1109 return map { ($_ => $_) }
1110 grep { /$handles/ } $self->_get_delegate_method_list;
1112 elsif ($handle_type eq 'CODE') {
1113 return $handles->($self, $self->_find_delegate_metaclass);
1115 elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
1116 return map { $_ => $_ } @{ $handles->methods };
1118 elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
1119 $handles = $handles->role;
1122 $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
1126 load_class($handles);
1127 my $role_meta = Class::MOP::class_of($handles);
1129 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
1130 || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
1132 return map { $_ => $_ }
1134 grep { !$_->isa('Class::MOP::Method::Meta') } (
1135 $role_meta->_get_local_methods,
1136 $role_meta->get_required_method_list,
1140 sub _get_delegate_method_list {
1142 my $meta = $self->_find_delegate_metaclass;
1143 if ($meta->isa('Class::MOP::Class')) {
1144 return map { $_->name } # NOTE: !never! delegate &meta
1145 grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
1146 $meta->get_all_methods;
1148 elsif ($meta->isa('Moose::Meta::Role')) {
1149 return $meta->get_method_list;
1152 $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
1156 sub _find_delegate_metaclass {
1158 if (my $class = $self->_isa_metadata) {
1159 unless ( is_class_loaded($class) ) {
1162 'The %s attribute is trying to delegate to a class which has not been loaded - %s',
1167 # we might be dealing with a non-Moose class,
1168 # and need to make our own metaclass. if there's
1169 # already a metaclass, it will be returned
1170 return Class::MOP::Class->initialize($class);
1172 elsif (my $role = $self->_does_metadata) {
1173 unless ( is_class_loaded($class) ) {
1176 'The %s attribute is trying to delegate to a role which has not been loaded - %s',
1182 return Class::MOP::class_of($role);
1185 $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
1189 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
1191 sub _make_delegation_method {
1192 my ( $self, $handle_name, $method_to_call ) = @_;
1194 my @curried_arguments;
1196 ($method_to_call, @curried_arguments) = @$method_to_call
1197 if 'ARRAY' eq ref($method_to_call);
1199 return $self->delegation_metaclass->new(
1200 name => $handle_name,
1201 package_name => $self->associated_class->name,
1203 delegate_to_method => $method_to_call,
1204 curried_arguments => \@curried_arguments,
1208 sub _coerce_and_verify {
1211 my $instance = shift;
1213 return $val unless $self->has_type_constraint;
1215 $val = $self->type_constraint->coerce($val)
1216 if $self->should_coerce && $self->type_constraint->has_coercion;
1218 $self->verify_against_type_constraint($val, instance => $instance);
1223 sub verify_against_type_constraint {
1227 return 1 if !$self->has_type_constraint;
1229 my $type_constraint = $self->type_constraint;
1231 $type_constraint->check($val)
1232 || $self->throw_error("Attribute ("
1234 . ") does not pass the type constraint because: "
1235 . $type_constraint->get_message($val), data => $val, @_);
1238 package Moose::Meta::Attribute::Custom::Moose;
1239 sub register_implementation { 'Moose::Meta::Attribute' }
1243 # ABSTRACT: The Moose attribute metaclass
1251 This class is a subclass of L<Class::MOP::Attribute> that provides
1252 additional Moose-specific functionality.
1254 To really understand this class, you will need to start with the
1255 L<Class::MOP::Attribute> documentation. This class can be understood
1256 as a set of additional features on top of the basic feature provided
1257 by that parent class.
1261 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
1265 Many of the documented below override methods in
1266 L<Class::MOP::Attribute> and add Moose specific features.
1272 =item B<< Moose::Meta::Attribute->new(%options) >>
1274 This method overrides the L<Class::MOP::Attribute> constructor.
1276 Many of the options below are described in more detail in the
1277 L<Moose::Manual::Attributes> document.
1279 It adds the following options to the constructor:
1283 =item * is => 'ro', 'rw', 'bare'
1285 This provides a shorthand for specifying the C<reader>, C<writer>, or
1286 C<accessor> names. If the attribute is read-only ('ro') then it will
1287 have a C<reader> method with the same attribute as the name.
1289 If it is read-write ('rw') then it will have an C<accessor> method
1290 with the same name. If you provide an explicit C<writer> for a
1291 read-write attribute, then you will have a C<reader> with the same
1292 name as the attribute, and a C<writer> with the name you provided.
1294 Use 'bare' when you are deliberately not installing any methods
1295 (accessor, reader, etc.) associated with this attribute; otherwise,
1296 Moose will issue a deprecation warning when this attribute is added to a
1299 =item * isa => $type
1301 This option accepts a type. The type can be a string, which should be
1302 a type name. If the type name is unknown, it is assumed to be a class
1305 This option can also accept a L<Moose::Meta::TypeConstraint> object.
1307 If you I<also> provide a C<does> option, then your C<isa> option must
1308 be a class name, and that class must do the role specified with
1311 =item * does => $role
1313 This is short-hand for saying that the attribute's type must be an
1314 object which does the named role.
1316 =item * coerce => $bool
1318 This option is only valid for objects with a type constraint
1319 (C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
1320 this attribute is set.
1322 You can make both this and the C<weak_ref> option true.
1324 =item * trigger => $sub
1326 This option accepts a subroutine reference, which will be called after
1327 the attribute is set.
1329 =item * required => $bool
1331 An attribute which is required must be provided to the constructor. An
1332 attribute which is required can also have a C<default> or C<builder>,
1333 which will satisfy its required-ness.
1335 A required attribute must have a C<default>, C<builder> or a
1336 non-C<undef> C<init_arg>
1338 =item * lazy => $bool
1340 A lazy attribute must have a C<default> or C<builder>. When an
1341 attribute is lazy, the default value will not be calculated until the
1344 =item * weak_ref => $bool
1346 If this is true, the attribute's value will be stored as a weak
1349 =item * auto_deref => $bool
1351 If this is true, then the reader will dereference the value when it is
1352 called. The attribute must have a type constraint which defines the
1353 attribute as an array or hash reference.
1355 =item * lazy_build => $bool
1357 Setting this to true makes the attribute lazy and provides a number of
1365 is equivalent to this:
1370 builder => '_build_size',
1371 clearer => 'clear_size',
1372 predicate => 'has_size',
1376 If your attribute name starts with an underscore (C<_>), then the clearer
1377 and predicate will as well:
1389 builder => '_build__size',
1390 clearer => '_clear_size',
1391 predicate => '_has_size',
1394 Note the doubled underscore in the builder name. Internally, Moose
1395 simply prepends the attribute name with "_build_" to come up with the
1398 =item * documentation
1400 An arbitrary string that can be retrieved later by calling C<<
1401 $attr->documentation >>.
1405 =item B<< $attr->clone(%options) >>
1407 This creates a new attribute based on attribute being cloned. You must
1408 supply a C<name> option to provide a new name for the attribute.
1410 The C<%options> can only specify options handled by
1411 L<Class::MOP::Attribute>.
1415 =head2 Value management
1419 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
1421 This method is used internally to initialize the attribute's slot in
1422 the object C<$instance>.
1424 This overrides the L<Class::MOP::Attribute> method to handle lazy
1425 attributes, weak references, and type constraints.
1431 eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
1436 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
1438 Before setting the value, a check is made on the type constraint of
1439 the attribute, if it has one, to see if the value passes it. If the
1440 value fails to pass, the set operation dies with a L</throw_error>.
1442 Any coercion to convert values is done before checking the type constraint.
1444 To check a value against a type constraint before setting it, fetch the
1445 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
1446 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
1447 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
1452 =head2 Attribute Accessor generation
1456 =item B<< $attr->install_accessors >>
1458 This method overrides the parent to also install delegation methods.
1460 If, after installing all methods, the attribute object has no associated
1461 methods, it throws an error unless C<< is => 'bare' >> was passed to the
1462 attribute constructor. (Trying to add an attribute that has no associated
1463 methods is almost always an error.)
1465 =item B<< $attr->remove_accessors >>
1467 This method overrides the parent to also remove delegation methods.
1469 =item B<< $attr->inline_set($instance_var, $value_var) >>
1471 This method return a code snippet suitable for inlining the relevant
1472 operation. It expect strings containing variable names to be used in the
1473 inlining, like C<'$self'> or C<'$_[1]'>.
1475 =item B<< $attr->install_delegation >>
1477 This method adds its delegation methods to the attribute's associated
1478 class, if it has any to add.
1480 =item B<< $attr->remove_delegation >>
1482 This method remove its delegation methods from the attribute's
1485 =item B<< $attr->accessor_metaclass >>
1487 Returns the accessor metaclass name, which defaults to
1488 L<Moose::Meta::Method::Accessor>.
1490 =item B<< $attr->delegation_metaclass >>
1492 Returns the delegation metaclass name, which defaults to
1493 L<Moose::Meta::Method::Delegation>.
1497 =head2 Additional Moose features
1499 These methods are not found in the superclass. They support features
1504 =item B<< $attr->does($role) >>
1506 This indicates whether the I<attribute itself> does the given
1507 role. The role can be given as a full class name, or as a resolvable
1510 Note that this checks the attribute itself, not its type constraint,
1511 so it is checking the attribute's metaclass and any traits applied to
1514 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1516 This is an alternate constructor that handles the C<metaclass> and
1519 Effectively, this method is a factory that finds or creates the
1520 appropriate class for the given C<metaclass> and/or C<traits>.
1522 Once it has the appropriate class, it will call C<< $class->new($name,
1523 %options) >> on that class.
1525 =item B<< $attr->clone_and_inherit_options(%options) >>
1527 This method supports the C<has '+foo'> feature. It does various bits
1528 of processing on the supplied C<%options> before ultimately calling
1529 the C<clone> method.
1531 One of its main tasks is to make sure that the C<%options> provided
1532 does not include the options returned by the
1533 C<illegal_options_for_inheritance> method.
1535 =item B<< $attr->illegal_options_for_inheritance >>
1537 This returns a blacklist of options that can not be overridden in a
1538 subclass's attribute definition.
1540 This exists to allow a custom metaclass to change or add to the list
1541 of options which can not be changed.
1543 =item B<< $attr->type_constraint >>
1545 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1548 =item B<< $attr->has_type_constraint >>
1550 Returns true if this attribute has a type constraint.
1552 =item B<< $attr->verify_against_type_constraint($value) >>
1554 Given a value, this method returns true if the value is valid for the
1555 attribute's type constraint. If the value is not valid, it throws an
1558 =item B<< $attr->handles >>
1560 This returns the value of the C<handles> option passed to the
1563 =item B<< $attr->has_handles >>
1565 Returns true if this attribute performs delegation.
1567 =item B<< $attr->is_weak_ref >>
1569 Returns true if this attribute stores its value as a weak reference.
1571 =item B<< $attr->is_required >>
1573 Returns true if this attribute is required to have a value.
1575 =item B<< $attr->is_lazy >>
1577 Returns true if this attribute is lazy.
1579 =item B<< $attr->is_lazy_build >>
1581 Returns true if the C<lazy_build> option was true when passed to the
1584 =item B<< $attr->should_coerce >>
1586 Returns true if the C<coerce> option passed to the constructor was
1589 =item B<< $attr->should_auto_deref >>
1591 Returns true if the C<auto_deref> option passed to the constructor was
1594 =item B<< $attr->trigger >>
1596 This is the subroutine reference that was in the C<trigger> option
1597 passed to the constructor, if any.
1599 =item B<< $attr->has_trigger >>
1601 Returns true if this attribute has a trigger set.
1603 =item B<< $attr->documentation >>
1605 Returns the value that was in the C<documentation> option passed to
1606 the constructor, if any.
1608 =item B<< $attr->has_documentation >>
1610 Returns true if this attribute has any documentation.
1612 =item B<< $attr->applied_traits >>
1614 This returns an array reference of all the traits which were applied
1615 to this attribute. If none were applied, this returns C<undef>.
1617 =item B<< $attr->has_applied_traits >>
1619 Returns true if this attribute has any traits applied.
1625 See L<Moose/BUGS> for details on reporting bugs.