2 package Class::MOP::Method::Accessor;
8 use Scalar::Util 'blessed', 'weaken';
10 our $VERSION = '0.94';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Class::MOP::Method::Generated';
20 (exists $options{attribute})
21 || confess "You must supply an attribute to construct with";
23 (exists $options{accessor_type})
24 || confess "You must supply an accessor_type to construct with";
26 (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
27 || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
29 ($options{package_name} && $options{name})
30 || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
32 my $self = $class->_new(\%options);
34 # we don't want this creating
35 # a cycle in the code, if not
37 weaken($self->{'attribute'});
39 $self->_initialize_body;
47 return Class::MOP::Class->initialize($class)->new_object(@_)
48 if $class ne __PACKAGE__;
50 my $params = @_ == 1 ? $_[0] : {@_};
53 # inherited from Class::MOP::Method
54 body => $params->{body},
55 associated_metaclass => $params->{associated_metaclass},
56 package_name => $params->{package_name},
57 name => $params->{name},
58 original_method => $params->{original_method},
60 # inherit from Class::MOP::Generated
61 is_inline => $params->{is_inline} || 0,
62 definition_context => $params->{definition_context},
64 # defined in this class
65 attribute => $params->{attribute},
66 accessor_type => $params->{accessor_type},
72 sub associated_attribute { (shift)->{'attribute'} }
73 sub accessor_type { (shift)->{'accessor_type'} }
77 sub _initialize_body {
80 my $method_name = join "_" => (
84 ($self->is_inline ? 'inline' : ())
87 $self->{'body'} = $self->$method_name();
92 sub _generate_accessor_method {
93 my $attr = (shift)->associated_attribute;
95 $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
96 $attr->get_value($_[0]);
100 sub _generate_reader_method {
101 my $attr = (shift)->associated_attribute;
103 confess "Cannot assign a value to a read-only accessor" if @_ > 1;
104 $attr->get_value($_[0]);
109 sub _generate_writer_method {
110 my $attr = (shift)->associated_attribute;
112 $attr->set_value($_[0], $_[1]);
116 sub _generate_predicate_method {
117 my $attr = (shift)->associated_attribute;
119 $attr->has_value($_[0])
123 sub _generate_clearer_method {
124 my $attr = (shift)->associated_attribute;
126 $attr->clear_value($_[0])
132 sub _generate_accessor_method_inline {
134 my $attr = $self->associated_attribute;
135 my $attr_name = $attr->name;
136 my $meta_instance = $attr->associated_class->instance_metaclass;
138 my ( $code, $e ) = $self->_eval_closure(
141 . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
142 . ' if scalar(@_) == 2; '
143 . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
146 confess "Could not generate inline accessor because : $e" if $e;
151 sub _generate_reader_method_inline {
153 my $attr = $self->associated_attribute;
154 my $attr_name = $attr->name;
155 my $meta_instance = $attr->associated_class->instance_metaclass;
157 my ( $code, $e ) = $self->_eval_closure(
160 . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
161 . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
164 confess "Could not generate inline reader because : $e" if $e;
169 sub _generate_writer_method_inline {
171 my $attr = $self->associated_attribute;
172 my $attr_name = $attr->name;
173 my $meta_instance = $attr->associated_class->instance_metaclass;
175 my ( $code, $e ) = $self->_eval_closure(
178 . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
181 confess "Could not generate inline writer because : $e" if $e;
186 sub _generate_predicate_method_inline {
188 my $attr = $self->associated_attribute;
189 my $attr_name = $attr->name;
190 my $meta_instance = $attr->associated_class->instance_metaclass;
192 my ( $code, $e ) = $self->_eval_closure(
195 . $meta_instance->inline_is_slot_initialized('$_[0]', $attr_name)
198 confess "Could not generate inline predicate because : $e" if $e;
203 sub _generate_clearer_method_inline {
205 my $attr = $self->associated_attribute;
206 my $attr_name = $attr->name;
207 my $meta_instance = $attr->associated_class->instance_metaclass;
209 my ( $code, $e ) = $self->_eval_closure(
212 . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name)
215 confess "Could not generate inline clearer because : $e" if $e;
228 Class::MOP::Method::Accessor - Method Meta Object for accessors
232 use Class::MOP::Method::Accessor;
234 my $reader = Class::MOP::Method::Accessor->new(
235 attribute => $attribute,
237 accessor_type => 'reader',
240 $reader->body->execute($instance); # call the reader method
244 This is a subclass of <Class::MOP::Method> which is used by
245 C<Class::MOP::Attribute> to generate accessor code. It handles
246 generation of readers, writers, predicates and clearers. For each type
247 of method, it can either create a subroutine reference, or actually
248 inline code by generating a string and C<eval>'ing it.
254 =item B<< Class::MOP::Method::Accessor->new(%options) >>
256 This returns a new C<Class::MOP::Method::Accessor> based on the
257 C<%options> provided.
263 This is the C<Class::MOP::Attribute> for which accessors are being
264 generated. This option is required.
266 =item * accessor_type
268 This is a string which should be one of "reader", "writer",
269 "accessor", "predicate", or "clearer". This is the type of method
270 being generated. This option is required.
274 This indicates whether or not the accessor should be inlined. This
279 The method name (without a package name). This is required.
283 The package name for the method. This is required.
287 =item B<< $metamethod->accessor_type >>
289 Returns the accessor type which was passed to C<new>.
291 =item B<< $metamethod->is_inline >>
293 Returns a boolean indicating whether or not the accessor is inlined.
295 =item B<< $metamethod->associated_attribute >>
297 This returns the L<Class::MOP::Attribute> object which was passed to
300 =item B<< $metamethod->body >>
302 The method itself is I<generated> when the accessor object is
309 Stevan Little E<lt>stevan@iinteractive.comE<gt>
311 =head1 COPYRIGHT AND LICENSE
313 Copyright 2006-2009 by Infinity Interactive, Inc.
315 L<http://www.iinteractive.com>
317 This library is free software; you can redistribute it and/or modify
318 it under the same terms as Perl itself.