2 package Class::MOP::Attribute;
8 use Scalar::Util 'blessed', 'reftype';
10 our $VERSION = '0.01';
13 require Class::MOP::Class;
14 Class::MOP::Class->initialize($_[0])
17 # NOTE: (meta-circularity)
18 # This method will be replaces in the
19 # boostrap section of Class::MOP, by
20 # a new version which uses the
21 # &Class::MOP::Class::construct_instance
22 # method to build an attribute meta-object
23 # which itself is described with attribute
25 # - Ain't meta-circularity grand? :)
31 (defined $name && $name)
32 || confess "You must provide a name for the attribute";
33 (!exists $options{reader} && !exists $options{writer})
34 || confess "You cannot declare an accessor and reader and/or writer functions"
35 if exists $options{accessor};
39 accessor => $options{accessor},
40 reader => $options{reader},
41 writer => $options{writer},
42 predicate => $options{predicate},
43 init_arg => $options{init_arg},
44 default => $options{default}
48 sub name { $_[0]->{name} }
50 sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 }
51 sub has_reader { defined($_[0]->{reader}) ? 1 : 0 }
52 sub has_writer { defined($_[0]->{writer}) ? 1 : 0 }
53 sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
54 sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 }
55 sub has_default { defined($_[0]->{default}) ? 1 : 0 }
57 sub accessor { $_[0]->{accessor} }
58 sub reader { $_[0]->{reader} }
59 sub writer { $_[0]->{writer} }
60 sub predicate { $_[0]->{predicate} }
61 sub init_arg { $_[0]->{init_arg} }
65 if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
66 # if the default is a CODE ref, then
67 # we pass in the instance and default
68 # can return a value based on that
69 # instance. Somewhat crude, but works.
70 return $self->{default}->(shift);
76 # this is just a utility routine to
77 # handle the details of accessors
78 my $_inspect_accessor = sub {
79 my ($attr_name, $type, $accessor) = @_;
81 my %ACCESSOR_TEMPLATES = (
82 'accessor' => qq{sub {
83 \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
84 \$_[0]->{'$attr_name'};
87 \$_[0]->{'$attr_name'};
90 \$_[0]->{'$attr_name'} = \$_[1];
92 'predicate' => qq{sub {
93 defined \$_[0]->{'$attr_name'} ? 1 : 0;
97 if (reftype($accessor) && reftype($accessor) eq 'HASH') {
98 my ($name, $method) = each %{$accessor};
99 return ($name, Class::MOP::Attribute::Accessor->wrap($method));
102 my $method = eval $ACCESSOR_TEMPLATES{$type};
103 confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
104 return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
108 sub install_accessors {
109 my ($self, $class) = @_;
110 (blessed($class) && $class->isa('Class::MOP::Class'))
111 || confess "You must pass a Class::MOP::Class instance (or a subclass)";
113 $_inspect_accessor->($self->name, 'accessor' => $self->accessor())
114 ) if $self->has_accessor();
117 $_inspect_accessor->($self->name, 'reader' => $self->reader())
118 ) if $self->has_reader();
121 $_inspect_accessor->($self->name, 'writer' => $self->writer())
122 ) if $self->has_writer();
125 $_inspect_accessor->($self->name, 'predicate' => $self->predicate())
126 ) if $self->has_predicate();
133 my $_remove_accessor = sub {
134 my ($accessor, $class) = @_;
135 if (reftype($accessor) && reftype($accessor) eq 'HASH') {
136 ($accessor) = keys %{$accessor};
138 my $method = $class->get_method($accessor);
139 $class->remove_method($accessor)
140 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
143 sub remove_accessors {
144 my ($self, $class) = @_;
145 (blessed($class) && $class->isa('Class::MOP::Class'))
146 || confess "You must pass a Class::MOP::Class instance (or a subclass)";
147 $_remove_accessor->($self->accessor(), $class) if $self->has_accessor();
148 $_remove_accessor->($self->reader(), $class) if $self->has_reader();
149 $_remove_accessor->($self->writer(), $class) if $self->has_writer();
150 $_remove_accessor->($self->predicate(), $class) if $self->has_predicate();
156 package Class::MOP::Attribute::Accessor;
161 use Class::MOP::Method;
163 our $VERSION = '0.01';
165 our @ISA = ('Class::MOP::Method');
175 Class::MOP::Attribute - Attribute Meta Object
179 Class::MOP::Attribute->new('$foo' => (
180 accessor => 'foo', # dual purpose get/set accessor
181 predicate => 'has_foo' # predicate check for defined-ness
182 init_arg => '-foo', # class->new will look for a -foo key
183 default => 'BAR IS BAZ!' # if no -foo key is provided, use this
186 Class::MOP::Attribute->new('$.bar' => (
187 reader => 'bar', # getter
188 writer => 'set_bar', # setter
189 predicate => 'has_bar' # predicate check for defined-ness
190 init_arg => ':bar', # class->new will look for a :bar key
191 # no default value means it is undef
196 The Attribute Protocol is almost entirely an invention of this module,
197 and is completely optional to this MOP. This is because Perl 5 does not
198 have consistent notion of what is an attribute of a class. There are
199 so many ways in which this is done, and very few (if any) are
200 easily discoverable by this module.
202 So, all that said, this module attempts to inject some order into this
203 chaos, by introducing a consistent API which can be used to create
212 =item B<new ($name, ?%options)>
214 An attribute must (at the very least), have a C<$name>. All other
215 C<%options> are contained added as key-value pairs. Acceptable keys
222 This should be a string value representing the expected key in
223 an initialization hash. For instance, if we have an I<init_arg>
224 value of C<-foo>, then the following code will Just Work.
226 MyClass->meta->construct_instance(-foo => "Hello There");
230 The value of this key is the default value which
231 C<Class::MOP::Class::construct_instance> will initialize the
235 If the value is a simple scalar (string or number), then it can
236 be just passed as is. However, if you wish to initialize it with
237 a HASH or ARRAY ref, then you need to wrap that inside a CODE
240 Class::MOP::Attribute->new('@foo' => (
241 default => sub { [] },
246 Class::MOP::Attribute->new('%foo' => (
247 default => sub { {} },
250 If you wish to initialize an attribute with a CODE reference
251 itself, then you need to wrap that in a subroutine as well, like
254 Class::MOP::Attribute->new('&foo' => (
255 default => sub { sub { print "Hello World" } },
258 And lastly, if the value of your attribute is dependent upon
259 some other aspect of the instance structure, then you can take
260 advantage of the fact that when the I<default> value is a CODE
261 reference, it is passed the raw (unblessed) instance structure
262 as it's only argument. So you can do things like this:
264 Class::MOP::Attribute->new('$object_identity' => (
265 default => sub { Scalar::Util::refaddr($_[0]) },
268 This last feature is fairly limited as there is no gurantee of
269 the order of attribute initializations, so you cannot perform
270 any kind of dependent initializations. However, if this is
271 something you need, you could subclass B<Class::MOP::Class> and
272 this class to acheive it. However, this is currently left as
273 an exercise to the reader :).
277 The I<accessor>, I<reader>, I<writer> and I<predicate> keys can
278 contain either; the name of the method and an appropriate default
279 one will be generated for you, B<or> a HASH ref containing exactly one
280 key (which will be used as the name of the method) and one value,
281 which should contain a CODE reference which will be installed as
288 The I<accessor> is a standard perl-style read/write accessor. It will
289 return the value of the attribute, and if a value is passed as an argument,
290 it will assign that value to the attribute.
293 This method will properly handle the following code, by assigning an
294 C<undef> value to the attribute.
296 $object->set_something(undef);
300 This is a basic read-only accessor, it will just return the value of
305 This is a basic write accessor, it accepts a single argument, and
306 assigns that value to the attribute. This method does not intentially
307 return a value, however perl will return the result of the last
308 expression in the subroutine, which returns in this returning the
309 same value that it was passed.
312 This method will properly handle the following code, by assigning an
313 C<undef> value to the attribute.
315 $object->set_something();
319 This is a basic test to see if the value of the attribute is not
320 C<undef>. It will return true (C<1>) if the attribute's value is
321 defined, and false (C<0>) otherwise.
329 These are all basic read-only value accessors for the values
330 passed into C<new>. I think they are pretty much self-explanitory.
346 =item B<default (?$instance)>
348 As noted in the documentation for C<new> above, if the I<default>
349 value is a CODE reference, this accessor will pass a single additional
350 argument C<$instance> into it and return the value.
354 =head2 Informational predicates
356 These are all basic predicate methods for the values passed into C<new>.
360 =item B<has_accessor>
366 =item B<has_predicate>
368 =item B<has_init_arg>
374 =head2 Attribute Accessor generation
378 =item B<install_accessors ($class)>
380 This allows the attribute to generate and install code for it's own
381 I<accessor/reader/writer/predicate> methods. This is called by
382 C<Class::MOP::Class::add_attribute>.
384 =item B<remove_accessors ($class)>
386 This allows the attribute to remove the method for it's own
387 I<accessor/reader/writer/predicate>. This is called by
388 C<Class::MOP::Class::remove_attribute>.
398 This will return a B<Class::MOP::Class> instance which is related
401 It should also be noted that B<Class::MOP> will actually bootstrap
402 this module by installing a number of attribute meta-objects into
403 it's metaclass. This will allow this class to reap all the benifits
404 of the MOP when subclassing it.
410 Stevan Little E<lt>stevan@iinteractive.comE<gt>
412 =head1 COPYRIGHT AND LICENSE
414 Copyright 2006 by Infinity Interactive, Inc.
416 L<http://www.iinteractive.com>
418 This library is free software; you can redistribute it and/or modify
419 it under the same terms as Perl itself.