lib/Mouse/Meta/Module.pm

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