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