2 package Class::MOP::Method::Accessor;
8 use Scalar::Util 'blessed', 'weaken', 'refaddr';
11 use base 'Class::MOP::Method::Generated';
17 (exists $options{attribute})
18 || confess "You must supply an attribute to construct with";
20 (exists $options{accessor_type})
21 || confess "You must supply an accessor_type to construct with";
23 (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
24 || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
26 ($options{package_name} && $options{name})
27 || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
29 my $self = $class->_new(\%options);
31 # we don't want this creating
32 # a cycle in the code, if not
34 weaken($self->{'attribute'});
36 $self->_initialize_body;
44 return Class::MOP::Class->initialize($class)->new_object(@_)
45 if $class ne __PACKAGE__;
47 my $params = @_ == 1 ? $_[0] : {@_};
50 # inherited from Class::MOP::Method
51 body => $params->{body},
52 associated_metaclass => $params->{associated_metaclass},
53 package_name => $params->{package_name},
54 name => $params->{name},
55 original_method => $params->{original_method},
57 # inherit from Class::MOP::Generated
58 is_inline => $params->{is_inline} || 0,
59 definition_context => $params->{definition_context},
61 # defined in this class
62 attribute => $params->{attribute},
63 accessor_type => $params->{accessor_type},
69 sub associated_attribute { (shift)->{'attribute'} }
70 sub accessor_type { (shift)->{'accessor_type'} }
74 sub _initialize_body {
77 my $method_name = join "_" => (
81 ($self->is_inline ? 'inline' : ())
84 $self->{'body'} = $self->$method_name();
89 sub _generate_accessor_method {
91 my $attr = $self->associated_attribute;
95 $attr->set_value($_[0], $_[1]);
97 $attr->get_value($_[0]);
101 sub _generate_deferred_inline_method {
102 my ($self, $gen, $gen_type) = @_;
106 return $orig = bless sub {
107 # there are several situations to handle - mostly just think about
108 # what happens on inheritance, composition, overriding, monkey-patching,
109 # etc. This should sync with the latest canonical database of record.
110 if (!defined($RuNNeR)) {
112 $RuNNeR = $gen->($self, $self->associated_attribute);
115 confess "Could not generate inline $gen_type because : $_";
117 # update the body member unless something else has stomped on it
118 my $body = $self->{'body'};
119 if (refaddr($orig) != refaddr($body)) {
120 # we seem to be outdated... paranoid future-proofing, I think..
121 goto $RuNNeR = $body;
123 $self->{'body'} = $RuNNeR;
124 # update the symbol in the stash if it's currently immutable
125 # and it's still the original we set previously.
126 my $assoc_class = $self->associated_attribute->associated_class;
127 my $sigiled_name = '&'.$self->{'name'};
128 if ($assoc_class->is_immutable) {
129 my $stash = $assoc_class->_package_stash;
130 my $symbol_ref = $stash->get_symbol($sigiled_name);
131 if (!defined($symbol_ref)) {
132 confess "A metaobject is corrupted";
134 if (refaddr($orig) != refaddr($symbol_ref)) {
135 goto $RuNNeR = $symbol_ref;
137 $stash->add_symbol($sigiled_name, $RuNNeR);
140 return unless defined($_[0]);
145 sub _generate_accessor_method_inline {
146 return _generate_deferred_inline_method(shift, sub {
147 my ($self, $attr) = @_;
148 return $self->_compile_code([
151 $attr->_inline_set_value('$_[0]', '$_[1]'),
153 $attr->_inline_get_value('$_[0]'),
159 sub _generate_reader_method {
161 my $attr = $self->associated_attribute;
164 confess "Cannot assign a value to a read-only accessor"
166 $attr->get_value($_[0]);
170 sub _generate_reader_method_inline {
171 return _generate_deferred_inline_method(shift, sub {
172 my ($self, $attr) = @_;
173 return $self->_compile_code([
176 # XXX: this is a hack, but our error stuff is terrible
177 $self->_inline_throw_error(
178 '"Cannot assign a value to a read-only accessor"',
182 $attr->_inline_get_value('$_[0]'),
188 sub _inline_throw_error {
190 return 'Carp::confess ' . $_[0];
193 sub _generate_writer_method {
195 my $attr = $self->associated_attribute;
198 $attr->set_value($_[0], $_[1]);
202 sub _generate_writer_method_inline {
203 return _generate_deferred_inline_method(shift, sub {
204 my ($self, $attr) = @_;
205 return $self->_compile_code([
207 $attr->_inline_set_value('$_[0]', '$_[1]'),
213 sub _generate_predicate_method {
215 my $attr = $self->associated_attribute;
218 $attr->has_value($_[0])
222 sub _generate_predicate_method_inline {
223 return _generate_deferred_inline_method(shift, sub {
224 my ($self, $attr) = @_;
225 return $self->_compile_code([
227 $attr->_inline_has_value('$_[0]'),
233 sub _generate_clearer_method {
235 my $attr = $self->associated_attribute;
238 $attr->clear_value($_[0])
242 sub _generate_clearer_method_inline {
243 return _generate_deferred_inline_method(shift, sub {
244 my ($self, $attr) = @_;
245 return $self->_compile_code([
247 $attr->_inline_clear_value('$_[0]'),
255 # ABSTRACT: Method Meta Object for accessors
263 use Class::MOP::Method::Accessor;
265 my $reader = Class::MOP::Method::Accessor->new(
266 attribute => $attribute,
268 accessor_type => 'reader',
271 $reader->body->execute($instance); # call the reader method
275 This is a subclass of C<Class::MOP::Method> which is used by
276 C<Class::MOP::Attribute> to generate accessor code. It handles
277 generation of readers, writers, predicates and clearers. For each type
278 of method, it can either create a subroutine reference, or actually
279 inline code by generating a string and C<eval>'ing it.
285 =item B<< Class::MOP::Method::Accessor->new(%options) >>
287 This returns a new C<Class::MOP::Method::Accessor> based on the
288 C<%options> provided.
294 This is the C<Class::MOP::Attribute> for which accessors are being
295 generated. This option is required.
297 =item * accessor_type
299 This is a string which should be one of "reader", "writer",
300 "accessor", "predicate", or "clearer". This is the type of method
301 being generated. This option is required.
305 This indicates whether or not the accessor should be inlined. This
310 The method name (without a package name). This is required.
314 The package name for the method. This is required.
318 =item B<< $metamethod->accessor_type >>
320 Returns the accessor type which was passed to C<new>.
322 =item B<< $metamethod->is_inline >>
324 Returns a boolean indicating whether or not the accessor is inlined.
326 =item B<< $metamethod->associated_attribute >>
328 This returns the L<Class::MOP::Attribute> object which was passed to
331 =item B<< $metamethod->body >>
333 The method itself is I<generated> when the accessor object is