bump version to 1.09
[gitmo/Moose.git] / lib / Moose / Meta / Method / Delegation.pm
CommitLineData
a05f85c1 1
2package Moose::Meta::Method::Delegation;
3
4use strict;
5use warnings;
6
7use Carp 'confess';
8use Scalar::Util 'blessed', 'weaken';
9
60f08160 10our $VERSION = '1.09';
a05f85c1 11$VERSION = eval $VERSION;
12our $AUTHORITY = 'cpan:STEVAN';
13
01164604 14use base 'Moose::Meta::Method',
15 'Class::MOP::Method::Generated';
a05f85c1 16
17
18sub 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
4adb0e7b 39 exists $options{curried_arguments}
40 || ( $options{curried_arguments} = [] );
2de18801 41
4adb0e7b 42 ( $options{curried_arguments} &&
43 ( 'ARRAY' eq ref $options{curried_arguments} ) )
44 || confess 'You must supply a curried_arguments which is an ARRAY reference';
2de18801 45
46f7e6a5 46 my $self = $class->_new( \%options );
47
48 weaken( $self->{'attribute'} );
49
50 $self->_initialize_body;
a05f85c1 51
52 return $self;
53}
54
01cd78f8 55sub _new {
56 my $class = shift;
57 my $options = @_ == 1 ? $_[0] : {@_};
58
59 return bless $options, $class;
60}
61
2de18801 62sub curried_arguments { (shift)->{'curried_arguments'} }
63
01cd78f8 64sub associated_attribute { (shift)->{'attribute'} }
65
46f7e6a5 66sub delegate_to_method { (shift)->{'delegate_to_method'} }
67
68sub _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
16f00af3 82 # doing the goto, and I preferred the act of delegation being
46f7e6a5 83 # actually represented in the stack trace. - SL
5120f8ff 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
46f7e6a5 88 $self->{body} = sub {
89 my $instance = shift;
90 my $proxy = $instance->$accessor();
6148c167 91
92 my $error
2cc6f982 93 = !defined $proxy ? ' is not defined'
94 : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
95 : undef;
6148c167 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
46f7e6a5 105 );
6148c167 106 }
c279b82f 107 unshift @_, @{ $self->curried_arguments };
108 $proxy->$method_to_call(@_);
46f7e6a5 109 };
110}
111
112sub _get_delegate_accessor {
113 my $self = shift;
53b3e214 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;
46f7e6a5 130
131 return $accessor;
132}
133
a05f85c1 1341;
01cd78f8 135
136__END__
137
138=pod
139
140=head1 NAME
141
142Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
143
144=head1 DESCRIPTION
145
146This is a subclass of L<Moose::Meta::Method> for delegation
147methods.
148
149=head1 METHODS
150
151=over 4
152
e6fb6ad2 153=item B<< Moose::Meta::Method::Delegation->new(%options) >>
01cd78f8 154
e6fb6ad2 155This creates the delegation methods based on the provided C<%options>.
01cd78f8 156
157=over 4
158
159=item I<attribute>
160
161This must be an instance of C<Moose::Meta::Attribute> which this
e6fb6ad2 162accessor is being generated for. This options is B<required>.
01cd78f8 163
46f7e6a5 164=item I<delegate_to_method>
165
166The method in the associated attribute's value to which we
167delegate. This can be either a method name or a code reference.
168
2de18801 169=item I<curried_arguments>
170
171An array reference of arguments that will be prepended to the argument list for
172any call to the delegating method.
173
01cd78f8 174=back
175
e6fb6ad2 176=item B<< $metamethod->associated_attribute >>
01cd78f8 177
178Returns the attribute associated with this method.
179
2de18801 180=item B<< $metamethod->curried_arguments >>
181
182Return any curried arguments that will be passed to the delegated method.
183
e6fb6ad2 184=item B<< $metamethod->delegate_to_method >>
46f7e6a5 185
e6fb6ad2 186Returns the method to which this method delegates, as passed to the
187constructor.
46f7e6a5 188
01cd78f8 189=back
190
191=head1 BUGS
192
d4048ef3 193See L<Moose/BUGS> for details on reporting bugs.
01cd78f8 194
195=head1 AUTHOR
196
197Dave Rolsky E<lt>autarch@urth.orgE<gt>
198
199=head1 COPYRIGHT AND LICENSE
200
2840a3b2 201Copyright 2009 by Infinity Interactive, Inc.
01cd78f8 202
203L<http://www.iinteractive.com>
204
205This library is free software; you can redistribute it and/or modify
206it under the same terms as Perl itself.
207
208=cut