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