File Coverage

blib/lib/Class/MOP/Method/Accessor.pm
Criterion Covered Total %
statement 84 84 100.0
branch 17 18 94.4
condition 6 8 75.0
subroutine 41 41 100.0
pod 1 1 100.0
total 149 152 98.0


line stmt bran cond sub pod time code
1             package Class::MOP::Method::Accessor;
2             our $VERSION = '2.2205';
3              
4 450     473   3445 use strict;
  450         1040  
  450         13612  
5 450     450   2298 use warnings;
  450         970  
  450         13091  
6              
7 450     450   2505 use Scalar::Util 'blessed', 'weaken';
  450         1100  
  450         22116  
8 450     450   2858 use Try::Tiny;
  450         1074  
  450         23921  
9              
10 450     450   3083 use parent 'Class::MOP::Method::Generated';
  450         1345  
  450         2950  
11              
12             sub new {
13 77754     77754 1 131838 my $class = shift;
14 77754         366726 my %options = @_;
15              
16             (exists $options{attribute})
17 77754 100       192435 || $class->_throw_exception( MustSupplyAnAttributeToConstructWith => params => \%options,
18             class => $class,
19             );
20              
21             (exists $options{accessor_type})
22 77753 100       154512 || $class->_throw_exception( MustSupplyAnAccessorTypeToConstructWith => params => \%options,
23             class => $class,
24             );
25              
26 77752 100 66     496462 (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
27             || $class->_throw_exception( MustSupplyAClassMOPAttributeInstance => params => \%options,
28             class => $class
29             );
30              
31             ($options{package_name} && $options{name})
32 77751 100 66     306928 || $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options,
33             class => $class
34             );
35              
36 77750         210429 my $self = $class->_new(\%options);
37              
38             # we don't want this creating
39             # a cycle in the code, if not
40             # needed
41 77750         372186 weaken($self->{'attribute'});
42              
43 77750         205369 $self->_initialize_body;
44              
45 77749         2090524 return $self;
46             }
47              
48             sub _new {
49 108223     108223   176151 my $class = shift;
50              
51 108223 100       234503 return Class::MOP::Class->initialize($class)->new_object(@_)
52             if $class ne __PACKAGE__;
53              
54 104993 50       231225 my $params = @_ == 1 ? $_[0] : {@_};
55              
56             return bless {
57             # inherited from Class::MOP::Method
58             body => $params->{body},
59             associated_metaclass => $params->{associated_metaclass},
60             package_name => $params->{package_name},
61             name => $params->{name},
62             original_method => $params->{original_method},
63              
64             # inherit from Class::MOP::Generated
65             is_inline => $params->{is_inline} || 0,
66             definition_context => $params->{definition_context},
67              
68             # defined in this class
69             attribute => $params->{attribute},
70             accessor_type => $params->{accessor_type},
71 104993   100     929874 } => $class;
72             }
73              
74             ## accessors
75              
76 94838     94838   266349 sub associated_attribute { (shift)->{'attribute'} }
77 76718     76718   331175 sub accessor_type { (shift)->{'accessor_type'} }
78              
79             ## factory
80              
81             sub _initialize_body {
82 76718     76718   115881 my $self = shift;
83              
84 76718 100       148497 my $method_name = join "_" => (
85             '_generate',
86             $self->accessor_type,
87             'method',
88             ($self->is_inline ? 'inline' : ())
89             );
90              
91 76718         269256 $self->{'body'} = $self->$method_name();
92             }
93              
94             ## generators
95              
96             sub _generate_accessor_method {
97 8166     8166   14714 my $self = shift;
98 8166         16828 my $attr = $self->associated_attribute;
99              
100             return sub {
101 142 100   142   19994 if (@_ >= 2) {
        277      
        210      
        173      
102 21         121 $attr->set_value($_[0], $_[1]);
103             }
104 142         491 $attr->get_value($_[0]);
105 8166         45353 };
106             }
107              
108             sub _generate_accessor_method_inline {
109 8400     8400   15094 my $self = shift;
110 8400         17109 my $attr = $self->associated_attribute;
111              
112             return try {
113 8400     8400   348498 $self->_compile_code([
114             'sub {',
115             'if (@_ > 1) {',
116             $attr->_inline_set_value('$_[0]', '$_[1]'),
117             '}',
118             $attr->_inline_get_value('$_[0]'),
119             '}',
120             ]);
121             }
122             catch {
123 1     1   22 $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
124             error => $_,
125             option => "accessor"
126             );
127 8400         51909 };
128             }
129              
130             sub _generate_reader_method {
131 21130     21130   35418 my $self = shift;
132 21130         41139 my $attr = $self->associated_attribute;
133 21130         48082 my $class = $attr->associated_class;
134              
135             return sub {
136 4821 100   4821   48242 $self->_throw_exception( CannotAssignValueToReadOnlyAccessor => class_name => $class->name,
        427      
        173      
137             value => $_[1],
138             attribute => $attr
139             )
140             if @_ > 1;
141 4818         15060 $attr->get_value($_[0]);
142 21130         124791 };
143             }
144              
145             sub _generate_reader_method_inline {
146 23528     23780   40705 my $self = shift;
147 23528         46232 my $attr = $self->associated_attribute;
148 23528         57128 my $attr_name = $attr->name;
149              
150             return try {
151 23528     23718   1004426 $self->_compile_code([
152             'sub {',
153             'if (@_ > 1) {',
154             $self->_inline_throw_exception( CannotAssignValueToReadOnlyAccessor =>
155             'class_name => ref $_[0],'.
156             'value => $_[1],'.
157             "attribute_name => '".$attr_name."'",
158             ) . ';',
159             '}',
160             $attr->_inline_get_value('$_[0]'),
161             '}',
162             ]);
163             }
164             catch {
165 1     163   23 $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
166             error => $_,
167             option => "reader"
168             );
169 23528         149968 };
170             }
171              
172             sub _generate_writer_method {
173 1184     1329   3626 my $self = shift;
174 1184         6304 my $attr = $self->associated_attribute;
175              
176             return sub {
177 60     222   3052 $attr->set_value($_[0], $_[1]);
178 1184         6728 };
179             }
180              
181             sub _generate_writer_method_inline {
182 1172     1411   3729 my $self = shift;
183 1172         3682 my $attr = $self->associated_attribute;
184              
185             return try {
186 1172     1408   51256 $self->_compile_code([
187             'sub {',
188             $attr->_inline_set_value('$_[0]', '$_[1]'),
189             '}',
190             ]);
191             }
192             catch {
193 2     221   59 $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
194             error => $_,
195             option => "writer"
196             );
197 1172         9461 };
198             }
199              
200             sub _generate_predicate_method {
201 6257     6419   11587 my $self = shift;
202 6257         14591 my $attr = $self->associated_attribute;
203              
204             return sub {
205 4843     5005   39105 $attr->has_value($_[0])
206 6257         32174 };
207             }
208              
209             sub _generate_predicate_method_inline {
210 6327     6909   12367 my $self = shift;
211 6327         13157 my $attr = $self->associated_attribute;
212              
213             return try {
214 6327     6911   254169 $self->_compile_code([
215             'sub {',
216             $attr->_inline_has_value('$_[0]'),
217             '}',
218             ]);
219             }
220             catch {
221 1     549   20 $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
222             error => $_,
223             option => "predicate"
224             );
225 6327         37236 };
226             }
227              
228             sub _generate_clearer_method {
229 463     762   1234 my $self = shift;
230 463         2276 my $attr = $self->associated_attribute;
231              
232             return sub {
233 15     314   777 $attr->clear_value($_[0])
        297      
234 463         2914 };
235             }
236              
237             sub _generate_clearer_method_inline {
238 80     94   300 my $self = shift;
239 80         267 my $attr = $self->associated_attribute;
240              
241             return try {
242 80     93   3992 $self->_compile_code([
243             'sub {',
244             $attr->_inline_clear_value('$_[0]'),
245             '}',
246             ]);
247             }
248             catch {
249 1     13   21 $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
250             error => $_,
251             option => "clearer"
252             );
253 80         705 };
254             }
255              
256             1;
257              
258             # ABSTRACT: Method Meta Object for accessors
259              
260             __END__
261              
262             =pod
263              
264             =encoding UTF-8
265              
266             =head1 NAME
267              
268             Class::MOP::Method::Accessor - Method Meta Object for accessors
269              
270             =head1 VERSION
271              
272             version 2.2205
273              
274             =head1 SYNOPSIS
275              
276             use Class::MOP::Method::Accessor;
277              
278             my $reader = Class::MOP::Method::Accessor->new(
279             attribute => $attribute,
280             is_inline => 1,
281             accessor_type => 'reader',
282             );
283              
284             $reader->body->execute($instance); # call the reader method
285              
286             =head1 DESCRIPTION
287              
288             This is a subclass of C<Class::MOP::Method> which is used by
289             C<Class::MOP::Attribute> to generate accessor code. It handles
290             generation of readers, writers, predicates and clearers. For each type
291             of method, it can either create a subroutine reference, or actually
292             inline code by generating a string and C<eval>'ing it.
293              
294             =head1 METHODS
295              
296             =over 4
297              
298             =item B<< Class::MOP::Method::Accessor->new(%options) >>
299              
300             This returns a new C<Class::MOP::Method::Accessor> based on the
301             C<%options> provided.
302              
303             =over 4
304              
305             =item * attribute
306              
307             This is the C<Class::MOP::Attribute> for which accessors are being
308             generated. This option is required.
309              
310             =item * accessor_type
311              
312             This is a string which should be one of "reader", "writer",
313             "accessor", "predicate", or "clearer". This is the type of method
314             being generated. This option is required.
315              
316             =item * is_inline
317              
318             This indicates whether or not the accessor should be inlined. This
319             defaults to false.
320              
321             =item * name
322              
323             The method name (without a package name). This is required.
324              
325             =item * package_name
326              
327             The package name for the method. This is required.
328              
329             =back
330              
331             =item B<< $metamethod->accessor_type >>
332              
333             Returns the accessor type which was passed to C<new>.
334              
335             =item B<< $metamethod->is_inline >>
336              
337             Returns a boolean indicating whether or not the accessor is inlined.
338              
339             =item B<< $metamethod->associated_attribute >>
340              
341             This returns the L<Class::MOP::Attribute> object which was passed to
342             C<new>.
343              
344             =item B<< $metamethod->body >>
345              
346             The method itself is I<generated> when the accessor object is
347             constructed.
348              
349             =back
350              
351             =head1 AUTHORS
352              
353             =over 4
354              
355             =item *
356              
357             Stevan Little <stevan@cpan.org>
358              
359             =item *
360              
361             Dave Rolsky <autarch@urth.org>
362              
363             =item *
364              
365             Jesse Luehrs <doy@cpan.org>
366              
367             =item *
368              
369             Shawn M Moore <sartak@cpan.org>
370              
371             =item *
372              
373             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
374              
375             =item *
376              
377             Karen Etheridge <ether@cpan.org>
378              
379             =item *
380              
381             Florian Ragwitz <rafl@debian.org>
382              
383             =item *
384              
385             Hans Dieter Pearcey <hdp@cpan.org>
386              
387             =item *
388              
389             Chris Prather <chris@prather.org>
390              
391             =item *
392              
393             Matt S Trout <mstrout@cpan.org>
394              
395             =back
396              
397             =head1 COPYRIGHT AND LICENSE
398              
399             This software is copyright (c) 2006 by Infinity Interactive, Inc.
400              
401             This is free software; you can redistribute it and/or modify it under
402             the same terms as the Perl 5 programming language system itself.
403              
404             =cut