lib/Class/MOP/Mixin/HasMethods.pm

   1 package Class::MOP::Mixin::HasMethods;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION   = '1.01';
   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 if blessed $map_entry && !$code;
 114
 115     return $map_entry if blessed $map_entry && $map_entry->body == $code;
 116
 117     unless ($map_entry) {
 118         return unless $code && $self->_code_is_mine($code);
 119     }
 120
 121     $code ||= $map_entry;
 122
 123     return $method_map->{$method_name} = $self->wrap_method_body(
 124         body                 => $code,
 125         name                 => $method_name,
 126         associated_metaclass => $self,
 127     );
 128 }
 129
 130 sub remove_method {
 131     my ( $self, $method_name ) = @_;
 132     ( defined $method_name && length $method_name )
 133         || confess "You must define a method name";
 134
 135     my $removed_method = delete $self->_full_method_map->{$method_name};
 136
 137     $self->remove_package_symbol(
 138         { sigil => '&', type => 'CODE', name => $method_name } );
 139
 140     $removed_method->detach_from_class
 141         if $removed_method && blessed $removed_method;
 142
 143     # still valid, since we just removed the method from the map
 144     $self->update_package_cache_flag;
 145
 146     return $removed_method;
 147 }
 148
 149 sub get_method_list {
 150     my $self = shift;
 151     return grep { $self->has_method($_) } keys %{ $self->namespace };
 152 }
 153
 154 1;
 155
 156 __END__
 157
 158 =pod
 159
 160 =head1 NAME
 161
 162 Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
 163
 164 =head1 DESCRIPTION
 165
 166 This class implements methods for metaclasses which have methods
 167 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
 168 for API details.
 169
 170 =head1 AUTHORS
 171
 172 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 173
 174 =head1 COPYRIGHT AND LICENSE
 175
 176 Copyright 2006-2010 by Infinity Interactive, Inc.
 177
 178 L<http://www.iinteractive.com>
 179
 180 This library is free software; you can redistribute it and/or modify
 181 it under the same terms as Perl itself.
 182
 183 =cut