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