Commit | Line | Data |
a05f85c1 |
1 | |
2 | package Moose::Meta::Method::Delegation; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed', 'weaken'; |
9 | |
e6ab9ca5 |
10 | our $VERSION = '0.83'; |
a05f85c1 |
11 | $VERSION = eval $VERSION; |
12 | our $AUTHORITY = 'cpan:STEVAN'; |
13 | |
01164604 |
14 | use base 'Moose::Meta::Method', |
15 | 'Class::MOP::Method::Generated'; |
a05f85c1 |
16 | |
17 | |
18 | sub new { |
19 | my $class = shift; |
20 | my %options = @_; |
21 | |
46f7e6a5 |
22 | ( exists $options{attribute} ) |
a05f85c1 |
23 | || confess "You must supply an attribute to construct with"; |
24 | |
46f7e6a5 |
25 | ( blessed( $options{attribute} ) |
26 | && $options{attribute}->isa('Moose::Meta::Attribute') ) |
27 | || confess |
28 | "You must supply an attribute which is a 'Moose::Meta::Attribute' instance"; |
a05f85c1 |
29 | |
46f7e6a5 |
30 | ( $options{package_name} && $options{name} ) |
31 | || confess |
32 | "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; |
a05f85c1 |
33 | |
46f7e6a5 |
34 | ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} ) |
35 | || ( 'CODE' eq ref $options{delegate_to_method} ) ) |
36 | || confess |
37 | 'You must supply a delegate_to_method which is a method name or a CODE reference'; |
a05f85c1 |
38 | |
2de18801 |
39 | ( !exists $options{curried_arguments} || ( |
40 | $options{curried_arguments} && |
41 | ( 'ARRAY' eq ref $options{curried_arguments} ) |
42 | ) ) || confess |
43 | 'You must supply a curried_arguments which is an ARRAY reference'; |
44 | |
45 | $options{curried_arguments} ||= []; |
46 | |
46f7e6a5 |
47 | my $self = $class->_new( \%options ); |
48 | |
49 | weaken( $self->{'attribute'} ); |
50 | |
51 | $self->_initialize_body; |
a05f85c1 |
52 | |
53 | return $self; |
54 | } |
55 | |
01cd78f8 |
56 | sub _new { |
57 | my $class = shift; |
58 | my $options = @_ == 1 ? $_[0] : {@_}; |
59 | |
60 | return bless $options, $class; |
61 | } |
62 | |
2de18801 |
63 | sub curried_arguments { (shift)->{'curried_arguments'} } |
64 | |
01cd78f8 |
65 | sub associated_attribute { (shift)->{'attribute'} } |
66 | |
46f7e6a5 |
67 | sub delegate_to_method { (shift)->{'delegate_to_method'} } |
68 | |
69 | sub _initialize_body { |
70 | my $self = shift; |
71 | |
72 | my $method_to_call = $self->delegate_to_method; |
73 | return $self->{body} = $method_to_call |
74 | if ref $method_to_call; |
75 | |
76 | my $accessor = $self->_get_delegate_accessor; |
77 | |
78 | my $handle_name = $self->name; |
79 | |
80 | # NOTE: we used to do a goto here, but the goto didn't handle |
81 | # failure correctly (it just returned nothing), so I took that |
82 | # out. However, the more I thought about it, the less I liked it |
83 | # doing the goto, and I prefered the act of delegation being |
84 | # actually represented in the stack trace. - SL |
5120f8ff |
85 | # not inlining this, since it won't really speed things up at |
86 | # all... the only thing that would end up different would be |
87 | # interpolating in $method_to_call, and a bunch of things in the |
88 | # error handling that mostly never gets called - doy |
46f7e6a5 |
89 | $self->{body} = sub { |
90 | my $instance = shift; |
91 | my $proxy = $instance->$accessor(); |
92 | ( defined $proxy ) |
93 | || $self->throw_error( |
94 | "Cannot delegate $handle_name to $method_to_call because " |
95 | . "the value of " |
4da72c45 |
96 | . $self->associated_attribute->name |
46f7e6a5 |
97 | . " is not defined", |
98 | method_name => $method_to_call, |
99 | object => $instance |
100 | ); |
2de18801 |
101 | my @args = (@{ $self->curried_arguments }, @_); |
102 | $proxy->$method_to_call(@args); |
46f7e6a5 |
103 | }; |
104 | } |
105 | |
106 | sub _get_delegate_accessor { |
107 | my $self = shift; |
108 | |
109 | my $accessor = $self->associated_attribute->get_read_method_ref; |
110 | |
111 | $accessor = $accessor->body if blessed $accessor; |
112 | |
113 | return $accessor; |
114 | } |
115 | |
a05f85c1 |
116 | 1; |
01cd78f8 |
117 | |
118 | __END__ |
119 | |
120 | =pod |
121 | |
122 | =head1 NAME |
123 | |
124 | Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods |
125 | |
126 | =head1 DESCRIPTION |
127 | |
128 | This is a subclass of L<Moose::Meta::Method> for delegation |
129 | methods. |
130 | |
131 | =head1 METHODS |
132 | |
133 | =over 4 |
134 | |
e6fb6ad2 |
135 | =item B<< Moose::Meta::Method::Delegation->new(%options) >> |
01cd78f8 |
136 | |
e6fb6ad2 |
137 | This creates the delegation methods based on the provided C<%options>. |
01cd78f8 |
138 | |
139 | =over 4 |
140 | |
141 | =item I<attribute> |
142 | |
143 | This must be an instance of C<Moose::Meta::Attribute> which this |
e6fb6ad2 |
144 | accessor is being generated for. This options is B<required>. |
01cd78f8 |
145 | |
46f7e6a5 |
146 | =item I<delegate_to_method> |
147 | |
148 | The method in the associated attribute's value to which we |
149 | delegate. This can be either a method name or a code reference. |
150 | |
2de18801 |
151 | =item I<curried_arguments> |
152 | |
153 | An array reference of arguments that will be prepended to the argument list for |
154 | any call to the delegating method. |
155 | |
01cd78f8 |
156 | =back |
157 | |
e6fb6ad2 |
158 | =item B<< $metamethod->associated_attribute >> |
01cd78f8 |
159 | |
160 | Returns the attribute associated with this method. |
161 | |
2de18801 |
162 | =item B<< $metamethod->curried_arguments >> |
163 | |
164 | Return any curried arguments that will be passed to the delegated method. |
165 | |
e6fb6ad2 |
166 | =item B<< $metamethod->delegate_to_method >> |
46f7e6a5 |
167 | |
e6fb6ad2 |
168 | Returns the method to which this method delegates, as passed to the |
169 | constructor. |
46f7e6a5 |
170 | |
01cd78f8 |
171 | =back |
172 | |
173 | =head1 BUGS |
174 | |
d03bd989 |
175 | All complex software has bugs lurking in it, and this module is no |
01cd78f8 |
176 | exception. If you find a bug please either email me, or add the bug |
177 | to cpan-RT. |
178 | |
179 | =head1 AUTHOR |
180 | |
181 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
182 | |
183 | =head1 COPYRIGHT AND LICENSE |
184 | |
2840a3b2 |
185 | Copyright 2009 by Infinity Interactive, Inc. |
01cd78f8 |
186 | |
187 | L<http://www.iinteractive.com> |
188 | |
189 | This library is free software; you can redistribute it and/or modify |
190 | it under the same terms as Perl itself. |
191 | |
192 | =cut |