2 package Class::MOP::Attribute;
8 use Scalar::Util 'blessed', 'reftype';
10 use Class::MOP::Class;
11 use Class::MOP::Method;
13 our $VERSION = '0.01';
15 sub meta { Class::MOP::Class->initialize($_[0]) }
22 (defined $name && $name)
23 || confess "You must provide a name for the attribute";
24 (!exists $options{reader} && !exists $options{writer})
25 || confess "You cannot declare an accessor and reader and/or writer functions"
26 if exists $options{accessor};
30 accessor => $options{accessor},
31 reader => $options{reader},
32 writer => $options{writer},
33 predicate => $options{predicate},
34 init_arg => $options{init_arg},
35 default => $options{default}
39 sub name { $_[0]->{name} }
41 sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 }
42 sub has_reader { defined($_[0]->{reader}) ? 1 : 0 }
43 sub has_writer { defined($_[0]->{writer}) ? 1 : 0 }
44 sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
45 sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 }
46 sub has_default { defined($_[0]->{default}) ? 1 : 0 }
48 sub accessor { $_[0]->{accessor} }
49 sub reader { $_[0]->{reader} }
50 sub writer { $_[0]->{writer} }
51 sub predicate { $_[0]->{predicate} }
52 sub init_arg { $_[0]->{init_arg} }
56 if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
57 return $self->{default}->(shift);
62 sub install_accessors {
63 my ($self, $class) = @_;
64 (blessed($class) && $class->isa('Class::MOP::Class'))
65 || confess "You must pass a Class::MOP::Class instance (or a subclass)";
67 if ($self->has_accessor()) {
68 my $accessor = $self->accessor();
69 if (reftype($accessor) && reftype($accessor) eq 'HASH') {
70 my ($name, $method) = each %{$accessor};
71 $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
74 $class->add_method($accessor => Class::MOP::Attribute::Accessor->wrap(sub {
75 $_[0]->{$self->name} = $_[1] if scalar(@_) == 2;
81 if ($self->has_reader()) {
82 my $reader = $self->reader();
83 if (reftype($reader) && reftype($reader) eq 'HASH') {
84 my ($name, $method) = each %{$reader};
85 $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
88 $class->add_method($reader => Class::MOP::Attribute::Accessor->wrap(sub {
93 if ($self->has_writer()) {
94 my $writer = $self->writer();
95 if (reftype($writer) && reftype($writer) eq 'HASH') {
96 my ($name, $method) = each %{$writer};
97 $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
100 $class->add_method($writer => Class::MOP::Attribute::Accessor->wrap(sub {
101 $_[0]->{$self->name} = $_[1];
108 if ($self->has_predicate()) {
109 my $predicate = $self->predicate();
110 if (reftype($predicate) && reftype($predicate) eq 'HASH') {
111 my ($name, $method) = each %{$predicate};
112 $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
115 $class->add_method($predicate => Class::MOP::Attribute::Accessor->wrap(sub {
116 defined $_[0]->{$self->name} ? 1 : 0;
122 sub remove_accessors {
123 my ($self, $class) = @_;
124 (blessed($class) && $class->isa('Class::MOP::Class'))
125 || confess "You must pass a Class::MOP::Class instance (or a subclass)";
127 if ($self->has_accessor()) {
128 my $accessor = $self->accessor();
129 if (reftype($accessor) && reftype($accessor) eq 'HASH') {
130 ($accessor) = keys %{$accessor};
132 my $method = $class->get_method($accessor);
133 $class->remove_method($accessor)
134 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
137 if ($self->has_reader()) {
138 my $reader = $self->reader();
139 if (reftype($reader) && reftype($reader) eq 'HASH') {
140 ($reader) = keys %{$reader};
142 my $method = $class->get_method($reader);
143 $class->remove_method($reader)
144 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
146 if ($self->has_writer()) {
147 my $writer = $self->writer();
148 if (reftype($writer) && reftype($writer) eq 'HASH') {
149 ($writer) = keys %{$writer};
151 my $method = $class->get_method($writer);
152 $class->remove_method($writer)
153 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
157 if ($self->has_predicate()) {
158 my $predicate = $self->predicate();
159 if (reftype($predicate) && reftype($predicate) eq 'HASH') {
160 ($predicate) = keys %{$predicate};
162 my $method = $class->get_method($predicate);
163 $class->remove_method($predicate)
164 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
168 package Class::MOP::Attribute::Accessor;
173 our $VERSION = '0.01';
175 our @ISA = ('Class::MOP::Method');
185 Class::MOP::Attribute - Attribute Meta Object
189 Class::MOP::Attribute->new('$foo' => (
190 accessor => 'foo', # dual purpose get/set accessor
191 init_arg => '-foo', # class->new will look for a -foo key
192 default => 'BAR IS BAZ!' # if no -foo key is provided, use this
195 Class::MOP::Attribute->new('$.bar' => (
196 reader => 'bar', # getter
197 writer => 'set_bar', # setter
198 init_arg => '-bar', # class->new will look for a -bar key
199 # no default value means it is undef
204 The Attribute Protocol is almost entirely an invention of this module. This is
205 because Perl 5 does not have consistent notion of what is an attribute
206 of a class. There are so many ways in which this is done, and very few
207 (if any) are discoverable by this module.
209 So, all that said, this module attempts to inject some order into this
210 chaos, by introducing a more consistent approach.
218 =item B<new ($name, %accessor_description, $class_initialization_arg, $default_value)>
242 =head2 Informational predicates
246 =item B<has_accessor>
248 Returns true if this attribute uses a get/set accessor, and false
253 Returns true if this attribute has a reader, and false otherwise
257 Returns true if this attribute has a writer, and false otherwise
259 =item B<has_predicate>
261 Returns true if this attribute has a predicate, and false otherwise
263 =item B<has_init_arg>
265 Returns true if this attribute has a class intialization argument, and
270 Returns true if this attribute has a default value, and false
275 =head2 Attribute Accessor generation
279 =item B<install_accessors ($class)>
281 This allows the attribute to generate and install code for it's own
282 accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
284 =item B<remove_accessors ($class)>
286 This allows the attribute to remove the method for it's own
287 accessor. This is called by C<Class::MOP::Class::remove_attribute>.
301 Stevan Little E<gt>stevan@iinteractive.comE<lt>
303 =head1 COPYRIGHT AND LICENSE
305 Copyright 2006 by Infinity Interactive, Inc.
307 L<http://www.iinteractive.com>
309 This library is free software; you can redistribute it and/or modify
310 it under the same terms as Perl itself.