error message for failed delegation should use the attribute name, not the delegate...
[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
d344c3fe 10our $VERSION = '0.68';
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
46f7e6a5 39 my $self = $class->_new( \%options );
40
41 weaken( $self->{'attribute'} );
42
43 $self->_initialize_body;
a05f85c1 44
45 return $self;
46}
47
01cd78f8 48sub _new {
49 my $class = shift;
50 my $options = @_ == 1 ? $_[0] : {@_};
51
52 return bless $options, $class;
53}
54
55sub associated_attribute { (shift)->{'attribute'} }
56
46f7e6a5 57sub delegate_to_method { (shift)->{'delegate_to_method'} }
58
59sub _initialize_body {
60 my $self = shift;
61
62 my $method_to_call = $self->delegate_to_method;
63 return $self->{body} = $method_to_call
64 if ref $method_to_call;
65
66 my $accessor = $self->_get_delegate_accessor;
67
68 my $handle_name = $self->name;
69
70 # NOTE: we used to do a goto here, but the goto didn't handle
71 # failure correctly (it just returned nothing), so I took that
72 # out. However, the more I thought about it, the less I liked it
73 # doing the goto, and I prefered the act of delegation being
74 # actually represented in the stack trace. - SL
75 $self->{body} = sub {
76 my $instance = shift;
77 my $proxy = $instance->$accessor();
78 ( defined $proxy )
79 || $self->throw_error(
80 "Cannot delegate $handle_name to $method_to_call because "
81 . "the value of "
4da72c45 82 . $self->associated_attribute->name
46f7e6a5 83 . " is not defined",
84 method_name => $method_to_call,
85 object => $instance
86 );
87 $proxy->$method_to_call(@_);
88 };
89}
90
91sub _get_delegate_accessor {
92 my $self = shift;
93
94 my $accessor = $self->associated_attribute->get_read_method_ref;
95
96 $accessor = $accessor->body if blessed $accessor;
97
98 return $accessor;
99}
100
a05f85c1 1011;
01cd78f8 102
103__END__
104
105=pod
106
107=head1 NAME
108
109Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
110
111=head1 DESCRIPTION
112
113This is a subclass of L<Moose::Meta::Method> for delegation
114methods.
115
116=head1 METHODS
117
118=over 4
119
120=item B<new (%options)>
121
122This creates the method based on the criteria in C<%options>,
123these options are:
124
125=over 4
126
127=item I<attribute>
128
129This must be an instance of C<Moose::Meta::Attribute> which this
6549b0d1 130accessor is being generated for. This parameter is B<required>.
01cd78f8 131
46f7e6a5 132=item I<delegate_to_method>
133
134The method in the associated attribute's value to which we
135delegate. This can be either a method name or a code reference.
136
01cd78f8 137=back
138
139=item B<associated_attribute>
140
141Returns the attribute associated with this method.
142
46f7e6a5 143=item B<delegate_to_method>
144
145Returns the method to which this method delegates.
146
01cd78f8 147=back
148
149=head1 BUGS
150
151All complex software has bugs lurking in it, and this module is no
152exception. If you find a bug please either email me, or add the bug
153to cpan-RT.
154
155=head1 AUTHOR
156
157Dave Rolsky E<lt>autarch@urth.orgE<gt>
158
159=head1 COPYRIGHT AND LICENSE
160
2840a3b2 161Copyright 2009 by Infinity Interactive, Inc.
01cd78f8 162
163L<http://www.iinteractive.com>
164
165This library is free software; you can redistribute it and/or modify
166it under the same terms as Perl itself.
167
168=cut