lib/Class/MOP/Mixin/HasMethods.pm

   1 package Class::MOP::Mixin::HasMethods;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION   = '1.09';
   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_maybe_raw_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 = $self->_get_maybe_raw_method($method_name)
 102         or return;
 103
 104     return $method if blessed $method;
 105
 106     return $self->_method_map->{$method_name} = $self->wrap_method_body(
 107         body                 => $method,
 108         name                 => $method_name,
 109         associated_metaclass => $self,
 110     );
 111 }
 112
 113 sub _get_maybe_raw_method {
 114     my ( $self, $method_name ) = @_;
 115
 116     my $method_map = $self->_method_map;
 117     my $map_entry  = $method_map->{$method_name};
 118     my $code       = $self->get_package_symbol(
 119         {
 120             name  => $method_name,
 121             sigil => '&',
 122             type  => 'CODE',
 123         }
 124     );
 125
 126     # The !$code case seems to happen in some weird cases where methods
 127     # modifiers are added via roles or some other such bizareness. Honestly, I
 128     # don't totally understand this, but returning the entry works, and keeps
 129     # various MX modules from blowing up. - DR
 130     return $map_entry
 131         if blessed $map_entry && ( !$code || $map_entry->body == $code );
 132
 133     unless ($map_entry) {
 134         return unless $code && $self->_code_is_mine($code);
 135     }
 136
 137     return $code;
 138 }
 139
 140 sub remove_method {
 141     my ( $self, $method_name ) = @_;
 142     ( defined $method_name && length $method_name )
 143         || confess "You must define a method name";
 144
 145     my $removed_method = delete $self->_full_method_map->{$method_name};
 146
 147     $self->remove_package_symbol(
 148         { sigil => '&', type => 'CODE', name => $method_name } );
 149
 150     $removed_method->detach_from_class
 151         if $removed_method && blessed $removed_method;
 152
 153     # still valid, since we just removed the method from the map
 154     $self->update_package_cache_flag;
 155
 156     return $removed_method;
 157 }
 158
 159 sub get_method_list {
 160     my $self = shift;
 161
 162     my $namespace = $self->namespace;
 163
 164     # Constants may show up as some sort of non-GLOB reference in the
 165     # namespace hash ref, depending on the Perl version.
 166     return grep {
 167         defined $namespace->{$_}
 168             && ( ref( \$namespace->{$_} ) ne 'GLOB'
 169             || *{ $namespace->{$_} }{CODE} )
 170             && $self->has_method($_)
 171         }
 172         keys %{$namespace};
 173 }
 174
 175 # This should probably be what get_method_list actually does, instead of just
 176 # returning names. This was created as a much faster alternative to
 177 # $meta->get_method($_) for $meta->get_method_list
 178 sub _get_local_methods {
 179     my $self = shift;
 180
 181     my $namespace = $self->namespace;
 182
 183     return map { $self->get_method($_) }
 184         grep {
 185         defined $namespace->{$_}
 186             && ( ref $namespace->{$_}
 187             || *{ $namespace->{$_} }{CODE} )
 188         }
 189         keys %{$namespace};
 190 }
 191
 192 1;
 193
 194 __END__
 195
 196 =pod
 197
 198 =head1 NAME
 199
 200 Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
 201
 202 =head1 DESCRIPTION
 203
 204 This class implements methods for metaclasses which have methods
 205 (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
 206 for API details.
 207
 208 =head1 AUTHORS
 209
 210 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 211
 212 =head1 COPYRIGHT AND LICENSE
 213
 214 Copyright 2006-2010 by Infinity Interactive, Inc.
 215
 216 L<http://www.iinteractive.com>
 217
 218 This library is free software; you can redistribute it and/or modify
 219 it under the same terms as Perl itself.
 220
 221 =cut