File | /usr/local/lib/perl/5.10.0/Moose/Meta/Method/Delegation.pm |
Statements Executed | 19 |
Total Time | 0.0008446 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN | Moose::Meta::Method::Delegation::
0 | 0 | 0 | 0s | 0s | __ANON__[:109] | Moose::Meta::Method::Delegation::
0 | 0 | 0 | 0s | 0s | _get_delegate_accessor | Moose::Meta::Method::Delegation::
0 | 0 | 0 | 0s | 0s | _initialize_body | Moose::Meta::Method::Delegation::
0 | 0 | 0 | 0s | 0s | _new | Moose::Meta::Method::Delegation::
0 | 0 | 0 | 0s | 0s | associated_attribute | Moose::Meta::Method::Delegation::
0 | 0 | 0 | 0s | 0s | curried_arguments | Moose::Meta::Method::Delegation::
0 | 0 | 0 | 0s | 0s | delegate_to_method | Moose::Meta::Method::Delegation::
0 | 0 | 0 | 0s | 0s | new | Moose::Meta::Method::Delegation::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | ||||
2 | package Moose::Meta::Method::Delegation; | |||
3 | ||||
4 | 3 | 28µs | 9µs | use strict; # spent 10µs making 1 call to strict::import |
5 | 3 | 34µs | 11µs | use warnings; # spent 28µs making 1 call to warnings::import |
6 | ||||
7 | 3 | 30µs | 10µs | use Carp 'confess'; # spent 51µs making 1 call to Exporter::import |
8 | 3 | 64µs | 21µs | use Scalar::Util 'blessed', 'weaken'; # spent 48µs making 1 call to Exporter::import |
9 | ||||
10 | 1 | 800ns | 800ns | our $VERSION = '1.15'; |
11 | 1 | 27µs | 27µs | $VERSION = eval $VERSION; |
12 | 1 | 700ns | 700ns | our $AUTHORITY = 'cpan:STEVAN'; |
13 | ||||
14 | 1 | 6µs | 6µs | use base 'Moose::Meta::Method', # spent 142µs making 1 call to base::import |
15 | 2 | 651µs | 325µs | '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 | 4µs | 4µs | 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 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 |