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