Inline the clone method in CMOP::Method as an optimization
[gitmo/Class-MOP.git] / lib / Class / MOP / Mixin / HasMethods.pm
1 package Class::MOP::Mixin::HasMethods;
2
3 use strict;
4 use warnings;
5
6 our $VERSION   = '1.04';
7 $VERSION = eval $VERSION;
8 our $AUTHORITY = 'cpan:STEVAN';
9
10 use Scalar::Util 'blessed';
11 use Carp         'confess';
12 use Sub::Name    'subname';
13
14 use base 'Class::MOP::Mixin';
15
16 sub method_metaclass         { $_[0]->{'method_metaclass'}            }
17 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'}    }
18
19 # This doesn't always get initialized in a constructor because there is a
20 # weird object construction path for subclasses of Class::MOP::Class. At one
21 # point, this always got initialized by calling into the XS code first, but
22 # that is no longer guaranteed to happen.
23 sub _method_map { $_[0]->{'methods'} ||= {} }
24
25 sub wrap_method_body {
26     my ( $self, %args ) = @_;
27
28     ( 'CODE' eq ref $args{body} )
29         || confess "Your code block must be a CODE reference";
30
31     $self->method_metaclass->wrap(
32         package_name => $self->name,
33         %args,
34     );
35 }
36
37 sub add_method {
38     my ( $self, $method_name, $method ) = @_;
39     ( defined $method_name && length $method_name )
40         || confess "You must define a method name";
41
42     my $body;
43     if ( blessed($method) ) {
44         $body = $method->body;
45         if ( $method->package_name ne $self->name ) {
46             $method = $method->clone(
47                 package_name => $self->name,
48                 name         => $method_name,
49             ) if $method->can('clone');
50         }
51
52         $method->attach_to_class($self);
53     }
54     else {
55         # If a raw code reference is supplied, its method object is not created.
56         # The method object won't be created until required.
57         $body = $method;
58     }
59
60     $self->_method_map->{$method_name} = $method;
61
62     my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
63
64     if ( !defined $current_name || $current_name =~ /^__ANON__/ ) {
65         my $full_method_name = ( $self->name . '::' . $method_name );
66         subname( $full_method_name => $body );
67     }
68
69     $self->add_package_symbol(
70         { sigil => '&', type => 'CODE', name => $method_name },
71         $body,
72     );
73 }
74
75 sub _code_is_mine {
76     my ( $self, $code ) = @_;
77
78     my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
79
80     return $code_package && $code_package eq $self->name
81         || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
82 }
83
84 sub has_method {
85     my ( $self, $method_name ) = @_;
86
87     ( defined $method_name && length $method_name )
88         || confess "You must define a method name";
89
90     return defined( $self->get_method($method_name) );
91 }
92
93 sub get_method {
94     my ( $self, $method_name ) = @_;
95
96     ( defined $method_name && length $method_name )
97         || confess "You must define a method name";
98
99     my $method_map = $self->_method_map;
100     my $map_entry  = $method_map->{$method_name};
101     my $code       = $self->get_package_symbol(
102         {
103             name  => $method_name,
104             sigil => '&',
105             type  => 'CODE',
106         }
107     );
108
109     # This seems to happen in some weird cases where methods modifiers are
110     # added via roles or some other such bizareness. Honestly, I don't totally
111     # understand this, but returning the entry works, and keeps various MX
112     # modules from blowing up. - DR
113     return $map_entry
114         if blessed $map_entry && ( !$code || $map_entry->body == $code );
115
116     unless ($map_entry) {
117         return unless $code && $self->_code_is_mine($code);
118     }
119
120     $code ||= $map_entry;
121
122     return $method_map->{$method_name} = $self->wrap_method_body(
123         body                 => $code,
124         name                 => $method_name,
125         associated_metaclass => $self,
126     );
127 }
128
129 sub remove_method {
130     my ( $self, $method_name ) = @_;
131     ( defined $method_name && length $method_name )
132         || confess "You must define a method name";
133
134     my $removed_method = delete $self->_full_method_map->{$method_name};
135
136     $self->remove_package_symbol(
137         { sigil => '&', type => 'CODE', name => $method_name } );
138
139     $removed_method->detach_from_class
140         if $removed_method && blessed $removed_method;
141
142     # still valid, since we just removed the method from the map
143     $self->update_package_cache_flag;
144
145     return $removed_method;
146 }
147
148 sub get_method_list {
149     my $self = shift;
150     return grep { $self->has_method($_) } keys %{ $self->namespace };
151 }
152
153 1;
154
155 __END__
156
157 =pod
158
159 =head1 NAME
160
161 Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
162
163 =head1 DESCRIPTION
164
165 This class implements methods for metaclasses which have methods
166 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
167 for API details.
168
169 =head1 AUTHORS
170
171 Dave Rolsky E<lt>autarch@urth.orgE<gt>
172
173 =head1 COPYRIGHT AND LICENSE
174
175 Copyright 2006-2010 by Infinity Interactive, Inc.
176
177 L<http://www.iinteractive.com>
178
179 This library is free software; you can redistribute it and/or modify
180 it under the same terms as Perl itself.
181
182 =cut