Use dzil Authority plugin - remove $AUTHORITY from code
[gitmo/Moose.git] / lib / Moose / Meta / Method / Delegation.pm
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
10 use base 'Moose::Meta::Method',
11          'Class::MOP::Method::Generated';
12
13
14 sub new {
15     my $class   = shift;
16     my %options = @_;
17
18     ( exists $options{attribute} )
19         || confess "You must supply an attribute to construct with";
20
21     ( blessed( $options{attribute} )
22             && $options{attribute}->isa('Moose::Meta::Attribute') )
23         || confess
24         "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";
25
26     ( $options{package_name} && $options{name} )
27         || confess
28         "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
29
30     ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
31             || ( 'CODE' eq ref $options{delegate_to_method} ) )
32         || confess
33         'You must supply a delegate_to_method which is a method name or a CODE reference';
34
35     exists $options{curried_arguments}
36         || ( $options{curried_arguments} = [] );
37
38     ( $options{curried_arguments} &&
39         ( 'ARRAY' eq ref $options{curried_arguments} ) )
40         || confess 'You must supply a curried_arguments which is an ARRAY reference';
41
42     my $self = $class->_new( \%options );
43
44     weaken( $self->{'attribute'} );
45
46     $self->_initialize_body;
47
48     return $self;
49 }
50
51 sub _new {
52     my $class = shift;
53     my $options = @_ == 1 ? $_[0] : {@_};
54
55     return bless $options, $class;
56 }
57
58 sub curried_arguments { (shift)->{'curried_arguments'} }
59
60 sub associated_attribute { (shift)->{'attribute'} }
61
62 sub delegate_to_method { (shift)->{'delegate_to_method'} }
63
64 sub _initialize_body {
65     my $self = shift;
66
67     my $method_to_call = $self->delegate_to_method;
68     return $self->{body} = $method_to_call
69         if ref $method_to_call;
70
71     my $accessor = $self->_get_delegate_accessor;
72
73     my $handle_name = $self->name;
74
75     # NOTE: we used to do a goto here, but the goto didn't handle
76     # failure correctly (it just returned nothing), so I took that
77     # out. However, the more I thought about it, the less I liked it
78     # doing the goto, and I preferred the act of delegation being
79     # actually represented in the stack trace.  - SL
80     # not inlining this, since it won't really speed things up at
81     # all... the only thing that would end up different would be
82     # interpolating in $method_to_call, and a bunch of things in the
83     # error handling that mostly never gets called - doy
84     $self->{body} = sub {
85         my $instance = shift;
86         my $proxy    = $instance->$accessor();
87
88         my $error
89             = !defined $proxy                 ? ' is not defined'
90             : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
91             : undef;
92
93         if ($error) {
94             $self->throw_error(
95                 "Cannot delegate $handle_name to $method_to_call because "
96                     . "the value of "
97                     . $self->associated_attribute->name
98                     . $error,
99                 method_name => $method_to_call,
100                 object      => $instance
101             );
102         }
103         unshift @_, @{ $self->curried_arguments };
104         $proxy->$method_to_call(@_);
105     };
106 }
107
108 sub _get_delegate_accessor {
109     my $self = shift;
110     my $attr = $self->associated_attribute;
111
112     # NOTE:
113     # always use a named method when
114     # possible, if you use the method
115     # ref and there are modifiers on
116     # the accessors then it will not
117     # pick up the modifiers too. Only
118     # the named method will assure that
119     # we also have any modifiers run.
120     # - SL
121     my $accessor = $attr->has_read_method
122         ? $attr->get_read_method
123         : $attr->get_read_method_ref;
124
125     $accessor = $accessor->body if Scalar::Util::blessed $accessor;
126
127     return $accessor;
128 }
129
130 1;
131
132 # ABSTRACT: A Moose Method metaclass for delegation methods
133
134 __END__
135
136 =pod
137
138 =head1 DESCRIPTION
139
140 This is a subclass of L<Moose::Meta::Method> for delegation
141 methods.
142
143 =head1 METHODS
144
145 =over 4
146
147 =item B<< Moose::Meta::Method::Delegation->new(%options) >>
148
149 This creates the delegation methods based on the provided C<%options>.
150
151 =over 4
152
153 =item I<attribute>
154
155 This must be an instance of C<Moose::Meta::Attribute> which this
156 accessor is being generated for. This options is B<required>.
157
158 =item I<delegate_to_method>
159
160 The method in the associated attribute's value to which we
161 delegate. This can be either a method name or a code reference.
162
163 =item I<curried_arguments>
164
165 An array reference of arguments that will be prepended to the argument list for
166 any call to the delegating method.
167
168 =back
169
170 =item B<< $metamethod->associated_attribute >>
171
172 Returns the attribute associated with this method.
173
174 =item B<< $metamethod->curried_arguments >>
175
176 Return any curried arguments that will be passed to the delegated method.
177
178 =item B<< $metamethod->delegate_to_method >>
179
180 Returns the method to which this method delegates, as passed to the
181 constructor.
182
183 =back
184
185 =head1 BUGS
186
187 See L<Moose/BUGS> for details on reporting bugs.
188
189 =cut