2 package Class::MOP::Attribute;
8 use Scalar::Util 'blessed', 'reftype', 'weaken';
10 our $VERSION = '0.04';
13 require Class::MOP::Class;
14 Class::MOP::Class->initialize(blessed($_[0]) || $_[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 $options{init_arg} = $name
34 if not exists $options{init_arg};
38 accessor => $options{accessor},
39 reader => $options{reader},
40 writer => $options{writer},
41 predicate => $options{predicate},
42 init_arg => $options{init_arg},
43 default => $options{default},
44 # keep a weakened link to the
45 # class we are associated with
46 associated_class => undef,
51 # this is a primative (and kludgy) clone operation
52 # for now, it will be repleace in the Class::MOP
53 # bootstrap with a proper one, however we know
54 # that this one will work fine for now.
59 || confess "Can only clone an instance";
60 return bless { %{$self}, %options } => blessed($self);
64 # the next bunch of methods will get bootstrapped
65 # away in the Class::MOP bootstrapping section
67 sub name { $_[0]->{name} }
69 sub associated_class { $_[0]->{associated_class} }
71 sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 }
72 sub has_reader { defined($_[0]->{reader}) ? 1 : 0 }
73 sub has_writer { defined($_[0]->{writer}) ? 1 : 0 }
74 sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
75 sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 }
76 sub has_default { defined($_[0]->{default}) ? 1 : 0 }
78 sub accessor { $_[0]->{accessor} }
79 sub reader { $_[0]->{reader} }
80 sub writer { $_[0]->{writer} }
81 sub predicate { $_[0]->{predicate} }
82 sub init_arg { $_[0]->{init_arg} }
84 # end bootstrapped away method section.
85 # (all methods below here are kept intact)
89 if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
90 # if the default is a CODE ref, then
91 # we pass in the instance and default
92 # can return a value based on that
93 # instance. Somewhat crude, but works.
94 return $self->{default}->(shift);
101 sub attach_to_class {
102 my ($self, $class) = @_;
103 (blessed($class) && $class->isa('Class::MOP::Class'))
104 || confess "You must pass a Class::MOP::Class instance (or a subclass)";
105 weaken($self->{associated_class} = $class);
108 sub detach_from_class {
110 $self->{associated_class} = undef;
113 ## Method generation helpers
115 sub generate_accessor_method {
116 my ($self, $attr_name) = @_;
118 \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
119 \$_[0]->{'$attr_name'};
123 sub generate_reader_method {
124 my ($self, $attr_name) = @_;
126 \$_[0]->{'$attr_name'};
130 sub generate_writer_method {
131 my ($self, $attr_name) = @_;
133 \$_[0]->{'$attr_name'} = \$_[1];
137 sub generate_predicate_method {
138 my ($self, $attr_name) = @_;
140 defined \$_[0]->{'$attr_name'} ? 1 : 0;
144 sub process_accessors {
145 my ($self, $type, $accessor) = @_;
146 if (reftype($accessor) && reftype($accessor) eq 'HASH') {
147 my ($name, $method) = each %{$accessor};
148 return ($name, Class::MOP::Attribute::Accessor->wrap($method));
151 my $generator = $self->can('generate_' . $type . '_method');
153 || confess "There is no method generator for the type='$type'";
154 if (my $method = $self->$generator($self->name)) {
155 return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
157 confess "Could not create the '$type' method for " . $self->name . " because : $@";
161 sub install_accessors {
163 my $class = $self->associated_class;
166 $self->process_accessors('accessor' => $self->accessor())
167 ) if $self->has_accessor();
170 $self->process_accessors('reader' => $self->reader())
171 ) if $self->has_reader();
174 $self->process_accessors('writer' => $self->writer())
175 ) if $self->has_writer();
178 $self->process_accessors('predicate' => $self->predicate())
179 ) if $self->has_predicate();
184 my $_remove_accessor = sub {
185 my ($accessor, $class) = @_;
186 if (reftype($accessor) && reftype($accessor) eq 'HASH') {
187 ($accessor) = keys %{$accessor};
189 my $method = $class->get_method($accessor);
190 $class->remove_method($accessor)
191 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
194 sub remove_accessors {
196 $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor();
197 $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader();
198 $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer();
199 $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
205 package Class::MOP::Attribute::Accessor;
210 use Class::MOP::Method;
212 our $VERSION = '0.01';
214 our @ISA = ('Class::MOP::Method');
224 Class::MOP::Attribute - Attribute Meta Object
228 Class::MOP::Attribute->new('$foo' => (
229 accessor => 'foo', # dual purpose get/set accessor
230 predicate => 'has_foo' # predicate check for defined-ness
231 init_arg => '-foo', # class->new will look for a -foo key
232 default => 'BAR IS BAZ!' # if no -foo key is provided, use this
235 Class::MOP::Attribute->new('$.bar' => (
236 reader => 'bar', # getter
237 writer => 'set_bar', # setter
238 predicate => 'has_bar' # predicate check for defined-ness
239 init_arg => ':bar', # class->new will look for a :bar key
240 # no default value means it is undef
245 The Attribute Protocol is almost entirely an invention of this module,
246 and is completely optional to this MOP. This is because Perl 5 does not
247 have consistent notion of what is an attribute of a class. There are
248 so many ways in which this is done, and very few (if any) are
249 easily discoverable by this module.
251 So, all that said, this module attempts to inject some order into this
252 chaos, by introducing a consistent API which can be used to create
261 =item B<new ($name, ?%options)>
263 An attribute must (at the very least), have a C<$name>. All other
264 C<%options> are contained added as key-value pairs. Acceptable keys
267 =item B<clone (%options)>
273 This should be a string value representing the expected key in
274 an initialization hash. For instance, if we have an I<init_arg>
275 value of C<-foo>, then the following code will Just Work.
277 MyClass->meta->construct_instance(-foo => "Hello There");
279 In an init_arg is not assigned, it will automatically use the
284 The value of this key is the default value which
285 C<Class::MOP::Class::construct_instance> will initialize the
289 If the value is a simple scalar (string or number), then it can
290 be just passed as is. However, if you wish to initialize it with
291 a HASH or ARRAY ref, then you need to wrap that inside a CODE
294 Class::MOP::Attribute->new('@foo' => (
295 default => sub { [] },
300 Class::MOP::Attribute->new('%foo' => (
301 default => sub { {} },
304 If you wish to initialize an attribute with a CODE reference
305 itself, then you need to wrap that in a subroutine as well, like
308 Class::MOP::Attribute->new('&foo' => (
309 default => sub { sub { print "Hello World" } },
312 And lastly, if the value of your attribute is dependent upon
313 some other aspect of the instance structure, then you can take
314 advantage of the fact that when the I<default> value is a CODE
315 reference, it is passed the raw (unblessed) instance structure
316 as it's only argument. So you can do things like this:
318 Class::MOP::Attribute->new('$object_identity' => (
319 default => sub { Scalar::Util::refaddr($_[0]) },
322 This last feature is fairly limited as there is no gurantee of
323 the order of attribute initializations, so you cannot perform
324 any kind of dependent initializations. However, if this is
325 something you need, you could subclass B<Class::MOP::Class> and
326 this class to acheive it. However, this is currently left as
327 an exercise to the reader :).
331 The I<accessor>, I<reader>, I<writer> and I<predicate> keys can
332 contain either; the name of the method and an appropriate default
333 one will be generated for you, B<or> a HASH ref containing exactly one
334 key (which will be used as the name of the method) and one value,
335 which should contain a CODE reference which will be installed as
342 The I<accessor> is a standard perl-style read/write accessor. It will
343 return the value of the attribute, and if a value is passed as an argument,
344 it will assign that value to the attribute.
347 This method will properly handle the following code, by assigning an
348 C<undef> value to the attribute.
350 $object->set_something(undef);
354 This is a basic read-only accessor, it will just return the value of
359 This is a basic write accessor, it accepts a single argument, and
360 assigns that value to the attribute. This method does not intentially
361 return a value, however perl will return the result of the last
362 expression in the subroutine, which returns in this returning the
363 same value that it was passed.
366 This method will properly handle the following code, by assigning an
367 C<undef> value to the attribute.
369 $object->set_something();
373 This is a basic test to see if the value of the attribute is not
374 C<undef>. It will return true (C<1>) if the attribute's value is
375 defined, and false (C<0>) otherwise.
383 These are all basic read-only value accessors for the values
384 passed into C<new>. I think they are pretty much self-explanitory.
400 =item B<default (?$instance)>
402 As noted in the documentation for C<new> above, if the I<default>
403 value is a CODE reference, this accessor will pass a single additional
404 argument C<$instance> into it and return the value.
408 =head2 Informational predicates
410 These are all basic predicate methods for the values passed into C<new>.
414 =item B<has_accessor>
420 =item B<has_predicate>
422 =item B<has_init_arg>
428 =head2 Class association
432 =item B<associated_class>
434 =item B<attach_to_class ($class)>
436 =item B<detach_from_class>
440 =head2 Attribute Accessor generation
444 =item B<install_accessors>
446 This allows the attribute to generate and install code for it's own
447 I<accessor/reader/writer/predicate> methods. This is called by
448 C<Class::MOP::Class::add_attribute>.
450 This method will call C<process_accessors> for each of the possible
451 method types (accessor, reader, writer & predicate).
453 =item B<process_accessors ($type, $value)>
455 This takes a C<$type> (accessor, reader, writer or predicate), and
456 a C<$value> (the value passed into the constructor for each of the
457 different types). It will then either generate the method itself
458 (using the C<generate_*_method> methods listed below) or it will
459 use the custom method passed through the constructor.
463 =item B<generate_accessor_method ($attr_name)>
465 =item B<generate_predicate_method ($attr_name)>
467 =item B<generate_reader_method ($attr_name)>
469 =item B<generate_writer_method ($attr_name)>
473 =item B<remove_accessors>
475 This allows the attribute to remove the method for it's own
476 I<accessor/reader/writer/predicate>. This is called by
477 C<Class::MOP::Class::remove_attribute>.
487 This will return a B<Class::MOP::Class> instance which is related
490 It should also be noted that B<Class::MOP> will actually bootstrap
491 this module by installing a number of attribute meta-objects into
492 it's metaclass. This will allow this class to reap all the benifits
493 of the MOP when subclassing it.
499 Stevan Little E<lt>stevan@iinteractive.comE<gt>
501 =head1 COPYRIGHT AND LICENSE
503 Copyright 2006 by Infinity Interactive, Inc.
505 L<http://www.iinteractive.com>
507 This library is free software; you can redistribute it and/or modify
508 it under the same terms as Perl itself.