Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Method::Accessor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
bdb2de61 |
8 | use Scalar::Util 'blessed', 'weaken', 'refaddr'; |
38bf2a25 |
9 | use Try::Tiny; |
10 | |
38bf2a25 |
11 | use base 'Class::MOP::Method::Generated'; |
12 | |
13 | sub new { |
14 | my $class = shift; |
15 | my %options = @_; |
16 | |
17 | (exists $options{attribute}) |
18 | || confess "You must supply an attribute to construct with"; |
19 | |
20 | (exists $options{accessor_type}) |
21 | || confess "You must supply an accessor_type to construct with"; |
22 | |
23 | (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) |
24 | || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; |
25 | |
26 | ($options{package_name} && $options{name}) |
27 | || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; |
28 | |
29 | my $self = $class->_new(\%options); |
30 | |
31 | # we don't want this creating |
32 | # a cycle in the code, if not |
33 | # needed |
34 | weaken($self->{'attribute'}); |
35 | |
36 | $self->_initialize_body; |
37 | |
38 | return $self; |
39 | } |
40 | |
41 | sub _new { |
42 | my $class = shift; |
43 | |
44 | return Class::MOP::Class->initialize($class)->new_object(@_) |
45 | if $class ne __PACKAGE__; |
46 | |
47 | my $params = @_ == 1 ? $_[0] : {@_}; |
48 | |
49 | return bless { |
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}, |
56 | |
57 | # inherit from Class::MOP::Generated |
58 | is_inline => $params->{is_inline} || 0, |
59 | definition_context => $params->{definition_context}, |
60 | |
61 | # defined in this class |
62 | attribute => $params->{attribute}, |
63 | accessor_type => $params->{accessor_type}, |
64 | } => $class; |
65 | } |
66 | |
67 | ## accessors |
68 | |
69 | sub associated_attribute { (shift)->{'attribute'} } |
70 | sub accessor_type { (shift)->{'accessor_type'} } |
71 | |
72 | ## factory |
73 | |
74 | sub _initialize_body { |
75 | my $self = shift; |
76 | |
77 | my $method_name = join "_" => ( |
78 | '_generate', |
79 | $self->accessor_type, |
80 | 'method', |
81 | ($self->is_inline ? 'inline' : ()) |
82 | ); |
83 | |
84 | $self->{'body'} = $self->$method_name(); |
85 | } |
86 | |
87 | ## generators |
88 | |
89 | sub _generate_accessor_method { |
90 | my $self = shift; |
91 | my $attr = $self->associated_attribute; |
92 | |
93 | return sub { |
94 | if (@_ >= 2) { |
95 | $attr->set_value($_[0], $_[1]); |
96 | } |
97 | $attr->get_value($_[0]); |
98 | }; |
99 | } |
100 | |
bdb2de61 |
101 | sub _generate_deferred_inline_method { |
102 | my ($self, $gen, $gen_type) = @_; |
103 | |
104 | my $RuNNeR; |
105 | my $orig; |
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)) { |
111 | try { |
112 | $RuNNeR = $gen->($self, $self->associated_attribute); |
113 | } |
114 | catch { |
115 | confess "Could not generate inline $gen_type because : $_"; |
116 | }; |
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; |
122 | } |
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"; |
133 | } |
134 | if (refaddr($orig) != refaddr($symbol_ref)) { |
135 | goto $RuNNeR = $symbol_ref; |
136 | } |
137 | $stash->add_symbol($sigiled_name, $RuNNeR); |
138 | } |
139 | }; |
140 | return unless defined($_[0]); |
141 | goto $RuNNeR; |
142 | },'RuNNeR'; |
143 | } |
38bf2a25 |
144 | |
bdb2de61 |
145 | sub _generate_accessor_method_inline { |
146 | return _generate_deferred_inline_method(shift, sub { |
147 | my ($self, $attr) = @_; |
148 | return $self->_compile_code([ |
38bf2a25 |
149 | 'sub {', |
150 | 'if (@_ > 1) {', |
151 | $attr->_inline_set_value('$_[0]', '$_[1]'), |
152 | '}', |
153 | $attr->_inline_get_value('$_[0]'), |
154 | '}', |
155 | ]); |
bdb2de61 |
156 | }, "accessor"); |
38bf2a25 |
157 | } |
158 | |
159 | sub _generate_reader_method { |
160 | my $self = shift; |
161 | my $attr = $self->associated_attribute; |
162 | |
163 | return sub { |
164 | confess "Cannot assign a value to a read-only accessor" |
165 | if @_ > 1; |
166 | $attr->get_value($_[0]); |
167 | }; |
168 | } |
169 | |
170 | sub _generate_reader_method_inline { |
bdb2de61 |
171 | return _generate_deferred_inline_method(shift, sub { |
172 | my ($self, $attr) = @_; |
173 | return $self->_compile_code([ |
38bf2a25 |
174 | 'sub {', |
175 | 'if (@_ > 1) {', |
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"', |
179 | 'data => \@_' |
180 | ) . ';', |
181 | '}', |
182 | $attr->_inline_get_value('$_[0]'), |
183 | '}', |
184 | ]); |
bdb2de61 |
185 | }, "reader"); |
38bf2a25 |
186 | } |
187 | |
188 | sub _inline_throw_error { |
189 | my $self = shift; |
b4c122a0 |
190 | return 'Carp::confess ' . $_[0]; |
38bf2a25 |
191 | } |
192 | |
193 | sub _generate_writer_method { |
194 | my $self = shift; |
195 | my $attr = $self->associated_attribute; |
196 | |
197 | return sub { |
198 | $attr->set_value($_[0], $_[1]); |
199 | }; |
200 | } |
201 | |
202 | sub _generate_writer_method_inline { |
bdb2de61 |
203 | return _generate_deferred_inline_method(shift, sub { |
204 | my ($self, $attr) = @_; |
205 | return $self->_compile_code([ |
38bf2a25 |
206 | 'sub {', |
207 | $attr->_inline_set_value('$_[0]', '$_[1]'), |
208 | '}', |
209 | ]); |
bdb2de61 |
210 | }, "writer"); |
38bf2a25 |
211 | } |
212 | |
213 | sub _generate_predicate_method { |
214 | my $self = shift; |
215 | my $attr = $self->associated_attribute; |
216 | |
217 | return sub { |
218 | $attr->has_value($_[0]) |
219 | }; |
220 | } |
221 | |
222 | sub _generate_predicate_method_inline { |
bdb2de61 |
223 | return _generate_deferred_inline_method(shift, sub { |
224 | my ($self, $attr) = @_; |
225 | return $self->_compile_code([ |
38bf2a25 |
226 | 'sub {', |
227 | $attr->_inline_has_value('$_[0]'), |
228 | '}', |
229 | ]); |
bdb2de61 |
230 | }, "predicate"); |
38bf2a25 |
231 | } |
232 | |
233 | sub _generate_clearer_method { |
234 | my $self = shift; |
235 | my $attr = $self->associated_attribute; |
236 | |
237 | return sub { |
238 | $attr->clear_value($_[0]) |
239 | }; |
240 | } |
241 | |
242 | sub _generate_clearer_method_inline { |
bdb2de61 |
243 | return _generate_deferred_inline_method(shift, sub { |
244 | my ($self, $attr) = @_; |
245 | return $self->_compile_code([ |
38bf2a25 |
246 | 'sub {', |
247 | $attr->_inline_clear_value('$_[0]'), |
248 | '}', |
249 | ]); |
bdb2de61 |
250 | }, "clearer"); |
38bf2a25 |
251 | } |
252 | |
253 | 1; |
254 | |
255 | # ABSTRACT: Method Meta Object for accessors |
256 | |
257 | __END__ |
258 | |
259 | =pod |
260 | |
261 | =head1 SYNOPSIS |
262 | |
263 | use Class::MOP::Method::Accessor; |
264 | |
265 | my $reader = Class::MOP::Method::Accessor->new( |
266 | attribute => $attribute, |
267 | is_inline => 1, |
268 | accessor_type => 'reader', |
269 | ); |
270 | |
271 | $reader->body->execute($instance); # call the reader method |
272 | |
273 | =head1 DESCRIPTION |
274 | |
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. |
280 | |
281 | =head1 METHODS |
282 | |
283 | =over 4 |
284 | |
285 | =item B<< Class::MOP::Method::Accessor->new(%options) >> |
286 | |
287 | This returns a new C<Class::MOP::Method::Accessor> based on the |
288 | C<%options> provided. |
289 | |
290 | =over 4 |
291 | |
292 | =item * attribute |
293 | |
294 | This is the C<Class::MOP::Attribute> for which accessors are being |
295 | generated. This option is required. |
296 | |
297 | =item * accessor_type |
298 | |
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. |
302 | |
303 | =item * is_inline |
304 | |
305 | This indicates whether or not the accessor should be inlined. This |
306 | defaults to false. |
307 | |
308 | =item * name |
309 | |
310 | The method name (without a package name). This is required. |
311 | |
312 | =item * package_name |
313 | |
314 | The package name for the method. This is required. |
315 | |
316 | =back |
317 | |
318 | =item B<< $metamethod->accessor_type >> |
319 | |
320 | Returns the accessor type which was passed to C<new>. |
321 | |
322 | =item B<< $metamethod->is_inline >> |
323 | |
324 | Returns a boolean indicating whether or not the accessor is inlined. |
325 | |
326 | =item B<< $metamethod->associated_attribute >> |
327 | |
328 | This returns the L<Class::MOP::Attribute> object which was passed to |
329 | C<new>. |
330 | |
331 | =item B<< $metamethod->body >> |
332 | |
333 | The method itself is I<generated> when the accessor object is |
334 | constructed. |
335 | |
336 | =back |
337 | |
338 | =cut |
339 | |