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