Commit | Line | Data |
f9e68395 |
1 | package Mouse::Role; |
2 | use strict; |
3 | use warnings; |
b32e8fb9 |
4 | use base 'Exporter'; |
f9e68395 |
5 | |
6d28c5cf |
6 | use Carp 'confess'; |
6c169c50 |
7 | use Scalar::Util 'blessed'; |
f9e68395 |
8 | |
6d28c5cf |
9 | use Mouse::Util qw(load_class not_supported); |
10 | use Mouse (); |
a2227e71 |
11 | |
67199842 |
12 | our @EXPORT = qw(before after around super override inner augment has extends with requires excludes confess blessed); |
2cb8b713 |
13 | |
14 | our @EXPORT = qw( |
15 | extends with |
16 | has |
17 | before after around |
18 | override super |
19 | augment inner |
20 | |
21 | requires excludes |
22 | |
23 | blessed confess |
24 | ); |
25 | |
3a63a2e7 |
26 | our %is_removable = map{ $_ => undef } @EXPORT; |
27 | delete $is_removable{confess}; |
28 | delete $is_removable{blessed}; |
b32e8fb9 |
29 | |
30 | sub before { |
8bc2760b |
31 | my $meta = Mouse::Meta::Role->initialize(scalar caller); |
b32e8fb9 |
32 | |
33 | my $code = pop; |
34 | for (@_) { |
35 | $meta->add_before_method_modifier($_ => $code); |
36 | } |
37 | } |
38 | |
39 | sub after { |
8bc2760b |
40 | my $meta = Mouse::Meta::Role->initialize(scalar caller); |
b32e8fb9 |
41 | |
42 | my $code = pop; |
43 | for (@_) { |
44 | $meta->add_after_method_modifier($_ => $code); |
f9e68395 |
45 | } |
b32e8fb9 |
46 | } |
47 | |
48 | sub around { |
8bc2760b |
49 | my $meta = Mouse::Meta::Role->initialize(scalar caller); |
b32e8fb9 |
50 | |
51 | my $code = pop; |
52 | for (@_) { |
53 | $meta->add_around_method_modifier($_ => $code); |
54 | } |
55 | } |
56 | |
67199842 |
57 | |
58 | sub super { |
59 | return unless $Mouse::SUPER_BODY; |
60 | $Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS); |
61 | } |
62 | |
63 | sub override { |
64 | my $classname = caller; |
65 | my $meta = Mouse::Meta::Role->initialize($classname); |
66 | |
67 | my $name = shift; |
68 | my $code = shift; |
69 | my $fullname = "${classname}::${name}"; |
70 | |
71 | defined &$fullname |
6d28c5cf |
72 | && $meta->throw_error("Cannot add an override of method '$fullname' " |
73 | . "because there is a local version of '$fullname'"); |
67199842 |
74 | |
75 | $meta->add_override_method_modifier($name => sub { |
76 | local $Mouse::SUPER_PACKAGE = shift; |
77 | local $Mouse::SUPER_BODY = shift; |
78 | local @Mouse::SUPER_ARGS = @_; |
79 | |
80 | $code->(@_); |
81 | }); |
82 | } |
83 | |
84 | # We keep the same errors messages as Moose::Role emits, here. |
85 | sub inner { |
6d28c5cf |
86 | Carp::croak "Roles cannot support 'inner'"; |
67199842 |
87 | } |
88 | |
89 | sub augment { |
6d28c5cf |
90 | Carp::croak "Roles cannot support 'augment'"; |
67199842 |
91 | } |
92 | |
b32e8fb9 |
93 | sub has { |
8bc2760b |
94 | my $meta = Mouse::Meta::Role->initialize(scalar caller); |
b32e8fb9 |
95 | |
96 | my $name = shift; |
97 | my %opts = @_; |
98 | |
99 | $meta->add_attribute($name => \%opts); |
100 | } |
101 | |
6d28c5cf |
102 | sub extends { |
103 | Carp::croak "Roles do not support 'extends'" |
104 | } |
b32e8fb9 |
105 | |
b1b81553 |
106 | sub with { |
8bc2760b |
107 | my $meta = Mouse::Meta::Role->initialize(scalar caller); |
ff687069 |
108 | Mouse::Util::apply_all_roles($meta->name, @_); |
b1b81553 |
109 | } |
b32e8fb9 |
110 | |
59089ec3 |
111 | sub requires { |
8bc2760b |
112 | my $meta = Mouse::Meta::Role->initialize(scalar caller); |
6d28c5cf |
113 | $meta->throw_error("Must specify at least one method") unless @_; |
59089ec3 |
114 | $meta->add_required_methods(@_); |
115 | } |
b32e8fb9 |
116 | |
6d28c5cf |
117 | sub excludes { |
118 | not_supported; |
119 | } |
b32e8fb9 |
120 | |
121 | sub import { |
7daedfff |
122 | my $class = shift; |
123 | |
b32e8fb9 |
124 | strict->import; |
125 | warnings->import; |
126 | |
127 | my $caller = caller; |
7daedfff |
128 | |
129 | # we should never export to main |
130 | if ($caller eq 'main') { |
131 | warn qq{$class does not export its sugar to the 'main' package.\n}; |
132 | return; |
133 | } |
134 | |
3a63a2e7 |
135 | Mouse::Meta::Role->initialize($caller)->add_method(meta => sub { |
136 | return Mouse::Meta::Role->initialize(ref($_[0]) || $_[0]); |
137 | }); |
b32e8fb9 |
138 | |
139 | Mouse::Role->export_to_level(1, @_); |
140 | } |
f9e68395 |
141 | |
b32e8fb9 |
142 | sub unimport { |
143 | my $caller = caller; |
e71d8033 |
144 | |
3a63a2e7 |
145 | my $stash = do{ |
146 | no strict 'refs'; |
147 | \%{$caller . '::'} |
148 | }; |
149 | |
b32e8fb9 |
150 | for my $keyword (@EXPORT) { |
3a63a2e7 |
151 | my $code; |
152 | if(exists $is_removable{$keyword} |
153 | && ($code = $caller->can($keyword)) |
154 | && (Mouse::Util::get_code_info($code))[0] eq __PACKAGE__){ |
155 | |
156 | delete $stash->{$keyword}; |
157 | } |
f9e68395 |
158 | } |
3a63a2e7 |
159 | return; |
b32e8fb9 |
160 | } |
f9e68395 |
161 | |
162 | 1; |
163 | |
cadd5b5e |
164 | __END__ |
165 | |
166 | =head1 NAME |
167 | |
137498b8 |
168 | Mouse::Role - define a role in Mouse |
cadd5b5e |
169 | |
170 | =head1 KEYWORDS |
171 | |
172 | =head2 meta -> Mouse::Meta::Role |
173 | |
174 | Returns this role's metaclass instance. |
175 | |
176 | =head2 before (method|methods) => Code |
177 | |
178 | Sets up a "before" method modifier. See L<Moose/before> or |
179 | L<Class::Method::Modifiers/before>. |
180 | |
181 | =head2 after (method|methods) => Code |
182 | |
183 | Sets up an "after" method modifier. See L<Moose/after> or |
184 | L<Class::Method::Modifiers/after>. |
185 | |
186 | =head2 around (method|methods) => Code |
187 | |
188 | Sets up an "around" method modifier. See L<Moose/around> or |
189 | L<Class::Method::Modifiers/around>. |
190 | |
4e8817b8 |
191 | =over 4 |
192 | |
67199842 |
193 | =item B<super> |
194 | |
195 | Sets up the "super" keyword. See L<Moose/super>. |
196 | |
197 | =item B<override ($name, &sub)> |
198 | |
199 | Sets up an "override" method modifier. See L<Moose/Role/override>. |
200 | |
201 | =item B<inner> |
202 | |
203 | This is not supported and emits an error. See L<Moose/Role>. |
204 | |
205 | =item B<augment ($name, &sub)> |
206 | |
207 | This is not supported and emits an error. See L<Moose/Role>. |
208 | |
4e8817b8 |
209 | =back |
210 | |
cadd5b5e |
211 | =head2 has (name|names) => parameters |
212 | |
213 | Sets up an attribute (or if passed an arrayref of names, multiple attributes) to |
214 | this role. See L<Mouse/has>. |
215 | |
216 | =head2 confess error -> BOOM |
217 | |
218 | L<Carp/confess> for your convenience. |
219 | |
220 | =head2 blessed value -> ClassName | undef |
221 | |
222 | L<Scalar::Util/blessed> for your convenience. |
223 | |
224 | =head1 MISC |
225 | |
226 | =head2 import |
227 | |
228 | Importing Mouse::Role will give you sugar. |
229 | |
230 | =head2 unimport |
231 | |
232 | Please unimport Mouse (C<no Mouse::Role>) so that if someone calls one of the |
233 | keywords (such as L</has>) it will break loudly instead breaking subtly. |
234 | |
235 | =cut |
236 | |