Commit | Line | Data |
8b978dd5 |
1 | |
2 | package Class::MOP::Method; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
2eb717d5 |
7 | use Carp 'confess'; |
3ea3a033 |
8 | use Scalar::Util 'weaken', 'reftype'; |
2eb717d5 |
9 | |
074ec38f |
10 | our $VERSION = '0.89'; |
d519662a |
11 | $VERSION = eval $VERSION; |
f0480c45 |
12 | our $AUTHORITY = 'cpan:STEVAN'; |
de19f115 |
13 | |
b1897d4d |
14 | use base 'Class::MOP::Object'; |
15 | |
ce2ae40f |
16 | # NOTE: |
32202ce2 |
17 | # if poked in the right way, |
ce2ae40f |
18 | # they should act like CODE refs. |
c23184fc |
19 | use overload '&{}' => sub { $_[0]->body }, fallback => 1; |
7855ddba |
20 | |
de19f115 |
21 | # construction |
22 | |
32202ce2 |
23 | sub wrap { |
5caf45ce |
24 | my ( $class, @args ) = @_; |
25 | |
26 | unshift @args, 'body' if @args % 2 == 1; |
27 | |
28 | my %params = @args; |
29 | my $code = $params{body}; |
32202ce2 |
30 | |
3ea3a033 |
31 | (ref $code && 'CODE' eq reftype($code)) |
4d47b77f |
32 | || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; |
32202ce2 |
33 | |
b38f3848 |
34 | ($params{package_name} && $params{name}) |
e7cfb28b |
35 | || confess "You must supply the package_name and name parameters"; |
32202ce2 |
36 | |
c2829bbc |
37 | my $self = $class->_new(\%params); |
5e607260 |
38 | |
39 | weaken($self->{associated_metaclass}) if $self->{associated_metaclass}; |
40 | |
41 | return $self; |
de19f115 |
42 | } |
43 | |
71b98d4f |
44 | sub _new { |
0bfc85b8 |
45 | my $class = shift; |
46 | my $params = @_ == 1 ? $_[0] : {@_}; |
71b98d4f |
47 | |
48 | my $self = bless { |
0bfc85b8 |
49 | 'body' => $params->{body}, |
50 | 'associated_metaclass' => $params->{associated_metaclass}, |
51 | 'package_name' => $params->{package_name}, |
52 | 'name' => $params->{name}, |
71b98d4f |
53 | } => $class; |
54 | } |
55 | |
ce2ae40f |
56 | ## accessors |
57 | |
5e607260 |
58 | sub associated_metaclass { shift->{'associated_metaclass'} } |
b1897d4d |
59 | |
3cf189f3 |
60 | sub _is_valid_generation{ |
61 | my($self) = @_; |
62 | my $metaclass = $self->associated_metaclass; |
63 | |
64 | if($metaclass){ |
65 | return( ($self->{_generation} || 0) == Class::MOP::check_package_cache_flag($metaclass->name) ); |
66 | } |
67 | else{ |
68 | return 1; |
69 | } |
70 | } |
71 | |
72 | sub _update_generation { |
73 | my($self) = @_; |
74 | my $metaclass = $self->associated_metaclass |
75 | or confess("No metaclass associated to the method " . $self->name); |
76 | $self->{_generation} = Class::MOP::check_package_cache_flag($metaclass->name); |
77 | } |
78 | |
5e607260 |
79 | sub attach_to_class { |
80 | my ( $self, $class ) = @_; |
81 | $self->{associated_metaclass} = $class; |
82 | weaken($self->{associated_metaclass}); |
83 | } |
84 | |
85 | sub detach_from_class { |
86 | my $self = shift; |
87 | delete $self->{associated_metaclass}; |
88 | } |
de19f115 |
89 | |
96ceced8 |
90 | sub fully_qualified_name { |
91b73829 |
91 | my $self = shift; |
92 | $self->package_name . '::' . $self->name; |
96ceced8 |
93 | } |
94 | |
2226a8b0 |
95 | sub original_method { (shift)->{'original_method'} } |
96 | |
97 | sub _set_original_method { $_[0]->{'original_method'} = $_[1] } |
98 | |
99 | # It's possible that this could cause a loop if there is a circular |
100 | # reference in here. That shouldn't ever happen in normal |
101 | # circumstances, since original method only gets set when clone is |
102 | # called. We _could_ check for such a loop, but it'd involve some sort |
103 | # of package-lexical variable, and wouldn't be terribly subclassable. |
104 | sub original_package_name { |
105 | my $self = shift; |
106 | |
107 | $self->original_method |
108 | ? $self->original_method->original_package_name |
109 | : $self->package_name; |
110 | } |
111 | |
112 | sub original_name { |
113 | my $self = shift; |
114 | |
115 | $self->original_method |
116 | ? $self->original_method->original_name |
117 | : $self->name; |
118 | } |
119 | |
120 | sub original_fully_qualified_name { |
121 | my $self = shift; |
122 | |
123 | $self->original_method |
124 | ? $self->original_method->original_fully_qualified_name |
125 | : $self->fully_qualified_name; |
126 | } |
127 | |
25a5f083 |
128 | sub execute { |
129 | my $self = shift; |
130 | $self->body->(@_); |
131 | } |
132 | |
4c105333 |
133 | # NOTE: |
134 | # the Class::MOP bootstrap |
135 | # will create this for us |
136 | # - SL |
137 | # sub clone { ... } |
138 | |
8b978dd5 |
139 | 1; |
140 | |
141 | __END__ |
142 | |
143 | =pod |
144 | |
32202ce2 |
145 | =head1 NAME |
8b978dd5 |
146 | |
147 | Class::MOP::Method - Method Meta Object |
148 | |
8b978dd5 |
149 | =head1 DESCRIPTION |
150 | |
32202ce2 |
151 | The Method Protocol is very small, since methods in Perl 5 are just |
8a0b1202 |
152 | subroutines in a specific package. We provide a very basic |
86482605 |
153 | introspection interface. |
fe122940 |
154 | |
2eb717d5 |
155 | =head1 METHODS |
156 | |
de19f115 |
157 | =over 4 |
fe122940 |
158 | |
8a0b1202 |
159 | =item B<< Class::MOP::Method->wrap($code, %options) >> |
2eb717d5 |
160 | |
8a0b1202 |
161 | This is the constructor. It accepts a subroutine reference and a hash |
162 | of options. |
fe122940 |
163 | |
8a0b1202 |
164 | The options are: |
2eb717d5 |
165 | |
8a0b1202 |
166 | =over 8 |
de19f115 |
167 | |
8a0b1202 |
168 | =item * name |
169 | |
170 | The method name (without a package name). This is required. |
de19f115 |
171 | |
8a0b1202 |
172 | =item * package_name |
127d39a7 |
173 | |
8a0b1202 |
174 | The package name for the method. This is required. |
4c105333 |
175 | |
8a0b1202 |
176 | =item * associated_metaclass |
4c105333 |
177 | |
8a0b1202 |
178 | An optional L<Class::MOP::Class> object. This is the metaclass for the |
179 | method's class. |
de19f115 |
180 | |
de19f115 |
181 | =back |
182 | |
8a0b1202 |
183 | =item B<< $metamethod->clone(%params) >> |
de19f115 |
184 | |
8a0b1202 |
185 | This makes a shallow clone of the method object. In particular, |
186 | subroutine reference itself is shared between all clones of a given |
187 | method. |
188 | |
189 | When a method is cloned, the original method object will be available |
190 | by calling C<original_method> on the clone. |
de19f115 |
191 | |
8a0b1202 |
192 | =item B<< $metamethod->body >> |
7855ddba |
193 | |
8a0b1202 |
194 | This returns a reference to the method's subroutine. |
127d39a7 |
195 | |
8a0b1202 |
196 | =item B<< $metamethod->name >> |
de19f115 |
197 | |
8a0b1202 |
198 | This returns the method's name |
127d39a7 |
199 | |
8a0b1202 |
200 | =item B<< $metamethod->package_name >> |
5e607260 |
201 | |
8a0b1202 |
202 | This returns the method's package name. |
5e607260 |
203 | |
8a0b1202 |
204 | =item B<< $metamethod->fully_qualified_name >> |
de19f115 |
205 | |
8a0b1202 |
206 | This returns the method's fully qualified name (package name and |
207 | method name). |
127d39a7 |
208 | |
8a0b1202 |
209 | =item B<< $metamethod->associated_metaclass >> |
96ceced8 |
210 | |
8a0b1202 |
211 | This returns the L<Class::MOP::Class> object for the method, if one |
212 | exists. |
127d39a7 |
213 | |
8a0b1202 |
214 | =item B<< $metamethod->original_method >> |
2226a8b0 |
215 | |
216 | If this method object was created as a clone of some other method |
217 | object, this returns the object that was cloned. |
218 | |
8a0b1202 |
219 | =item B<< $metamethod->original_name >> |
2226a8b0 |
220 | |
8a0b1202 |
221 | This returns the method's original name, wherever it was first |
222 | defined. |
2226a8b0 |
223 | |
2f011227 |
224 | If this method is a clone of a clone (of a clone, etc.), this method |
225 | returns the name from the I<first> method in the chain of clones. |
226 | |
8a0b1202 |
227 | =item B<< $metamethod->original_package_name >> |
2226a8b0 |
228 | |
8a0b1202 |
229 | This returns the method's original package name, wherever it was first |
230 | defined. |
2226a8b0 |
231 | |
2f011227 |
232 | If this method is a clone of a clone (of a clone, etc.), this method |
233 | returns the package name from the I<first> method in the chain of |
234 | clones. |
235 | |
8a0b1202 |
236 | =item B<< $metamethod->original_fully_qualified_name >> |
2226a8b0 |
237 | |
8a0b1202 |
238 | This returns the method's original fully qualified name, wherever it |
239 | was first defined. |
2226a8b0 |
240 | |
2f011227 |
241 | If this method is a clone of a clone (of a clone, etc.), this method |
242 | returns the fully qualified name from the I<first> method in the chain |
243 | of clones. |
244 | |
8a0b1202 |
245 | =item B<< $metamethod->attach_to_class($metaclass) >> |
96ceced8 |
246 | |
8a0b1202 |
247 | Given a L<Class::MOP::Class> object, this method sets the associated |
248 | metaclass for the method. This will overwrite any existing associated |
249 | metaclass. |
5e607260 |
250 | |
8a0b1202 |
251 | =item B<< $metamethod->detach_from_class >> |
5e607260 |
252 | |
8a0b1202 |
253 | Removes any associated metaclass object for the method. |
5e607260 |
254 | |
8a0b1202 |
255 | =item B<< $metamethod->execute(...) >> |
5e607260 |
256 | |
8a0b1202 |
257 | This executes the method. Any arguments provided will be passed on to |
258 | the method itself. |
25a5f083 |
259 | |
8a0b1202 |
260 | =item B<< Class::MOP::Method->meta >> |
25a5f083 |
261 | |
8a0b1202 |
262 | This will return a L<Class::MOP::Class> instance for this class. |
25a5f083 |
263 | |
8a0b1202 |
264 | It should also be noted that L<Class::MOP> will actually bootstrap |
265 | this module by installing a number of attribute meta-objects into its |
266 | metaclass. |
25a5f083 |
267 | |
268 | =back |
269 | |
1a09d9cc |
270 | =head1 AUTHORS |
8b978dd5 |
271 | |
a2e85e6c |
272 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
8b978dd5 |
273 | |
274 | =head1 COPYRIGHT AND LICENSE |
275 | |
070bb6c9 |
276 | Copyright 2006-2009 by Infinity Interactive, Inc. |
8b978dd5 |
277 | |
278 | L<http://www.iinteractive.com> |
279 | |
280 | This library is free software; you can redistribute it and/or modify |
32202ce2 |
281 | it under the same terms as Perl itself. |
8b978dd5 |
282 | |
16e960bd |
283 | =cut |
284 | |