line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Role::Tiny; |
2
|
27
|
|
|
27
|
|
1606614
|
use strict; |
|
27
|
|
|
|
|
253
|
|
|
27
|
|
|
|
|
712
|
|
3
|
27
|
|
|
27
|
|
119
|
use warnings; |
|
27
|
|
|
|
|
45
|
|
|
27
|
|
|
|
|
6152
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '2.002004'; |
6
|
|
|
|
|
|
|
$VERSION =~ tr/_//d; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our %INFO; |
9
|
|
|
|
|
|
|
our %APPLIED_TO; |
10
|
|
|
|
|
|
|
our %COMPOSED; |
11
|
|
|
|
|
|
|
our %COMPOSITE_INFO; |
12
|
|
|
|
|
|
|
our @ON_ROLE_CREATE; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# Module state workaround totally stolen from Zefram's Module::Runtime. |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
BEGIN { |
17
|
27
|
50
|
|
27
|
|
245
|
*_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0}; |
18
|
|
|
|
|
|
|
*_WORK_AROUND_HINT_LEAKAGE |
19
|
|
|
|
|
|
|
= "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001) |
20
|
27
|
50
|
33
|
|
|
237
|
? sub(){1} : sub(){0}; |
21
|
27
|
50
|
33
|
|
|
1097
|
*_CONSTANTS_DEFLATE = "$]" >= 5.012 && "$]" < 5.020 ? sub(){1} : sub(){0}; |
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
|
24
|
27
|
|
|
27
|
|
162
|
sub _getglob { no strict 'refs'; \*{$_[0]} } |
|
27
|
|
|
713
|
|
52
|
|
|
27
|
|
|
|
|
1452
|
|
|
713
|
|
|
|
|
755
|
|
|
713
|
|
|
|
|
3318
|
|
25
|
27
|
|
|
27
|
|
158
|
sub _getstash { no strict 'refs'; \%{"$_[0]::"} } |
|
27
|
|
|
578
|
|
49
|
|
|
27
|
|
|
|
|
1695
|
|
|
578
|
|
|
|
|
589
|
|
|
578
|
|
|
|
|
2350
|
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub croak { |
28
|
8
|
|
|
8
|
0
|
41
|
require Carp; |
29
|
27
|
|
|
27
|
|
158
|
no warnings 'redefine'; |
|
27
|
|
|
|
|
52
|
|
|
27
|
|
|
|
|
8061
|
|
30
|
8
|
|
|
|
|
29
|
*croak = \&Carp::croak; |
31
|
8
|
|
|
|
|
1427
|
goto &Carp::croak; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
sub Role::Tiny::__GUARD__::DESTROY { |
35
|
0
|
0
|
|
0
|
|
0
|
delete $INC{$_[0]->[0]} if @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub _load_module { |
39
|
279
|
|
|
279
|
|
2599
|
my ($module) = @_; |
40
|
279
|
|
|
|
|
901
|
(my $file = "$module.pm") =~ s{::}{/}g; |
41
|
|
|
|
|
|
|
return 1 |
42
|
279
|
100
|
|
|
|
639
|
if $INC{$file}; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
# can't just ->can('can') because a sub-package Foo::Bar::Baz |
45
|
|
|
|
|
|
|
# creates a 'Baz::' key in Foo::Bar's symbol table |
46
|
|
|
|
|
|
|
return 1 |
47
|
266
|
100
|
|
|
|
295
|
if grep !/::\z/, keys %{_getstash($module)}; |
|
266
|
|
|
|
|
385
|
|
48
|
4
|
|
|
|
|
9
|
my $guard = _WORK_AROUND_BROKEN_MODULE_STATE |
49
|
|
|
|
|
|
|
&& bless([ $file ], 'Role::Tiny::__GUARD__'); |
50
|
4
|
|
|
|
|
4
|
local %^H if _WORK_AROUND_HINT_LEAKAGE; |
51
|
4
|
|
|
|
|
965
|
require $file; |
52
|
1
|
|
|
|
|
12
|
pop @$guard if _WORK_AROUND_BROKEN_MODULE_STATE; |
53
|
1
|
|
|
|
|
3
|
return 1; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub _require_module { |
57
|
275
|
|
|
275
|
|
460
|
_load_module($_[1]); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub _all_subs { |
61
|
312
|
|
|
312
|
|
487
|
my ($me, $package) = @_; |
62
|
312
|
|
|
|
|
440
|
my $stash = _getstash($package); |
63
|
|
|
|
|
|
|
return { |
64
|
|
|
|
|
|
|
map {; |
65
|
27
|
|
|
27
|
|
213
|
no strict 'refs'; |
|
27
|
|
|
|
|
42
|
|
|
27
|
|
|
|
|
33136
|
|
66
|
|
|
|
|
|
|
# this is an ugly hack to populate the scalar slot of any globs, to |
67
|
|
|
|
|
|
|
# prevent perl from converting constants back into scalar refs in the |
68
|
|
|
|
|
|
|
# stash when they are used (perl 5.12 - 5.18). scalar slots on their own |
69
|
|
|
|
|
|
|
# aren't detectable through pure perl, so this seems like an acceptable |
70
|
|
|
|
|
|
|
# compromise. |
71
|
1237
|
|
|
|
|
1293
|
${"${package}::${_}"} = ${"${package}::${_}"} |
72
|
|
|
|
|
|
|
if _CONSTANTS_DEFLATE; |
73
|
1237
|
|
|
|
|
1212
|
$_ => \&{"${package}::${_}"} |
|
1237
|
|
|
|
|
3059
|
|
74
|
|
|
|
|
|
|
} |
75
|
312
|
|
|
|
|
1272
|
grep exists &{"${package}::${_}"}, |
|
1614
|
|
|
|
|
2821
|
|
76
|
|
|
|
|
|
|
grep !/::\z/, |
77
|
|
|
|
|
|
|
keys %$stash |
78
|
|
|
|
|
|
|
}; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
sub import { |
82
|
91
|
|
|
91
|
|
8466
|
my $target = caller; |
83
|
91
|
|
|
|
|
130
|
my $me = shift; |
84
|
91
|
|
|
|
|
417
|
strict->import; |
85
|
91
|
|
|
|
|
758
|
warnings->import; |
86
|
91
|
|
|
|
|
206
|
my $non_methods = $me->_non_methods($target); |
87
|
91
|
|
|
|
|
242
|
$me->_install_subs($target, @_); |
88
|
91
|
|
|
|
|
221
|
$me->make_role($target); |
89
|
91
|
100
|
66
|
|
|
416
|
$me->_mark_new_non_methods($target, $non_methods) |
90
|
|
|
|
|
|
|
if $non_methods && %$non_methods; |
91
|
91
|
|
|
|
|
15062
|
return; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub _mark_new_non_methods { |
95
|
2
|
|
|
2
|
|
5
|
my ($me, $target, $old_non_methods) = @_; |
96
|
|
|
|
|
|
|
|
97
|
2
|
|
|
|
|
3
|
my $non_methods = $INFO{$target}{non_methods}; |
98
|
|
|
|
|
|
|
|
99
|
2
|
|
|
|
|
5
|
my $subs = $me->_all_subs($target); |
100
|
2
|
|
|
|
|
6
|
for my $sub (keys %$subs) { |
101
|
6
|
100
|
66
|
|
|
40
|
if ( exists $old_non_methods->{$sub} && $non_methods->{$sub} != $subs->{$sub} ) { |
102
|
5
|
|
|
|
|
11
|
$non_methods->{$sub} = $subs->{$sub}; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
2
|
|
|
|
|
7
|
return; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub make_role { |
110
|
92
|
|
|
92
|
1
|
242
|
my ($me, $target) = @_; |
111
|
|
|
|
|
|
|
|
112
|
92
|
100
|
|
|
|
211
|
return if $me->is_role($target); |
113
|
90
|
|
|
|
|
242
|
$INFO{$target}{is_role} = 1; |
114
|
|
|
|
|
|
|
|
115
|
90
|
|
|
|
|
185
|
my $non_methods = $me->_all_subs($target); |
116
|
90
|
|
|
|
|
322
|
delete @{$non_methods}{grep /\A\(/, keys %$non_methods}; |
|
90
|
|
|
|
|
164
|
|
117
|
90
|
|
|
|
|
167
|
$INFO{$target}{non_methods} = $non_methods; |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# a role does itself |
120
|
90
|
|
|
|
|
186
|
$APPLIED_TO{$target} = { $target => undef }; |
121
|
90
|
|
|
|
|
198
|
foreach my $hook (@ON_ROLE_CREATE) { |
122
|
2
|
|
|
|
|
14
|
$hook->($target); |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub _install_subs { |
127
|
91
|
|
|
91
|
|
154
|
my ($me, $target) = @_; |
128
|
91
|
100
|
|
|
|
183
|
return if $me->is_role($target); |
129
|
90
|
|
|
|
|
216
|
my %install = $me->_gen_subs($target); |
130
|
450
|
|
|
|
|
972
|
*{_getglob("${target}::${_}")} = $install{$_} |
131
|
90
|
|
|
|
|
531
|
for sort keys %install; |
132
|
90
|
|
|
|
|
424
|
return; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub _gen_subs { |
136
|
90
|
|
|
90
|
|
163
|
my ($me, $target) = @_; |
137
|
|
|
|
|
|
|
( |
138
|
|
|
|
|
|
|
(map {; |
139
|
270
|
|
|
|
|
365
|
my $type = $_; |
140
|
|
|
|
|
|
|
$type => sub { |
141
|
15
|
|
|
15
|
|
6431
|
my $code = pop; |
142
|
15
|
100
|
|
|
|
61
|
my @names = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; |
|
1
|
|
|
|
|
2
|
|
143
|
15
|
|
100
|
|
|
20
|
push @{$INFO{$target}{modifiers}||=[]}, [ $type, @names, $code ]; |
|
15
|
|
|
|
|
99
|
|
144
|
15
|
|
|
|
|
192
|
return; |
145
|
270
|
|
|
|
|
1733
|
}; |
146
|
|
|
|
|
|
|
} qw(before after around)), |
147
|
|
|
|
|
|
|
requires => sub { |
148
|
13
|
|
50
|
13
|
|
4299
|
push @{$INFO{$target}{requires}||=[]}, @_; |
|
13
|
|
|
|
|
87
|
|
149
|
13
|
|
|
|
|
152
|
return; |
150
|
|
|
|
|
|
|
}, |
151
|
|
|
|
|
|
|
with => sub { |
152
|
22
|
|
|
22
|
|
4463
|
$me->apply_roles_to_package($target, @_); |
153
|
21
|
|
|
|
|
139
|
return; |
154
|
|
|
|
|
|
|
}, |
155
|
90
|
|
|
|
|
149
|
); |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
sub role_application_steps { |
159
|
121
|
|
|
121
|
0
|
291
|
qw( |
160
|
|
|
|
|
|
|
_install_methods |
161
|
|
|
|
|
|
|
_check_requires |
162
|
|
|
|
|
|
|
_install_modifiers |
163
|
|
|
|
|
|
|
_copy_applied_list |
164
|
|
|
|
|
|
|
); |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub _copy_applied_list { |
168
|
130
|
|
|
130
|
|
213
|
my ($me, $to, $role) = @_; |
169
|
|
|
|
|
|
|
# copy our role list into the target's |
170
|
130
|
|
100
|
|
|
168
|
@{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = (); |
|
130
|
|
|
|
|
727
|
|
|
130
|
|
|
|
|
335
|
|
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub apply_roles_to_object { |
174
|
43
|
|
|
43
|
1
|
10006
|
my ($me, $object, @roles) = @_; |
175
|
43
|
|
|
|
|
65
|
my $class = ref($object); |
176
|
|
|
|
|
|
|
# on perl < 5.8.9, magic isn't copied to all ref copies. bless the parameter |
177
|
|
|
|
|
|
|
# directly, so at least the variable passed to us will get any magic applied |
178
|
43
|
|
|
|
|
82
|
bless($_[1], $me->create_class_with_roles($class, @roles)); |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
my $role_suffix = 'A000'; |
182
|
|
|
|
|
|
|
sub _composite_name { |
183
|
53
|
|
|
53
|
|
86
|
my ($me, $superclass, @roles) = @_; |
184
|
|
|
|
|
|
|
|
185
|
53
|
|
|
|
|
134
|
my $new_name = $superclass . '__WITH__' . join '__AND__', @roles; |
186
|
|
|
|
|
|
|
|
187
|
53
|
100
|
|
|
|
108
|
if (length($new_name) > 252) { |
188
|
7
|
|
33
|
|
|
22
|
$new_name = $COMPOSED{abbrev}{$new_name} ||= do { |
189
|
7
|
|
|
|
|
15
|
my $abbrev = substr $new_name, 0, 250 - length $role_suffix; |
190
|
7
|
|
|
|
|
15
|
$abbrev =~ s/(?<!:):$//; |
191
|
7
|
|
|
|
|
32
|
$abbrev.'__'.$role_suffix++; |
192
|
|
|
|
|
|
|
}; |
193
|
|
|
|
|
|
|
} |
194
|
53
|
|
|
|
|
95
|
return $new_name; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub create_class_with_roles { |
198
|
57
|
|
|
57
|
1
|
7410
|
my ($me, $superclass, @roles) = @_; |
199
|
|
|
|
|
|
|
|
200
|
57
|
|
|
|
|
131
|
$me->_require_module($superclass); |
201
|
57
|
|
|
|
|
161
|
$me->_check_roles(@roles); |
202
|
|
|
|
|
|
|
|
203
|
53
|
|
|
|
|
108
|
my $new_name = $me->_composite_name($superclass, @roles); |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
return $new_name |
206
|
53
|
100
|
|
|
|
122
|
if $COMPOSED{class}{$new_name}; |
207
|
|
|
|
|
|
|
|
208
|
50
|
|
|
|
|
91
|
return $me->_build_class_with_roles($new_name, $superclass, @roles); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub _build_class_with_roles { |
212
|
50
|
|
|
50
|
|
99
|
my ($me, $new_name, $superclass, @roles) = @_; |
213
|
|
|
|
|
|
|
|
214
|
50
|
|
|
|
|
123
|
$COMPOSED{base}{$new_name} = $superclass; |
215
|
50
|
|
|
|
|
61
|
@{*{_getglob("${new_name}::ISA")}} = ( $superclass ); |
|
50
|
|
|
|
|
53
|
|
|
50
|
|
|
|
|
111
|
|
216
|
50
|
|
|
|
|
309
|
$me->apply_roles_to_package($new_name, @roles); |
217
|
45
|
|
|
|
|
82
|
$COMPOSED{class}{$new_name} = 1; |
218
|
45
|
|
|
|
|
175
|
return $new_name; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
sub _check_roles { |
222
|
183
|
|
|
183
|
|
298
|
my ($me, @roles) = @_; |
223
|
183
|
100
|
|
|
|
526
|
croak "No roles supplied!" unless @roles; |
224
|
|
|
|
|
|
|
|
225
|
181
|
|
|
|
|
232
|
my %seen; |
226
|
181
|
100
|
|
|
|
698
|
if (my @dupes = grep 1 == $seen{$_}++, @roles) { |
227
|
1
|
|
|
|
|
6
|
croak "Duplicated roles: ".join(', ', @dupes); |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
180
|
|
|
|
|
288
|
foreach my $role (@roles) { |
231
|
215
|
|
|
|
|
438
|
$me->_require_module($role); |
232
|
214
|
100
|
|
|
|
549
|
croak "${role} is not a ${me}" unless $me->is_role($role); |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
our %BACKCOMPAT_HACK; |
237
|
|
|
|
|
|
|
$BACKCOMPAT_HACK{+__PACKAGE__} = 0; |
238
|
|
|
|
|
|
|
sub _want_backcompat_hack { |
239
|
121
|
|
|
121
|
|
189
|
my $me = shift; |
240
|
|
|
|
|
|
|
return $BACKCOMPAT_HACK{$me} |
241
|
121
|
100
|
|
|
|
455
|
if exists $BACKCOMPAT_HACK{$me}; |
242
|
27
|
|
|
27
|
|
192
|
no warnings 'uninitialized'; |
|
27
|
|
|
|
|
83
|
|
|
27
|
|
|
|
|
45378
|
|
243
|
3
|
|
100
|
|
|
49
|
$BACKCOMPAT_HACK{$me} = |
244
|
|
|
|
|
|
|
$me->can('apply_single_role_to_package') != \&apply_single_role_to_package |
245
|
|
|
|
|
|
|
&& $me->can('role_application_steps') == \&role_application_steps |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
our $IN_APPLY_ROLES; |
249
|
|
|
|
|
|
|
sub apply_single_role_to_package { |
250
|
|
|
|
|
|
|
return |
251
|
2
|
50
|
|
2
|
0
|
12
|
if $IN_APPLY_ROLES; |
252
|
0
|
|
|
|
|
0
|
local $IN_APPLY_ROLES = 1; |
253
|
|
|
|
|
|
|
|
254
|
0
|
|
|
|
|
0
|
my ($me, $to, $role) = @_; |
255
|
0
|
|
|
|
|
0
|
$me->apply_roles_to_package($to, $role); |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
sub apply_role_to_package { |
259
|
9
|
|
|
9
|
0
|
2293
|
my ($me, $to, $role) = @_; |
260
|
9
|
|
|
|
|
30
|
$me->apply_roles_to_package($to, $role); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub apply_roles_to_package { |
264
|
127
|
|
|
127
|
1
|
4438
|
my ($me, $to, @roles) = @_; |
265
|
127
|
100
|
|
|
|
298
|
croak "Can't apply roles to object with apply_roles_to_package" |
266
|
|
|
|
|
|
|
if ref $to; |
267
|
|
|
|
|
|
|
|
268
|
126
|
|
|
|
|
313
|
$me->_check_roles(@roles); |
269
|
|
|
|
|
|
|
|
270
|
124
|
|
|
|
|
186
|
my @have_conflicts; |
271
|
|
|
|
|
|
|
my %role_methods; |
272
|
|
|
|
|
|
|
|
273
|
124
|
100
|
|
|
|
260
|
if (@roles > 1) { |
274
|
19
|
|
|
|
|
27
|
my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}}; |
|
19
|
|
|
|
|
63
|
|
275
|
19
|
|
|
|
|
79
|
@have_conflicts = grep $to->can($_), keys %conflicts; |
276
|
19
|
|
|
|
|
36
|
delete @conflicts{@have_conflicts}; |
277
|
|
|
|
|
|
|
|
278
|
19
|
100
|
|
|
|
60
|
if (keys %conflicts) { |
279
|
3
|
|
66
|
|
|
12
|
my $class = $COMPOSED{base}{$to} || $to; |
280
|
|
|
|
|
|
|
my $fail = |
281
|
|
|
|
|
|
|
join "\n", |
282
|
|
|
|
|
|
|
map { |
283
|
3
|
|
|
|
|
9
|
"Due to a method name conflict between roles " |
284
|
3
|
|
|
|
|
7
|
.join(' and ', map "'$_'", sort values %{$conflicts{$_}}) |
|
3
|
|
|
|
|
31
|
|
285
|
|
|
|
|
|
|
.", the method '$_' must be implemented by '$class'" |
286
|
|
|
|
|
|
|
} sort keys %conflicts; |
287
|
3
|
|
|
|
|
102
|
croak $fail; |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
16
|
|
|
|
|
50
|
%role_methods = map +($_ => $me->_concrete_methods_of($_)), @roles; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
121
|
100
|
66
|
|
|
386
|
if (!$IN_APPLY_ROLES and _want_backcompat_hack($me)) { |
294
|
1
|
|
|
|
|
4
|
local $IN_APPLY_ROLES = 1; |
295
|
1
|
|
|
|
|
2
|
foreach my $role (@roles) { |
296
|
2
|
|
|
|
|
8
|
$me->apply_single_role_to_package($to, $role); |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
121
|
|
|
|
|
174
|
my $role_methods; |
301
|
121
|
|
|
|
|
254
|
foreach my $step ($me->role_application_steps) { |
302
|
468
|
|
|
|
|
4173
|
foreach my $role (@roles) { |
303
|
|
|
|
|
|
|
# conflicting methods are supposed to be treated as required by the |
304
|
|
|
|
|
|
|
# composed role. we don't have an actual composed role, but because |
305
|
|
|
|
|
|
|
# we know the target class already provides them, we can instead |
306
|
|
|
|
|
|
|
# pretend that the roles don't do for the duration of application. |
307
|
|
|
|
|
|
|
$role_methods = $role_methods{$role} and ( |
308
|
140
|
|
|
|
|
186
|
(local @{$role_methods}{@have_conflicts}), |
309
|
544
|
100
|
|
|
|
3057
|
(delete @{$role_methods}{@have_conflicts}), |
|
140
|
|
|
|
|
159
|
|
310
|
|
|
|
|
|
|
); |
311
|
|
|
|
|
|
|
|
312
|
544
|
|
|
|
|
1246
|
$me->$step($to, $role); |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
} |
315
|
111
|
|
|
|
|
7911
|
$APPLIED_TO{$to}{join('|',@roles)} = 1; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
sub _composite_info_for { |
319
|
19
|
|
|
19
|
|
98
|
my ($me, @roles) = @_; |
320
|
19
|
|
66
|
|
|
120
|
$COMPOSITE_INFO{join('|', sort @roles)} ||= do { |
321
|
16
|
|
|
|
|
27
|
my %methods; |
322
|
16
|
|
|
|
|
31
|
foreach my $role (@roles) { |
323
|
35
|
|
|
|
|
75
|
my $this_methods = $me->_concrete_methods_of($role); |
324
|
35
|
|
|
|
|
141
|
$methods{$_}{$this_methods->{$_}} = $role for keys %$this_methods; |
325
|
|
|
|
|
|
|
} |
326
|
16
|
|
|
|
|
45
|
delete $methods{$_} for grep keys(%{$methods{$_}}) == 1, keys %methods; |
|
18
|
|
|
|
|
160
|
|
327
|
16
|
|
|
|
|
85
|
+{ conflicts => \%methods } |
328
|
|
|
|
|
|
|
}; |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
sub _check_requires { |
332
|
140
|
|
|
140
|
|
310
|
my ($me, $to, $name, $requires) = @_; |
333
|
140
|
|
100
|
|
|
735
|
$requires ||= $INFO{$name}{requires} || []; |
|
|
|
33
|
|
|
|
|
334
|
140
|
100
|
|
|
|
550
|
if (my @requires_fail = grep !$to->can($_), @$requires) { |
335
|
|
|
|
|
|
|
# role -> role, add to requires, role -> class, error out |
336
|
13
|
100
|
|
|
|
40
|
if (my $to_info = $INFO{$to}) { |
337
|
5
|
|
100
|
|
|
8
|
push @{$to_info->{requires}||=[]}, @requires_fail; |
|
5
|
|
|
|
|
24
|
|
338
|
|
|
|
|
|
|
} else { |
339
|
8
|
|
|
|
|
427
|
croak "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail); |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
sub _non_methods { |
345
|
170
|
|
|
170
|
|
308
|
my ($me, $role) = @_; |
346
|
170
|
100
|
|
|
|
455
|
my $info = $INFO{$role} or return {}; |
347
|
|
|
|
|
|
|
|
348
|
80
|
50
|
|
|
|
121
|
my %non_methods = %{ $info->{non_methods} || {} }; |
|
80
|
|
|
|
|
508
|
|
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# this is only for backwards compatibility with older Moo, which |
351
|
|
|
|
|
|
|
# reimplements method tracking rather than calling our method |
352
|
80
|
100
|
|
|
|
153
|
my %not_methods = reverse %{ $info->{not_methods} || {} }; |
|
80
|
|
|
|
|
384
|
|
353
|
80
|
100
|
|
|
|
377
|
return \%non_methods unless keys %not_methods; |
354
|
|
|
|
|
|
|
|
355
|
1
|
|
|
|
|
2
|
my $subs = $me->_all_subs($role); |
356
|
1
|
|
|
|
|
6
|
for my $sub (grep !/\A\(/, keys %$subs) { |
357
|
6
|
|
|
|
|
7
|
my $code = $subs->{$sub}; |
358
|
6
|
100
|
|
|
|
12
|
if (exists $not_methods{$code}) { |
359
|
1
|
|
|
|
|
2
|
$non_methods{$sub} = $code; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
1
|
|
|
|
|
4
|
return \%non_methods; |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
sub _concrete_methods_of { |
367
|
215
|
|
|
215
|
|
959
|
my ($me, $role) = @_; |
368
|
215
|
|
|
|
|
284
|
my $info = $INFO{$role}; |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
return $info->{methods} |
371
|
215
|
100
|
100
|
|
|
1306
|
if $info && $info->{methods}; |
372
|
|
|
|
|
|
|
|
373
|
79
|
|
|
|
|
184
|
my $non_methods = $me->_non_methods($role); |
374
|
|
|
|
|
|
|
|
375
|
79
|
|
|
|
|
203
|
my $subs = $me->_all_subs($role); |
376
|
79
|
|
|
|
|
298
|
for my $sub (keys %$subs) { |
377
|
476
|
100
|
66
|
|
|
1215
|
if ( exists $non_methods->{$sub} && $non_methods->{$sub} == $subs->{$sub} ) { |
378
|
398
|
|
|
|
|
551
|
delete $subs->{$sub}; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
|
382
|
79
|
100
|
|
|
|
216
|
if ($info) { |
383
|
78
|
|
|
|
|
142
|
$info->{methods} = $subs; |
384
|
|
|
|
|
|
|
} |
385
|
79
|
|
|
|
|
197
|
return $subs; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
sub methods_provided_by { |
389
|
3
|
|
|
3
|
0
|
2128
|
my ($me, $role) = @_; |
390
|
3
|
|
|
|
|
9
|
$me->_require_module($role); |
391
|
3
|
100
|
|
|
|
9
|
croak "${role} is not a ${me}" unless $me->is_role($role); |
392
|
2
|
50
|
|
|
|
3
|
sort (keys %{$me->_concrete_methods_of($role)}, @{$INFO{$role}->{requires}||[]}); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
17
|
|
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
sub _install_methods { |
396
|
140
|
|
|
140
|
|
243
|
my ($me, $to, $role) = @_; |
397
|
|
|
|
|
|
|
|
398
|
140
|
|
|
|
|
263
|
my $methods = $me->_concrete_methods_of($role); |
399
|
|
|
|
|
|
|
|
400
|
140
|
|
|
|
|
174
|
my %existing_methods; |
401
|
140
|
|
|
|
|
171
|
@existing_methods{keys %{ $me->_all_subs($to) }} = (); |
|
140
|
|
|
|
|
253
|
|
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
# _concrete_methods_of caches its result on roles. that cache needs to be |
404
|
|
|
|
|
|
|
# invalidated after applying roles |
405
|
140
|
100
|
|
|
|
483
|
delete $INFO{$to}{methods} if $INFO{$to}; |
406
|
|
|
|
|
|
|
|
407
|
140
|
|
|
|
|
275
|
foreach my $i (keys %$methods) { |
408
|
|
|
|
|
|
|
next |
409
|
106
|
100
|
|
|
|
232
|
if exists $existing_methods{$i}; |
410
|
|
|
|
|
|
|
|
411
|
85
|
|
|
|
|
200
|
my $glob = _getglob "${to}::${i}"; |
412
|
85
|
|
|
|
|
197
|
*$glob = $methods->{$i}; |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
# overloads using method names have the method stored in the scalar slot |
415
|
|
|
|
|
|
|
# and &overload::nil in the code slot. |
416
|
|
|
|
|
|
|
next |
417
|
|
|
|
|
|
|
unless $i =~ /^\(/ |
418
|
|
|
|
|
|
|
&& ((defined &overload::nil && $methods->{$i} == \&overload::nil) |
419
|
85
|
50
|
66
|
|
|
302
|
|| (defined &overload::_nil && $methods->{$i} == \&overload::_nil)); |
|
|
|
66
|
|
|
|
|
420
|
|
|
|
|
|
|
|
421
|
9
|
|
|
|
|
12
|
my $overload = ${ _getglob "${role}::${i}" }; |
|
9
|
|
|
|
|
19
|
|
422
|
|
|
|
|
|
|
next |
423
|
9
|
50
|
|
|
|
26
|
unless defined $overload; |
424
|
|
|
|
|
|
|
|
425
|
9
|
|
|
|
|
21
|
*$glob = \$overload; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
|
428
|
140
|
|
|
|
|
304
|
$me->_install_does($to); |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
sub _install_modifiers { |
432
|
132
|
|
|
132
|
|
222
|
my ($me, $to, $name) = @_; |
433
|
132
|
100
|
|
|
|
339
|
return unless my $modifiers = $INFO{$name}{modifiers}; |
434
|
33
|
|
|
|
|
46
|
my $info = $INFO{$to}; |
435
|
33
|
100
|
100
|
|
|
162
|
my $existing = ($info ? $info->{modifiers} : $COMPOSED{modifiers}{$to}) ||= []; |
436
|
|
|
|
|
|
|
my @modifiers = grep { |
437
|
35
|
|
|
|
|
45
|
my $modifier = $_; |
438
|
35
|
|
|
|
|
118
|
!grep $_ == $modifier, @$existing; |
439
|
33
|
50
|
|
|
|
60
|
} @{$modifiers||[]}; |
|
33
|
|
|
|
|
81
|
|
440
|
33
|
|
|
|
|
70
|
push @$existing, @modifiers; |
441
|
|
|
|
|
|
|
|
442
|
33
|
100
|
|
|
|
76
|
if (!$info) { |
443
|
26
|
|
|
|
|
48
|
foreach my $modifier (@modifiers) { |
444
|
26
|
|
|
|
|
827
|
$me->_install_single_modifier($to, @$modifier); |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
my $vcheck_error; |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
sub _install_single_modifier { |
452
|
26
|
|
|
26
|
|
63
|
my ($me, @args) = @_; |
453
|
26
|
100
|
|
|
|
56
|
defined($vcheck_error) or $vcheck_error = do { |
454
|
6
|
|
|
|
|
9
|
local $@; |
455
|
6
|
50
|
|
|
|
10
|
eval { |
456
|
6
|
|
|
|
|
570
|
require Class::Method::Modifiers; |
457
|
6
|
|
|
|
|
1798
|
Class::Method::Modifiers->VERSION(1.05); |
458
|
6
|
|
|
|
|
36
|
1; |
459
|
|
|
|
|
|
|
} ? 0 : $@; |
460
|
|
|
|
|
|
|
}; |
461
|
26
|
50
|
|
|
|
81
|
$vcheck_error and die $vcheck_error; |
462
|
26
|
|
|
|
|
76
|
Class::Method::Modifiers::install_modifier(@args); |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
my $FALLBACK = sub { 0 }; |
466
|
|
|
|
|
|
|
sub _install_does { |
467
|
140
|
|
|
140
|
|
230
|
my ($me, $to) = @_; |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
# only add does() method to classes |
470
|
140
|
100
|
|
|
|
307
|
return if $me->is_role($to); |
471
|
|
|
|
|
|
|
|
472
|
115
|
|
|
|
|
530
|
my $does = $me->can('does_role'); |
473
|
|
|
|
|
|
|
# add does() only if they don't have one |
474
|
115
|
100
|
|
|
|
869
|
*{_getglob "${to}::does"} = $does unless $to->can('does'); |
|
60
|
|
|
|
|
201
|
|
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
return |
477
|
115
|
100
|
50
|
|
|
1084
|
if $to->can('DOES') and $to->can('DOES') != (UNIVERSAL->can('DOES') || 0); |
|
|
|
66
|
|
|
|
|
478
|
|
|
|
|
|
|
|
479
|
59
|
|
33
|
|
|
262
|
my $existing = $to->can('DOES') || $to->can('isa') || $FALLBACK; |
480
|
|
|
|
|
|
|
my $new_sub = sub { |
481
|
5
|
|
|
5
|
|
36
|
my ($proto, $role) = @_; |
482
|
5
|
50
|
|
|
|
13
|
$proto->$does($role) or $proto->$existing($role); |
483
|
59
|
|
|
|
|
260
|
}; |
484
|
27
|
|
|
27
|
|
245
|
no warnings 'redefine'; |
|
27
|
|
|
|
|
112
|
|
|
27
|
|
|
|
|
8524
|
|
485
|
59
|
|
|
|
|
159
|
return *{_getglob "${to}::DOES"} = $new_sub; |
|
59
|
|
|
|
|
192
|
|
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# optimize for newer perls |
489
|
|
|
|
|
|
|
require mro |
490
|
|
|
|
|
|
|
if "$]" >= 5.009_005; |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
if (defined &mro::get_linear_isa) { |
493
|
|
|
|
|
|
|
*_linear_isa = \&mro::get_linear_isa; |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
else { |
496
|
|
|
|
|
|
|
my $e; |
497
|
|
|
|
|
|
|
{ |
498
|
|
|
|
|
|
|
local $@; |
499
|
|
|
|
|
|
|
# this routine is simplified and not fully compatible with mro::get_linear_isa |
500
|
|
|
|
|
|
|
# but for our use the order doesn't matter, so we don't need to care |
501
|
|
|
|
|
|
|
eval <<'END_CODE' or $e = $@; |
502
|
|
|
|
|
|
|
sub _linear_isa($;$) { |
503
|
|
|
|
|
|
|
if (defined &mro::get_linear_isa) { |
504
|
|
|
|
|
|
|
no warnings 'redefine', 'prototype'; |
505
|
|
|
|
|
|
|
*_linear_isa = \&mro::get_linear_isa; |
506
|
|
|
|
|
|
|
goto &mro::get_linear_isa; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
my @check = shift; |
510
|
|
|
|
|
|
|
my @lin; |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
my %found; |
513
|
|
|
|
|
|
|
while (defined(my $check = shift @check)) { |
514
|
|
|
|
|
|
|
push @lin, $check; |
515
|
|
|
|
|
|
|
no strict 'refs'; |
516
|
|
|
|
|
|
|
unshift @check, grep !$found{$_}++, @{"$check\::ISA"}; |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
return \@lin; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
1; |
523
|
|
|
|
|
|
|
END_CODE |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
die $e if defined $e; |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
sub does_role { |
529
|
38
|
|
|
38
|
1
|
5966
|
my ($proto, $role) = @_; |
530
|
38
|
|
66
|
|
|
55
|
foreach my $class (@{_linear_isa(ref($proto)||$proto)}) { |
|
38
|
|
|
|
|
210
|
|
531
|
41
|
100
|
|
|
|
202
|
return 1 if exists $APPLIED_TO{$class}{$role}; |
532
|
|
|
|
|
|
|
} |
533
|
10
|
|
|
|
|
48
|
return 0; |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
sub is_role { |
537
|
541
|
|
|
541
|
1
|
1244
|
my ($me, $role) = @_; |
538
|
|
|
|
|
|
|
return !!($INFO{$role} && ( |
539
|
|
|
|
|
|
|
$INFO{$role}{is_role} |
540
|
|
|
|
|
|
|
# these are for backward compatibility with older Moo that overrode some |
541
|
|
|
|
|
|
|
# methods without calling the originals, thus not getting is_role set |
542
|
|
|
|
|
|
|
|| $INFO{$role}{requires} |
543
|
|
|
|
|
|
|
|| $INFO{$role}{not_methods} |
544
|
|
|
|
|
|
|
|| $INFO{$role}{non_methods} |
545
|
541
|
|
66
|
|
|
2554
|
)); |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
1; |
549
|
|
|
|
|
|
|
__END__ |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
=encoding utf-8 |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
=head1 NAME |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
Role::Tiny - Roles: a nouvelle cuisine portion size slice of Moose |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
=head1 SYNOPSIS |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
package Some::Role; |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
use Role::Tiny; |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
sub foo { ... } |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
sub bar { ... } |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
around baz => sub { ... }; |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
1; |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
elsewhere |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
package Some::Class; |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
use Role::Tiny::With; |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
# bar gets imported, but not foo |
578
|
|
|
|
|
|
|
with 'Some::Role'; |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
sub foo { ... } |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
# baz is wrapped in the around modifier by Class::Method::Modifiers |
583
|
|
|
|
|
|
|
sub baz { ... } |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
1; |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
If you wanted attributes as well, look at L<Moo::Role>. |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
=head1 DESCRIPTION |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
C<Role::Tiny> is a minimalist role composition tool. |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
=head1 ROLE COMPOSITION |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
Role composition can be thought of as much more clever and meaningful multiple |
596
|
|
|
|
|
|
|
inheritance. The basics of this implementation of roles is: |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
=over 2 |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
=item * |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
If a method is already defined on a class, that method will not be composed in |
603
|
|
|
|
|
|
|
from the role. A method inherited by a class gets overridden by the role's |
604
|
|
|
|
|
|
|
method of the same name, though. |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
=item * |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
If a method that the role L</requires> to be implemented is not implemented, |
609
|
|
|
|
|
|
|
role application will fail loudly. |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
=back |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
Unlike L<Class::C3>, where the B<last> class inherited from "wins," role |
614
|
|
|
|
|
|
|
composition is the other way around, where the class wins. If multiple roles |
615
|
|
|
|
|
|
|
are applied in a single call (single with statement), then if any of their |
616
|
|
|
|
|
|
|
provided methods clash, an exception is raised unless the class provides |
617
|
|
|
|
|
|
|
a method since this conflict indicates a potential problem. |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
=head2 ROLE METHODS |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
All subs created after importing Role::Tiny will be considered methods to be |
622
|
|
|
|
|
|
|
composed. For example: |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
package MyRole; |
625
|
|
|
|
|
|
|
use List::Util qw(min); |
626
|
|
|
|
|
|
|
sub mysub { } |
627
|
|
|
|
|
|
|
use Role::Tiny; |
628
|
|
|
|
|
|
|
use List::Util qw(max); |
629
|
|
|
|
|
|
|
sub mymethod { } |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
In this role, C<max> and C<mymethod> will be included when composing MyRole, |
632
|
|
|
|
|
|
|
and C<min> and C<mysub> will not. For additional control, L<namespace::clean> |
633
|
|
|
|
|
|
|
can be used to exclude undesired subs from roles. |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
=head1 IMPORTED SUBROUTINES |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
=head2 requires |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
requires qw(foo bar); |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
Declares a list of methods that must be defined to compose role. |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
=head2 with |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
with 'Some::Role1'; |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
with 'Some::Role1', 'Some::Role2'; |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
Composes another role into the current role (or class via L<Role::Tiny::With>). |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
If you have conflicts and want to resolve them in favour of Some::Role1 you |
652
|
|
|
|
|
|
|
can instead write: |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
with 'Some::Role1'; |
655
|
|
|
|
|
|
|
with 'Some::Role2'; |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
If you have conflicts and want to resolve different conflicts in favour of |
658
|
|
|
|
|
|
|
different roles, please refactor your codebase. |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
=head2 before |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
before foo => sub { ... }; |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
See L<< Class::Method::Modifiers/before method(s) => sub { ... }; >> for full |
665
|
|
|
|
|
|
|
documentation. |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
Note that since you are not required to use method modifiers, |
668
|
|
|
|
|
|
|
L<Class::Method::Modifiers> is lazily loaded and we do not declare it as |
669
|
|
|
|
|
|
|
a dependency. If your L<Role::Tiny> role uses modifiers you must depend on |
670
|
|
|
|
|
|
|
both L<Class::Method::Modifiers> and L<Role::Tiny>. |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
=head2 around |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
around foo => sub { ... }; |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
See L<< Class::Method::Modifiers/around method(s) => sub { ... }; >> for full |
677
|
|
|
|
|
|
|
documentation. |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
Note that since you are not required to use method modifiers, |
680
|
|
|
|
|
|
|
L<Class::Method::Modifiers> is lazily loaded and we do not declare it as |
681
|
|
|
|
|
|
|
a dependency. If your L<Role::Tiny> role uses modifiers you must depend on |
682
|
|
|
|
|
|
|
both L<Class::Method::Modifiers> and L<Role::Tiny>. |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
=head2 after |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
after foo => sub { ... }; |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
See L<< Class::Method::Modifiers/after method(s) => sub { ... }; >> for full |
689
|
|
|
|
|
|
|
documentation. |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
Note that since you are not required to use method modifiers, |
692
|
|
|
|
|
|
|
L<Class::Method::Modifiers> is lazily loaded and we do not declare it as |
693
|
|
|
|
|
|
|
a dependency. If your L<Role::Tiny> role uses modifiers you must depend on |
694
|
|
|
|
|
|
|
both L<Class::Method::Modifiers> and L<Role::Tiny>. |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
=head2 Strict and Warnings |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
In addition to importing subroutines, using C<Role::Tiny> applies L<strict> and |
699
|
|
|
|
|
|
|
L<warnings> to the caller. |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
=head1 SUBROUTINES |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
=head2 does_role |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
if (Role::Tiny::does_role($foo, 'Some::Role')) { |
706
|
|
|
|
|
|
|
... |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
Returns true if class has been composed with role. |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
This subroutine is also installed as ->does on any class a Role::Tiny is |
712
|
|
|
|
|
|
|
composed into unless that class already has an ->does method, so |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
if ($foo->does('Some::Role')) { |
715
|
|
|
|
|
|
|
... |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
will work for classes but to test a role, one must use ::does_role directly. |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
Additionally, Role::Tiny will override the standard Perl C<DOES> method |
721
|
|
|
|
|
|
|
for your class. However, if C<any> class in your class' inheritance |
722
|
|
|
|
|
|
|
hierarchy provides C<DOES>, then Role::Tiny will not override it. |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
=head1 METHODS |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
=head2 make_role |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
Role::Tiny->make_role('Some::Role'); |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
Makes a package into a role, but does not export any subs into it. |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
=head2 apply_roles_to_package |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
Role::Tiny->apply_roles_to_package( |
735
|
|
|
|
|
|
|
'Some::Package', 'Some::Role', 'Some::Other::Role' |
736
|
|
|
|
|
|
|
); |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
Composes role with package. See also L<Role::Tiny::With>. |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
=head2 apply_roles_to_object |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
Role::Tiny->apply_roles_to_object($foo, qw(Some::Role1 Some::Role2)); |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
Composes roles in order into object directly. Object is reblessed into the |
745
|
|
|
|
|
|
|
resulting class. Note that the object's methods get overridden by the role's |
746
|
|
|
|
|
|
|
ones with the same names. |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
=head2 create_class_with_roles |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
Role::Tiny->create_class_with_roles('Some::Base', qw(Some::Role1 Some::Role2)); |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
Creates a new class based on base, with the roles composed into it in order. |
753
|
|
|
|
|
|
|
New class is returned. |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
=head2 is_role |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
Role::Tiny->is_role('Some::Role1') |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
Returns true if the given package is a role. |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
=head1 CAVEATS |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
=over 4 |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
=item * On perl 5.8.8 and earlier, applying a role to an object won't apply any |
766
|
|
|
|
|
|
|
overloads from the role to other copies of the object. |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
=item * On perl 5.16 and earlier, applying a role to a class won't apply any |
769
|
|
|
|
|
|
|
overloads from the role to any existing instances of the class. |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
=back |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
=head1 SEE ALSO |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
L<Role::Tiny> is the attribute-less subset of L<Moo::Role>; L<Moo::Role> is |
776
|
|
|
|
|
|
|
a meta-protocol-less subset of the king of role systems, L<Moose::Role>. |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
Ovid's L<Role::Basic> provides roles with a similar scope, but without method |
779
|
|
|
|
|
|
|
modifiers, and having some extra usage restrictions. |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
=head1 AUTHOR |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk> |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
=head1 CONTRIBUTORS |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx> |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com> |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
hobbs - Andrew Rodland (cpan:ARODLAND) <arodland@cpan.org> |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
jnap - John Napiorkowski (cpan:JJNAPIORK) <jjn1056@yahoo.com> |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org> |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
chip - Chip Salzenberg (cpan:CHIPS) <chip@pobox.com> |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
ajgb - Alex J. G. Burzyński (cpan:AJGB) <ajgb@cpan.org> |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
doy - Jesse Luehrs (cpan:DOY) <doy at tozt dot net> |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
perigrin - Chris Prather (cpan:PERIGRIN) <chris@prather.org> |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com> |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org> |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org> |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org> |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
=head1 COPYRIGHT |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
Copyright (c) 2010-2012 the Role::Tiny L</AUTHOR> and L</CONTRIBUTORS> |
816
|
|
|
|
|
|
|
as listed above. |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=head1 LICENSE |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
This library is free software and may be distributed under the same terms |
821
|
|
|
|
|
|
|
as perl itself. |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
=cut |