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