Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Method::Accessor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed', 'weaken'; |
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 | |
101 | sub _generate_accessor_method_inline { |
102 | my $self = shift; |
103 | my $attr = $self->associated_attribute; |
104 | |
d0efb39c |
105 | my $RuNNeR; return bless sub { if (!defined($RuNNeR)) { $RuNNeR = try { |
38bf2a25 |
106 | $self->_compile_code([ |
107 | 'sub {', |
108 | 'if (@_ > 1) {', |
109 | $attr->_inline_set_value('$_[0]', '$_[1]'), |
110 | '}', |
111 | $attr->_inline_get_value('$_[0]'), |
112 | '}', |
113 | ]); |
114 | } |
115 | catch { |
116 | confess "Could not generate inline accessor because : $_"; |
117 | }; |
d0efb39c |
118 | return $RuNNeR if !defined($_[0]) && ref($_[1]) && ref($_[1]) eq 'RuNNeR'}; goto $RuNNeR},'RuNNeR'; |
38bf2a25 |
119 | } |
120 | |
121 | sub _generate_reader_method { |
122 | my $self = shift; |
123 | my $attr = $self->associated_attribute; |
124 | |
125 | return sub { |
126 | confess "Cannot assign a value to a read-only accessor" |
127 | if @_ > 1; |
128 | $attr->get_value($_[0]); |
129 | }; |
130 | } |
131 | |
132 | sub _generate_reader_method_inline { |
133 | my $self = shift; |
134 | my $attr = $self->associated_attribute; |
135 | |
d0efb39c |
136 | my $RuNNeR; return bless sub { if (!defined($RuNNeR)) { $RuNNeR = try { |
38bf2a25 |
137 | $self->_compile_code([ |
138 | 'sub {', |
139 | 'if (@_ > 1) {', |
140 | # XXX: this is a hack, but our error stuff is terrible |
141 | $self->_inline_throw_error( |
142 | '"Cannot assign a value to a read-only accessor"', |
143 | 'data => \@_' |
144 | ) . ';', |
145 | '}', |
146 | $attr->_inline_get_value('$_[0]'), |
147 | '}', |
148 | ]); |
149 | } |
150 | catch { |
151 | confess "Could not generate inline reader because : $_"; |
152 | }; |
d0efb39c |
153 | return $RuNNeR if !defined($_[0]) && ref($_[1]) && ref($_[1]) eq 'RuNNeR'}; goto $RuNNeR},'RuNNeR'; |
38bf2a25 |
154 | } |
155 | |
156 | sub _inline_throw_error { |
157 | my $self = shift; |
b4c122a0 |
158 | return 'Carp::confess ' . $_[0]; |
38bf2a25 |
159 | } |
160 | |
161 | sub _generate_writer_method { |
162 | my $self = shift; |
163 | my $attr = $self->associated_attribute; |
164 | |
165 | return sub { |
166 | $attr->set_value($_[0], $_[1]); |
167 | }; |
168 | } |
169 | |
170 | sub _generate_writer_method_inline { |
171 | my $self = shift; |
172 | my $attr = $self->associated_attribute; |
173 | |
d0efb39c |
174 | my $RuNNeR; return bless sub { if (!defined($RuNNeR)) { $RuNNeR = try { |
38bf2a25 |
175 | $self->_compile_code([ |
176 | 'sub {', |
177 | $attr->_inline_set_value('$_[0]', '$_[1]'), |
178 | '}', |
179 | ]); |
180 | } |
181 | catch { |
182 | confess "Could not generate inline writer because : $_"; |
183 | }; |
d0efb39c |
184 | return $RuNNeR if !defined($_[0]) && ref($_[1]) && ref($_[1]) eq 'RuNNeR'}; goto $RuNNeR},'RuNNeR'; |
38bf2a25 |
185 | } |
186 | |
187 | sub _generate_predicate_method { |
188 | my $self = shift; |
189 | my $attr = $self->associated_attribute; |
190 | |
191 | return sub { |
192 | $attr->has_value($_[0]) |
193 | }; |
194 | } |
195 | |
196 | sub _generate_predicate_method_inline { |
197 | my $self = shift; |
198 | my $attr = $self->associated_attribute; |
199 | |
d0efb39c |
200 | my $RuNNeR; return bless sub { if (!defined($RuNNeR)) { $RuNNeR = try { |
38bf2a25 |
201 | $self->_compile_code([ |
202 | 'sub {', |
203 | $attr->_inline_has_value('$_[0]'), |
204 | '}', |
205 | ]); |
206 | } |
207 | catch { |
208 | confess "Could not generate inline predicate because : $_"; |
209 | }; |
d0efb39c |
210 | return $RuNNeR if !defined($_[0]) && ref($_[1]) && ref($_[1]) eq 'RuNNeR'}; goto $RuNNeR},'RuNNeR'; |
38bf2a25 |
211 | } |
212 | |
213 | sub _generate_clearer_method { |
214 | my $self = shift; |
215 | my $attr = $self->associated_attribute; |
216 | |
217 | return sub { |
218 | $attr->clear_value($_[0]) |
219 | }; |
220 | } |
221 | |
222 | sub _generate_clearer_method_inline { |
223 | my $self = shift; |
224 | my $attr = $self->associated_attribute; |
225 | |
d0efb39c |
226 | my $RuNNeR; return bless sub { if (!defined($RuNNeR)) { $RuNNeR = try { |
38bf2a25 |
227 | $self->_compile_code([ |
228 | 'sub {', |
229 | $attr->_inline_clear_value('$_[0]'), |
230 | '}', |
231 | ]); |
232 | } |
233 | catch { |
234 | confess "Could not generate inline clearer because : $_"; |
235 | }; |
d0efb39c |
236 | return $RuNNeR if !defined($_[0]) && ref($_[1]) && ref($_[1]) eq 'RuNNeR'}; goto $RuNNeR},'RuNNeR'; |
38bf2a25 |
237 | } |
238 | |
239 | 1; |
240 | |
241 | # ABSTRACT: Method Meta Object for accessors |
242 | |
243 | __END__ |
244 | |
245 | =pod |
246 | |
247 | =head1 SYNOPSIS |
248 | |
249 | use Class::MOP::Method::Accessor; |
250 | |
251 | my $reader = Class::MOP::Method::Accessor->new( |
252 | attribute => $attribute, |
253 | is_inline => 1, |
254 | accessor_type => 'reader', |
255 | ); |
256 | |
257 | $reader->body->execute($instance); # call the reader method |
258 | |
259 | =head1 DESCRIPTION |
260 | |
261 | This is a subclass of C<Class::MOP::Method> which is used by |
262 | C<Class::MOP::Attribute> to generate accessor code. It handles |
263 | generation of readers, writers, predicates and clearers. For each type |
264 | of method, it can either create a subroutine reference, or actually |
265 | inline code by generating a string and C<eval>'ing it. |
266 | |
267 | =head1 METHODS |
268 | |
269 | =over 4 |
270 | |
271 | =item B<< Class::MOP::Method::Accessor->new(%options) >> |
272 | |
273 | This returns a new C<Class::MOP::Method::Accessor> based on the |
274 | C<%options> provided. |
275 | |
276 | =over 4 |
277 | |
278 | =item * attribute |
279 | |
280 | This is the C<Class::MOP::Attribute> for which accessors are being |
281 | generated. This option is required. |
282 | |
283 | =item * accessor_type |
284 | |
285 | This is a string which should be one of "reader", "writer", |
286 | "accessor", "predicate", or "clearer". This is the type of method |
287 | being generated. This option is required. |
288 | |
289 | =item * is_inline |
290 | |
291 | This indicates whether or not the accessor should be inlined. This |
292 | defaults to false. |
293 | |
294 | =item * name |
295 | |
296 | The method name (without a package name). This is required. |
297 | |
298 | =item * package_name |
299 | |
300 | The package name for the method. This is required. |
301 | |
302 | =back |
303 | |
304 | =item B<< $metamethod->accessor_type >> |
305 | |
306 | Returns the accessor type which was passed to C<new>. |
307 | |
308 | =item B<< $metamethod->is_inline >> |
309 | |
310 | Returns a boolean indicating whether or not the accessor is inlined. |
311 | |
312 | =item B<< $metamethod->associated_attribute >> |
313 | |
314 | This returns the L<Class::MOP::Attribute> object which was passed to |
315 | C<new>. |
316 | |
317 | =item B<< $metamethod->body >> |
318 | |
319 | The method itself is I<generated> when the accessor object is |
320 | constructed. |
321 | |
322 | =back |
323 | |
324 | =cut |
325 | |