lib/Class/MOP/Mixin/HasMethods.pm

   1 package Class::MOP::Mixin::HasMethods;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Class::MOP::Method::Meta;
   7 use Class::MOP::Method::Overload;
   8
   9 use Scalar::Util 'blessed';
  10 use Carp         'confess';
  11 use Sub::Name    'subname';
  12
  13 use overload ();
  14
  15 use base 'Class::MOP::Mixin';
  16
  17 sub _meta_method_class { 'Class::MOP::Method::Meta' }
  18
  19 sub _add_meta_method {
  20     my $self = shift;
  21     my ($name) = @_;
  22     my $existing_method = $self->can('find_method_by_name')
  23                               ? $self->find_method_by_name($name)
  24                               : $self->get_method($name);
  25     return if $existing_method
  26            && $existing_method->isa($self->_meta_method_class);
  27     $self->add_method(
  28         $name => $self->_meta_method_class->wrap(
  29             name                 => $name,
  30             package_name         => $self->name,
  31             associated_metaclass => $self,
  32         )
  33     );
  34 }
  35
  36 sub wrap_method_body {
  37     my ( $self, %args ) = @_;
  38
  39     ( 'CODE' eq ref $args{body} )
  40         || confess "Your code block must be a CODE reference";
  41
  42     $self->method_metaclass->wrap(
  43         package_name => $self->name,
  44         %args,
  45     );
  46 }
  47
  48 sub add_method {
  49     my ( $self, $method_name, $method ) = @_;
  50     ( defined $method_name && length $method_name )
  51         || confess "You must define a method name";
  52
  53     my $package_name = $self->name;
  54
  55     my $body;
  56     if ( blessed($method) ) {
  57         $body = $method->body;
  58         if ( $method->package_name ne $package_name ) {
  59             $method = $method->clone(
  60                 package_name => $package_name,
  61                 name         => $method_name,
  62             );
  63         }
  64
  65         $method->attach_to_class($self);
  66     }
  67     else {
  68         # If a raw code reference is supplied, its method object is not created.
  69         # The method object won't be created until required.
  70         $body = $method;
  71     }
  72
  73     $self->_method_map->{$method_name} = $method;
  74
  75     my ($current_package, $current_name) = Class::MOP::get_code_info($body);
  76
  77     subname($package_name . '::' . $method_name, $body)
  78         unless defined $current_name && $current_name !~ /^__ANON__/;
  79
  80     $self->add_package_symbol("&$method_name", $body);
  81
  82     # we added the method to the method map too, so it's still valid
  83     $self->update_package_cache_flag;
  84 }
  85
  86 sub _code_is_mine {
  87     my ( $self, $code ) = @_;
  88
  89     my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
  90
  91     return ( $code_package && $code_package eq $self->name )
  92         || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
  93 }
  94
  95 sub has_method {
  96     my ( $self, $method_name ) = @_;
  97
  98     ( defined $method_name && length $method_name )
  99         || confess "You must define a method name";
 100
 101     my $method = $self->_get_maybe_raw_method($method_name)
 102         or return;
 103
 104     return defined($self->_method_map->{$method_name} = $method);
 105 }
 106
 107 sub get_method {
 108     my ( $self, $method_name ) = @_;
 109
 110     ( defined $method_name && length $method_name )
 111         || confess "You must define a method name";
 112
 113     my $method = $self->_get_maybe_raw_method($method_name)
 114         or return;
 115
 116     return $method if blessed $method;
 117
 118     return $self->_method_map->{$method_name} = $self->wrap_method_body(
 119         body                 => $method,
 120         name                 => $method_name,
 121         associated_metaclass => $self,
 122     );
 123 }
 124
 125 sub _get_maybe_raw_method {
 126     my ( $self, $method_name ) = @_;
 127
 128     my $map_entry = $self->_method_map->{$method_name};
 129     return $map_entry if defined $map_entry;
 130
 131     my $code = $self->get_package_symbol("&$method_name");
 132
 133     return unless $code && $self->_code_is_mine($code);
 134
 135     return $code;
 136 }
 137
 138 sub remove_method {
 139     my ( $self, $method_name ) = @_;
 140
 141     ( defined $method_name && length $method_name )
 142         || confess "You must define a method name";
 143
 144     my $removed_method = delete $self->_method_map->{$method_name};
 145
 146     $self->remove_package_symbol("&$method_name");
 147
 148     $removed_method->detach_from_class
 149         if blessed($removed_method);
 150
 151     # still valid, since we just removed the method from the map
 152     $self->update_package_cache_flag;
 153
 154     return $removed_method;
 155 }
 156
 157 sub get_method_list {
 158     my $self = shift;
 159
 160     return keys %{ $self->_full_method_map };
 161 }
 162
 163 sub _get_local_methods {
 164     my $self = shift;
 165
 166     return values %{ $self->_full_method_map };
 167 }
 168
 169 sub _restore_metamethods_from {
 170     my $self = shift;
 171     my ($old_meta) = @_;
 172
 173     for my $method ($old_meta->_get_local_methods) {
 174         $method->_make_compatible_with($self->method_metaclass);
 175         $self->add_method($method->name => $method);
 176     }
 177 }
 178
 179 sub reset_package_cache_flag  { (shift)->{'_package_cache_flag'} = undef }
 180 sub update_package_cache_flag {
 181     my $self = shift;
 182     # NOTE:
 183     # we can manually update the cache number
 184     # since we are actually adding the method
 185     # to our cache as well. This avoids us
 186     # having to regenerate the method_map.
 187     # - SL
 188     $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
 189 }
 190
 191 sub _full_method_map {
 192     my $self = shift;
 193
 194     my $pkg_gen = Class::MOP::check_package_cache_flag($self->name);
 195
 196     if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) {
 197         # forcibly reify all method map entries
 198         $self->get_method($_)
 199             for $self->list_all_package_symbols('CODE');
 200         $self->{_package_cache_flag_full} = $pkg_gen;
 201     }
 202
 203     return $self->_method_map;
 204 }
 205
 206 # overloading
 207
 208 my $overload_operators;
 209 sub overload_operators {
 210     $overload_operators ||= [map { split /\s+/ } values %overload::ops];
 211     return @$overload_operators;
 212 }
 213
 214 sub is_overloaded {
 215     my $self = shift;
 216     return overload::Overloaded($self->name);
 217 }
 218
 219 # XXX this could probably stand to be cached, but i figure it should be
 220 # uncommon enough to not particularly matter
 221 sub _overload_map {
 222     my $self = shift;
 223
 224     return {} unless $self->is_overloaded;
 225
 226     my %map;
 227     for my $op ($self->overload_operators) {
 228         my $body = $self->_get_overloaded_operator_body($op);
 229         next unless defined $body;
 230         $map{$op} = $body;
 231     }
 232
 233     return \%map;
 234 }
 235
 236 sub get_overload_list {
 237     my $self = shift;
 238     return keys $self->_overload_map;
 239 }
 240
 241 sub get_all_overloaded_operators {
 242     my $self = shift;
 243     my $map = $self->_overload_map;
 244     return map { $self->_wrap_overload($_, $map->{$_}) } keys $map;
 245 }
 246
 247 sub has_overloaded_operator {
 248     my $self = shift;
 249     my ($op) = @_;
 250     return defined $self->_get_overloaded_operator_body($op);
 251 }
 252
 253 sub get_overloaded_operator {
 254     my $self = shift;
 255     my ($op) = @_;
 256     my $body = $self->_get_overloaded_operator_body($op);
 257     return unless defined $body;
 258     return $self->_wrap_overload($op, $body);
 259 }
 260
 261 sub add_overloaded_operator {
 262     my $self = shift;
 263     my ($op, $body) = @_;
 264     $self->name->overload::OVERLOAD($op => $body);
 265 }
 266
 267 sub _get_overloaded_operator_body {
 268     my $self = shift;
 269     my ($op) = @_;
 270     return overload::Method($self->name, $op);
 271 }
 272
 273 sub _wrap_overload {
 274     my $self = shift;
 275     my ($op, $body) = @_;
 276     return Class::MOP::Method::Overload->wrap(
 277         operator             => $op,
 278         package_name         => $self->name,
 279         associated_metaclass => $self,
 280         body                 => $body,
 281     );
 282 }
 283
 284 1;
 285
 286 # ABSTRACT: Methods for metaclasses which have methods
 287
 288 __END__
 289
 290 =pod
 291
 292 =head1 DESCRIPTION
 293
 294 This class implements methods for metaclasses which have methods
 295 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
 296 for API details.
 297
 298 =cut