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