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