lib/Mouse/Meta/Module.pm

   1 package Mouse::Meta::Module;
   2 use strict;
   3 use warnings;
   4
   5 use Mouse::Util qw/get_code_info/;
   6 use Carp 'confess';
   7
   8 sub name { $_[0]->{package} }
   9 sub _method_map{ $_[0]->{methods} }
  10
  11
  12 sub version   { no strict 'refs'; ${shift->name.'::VERSION'}   }
  13 sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
  14 sub identifier {
  15     my $self = shift;
  16     return join '-' => (
  17         $self->name,
  18         ($self->version   || ()),
  19         ($self->authority || ()),
  20     );
  21 }
  22
  23
  24 sub namespace{
  25     my $name = $_[0]->{package};
  26     no strict 'refs';
  27     return \%{ $name . '::' };
  28 }
  29
  30 sub add_method {
  31     my($self, $name, $code) = @_;
  32
  33     if(!defined $name){
  34         confess "You must pass a defined name";
  35     }
  36     if(ref($code) ne 'CODE'){
  37         confess "You must pass a CODE reference";
  38     }
  39
  40     $self->_method_map->{$name}++; # Moose stores meta object here.
  41
  42     my $pkg = $self->name;
  43     no strict 'refs';
  44     no warnings 'redefine';
  45     *{ $pkg . '::' . $name } = $code;
  46 }
  47
  48 sub _code_is_mine { # taken from Class::MOP::Class\r
  49     my ( $self, $code ) = @_;\r
  50 \r
  51     my ( $code_package, $code_name ) = get_code_info($code);\r
  52 \r
  53     return $code_package && $code_package eq $self->name\r
  54         || ( $code_package eq 'constant' && $code_name eq '__ANON__' );\r
  55 }
  56
  57 sub has_method {
  58     my($self, $method_name) = @_;
  59
  60     return 1 if $self->_method_map->{$method_name};
  61     my $code = $self->name->can($method_name);
  62
  63     return $code && $self->_code_is_mine($code);
  64 }
  65
  66
  67
  68 sub get_method_list {\r
  69     my($self) = @_;
  70 \r
  71     return grep { $self->has_method($_) } keys %{ $self->namespace };\r
  72 }
  73
  74 sub get_attribute_map { $_[0]->{attributes} }
  75 sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
  76 sub get_attribute     { $_[0]->{attributes}->{$_[1]} }
  77 sub get_attribute_list {
  78     my $self = shift;
  79     keys %{$self->get_attribute_map};
  80 }
  81
  82
  83 1;
  84
  85 __END__
  86
  87 =head1 NAME
  88
  89 Mouse::Meta::Module - Common base class for Mouse::Meta::Class and Mouse::Meta::Role
  90
  91 =cut