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
   8 our $VERSION   = '1.12';
   9 $VERSION = eval $VERSION;
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use Scalar::Util 'blessed';
  13 use Carp         'confess';
  14 use Sub::Name    'subname';
  15
  16 use base 'Class::MOP::Mixin';
  17
  18 sub _meta_method_class { 'Class::MOP::Method::Meta' }
  19
  20 sub _add_meta_method {
  21     my $self = shift;
  22     my ($name) = @_;
  23     my $existing_method = $self->can('find_method_by_name')
  24                               ? $self->find_method_by_name($name)
  25                               : $self->get_method($name);
  26     return if $existing_method
  27            && $existing_method->isa($self->_meta_method_class);
  28     $self->add_method(
  29         $name => $self->_meta_method_class->wrap(
  30             name                 => $name,
  31             package_name         => $self->name,
  32             associated_metaclass => $self,
  33         )
  34     );
  35 }
  36
  37 sub wrap_method_body {
  38     my ( $self, %args ) = @_;
  39
  40     ( 'CODE' eq ref $args{body} )
  41         || confess "Your code block must be a CODE reference";
  42
  43     $self->method_metaclass->wrap(
  44         package_name => $self->name,
  45         %args,
  46     );
  47 }
  48
  49 sub add_method {
  50     my ( $self, $method_name, $method ) = @_;
  51     ( defined $method_name && length $method_name )
  52         || confess "You must define a method name";
  53
  54     my $package_name = $self->name;
  55
  56     my $body;
  57     if ( blessed($method) ) {
  58         $body = $method->body;
  59         if ( $method->package_name ne $package_name ) {
  60             $method = $method->clone(
  61                 package_name => $package_name,
  62                 name         => $method_name,
  63             );
  64         }
  65
  66         $method->attach_to_class($self);
  67     }
  68     else {
  69         # If a raw code reference is supplied, its method object is not created.
  70         # The method object won't be created until required.
  71         $body = $method;
  72     }
  73
  74     $self->_method_map->{$method_name} = $method;
  75
  76     my ($current_package, $current_name) = Class::MOP::get_code_info($body);
  77
  78     subname($package_name . '::' . $method_name, $body)
  79         unless defined $current_name && $current_name !~ /^__ANON__/;
  80
  81     $self->add_package_symbol("&$method_name", $body);
  82
  83     # we added the method to the method map too, so it's still valid
  84     $self->update_package_cache_flag;
  85 }
  86
  87 sub _code_is_mine {
  88     my ( $self, $code ) = @_;
  89
  90     my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
  91
  92     return ( $code_package && $code_package eq $self->name )
  93         || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
  94 }
  95
  96 sub has_method {
  97     my ( $self, $method_name ) = @_;
  98
  99     ( defined $method_name && length $method_name )
 100         || confess "You must define a method name";
 101
 102     my $method = $self->_get_maybe_raw_method($method_name)
 103         or return;
 104
 105     return defined($self->_method_map->{$method_name} = $method);
 106 }
 107
 108 sub get_method {
 109     my ( $self, $method_name ) = @_;
 110
 111     ( defined $method_name && length $method_name )
 112         || confess "You must define a method name";
 113
 114     my $method = $self->_get_maybe_raw_method($method_name)
 115         or return;
 116
 117     return $method if blessed $method;
 118
 119     return $self->_method_map->{$method_name} = $self->wrap_method_body(
 120         body                 => $method,
 121         name                 => $method_name,
 122         associated_metaclass => $self,
 123     );
 124 }
 125
 126 sub _get_maybe_raw_method {
 127     my ( $self, $method_name ) = @_;
 128
 129     my $map_entry = $self->_method_map->{$method_name};
 130     return $map_entry if defined $map_entry;
 131
 132     my $code = $self->get_package_symbol("&$method_name");
 133
 134     return unless $code && $self->_code_is_mine($code);
 135
 136     return $code;
 137 }
 138
 139 sub remove_method {
 140     my ( $self, $method_name ) = @_;
 141
 142     ( defined $method_name && length $method_name )
 143         || confess "You must define a method name";
 144
 145     my $removed_method = delete $self->_method_map->{$method_name};
 146
 147     $self->remove_package_symbol("&$method_name");
 148
 149     $removed_method->detach_from_class
 150         if blessed($removed_method);
 151
 152     # still valid, since we just removed the method from the map
 153     $self->update_package_cache_flag;
 154
 155     return $removed_method;
 156 }
 157
 158 sub get_method_list {
 159     my $self = shift;
 160
 161     return keys %{ $self->_full_method_map };
 162 }
 163
 164 sub _get_local_methods {
 165     my $self = shift;
 166
 167     return values %{ $self->_full_method_map };
 168 }
 169
 170 sub _restore_metamethods_from {
 171     my $self = shift;
 172     my ($old_meta) = @_;
 173
 174     for my $method ($old_meta->_get_local_methods) {
 175         $method->_make_compatible_with($self->method_metaclass);
 176         $self->add_method($method->name => $method);
 177     }
 178 }
 179
 180 sub reset_package_cache_flag  { (shift)->{'_package_cache_flag'} = undef }
 181 sub update_package_cache_flag {
 182     my $self = shift;
 183     # NOTE:
 184     # we can manually update the cache number
 185     # since we are actually adding the method
 186     # to our cache as well. This avoids us
 187     # having to regenerate the method_map.
 188     # - SL
 189     $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
 190 }
 191
 192 sub _full_method_map {
 193     my $self = shift;
 194
 195     my $pkg_gen = Class::MOP::check_package_cache_flag($self->name);
 196
 197     if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) {
 198         # forcibly reify all method map entries
 199         $self->get_method($_)
 200             for $self->list_all_package_symbols('CODE');
 201         $self->{_package_cache_flag_full} = $pkg_gen;
 202     }
 203
 204     return $self->_method_map;
 205 }
 206
 207 1;
 208
 209 __END__
 210
 211 =pod
 212
 213 =head1 NAME
 214
 215 Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
 216
 217 =head1 DESCRIPTION
 218
 219 This class implements methods for metaclasses which have methods
 220 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
 221 for API details.
 222
 223 =head1 AUTHORS
 224
 225 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 226
 227 =head1 COPYRIGHT AND LICENSE
 228
 229 Copyright 2006-2010 by Infinity Interactive, Inc.
 230
 231 L<http://www.iinteractive.com>
 232
 233 This library is free software; you can redistribute it and/or modify
 234 it under the same terms as Perl itself.
 235
 236 =cut