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