refactor load_first_existing_class
[gitmo/Class-MOP.git] / lib / Class / MOP / Method.pm
CommitLineData
8b978dd5 1
2package Class::MOP::Method;
3
4use strict;
5use warnings;
6
2eb717d5 7use Carp 'confess';
6db5c459 8use Scalar::Util 'weaken', 'reftype', 'blessed';
2eb717d5 9
f6ca0704 10our $VERSION = '0.94';
d519662a 11$VERSION = eval $VERSION;
f0480c45 12our $AUTHORITY = 'cpan:STEVAN';
de19f115 13
b1897d4d 14use 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 19use overload '&{}' => sub { $_[0]->body }, fallback => 1;
7855ddba 20
de19f115 21# construction
22
32202ce2 23sub 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 51sub _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
ce2ae40f 68## accessors
69
5e607260 70sub associated_metaclass { shift->{'associated_metaclass'} }
b1897d4d 71
5e607260 72sub attach_to_class {
73 my ( $self, $class ) = @_;
74 $self->{associated_metaclass} = $class;
75 weaken($self->{associated_metaclass});
76}
77
78sub detach_from_class {
79 my $self = shift;
80 delete $self->{associated_metaclass};
81}
de19f115 82
96ceced8 83sub fully_qualified_name {
91b73829 84 my $self = shift;
85 $self->package_name . '::' . $self->name;
96ceced8 86}
87
2226a8b0 88sub original_method { (shift)->{'original_method'} }
89
90sub _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.
97sub 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
105sub original_name {
106 my $self = shift;
107
108 $self->original_method
109 ? $self->original_method->original_name
110 : $self->name;
111}
112
113sub 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
25a5f083 121sub execute {
122 my $self = shift;
123 $self->body->(@_);
124}
125
4c105333 126# NOTE:
127# the Class::MOP bootstrap
128# will create this for us
129# - SL
130# sub clone { ... }
131
8b978dd5 1321;
133
134__END__
135
136=pod
137
32202ce2 138=head1 NAME
8b978dd5 139
140Class::MOP::Method - Method Meta Object
141
8b978dd5 142=head1 DESCRIPTION
143
32202ce2 144The Method Protocol is very small, since methods in Perl 5 are just
8a0b1202 145subroutines in a specific package. We provide a very basic
86482605 146introspection interface.
fe122940 147
2eb717d5 148=head1 METHODS
149
de19f115 150=over 4
fe122940 151
8a0b1202 152=item B<< Class::MOP::Method->wrap($code, %options) >>
2eb717d5 153
9fd0e686 154This is the constructor. It accepts a method body in the form of
155either a code reference or a L<Class::MOP::Method> instance, followed
156by a hash of options.
fe122940 157
8a0b1202 158The options are:
2eb717d5 159
8a0b1202 160=over 8
de19f115 161
8a0b1202 162=item * name
163
9fd0e686 164The method name (without a package name). This is required if C<$code>
165is a coderef.
de19f115 166
8a0b1202 167=item * package_name
127d39a7 168
9fd0e686 169The package name for the method. This is required if C<$code> is a
170coderef.
4c105333 171
8a0b1202 172=item * associated_metaclass
4c105333 173
8a0b1202 174An optional L<Class::MOP::Class> object. This is the metaclass for the
175method's class.
de19f115 176
de19f115 177=back
178
8a0b1202 179=item B<< $metamethod->clone(%params) >>
de19f115 180
8a0b1202 181This makes a shallow clone of the method object. In particular,
182subroutine reference itself is shared between all clones of a given
183method.
184
185When a method is cloned, the original method object will be available
186by calling C<original_method> on the clone.
de19f115 187
8a0b1202 188=item B<< $metamethod->body >>
7855ddba 189
8a0b1202 190This returns a reference to the method's subroutine.
127d39a7 191
8a0b1202 192=item B<< $metamethod->name >>
de19f115 193
8a0b1202 194This returns the method's name
127d39a7 195
8a0b1202 196=item B<< $metamethod->package_name >>
5e607260 197
8a0b1202 198This returns the method's package name.
5e607260 199
8a0b1202 200=item B<< $metamethod->fully_qualified_name >>
de19f115 201
8a0b1202 202This returns the method's fully qualified name (package name and
203method name).
127d39a7 204
8a0b1202 205=item B<< $metamethod->associated_metaclass >>
96ceced8 206
8a0b1202 207This returns the L<Class::MOP::Class> object for the method, if one
208exists.
127d39a7 209
8a0b1202 210=item B<< $metamethod->original_method >>
2226a8b0 211
212If this method object was created as a clone of some other method
213object, this returns the object that was cloned.
214
8a0b1202 215=item B<< $metamethod->original_name >>
2226a8b0 216
8a0b1202 217This returns the method's original name, wherever it was first
218defined.
2226a8b0 219
2f011227 220If this method is a clone of a clone (of a clone, etc.), this method
221returns the name from the I<first> method in the chain of clones.
222
8a0b1202 223=item B<< $metamethod->original_package_name >>
2226a8b0 224
8a0b1202 225This returns the method's original package name, wherever it was first
226defined.
2226a8b0 227
2f011227 228If this method is a clone of a clone (of a clone, etc.), this method
229returns the package name from the I<first> method in the chain of
230clones.
231
8a0b1202 232=item B<< $metamethod->original_fully_qualified_name >>
2226a8b0 233
8a0b1202 234This returns the method's original fully qualified name, wherever it
235was first defined.
2226a8b0 236
2f011227 237If this method is a clone of a clone (of a clone, etc.), this method
238returns the fully qualified name from the I<first> method in the chain
239of clones.
240
8a0b1202 241=item B<< $metamethod->attach_to_class($metaclass) >>
96ceced8 242
8a0b1202 243Given a L<Class::MOP::Class> object, this method sets the associated
244metaclass for the method. This will overwrite any existing associated
245metaclass.
5e607260 246
8a0b1202 247=item B<< $metamethod->detach_from_class >>
5e607260 248
8a0b1202 249Removes any associated metaclass object for the method.
5e607260 250
8a0b1202 251=item B<< $metamethod->execute(...) >>
5e607260 252
8a0b1202 253This executes the method. Any arguments provided will be passed on to
254the method itself.
25a5f083 255
8a0b1202 256=item B<< Class::MOP::Method->meta >>
25a5f083 257
8a0b1202 258This will return a L<Class::MOP::Class> instance for this class.
25a5f083 259
8a0b1202 260It should also be noted that L<Class::MOP> will actually bootstrap
261this module by installing a number of attribute meta-objects into its
262metaclass.
25a5f083 263
264=back
265
1a09d9cc 266=head1 AUTHORS
8b978dd5 267
a2e85e6c 268Stevan Little E<lt>stevan@iinteractive.comE<gt>
8b978dd5 269
270=head1 COPYRIGHT AND LICENSE
271
070bb6c9 272Copyright 2006-2009 by Infinity Interactive, Inc.
8b978dd5 273
274L<http://www.iinteractive.com>
275
276This library is free software; you can redistribute it and/or modify
32202ce2 277it under the same terms as Perl itself.
8b978dd5 278
16e960bd 279=cut
280