Commit | Line | Data |
3a63a2e7 |
1 | package Mouse::Meta::Module; |
2 | use strict; |
3 | use warnings; |
4 | |
23264b5b |
5 | use Mouse::Util qw/get_code_info/; |
3a63a2e7 |
6 | use Carp 'confess'; |
7 | |
8 | sub name { $_[0]->{package} } |
9 | sub _method_map{ $_[0]->{methods} } |
10 | |
23264b5b |
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 | |
3a63a2e7 |
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 |