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 $package_name = $self->name;
  43
  44     my $body;
  45     if ( blessed($method) ) {
  46         $body = $method->body;
  47         if ( $method->package_name ne $package_name ) {
  48             $method = $method->clone(
  49                 package_name => $package_name,
  50                 name         => $method_name,
  51             ) if $method->can('clone');
  52         }
  53
  54         $method->attach_to_class($self);
  55     }
  56     else {
  57         # If a raw code reference is supplied, its method object is not created.
  58         # The method object won't be created until required.
  59         $body = $method;
  60     }
  61
  62     $self->_method_map->{$method_name} = $method;
  63
  64     my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
  65
  66     if ( !defined $current_name || $current_name =~ /^__ANON__/ ) {
  67         my $full_method_name = ( $package_name . '::' . $method_name );
  68         subname( $full_method_name => $body );
  69     }
  70
  71     $self->add_package_symbol(
  72         { sigil => '&', type => 'CODE', name => $method_name },
  73         $body,
  74     );
  75 }
  76
  77 sub _code_is_mine {
  78     my ( $self, $code ) = @_;
  79
  80     my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
  81
  82     return $code_package && $code_package eq $self->name
  83         || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
  84 }
  85
  86 sub has_method {
  87     my ( $self, $method_name ) = @_;
  88
  89     ( defined $method_name && length $method_name )
  90         || confess "You must define a method name";
  91
  92     return defined( $self->get_method($method_name) );
  93 }
  94
  95 sub get_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_map = $self->_method_map;
 102     my $map_entry  = $method_map->{$method_name};
 103     my $code       = $self->get_package_symbol(
 104         {
 105             name  => $method_name,
 106             sigil => '&',
 107             type  => 'CODE',
 108         }
 109     );
 110
 111     # The !$code case seems to happen in some weird cases where methods
 112     # modifiers are added via roles or some other such bizareness. Honestly, I
 113     # don't totally understand this, but returning the entry works, and keeps
 114     # various MX modules from blowing up. - DR
 115     return $map_entry
 116         if blessed $map_entry && ( !$code || $map_entry->body == $code );
 117
 118     unless ($map_entry) {
 119         return unless $code && $self->_code_is_mine($code);
 120     }
 121
 122     $code ||= $map_entry;
 123
 124     return $method_map->{$method_name} = $self->wrap_method_body(
 125         body                 => $code,
 126         name                 => $method_name,
 127         associated_metaclass => $self,
 128     );
 129 }
 130
 131 sub remove_method {
 132     my ( $self, $method_name ) = @_;
 133     ( defined $method_name && length $method_name )
 134         || confess "You must define a method name";
 135
 136     my $removed_method = delete $self->_full_method_map->{$method_name};
 137
 138     $self->remove_package_symbol(
 139         { sigil => '&', type => 'CODE', name => $method_name } );
 140
 141     $removed_method->detach_from_class
 142         if $removed_method && blessed $removed_method;
 143
 144     # still valid, since we just removed the method from the map
 145     $self->update_package_cache_flag;
 146
 147     return $removed_method;
 148 }
 149
 150 sub get_method_list {
 151     my $self = shift;
 152
 153     my $namespace = $self->namespace;
 154
 155     return grep { *{ $namespace->{$_} }{CODE} && $self->has_method($_) }
 156         keys %{$namespace};
 157 }
 158
 159 # This should probably be what get_method_list actually does, instead of just
 160 # returning names. This was created as a much faster alternative to
 161 # $meta->get_method($_) for $meta->get_method_list
 162 sub _get_local_methods {
 163     my $self = shift;
 164
 165     my $namespace = $self->namespace;
 166
 167     return map { $self->get_method($_) } grep { *{ $namespace->{$_} }{CODE} }
 168         keys %{$namespace};
 169 }
 170
 171 1;
 172
 173 __END__
 174
 175 =pod
 176
 177 =head1 NAME
 178
 179 Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
 180
 181 =head1 DESCRIPTION
 182
 183 This class implements methods for metaclasses which have methods
 184 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
 185 for API details.
 186
 187 =head1 AUTHORS
 188
 189 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 190
 191 =head1 COPYRIGHT AND LICENSE
 192
 193 Copyright 2006-2010 by Infinity Interactive, Inc.
 194
 195 L<http://www.iinteractive.com>
 196
 197 This library is free software; you can redistribute it and/or modify
 198 it under the same terms as Perl itself.
 199
 200 =cut