2 package Class::MOP::Attribute;
7 use Class::MOP::Method::Accessor;
10 use Scalar::Util 'blessed', 'weaken';
12 our $VERSION = '0.83';
13 $VERSION = eval $VERSION;
14 our $AUTHORITY = 'cpan:STEVAN';
16 use base 'Class::MOP::Object';
18 # NOTE: (meta-circularity)
19 # This method will be replaced in the
20 # boostrap section of Class::MOP, by
21 # a new version which uses the
22 # &Class::MOP::Class::construct_instance
23 # method to build an attribute meta-object
24 # which itself is described with attribute
26 # - Ain't meta-circularity grand? :)
28 my ( $class, @args ) = @_;
30 unshift @args, "name" if @args % 2 == 1;
33 my $name = $options{name};
35 (defined $name && $name)
36 || confess "You must provide a name for the attribute";
38 $options{init_arg} = $name
39 if not exists $options{init_arg};
40 if(exists $options{builder}){
41 confess("builder must be a defined scalar value which is a method name")
42 if ref $options{builder} || !(defined $options{builder});
43 confess("Setting both default and builder is not allowed.")
44 if exists $options{default};
46 (is_default_a_coderef(\%options))
47 || confess("References are not allowed as default values, you must ".
48 "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
49 if exists $options{default} && ref $options{default};
51 if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) {
52 confess("A required attribute must have either 'init_arg', 'builder', or 'default'");
55 $class->_new(\%options);
60 my $options = @_ == 1 ? $_[0] : {@_};
63 'name' => $options->{name},
64 'accessor' => $options->{accessor},
65 'reader' => $options->{reader},
66 'writer' => $options->{writer},
67 'predicate' => $options->{predicate},
68 'clearer' => $options->{clearer},
69 'builder' => $options->{builder},
70 'init_arg' => $options->{init_arg},
71 'default' => $options->{default},
72 'initializer' => $options->{initializer},
73 'definition_context' => $options->{definition_context},
74 # keep a weakened link to the
75 # class we are associated with
76 'associated_class' => undef,
77 # and a list of the methods
78 # associated with this attr
79 'associated_methods' => [],
80 # this let's us keep track of
81 # our order inside the associated
83 'insertion_order' => undef,
88 # this is a primative (and kludgy) clone operation
89 # for now, it will be replaced in the Class::MOP
90 # bootstrap with a proper one, however we know
91 # that this one will work fine for now.
96 || confess "Can only clone an instance";
97 return bless { %{$self}, %options } => ref($self);
100 sub initialize_instance_slot {
101 my ($self, $meta_instance, $instance, $params) = @_;
102 my $init_arg = $self->{'init_arg'};
104 # try to fetch the init arg from the %params ...
106 # if nothing was in the %params, we can use the
107 # attribute's default value (if it has one)
108 if(defined $init_arg and exists $params->{$init_arg}){
109 $self->_set_initial_slot_value(
112 $params->{$init_arg},
115 elsif (defined $self->{'default'}) {
116 $self->_set_initial_slot_value(
119 $self->default($instance),
122 elsif (defined( my $builder = $self->{'builder'})) {
123 if ($builder = $instance->can($builder)) {
124 $self->_set_initial_slot_value(
131 confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'");
136 sub _set_initial_slot_value {
137 my ($self, $meta_instance, $instance, $value) = @_;
139 my $slot_name = $self->name;
141 return $meta_instance->set_slot_value($instance, $slot_name, $value)
142 unless $self->has_initializer;
145 $meta_instance->set_slot_value($instance, $slot_name, $_[0]);
148 my $initializer = $self->initializer;
150 # most things will just want to set a value, so make it first arg
151 $instance->$initializer($value, $callback, $self);
155 # the next bunch of methods will get bootstrapped
156 # away in the Class::MOP bootstrapping section
158 sub associated_class { $_[0]->{'associated_class'} }
159 sub associated_methods { $_[0]->{'associated_methods'} }
161 sub has_accessor { defined($_[0]->{'accessor'}) }
162 sub has_reader { defined($_[0]->{'reader'}) }
163 sub has_writer { defined($_[0]->{'writer'}) }
164 sub has_predicate { defined($_[0]->{'predicate'}) }
165 sub has_clearer { defined($_[0]->{'clearer'}) }
166 sub has_builder { defined($_[0]->{'builder'}) }
167 sub has_init_arg { defined($_[0]->{'init_arg'}) }
168 sub has_default { defined($_[0]->{'default'}) }
169 sub has_initializer { defined($_[0]->{'initializer'}) }
170 sub has_insertion_order { defined($_[0]->{'insertion_order'}) }
172 sub accessor { $_[0]->{'accessor'} }
173 sub reader { $_[0]->{'reader'} }
174 sub writer { $_[0]->{'writer'} }
175 sub predicate { $_[0]->{'predicate'} }
176 sub clearer { $_[0]->{'clearer'} }
177 sub builder { $_[0]->{'builder'} }
178 sub init_arg { $_[0]->{'init_arg'} }
179 sub initializer { $_[0]->{'initializer'} }
180 sub definition_context { $_[0]->{'definition_context'} }
181 sub insertion_order { $_[0]->{'insertion_order'} }
183 # end bootstrapped away method section.
184 # (all methods below here are kept intact)
186 sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
187 sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
189 sub get_read_method {
191 my $reader = $self->reader || $self->accessor;
193 return $reader unless ref $reader;
195 my ($name) = %$reader;
199 sub get_write_method {
201 my $writer = $self->writer || $self->accessor;
203 return $writer unless ref $writer;
205 my ($name) = %$writer;
209 sub get_read_method_ref {
211 if ((my $reader = $self->get_read_method) && $self->associated_class) {
212 return $self->associated_class->get_method($reader);
215 my $code = sub { $self->get_value(@_) };
216 if (my $class = $self->associated_class) {
217 return $class->method_metaclass->wrap(
219 package_name => $class->name,
229 sub get_write_method_ref {
231 if ((my $writer = $self->get_write_method) && $self->associated_class) {
232 return $self->associated_class->get_method($writer);
235 my $code = sub { $self->set_value(@_) };
236 if (my $class = $self->associated_class) {
237 return $class->method_metaclass->wrap(
239 package_name => $class->name,
249 sub is_default_a_coderef {
250 ('CODE' eq ref($_[0]->{'default'}))
254 my ($self, $instance) = @_;
255 if (defined $instance && $self->is_default_a_coderef) {
256 # if the default is a CODE ref, then
257 # we pass in the instance and default
258 # can return a value based on that
259 # instance. Somewhat crude, but works.
260 return $self->{'default'}->($instance);
267 sub slots { (shift)->name }
271 sub attach_to_class {
272 my ($self, $class) = @_;
273 (blessed($class) && $class->isa('Class::MOP::Class'))
274 || confess "You must pass a Class::MOP::Class instance (or a subclass)";
275 weaken($self->{'associated_class'} = $class);
278 sub detach_from_class {
280 $self->{'associated_class'} = undef;
285 sub associate_method {
286 my ($self, $method) = @_;
287 push @{$self->{'associated_methods'}} => $method;
292 sub set_initial_value {
293 my ($self, $instance, $value) = @_;
294 $self->_set_initial_slot_value(
295 Class::MOP::Class->initialize(ref($instance))->get_meta_instance,
302 my ($self, $instance, $value) = @_;
304 Class::MOP::Class->initialize(ref($instance))
306 ->set_slot_value($instance, $self->name, $value);
310 my ($self, $instance) = @_;
312 Class::MOP::Class->initialize(ref($instance))
314 ->get_slot_value($instance, $self->name);
318 my ($self, $instance) = @_;
320 Class::MOP::Class->initialize(ref($instance))
322 ->is_slot_initialized($instance, $self->name);
326 my ($self, $instance) = @_;
328 Class::MOP::Class->initialize(ref($instance))
330 ->deinitialize_slot($instance, $self->name);
335 sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
337 sub process_accessors {
338 Carp::cluck('The process_accessors method has been made private.'
339 . " The public version is deprecated and will be removed in a future release.\n");
340 shift->_process_accessors(@_);
343 sub _process_accessors {
344 my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
348 if ( my $ctx = $self->definition_context ) {
349 $method_ctx = { %$ctx };
352 if (ref($accessor)) {
353 (ref($accessor) eq 'HASH')
354 || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
355 my ($name, $method) = %{$accessor};
356 $method = $self->accessor_metaclass->wrap(
358 package_name => $self->associated_class->name,
360 definition_context => $method_ctx,
362 $self->associate_method($method);
363 return ($name, $method);
366 my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
370 my $desc = "accessor $accessor";
371 if ( $accessor ne $self->name ) {
372 $desc .= " of attribute " . $self->name;
375 $method_ctx->{description} = $desc;
378 $method = $self->accessor_metaclass->new(
380 is_inline => $inline_me,
381 accessor_type => $type,
382 package_name => $self->associated_class->name,
384 definition_context => $method_ctx,
387 confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;
388 $self->associate_method($method);
389 return ($accessor, $method);
393 sub install_accessors {
396 my $class = $self->associated_class;
399 $self->_process_accessors('accessor' => $self->accessor(), $inline)
400 ) if $self->has_accessor();
403 $self->_process_accessors('reader' => $self->reader(), $inline)
404 ) if $self->has_reader();
407 $self->_process_accessors('writer' => $self->writer(), $inline)
408 ) if $self->has_writer();
411 $self->_process_accessors('predicate' => $self->predicate(), $inline)
412 ) if $self->has_predicate();
415 $self->_process_accessors('clearer' => $self->clearer(), $inline)
416 ) if $self->has_clearer();
422 my $_remove_accessor = sub {
423 my ($accessor, $class) = @_;
424 if (ref($accessor) && ref($accessor) eq 'HASH') {
425 ($accessor) = keys %{$accessor};
427 my $method = $class->get_method($accessor);
428 $class->remove_method($accessor)
429 if (ref($method) && $method->isa('Class::MOP::Method::Accessor'));
432 sub remove_accessors {
435 # we really need to make sure to remove from the
436 # associates methods here as well. But this is
437 # such a slimly used method, I am not worried
438 # about it right now.
439 $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor();
440 $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader();
441 $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer();
442 $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
443 $_remove_accessor->($self->clearer(), $self->associated_class()) if $self->has_clearer();
457 Class::MOP::Attribute - Attribute Meta Object
461 Class::MOP::Attribute->new(
463 accessor => 'foo', # dual purpose get/set accessor
464 predicate => 'has_foo', # predicate check for defined-ness
465 init_arg => '-foo', # class->new will look for a -foo key
466 default => 'BAR IS BAZ!' # if no -foo key is provided, use this
470 Class::MOP::Attribute->new(
472 reader => 'bar', # getter
473 writer => 'set_bar', # setter
474 predicate => 'has_bar', # predicate check for defined-ness
475 init_arg => ':bar', # class->new will look for a :bar key
476 # no default value means it is undef
482 The Attribute Protocol is almost entirely an invention of
483 C<Class::MOP>. Perl 5 does not have a consistent notion of
484 attributes. There are so many ways in which this is done, and very few
485 (if any) are easily discoverable by this module.
487 With that said, this module attempts to inject some order into this
488 chaos, by introducing a consistent API which can be used to create
497 =item B<< Class::MOP::Attribute->new($name, ?%options) >>
499 An attribute must (at the very least), have a C<$name>. All other
500 C<%options> are added as key-value pairs.
506 This is a string value representing the expected key in an
507 initialization hash. For instance, if we have an C<init_arg> value of
508 C<-foo>, then the following code will Just Work.
510 MyClass->meta->new_object( -foo => 'Hello There' );
512 If an init_arg is not assigned, it will automatically use the
513 attribute's name. If C<init_arg> is explicitly set to C<undef>, the
514 attribute cannot be specified during initialization.
518 This provides the name of a method that will be called to initialize
519 the attribute. This method will be called on the object after it is
520 constructed. It is expected to return a valid value for the attribute.
524 This can be used to provide an explicit default for initializing the
525 attribute. If the default you provide is a subroutine reference, then
526 this reference will be called I<as a method> on the object.
528 If the value is a simple scalar (string or number), then it can be
529 just passed as is. However, if you wish to initialize it with a HASH
530 or ARRAY ref, then you need to wrap that inside a subroutine
533 Class::MOP::Attribute->new(
535 default => sub { [] },
541 Class::MOP::Attribute->new(
543 default => sub { {} },
547 If you wish to initialize an attribute with a subroutine reference
548 itself, then you need to wrap that in a subroutine as well:
550 Class::MOP::Attribute->new(
553 sub { print "Hello World" }
558 And lastly, if the value of your attribute is dependent upon some
559 other aspect of the instance structure, then you can take advantage of
560 the fact that when the C<default> value is called as a method:
562 Class::MOP::Attribute->new(
563 'object_identity' => (
564 default => sub { Scalar::Util::refaddr( $_[0] ) },
568 Note that there is no guarantee that attributes are initialized in any
569 particular order, so you cannot rely on the value of some other
570 attribute when generating the default.
574 This option can be either a method name or a subroutine
575 reference. This method will be called when setting the attribute's
576 value in the constructor. Unlike C<default> and C<builder>, the
577 initializer is only called when a value is provided to the
578 constructor. The initializer allows you to munge this value during
581 The initializer is called as a method with three arguments. The first
582 is the value that was passed to the constructor. The second is a
583 subroutine reference that can be called to actually set the
584 attribute's value, and the last is the associated
585 C<Class::MOP::Attribute> object.
587 This contrived example shows an initializer that sets the attribute to
588 twice the given value.
590 Class::MOP::Attribute->new(
593 my ( $instance, $value, $set ) = @_;
594 $set->( $value * 2 );
599 Since an initializer can be a method name, you can easily make
600 attribute initialization use the writer:
602 Class::MOP::Attribute->new(
604 writer => 'some_attr',
605 initializer => 'some_attr',
609 Your writer will need to examine C<@_> and determine under which
610 context it is being called.
614 The C<accessor>, C<reader>, C<writer>, C<predicate> and C<clearer>
615 options all accept the same parameters. You can provide the name of
616 the method, in which case an appropriate default method will be
617 generated for you. Or instead you can also provide hash reference
618 containing exactly one key (the method name) and one value. The value
619 should be a subroutine reference, which will be installed as the
626 An C<accessor> is a standard Perl-style read/write accessor. It will
627 return the value of the attribute, and if a value is passed as an
628 argument, it will assign that value to the attribute.
630 Note that C<undef> is a legitimate value, so this will work:
632 $object->set_something(undef);
636 This is a basic read-only accessor. It returns the value of the
641 This is a basic write accessor, it accepts a single argument, and
642 assigns that value to the attribute.
644 Note that C<undef> is a legitimate value, so this will work:
646 $object->set_something(undef);
650 The predicate method returns a boolean indicating whether or not the
651 attribute has been explicitly set.
653 Note that the predicate returns true even if the attribute was set to
654 a false value (C<0> or C<undef>).
658 This method will uninitialize the attribute. After an attribute is
659 cleared, its C<predicate> will return false.
661 =item * definition_context
663 Mostly, this exists as a hook for the benefit of Moose.
665 This option should be a hash reference containing several keys which
666 will be used when inlining the attribute's accessors. The keys should
667 include C<line>, the line number where the attribute was created, and
668 either C<file> or C<description>.
670 This information will ultimately be used when eval'ing inlined
671 accessor code so that error messages report a useful line and file
676 =item B<< $attr->clone(%options) >>
678 This clones the attribute. Any options you provide will override the
679 settings of the original attribute. You can change the name of the new
680 attribute by passing a C<name> key in C<%options>.
686 These are all basic read-only accessors for the values passed into
691 =item B<< $attr->name >>
693 Returns the attribute's name.
695 =item B<< $attr->accessor >>
697 =item B<< $attr->reader >>
699 =item B<< $attr->writer >>
701 =item B<< $attr->predicate >>
703 =item B<< $attr->clearer >>
705 The C<accessor>, C<reader>, C<writer>, C<predicate>, and C<clearer>
706 methods all return exactly what was passed to the constructor, so it
707 can be either a string containing a method name, or a hash reference.
709 =item B<< $attr->initializer >>
711 Returns the initializer as passed to the constructor, so this may be
712 either a method name or a subroutine reference.
714 =item B<< $attr->init_arg >>
716 =item B<< $attr->is_default_a_coderef >>
718 =item B<< $attr->default($instance) >>
720 The C<$instance> argument is optional. If you don't pass it, the
721 return value for this method is exactly what was passed to the
722 constructor, either a simple scalar or a subroutine reference.
724 If you I<do> pass an C<$instance> and the default is a subroutine
725 reference, then the reference is called as a method on the
726 C<$instance> and the generated value is returned.
728 =item B<< $attr->slots >>
730 Return a list of slots required by the attribute. This is usually just
731 one, the name of the attribute.
733 A slot is the name of the hash key used to store the attribute in an
736 =item B<< $attr->get_read_method >>
738 =item B<< $attr->get_write_method >>
740 Returns the name of a method suitable for reading or writing the value
741 of the attribute in the associated class.
743 If an attribute is read- or write-only, then these methods can return
744 C<undef> as appropriate.
746 =item B<< $attr->has_read_method >>
748 =item B<< $attr->has_write_method >>
750 This returns a boolean indicating whether the attribute has a I<named>
751 read or write method.
753 =item B<< $attr->get_read_method_ref >>
755 =item B<< $attr->get_write_method_ref >>
757 Returns the subroutine reference of a method suitable for reading or
758 writing the attribute's value in the associated class. These methods
759 always return a subroutine reference, regardless of whether or not the
760 attribute is read- or write-only.
764 =head2 Informational predicates
766 These are all basic predicate methods for the values passed into C<new>.
770 =item B<< $attr->has_accessor >>
772 =item B<< $attr->has_reader >>
774 =item B<< $attr->has_writer >>
776 =item B<< $attr->has_predicate >>
778 =item B<< $attr->has_clearer >>
780 =item B<< $attr->has_initializer >>
782 =item B<< $attr->has_init_arg >>
784 This will be I<false> if the C<init_arg> was set to C<undef>.
786 =item B<< $attr->has_default >>
788 This will be I<false> if the C<default> was set to C<undef>, since
789 C<undef> is the default C<default> anyway.
791 =item B<< $attr->has_builder >>
795 =head2 Value management
797 These methods are basically "back doors" to the instance, and can be
798 used to bypass the regular accessors, but still stay within the MOP.
800 These methods are not for general use, and should only be used if you
801 really know what you are doing.
805 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
807 This method is used internally to initialize the attribute's slot in
808 the object C<$instance>.
810 The C<$params> is a hash reference of the values passed to the object
813 It's unlikely that you'll need to call this method yourself.
815 =item B<< $attr->set_value($instance, $value) >>
817 Sets the value without going through the accessor. Note that this
818 works even with read-only attributes.
820 =item B<< $attr->set_initial_value($instance, $value) >>
822 Sets the value without going through the accessor. This method is only
823 called when the instance is first being initialized.
825 =item B<< $attr->get_value($instance) >>
827 Returns the value without going through the accessor. Note that this
828 works even with write-only accessors.
830 =item B<< $attr->has_value($instance) >>
832 Return a boolean indicating whether the attribute has been set in
833 C<$instance>. This how the default C<predicate> method works.
835 =item B<< $attr->clear_value($instance) >>
837 This will clear the attribute's value in C<$instance>. This is what
838 the default C<clearer> calls.
840 Note that this works even if the attribute does not have any
841 associated read, write or clear methods.
845 =head2 Class association
847 These methods allow you to manage the attributes association with
848 the class that contains it. These methods should not be used
849 lightly, nor are they very magical, they are mostly used internally
850 and by metaclass instances.
854 =item B<< $attr->associated_class >>
856 This returns the C<Class::MOP::Class> with which this attribute is
859 =item B<< $attr->attach_to_class($metaclass) >>
861 This method stores a weakened reference to the C<$metaclass> object
864 This method does not remove the attribute from its old class,
865 nor does it create any accessors in the new class.
867 It is probably best to use the L<Class::MOP::Class> C<add_attribute>
870 =item B<< $attr->detach_from_class >>
872 This method removes the associate metaclass object from the attribute
875 This method does not remove the attribute itself from the class, or
876 remove its accessors.
878 It is probably best to use the L<Class::MOP::Class>
879 C<remove_attribute> method instead.
883 =head2 Attribute Accessor generation
887 =item B<< $attr->accessor_metaclass >>
889 Accessor methods are generated using an accessor metaclass. By
890 default, this is L<Class::MOP::Method::Accessor>. This method returns
891 the name of the accessor metaclass that this attribute uses.
893 =item B<< $attr->associate_method($method) >>
895 This associates a L<Class::MOP::Method> object with the
896 attribute. Typically, this is called internally when an attribute
897 generates its accessors.
899 =item B<< $attr->associated_methods >>
901 This returns the list of methods which have been associated with the
904 =item B<< $attr->install_accessors >>
906 This method generates and installs code the attributes various
907 accessors. It is typically called from the L<Class::MOP::Class>
908 C<add_attribute> method.
910 =item B<< $attr->remove_accessors >>
912 This method removes all of the accessors associated with the
915 This does not currently remove methods from the list returned by
916 C<associated_methods>.
924 =item B<< Class::MOP::Attribute->meta >>
926 This will return a L<Class::MOP::Class> instance for this class.
928 It should also be noted that L<Class::MOP> will actually bootstrap
929 this module by installing a number of attribute meta-objects into its
936 Stevan Little E<lt>stevan@iinteractive.comE<gt>
938 =head1 COPYRIGHT AND LICENSE
940 Copyright 2006-2009 by Infinity Interactive, Inc.
942 L<http://www.iinteractive.com>
944 This library is free software; you can redistribute it and/or modify
945 it under the same terms as Perl itself.