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];
93 'predicate' => qq{sub {
94 return defined \$_[0]->{'$attr_name'} ? 1 : 0;
98 if (reftype($accessor) && reftype($accessor) eq 'HASH') {
99 my ($name, $method) = each %{$accessor};
100 return ($name, Class::MOP::Attribute::Accessor->wrap($method));
103 my $method = eval $ACCESSOR_TEMPLATES{$type};
104 confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
105 return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
109 sub install_accessors {
110 my ($self, $class) = @_;
111 (blessed($class) && $class->isa('Class::MOP::Class'))
112 || confess "You must pass a Class::MOP::Class instance (or a subclass)";
114 $_inspect_accessor->($self->name, 'accessor' => $self->accessor())
115 ) if $self->has_accessor();
118 $_inspect_accessor->($self->name, 'reader' => $self->reader())
119 ) if $self->has_reader();
122 $_inspect_accessor->($self->name, 'writer' => $self->writer())
123 ) if $self->has_writer();
126 $_inspect_accessor->($self->name, 'predicate' => $self->predicate())
127 ) if $self->has_predicate();
134 my $_remove_accessor = sub {
135 my ($accessor, $class) = @_;
136 if (reftype($accessor) && reftype($accessor) eq 'HASH') {
137 ($accessor) = keys %{$accessor};
139 my $method = $class->get_method($accessor);
140 $class->remove_method($accessor)
141 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
144 sub remove_accessors {
145 my ($self, $class) = @_;
146 (blessed($class) && $class->isa('Class::MOP::Class'))
147 || confess "You must pass a Class::MOP::Class instance (or a subclass)";
148 $_remove_accessor->($self->accessor(), $class) if $self->has_accessor();
149 $_remove_accessor->($self->reader(), $class) if $self->has_reader();
150 $_remove_accessor->($self->writer(), $class) if $self->has_writer();
151 $_remove_accessor->($self->predicate(), $class) if $self->has_predicate();
157 package Class::MOP::Attribute::Accessor;
162 use Class::MOP::Method;
164 our $VERSION = '0.01';
166 our @ISA = ('Class::MOP::Method');
176 Class::MOP::Attribute - Attribute Meta Object
180 Class::MOP::Attribute->new('$foo' => (
181 accessor => 'foo', # dual purpose get/set accessor
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 init_arg => '-bar', # class->new will look for a -bar key
190 # no default value means it is undef
195 The Attribute Protocol is almost entirely an invention of this module. This is
196 because Perl 5 does not have consistent notion of what is an attribute
197 of a class. There are so many ways in which this is done, and very few
198 (if any) are discoverable by this module.
200 So, all that said, this module attempts to inject some order into this
201 chaos, by introducing a more consistent approach.
209 =item B<new ($name, %options)>
249 =head2 Informational predicates
253 =item B<has_accessor>
255 Returns true if this attribute uses a get/set accessor, and false
260 Returns true if this attribute has a reader, and false otherwise
264 Returns true if this attribute has a writer, and false otherwise
266 =item B<has_predicate>
268 Returns true if this attribute has a predicate, and false otherwise
270 =item B<has_init_arg>
272 Returns true if this attribute has a class intialization argument, and
277 Returns true if this attribute has a default value, and false
282 =head2 Attribute Accessor generation
286 =item B<install_accessors ($class)>
288 This allows the attribute to generate and install code for it's own
289 accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
291 =item B<remove_accessors ($class)>
293 This allows the attribute to remove the method for it's own
294 accessor. This is called by C<Class::MOP::Class::remove_attribute>.
308 Stevan Little E<gt>stevan@iinteractive.comE<lt>
310 =head1 COPYRIGHT AND LICENSE
312 Copyright 2006 by Infinity Interactive, Inc.
314 L<http://www.iinteractive.com>
316 This library is free software; you can redistribute it and/or modify
317 it under the same terms as Perl itself.