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