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 | |
75d2da34 |
10 | our $VERSION = '0.77'; |
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 | |
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 |
48 | sub _new { |
49 | my $class = shift; |
50 | my $options = @_ == 1 ? $_[0] : {@_}; |
51 | |
52 | return bless $options, $class; |
53 | } |
54 | |
55 | sub associated_attribute { (shift)->{'attribute'} } |
56 | |
46f7e6a5 |
57 | sub delegate_to_method { (shift)->{'delegate_to_method'} } |
58 | |
59 | sub _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 |
5120f8ff |
75 | # not inlining this, since it won't really speed things up at |
76 | # all... the only thing that would end up different would be |
77 | # interpolating in $method_to_call, and a bunch of things in the |
78 | # error handling that mostly never gets called - doy |
46f7e6a5 |
79 | $self->{body} = sub { |
80 | my $instance = shift; |
81 | my $proxy = $instance->$accessor(); |
82 | ( defined $proxy ) |
83 | || $self->throw_error( |
84 | "Cannot delegate $handle_name to $method_to_call because " |
85 | . "the value of " |
4da72c45 |
86 | . $self->associated_attribute->name |
46f7e6a5 |
87 | . " is not defined", |
88 | method_name => $method_to_call, |
89 | object => $instance |
90 | ); |
91 | $proxy->$method_to_call(@_); |
92 | }; |
93 | } |
94 | |
95 | sub _get_delegate_accessor { |
96 | my $self = shift; |
97 | |
98 | my $accessor = $self->associated_attribute->get_read_method_ref; |
99 | |
100 | $accessor = $accessor->body if blessed $accessor; |
101 | |
102 | return $accessor; |
103 | } |
104 | |
a05f85c1 |
105 | 1; |
01cd78f8 |
106 | |
107 | __END__ |
108 | |
109 | =pod |
110 | |
111 | =head1 NAME |
112 | |
113 | Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods |
114 | |
115 | =head1 DESCRIPTION |
116 | |
117 | This is a subclass of L<Moose::Meta::Method> for delegation |
118 | methods. |
119 | |
120 | =head1 METHODS |
121 | |
122 | =over 4 |
123 | |
e6fb6ad2 |
124 | =item B<< Moose::Meta::Method::Delegation->new(%options) >> |
01cd78f8 |
125 | |
e6fb6ad2 |
126 | This creates the delegation methods based on the provided C<%options>. |
01cd78f8 |
127 | |
128 | =over 4 |
129 | |
130 | =item I<attribute> |
131 | |
132 | This must be an instance of C<Moose::Meta::Attribute> which this |
e6fb6ad2 |
133 | accessor is being generated for. This options is B<required>. |
01cd78f8 |
134 | |
46f7e6a5 |
135 | =item I<delegate_to_method> |
136 | |
137 | The method in the associated attribute's value to which we |
138 | delegate. This can be either a method name or a code reference. |
139 | |
01cd78f8 |
140 | =back |
141 | |
e6fb6ad2 |
142 | =item B<< $metamethod->associated_attribute >> |
01cd78f8 |
143 | |
144 | Returns the attribute associated with this method. |
145 | |
e6fb6ad2 |
146 | =item B<< $metamethod->delegate_to_method >> |
46f7e6a5 |
147 | |
e6fb6ad2 |
148 | Returns the method to which this method delegates, as passed to the |
149 | constructor. |
46f7e6a5 |
150 | |
01cd78f8 |
151 | =back |
152 | |
153 | =head1 BUGS |
154 | |
d03bd989 |
155 | All complex software has bugs lurking in it, and this module is no |
01cd78f8 |
156 | exception. If you find a bug please either email me, or add the bug |
157 | to cpan-RT. |
158 | |
159 | =head1 AUTHOR |
160 | |
161 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
162 | |
163 | =head1 COPYRIGHT AND LICENSE |
164 | |
2840a3b2 |
165 | Copyright 2009 by Infinity Interactive, Inc. |
01cd78f8 |
166 | |
167 | L<http://www.iinteractive.com> |
168 | |
169 | This library is free software; you can redistribute it and/or modify |
170 | it under the same terms as Perl itself. |
171 | |
172 | =cut |