File Coverage

blib/lib/Moose/Meta/Method/Delegation.pm
Criterion Covered Total %
statement 68 69 98.5
branch 24 28 85.7
condition 14 18 77.7
subroutine 16 17 94.1
pod 4 4 100.0
total 126 136 92.6


line stmt bran cond sub pod time code
1             package Moose::Meta::Method::Delegation;
2             our $VERSION = '2.2206';
3              
4 390     390   2850 use strict;
  390         856  
  390         12015  
5 390     390   2042 use warnings;
  390         949  
  390         11081  
6              
7 390     390   2244 use Scalar::Util 'blessed', 'weaken';
  390         1017  
  390         20641  
8 390     390   2597 use Try::Tiny;
  390         1004  
  390         21940  
9              
10 390         2638 use parent 'Moose::Meta::Method',
11 390     390   2759 'Class::MOP::Method::Generated';
  390         1080  
12              
13 390     390   33465 use Moose::Util 'throw_exception';
  390         1100  
  390         2735  
14              
15             sub new {
16 55     55 1 811 my $class = shift;
17 55         272 my %options = @_;
18              
19             ( exists $options{attribute} )
20 55 100       177 || throw_exception( MustSupplyAnAttributeToConstructWith => params => \%options,
21             class => $class
22             );
23              
24             ( blessed( $options{attribute} )
25 54 100 66     472 && $options{attribute}->isa('Moose::Meta::Attribute') )
26             || throw_exception( MustSupplyAMooseMetaAttributeInstance => params => \%options,
27             class => $class
28             );
29              
30             ( $options{package_name} && $options{name} )
31 53 100 66     321 || throw_exception( MustSupplyPackageNameAndName => params => \%options,
32             class => $class
33             );
34              
35             ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
36 52 100 100     283 || ( 'CODE' eq ref $options{delegate_to_method} ) )
      100        
37             || throw_exception( MustSupplyADelegateToMethod => params => \%options,
38             class => $class
39             );
40              
41             exists $options{curried_arguments}
42 51 50       208 || ( $options{curried_arguments} = [] );
43              
44             ( $options{curried_arguments} &&
45 51 100 66     307 ( 'ARRAY' eq ref $options{curried_arguments} ) )
46             || throw_exception( MustSupplyArrayRefAsCurriedArguments => params => \%options,
47             class_name => $class
48             );
49              
50 50         187 my $self = $class->_new( \%options );
51              
52 50         973 weaken( $self->{'attribute'} );
53              
54 50         180 $self->_initialize_body;
55              
56 50         221 return $self;
57             }
58              
59             sub _new {
60 50     50   104 my $class = shift;
61 50 50       153 my $options = @_ == 1 ? $_[0] : {@_};
62              
63 50         134 return bless $options, $class;
64             }
65              
66 2166     2166 1 10295 sub curried_arguments { (shift)->{'curried_arguments'} }
67              
68 157     157 1 829 sub associated_attribute { (shift)->{'attribute'} }
69              
70 1951     1951 1 9065 sub delegate_to_method { (shift)->{'delegate_to_method'} }
71              
72             sub _initialize_body {
73 50     50   87 my $self = shift;
74              
75 50         180 my $method_to_call = $self->delegate_to_method;
76 50 50       135 return $self->{body} = $method_to_call
77             if ref $method_to_call;
78              
79             # We don't inline because it's faster, we do it because when the method is
80             # inlined, any errors thrown because of the delegated method have a _much_
81             # nicer stack trace, as the trace doesn't include any Moose internals.
82 50         152 $self->{body} = $self->_generate_inline_method;
83              
84 50         29934 return;
85             }
86              
87             sub _generate_inline_method {
88 50     50   85 my $self = shift;
89              
90 50         124 my $attr = $self->associated_attribute;
91 50         124 my $delegate = $self->delegate_to_method;
92              
93 50         303 my $method_name = B::perlstring( $self->name );
94 50         145 my $attr_name = B::perlstring( $self->associated_attribute->name );
95              
96 50         425 my $undefined_attr_throw = $self->_inline_throw_exception(
97             'AttributeValueIsNotDefined',
98             sprintf( <<'EOF', $method_name, $attr_name ) );
99             method => $self->meta->find_method_by_name(%s),
100             instance => $self,
101             attribute => $self->meta->find_attribute_by_name(%s),
102             EOF
103              
104 50         264 my $not_an_object_throw = $self->_inline_throw_exception(
105             'AttributeValueIsNotAnObject',
106             sprintf( <<'EOF', $method_name, $attr_name ) );
107             method => $self->meta->find_method_by_name(%s),
108             instance => $self,
109             attribute => $self->meta->find_attribute_by_name(%s),
110             given_value => $proxy,
111             EOF
112              
113 50 100       227 my $get_proxy
114             = $attr->has_read_method ? $attr->get_read_method : '$reader';
115              
116 50 100       108 my $args = @{ $self->curried_arguments } ? '@curried, @_' : '@_';
  50         141  
117 50         308 my $source = sprintf(
118             <<'EOF', $get_proxy, $undefined_attr_throw, $not_an_object_throw, $delegate, $args );
119             sub {
120             my $self = shift;
121              
122             my $proxy = $self->%s;
123             if ( !defined $proxy ) {
124             %s;
125             }
126             elsif ( ref $proxy && !Scalar::Util::blessed($proxy) ) {
127             %s;
128             }
129             return $proxy->%s( %s );
130             }
131             EOF
132              
133 50         320 my $description
134             = 'inline delegation in '
135             . $self->package_name . ' for '
136             . $attr->name . '->'
137             . $delegate;
138              
139 50         149 my $definition = $attr->definition_context;
140             # While all attributes created in the usual way (via Moose's has()) will
141             # define this, there's no guarantee that this must be defined. For
142             # example, when Moo inflates a class to Moose it does not define these (as
143             # of Moo 2.003).
144             $description .= " (attribute declared in $definition->{file} at line $definition->{line})"
145 50 100 66     389 if defined $definition->{file} && defined $definition->{line};
146              
147             return try {
148 50     50   2409 $self->_compile_code(
149             source => $source,
150             description => $description,
151             );
152             }
153             catch {
154 0     0   0 $self->_throw_exception(
155             'CouldNotGenerateInlineAttributeMethod',
156             instance => $self,
157             error => $_,
158             option => 'handles for ' . $attr->name . '->' . $delegate,
159             );
160 50         400 };
161             }
162              
163             sub _eval_environment {
164 50     50   110 my $self = shift;
165              
166 50         99 my %env;
167 50 100       79 if ( @{ $self->curried_arguments } ) {
  50         123  
168 2         12 $env{'@curried'} = $self->curried_arguments;
169             }
170              
171 50 100       137 unless ( $self->associated_attribute->has_read_method ) {
172 6         45 $env{'$reader'} = \( $self->_get_delegate_accessor );
173             }
174              
175 50         175 return \%env;
176             }
177              
178             sub _get_delegate_accessor {
179 6     6   16 my $self = shift;
180              
181 6         19 my $accessor = $self->associated_attribute->get_read_method_ref;
182              
183             # If it's blessed it's a Moose::Meta::Method
184 6 50       109 return blessed $accessor
185             ? ( $accessor->body )
186             : $accessor;
187             }
188              
189             1;
190              
191             # ABSTRACT: A Moose Method metaclass for delegation methods
192              
193             __END__
194              
195             =pod
196              
197             =encoding UTF-8
198              
199             =head1 NAME
200              
201             Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
202              
203             =head1 VERSION
204              
205             version 2.2206
206              
207             =head1 DESCRIPTION
208              
209             This is a subclass of L<Moose::Meta::Method> for delegation
210             methods.
211              
212             =head1 METHODS
213              
214             =head2 Moose::Meta::Method::Delegation->new(%options)
215              
216             This creates the delegation methods based on the provided C<%options>.
217              
218             =over 4
219              
220             =item I<attribute>
221              
222             This must be an instance of C<Moose::Meta::Attribute> which this
223             accessor is being generated for. This options is B<required>.
224              
225             =item I<delegate_to_method>
226              
227             The method in the associated attribute's value to which we
228             delegate. This can be either a method name or a code reference.
229              
230             =item I<curried_arguments>
231              
232             An array reference of arguments that will be prepended to the argument list for
233             any call to the delegating method.
234              
235             =back
236              
237             =head2 $metamethod->associated_attribute
238              
239             Returns the attribute associated with this method.
240              
241             =head2 $metamethod->curried_arguments
242              
243             Return any curried arguments that will be passed to the delegated method.
244              
245             =head2 $metamethod->delegate_to_method
246              
247             Returns the method to which this method delegates, as passed to the
248             constructor.
249              
250             =head1 BUGS
251              
252             See L<Moose/BUGS> for details on reporting bugs.
253              
254             =head1 AUTHORS
255              
256             =over 4
257              
258             =item *
259              
260             Stevan Little <stevan@cpan.org>
261              
262             =item *
263              
264             Dave Rolsky <autarch@urth.org>
265              
266             =item *
267              
268             Jesse Luehrs <doy@cpan.org>
269              
270             =item *
271              
272             Shawn M Moore <sartak@cpan.org>
273              
274             =item *
275              
276             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
277              
278             =item *
279              
280             Karen Etheridge <ether@cpan.org>
281              
282             =item *
283              
284             Florian Ragwitz <rafl@debian.org>
285              
286             =item *
287              
288             Hans Dieter Pearcey <hdp@cpan.org>
289              
290             =item *
291              
292             Chris Prather <chris@prather.org>
293              
294             =item *
295              
296             Matt S Trout <mstrout@cpan.org>
297              
298             =back
299              
300             =head1 COPYRIGHT AND LICENSE
301              
302             This software is copyright (c) 2006 by Infinity Interactive, Inc.
303              
304             This is free software; you can redistribute it and/or modify it under
305             the same terms as the Perl 5 programming language system itself.
306              
307             =cut