line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Role::Tiny; |
2
|
|
|
|
|
|
|
|
3
|
490
|
|
|
490
|
|
570
|
sub _getglob { \*{$_[0]} } |
|
490
|
|
|
|
|
2267
|
|
4
|
397
|
|
|
397
|
|
465
|
sub _getstash { \%{"$_[0]::"} } |
|
397
|
|
|
|
|
1600
|
|
5
|
|
|
|
|
|
|
|
6
|
17
|
|
|
17
|
|
836463
|
use strict; |
|
17
|
|
|
|
|
192
|
|
|
17
|
|
|
|
|
541
|
|
7
|
17
|
|
|
17
|
|
81
|
use warnings; |
|
17
|
|
|
|
|
25
|
|
|
17
|
|
|
|
|
3353
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $VERSION = '2.000006'; |
10
|
|
|
|
|
|
|
$VERSION =~ tr/_//d; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our %INFO; |
13
|
|
|
|
|
|
|
our %APPLIED_TO; |
14
|
|
|
|
|
|
|
our %COMPOSED; |
15
|
|
|
|
|
|
|
our %COMPOSITE_INFO; |
16
|
|
|
|
|
|
|
our @ON_ROLE_CREATE; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# Module state workaround totally stolen from Zefram's Module::Runtime. |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
BEGIN { |
21
|
17
|
50
|
|
17
|
|
152
|
*_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0}; |
22
|
|
|
|
|
|
|
*_WORK_AROUND_HINT_LEAKAGE |
23
|
|
|
|
|
|
|
= "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001) |
24
|
17
|
50
|
33
|
|
|
145
|
? sub(){1} : sub(){0}; |
25
|
17
|
50
|
|
|
|
607
|
*_MRO_MODULE = "$]" < 5.010 ? sub(){"MRO/Compat.pm"} : sub(){"mro.pm"}; |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub croak { |
29
|
7
|
|
|
7
|
0
|
40
|
require Carp; |
30
|
17
|
|
|
17
|
|
99
|
no warnings 'redefine'; |
|
17
|
|
|
|
|
26
|
|
|
17
|
|
|
|
|
27653
|
|
31
|
7
|
|
|
|
|
30
|
*croak = \&Carp::croak; |
32
|
7
|
|
|
|
|
1112
|
goto &Carp::croak; |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub Role::Tiny::__GUARD__::DESTROY { |
36
|
0
|
0
|
|
0
|
|
0
|
delete $INC{$_[0]->[0]} if @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub _load_module { |
40
|
159
|
|
|
159
|
|
1972
|
my ($module) = @_; |
41
|
159
|
|
|
|
|
578
|
(my $file = "$module.pm") =~ s{::}{/}g; |
42
|
|
|
|
|
|
|
return 1 |
43
|
159
|
100
|
|
|
|
424
|
if $INC{$file}; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# can't just ->can('can') because a sub-package Foo::Bar::Baz |
46
|
|
|
|
|
|
|
# creates a 'Baz::' key in Foo::Bar's symbol table |
47
|
|
|
|
|
|
|
return 1 |
48
|
143
|
100
|
|
|
|
181
|
if grep !/::\z/, keys %{_getstash($module)}; |
|
143
|
|
|
|
|
236
|
|
49
|
4
|
|
|
|
|
9
|
my $guard = _WORK_AROUND_BROKEN_MODULE_STATE |
50
|
|
|
|
|
|
|
&& bless([ $file ], 'Role::Tiny::__GUARD__'); |
51
|
4
|
|
|
|
|
6
|
local %^H if _WORK_AROUND_HINT_LEAKAGE; |
52
|
4
|
|
|
|
|
709
|
require $file; |
53
|
0
|
|
|
|
|
0
|
pop @$guard if _WORK_AROUND_BROKEN_MODULE_STATE; |
54
|
0
|
|
|
|
|
0
|
return 1; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub import { |
58
|
61
|
|
|
61
|
|
5653
|
my $target = caller; |
59
|
61
|
|
|
|
|
95
|
my $me = shift; |
60
|
61
|
|
|
|
|
268
|
strict->import; |
61
|
61
|
|
|
|
|
509
|
warnings->import; |
62
|
61
|
|
|
|
|
155
|
$me->_install_subs($target); |
63
|
61
|
50
|
|
|
|
159
|
return if $me->is_role($target); # already exported into this package |
64
|
61
|
|
|
|
|
146
|
$INFO{$target}{is_role} = 1; |
65
|
|
|
|
|
|
|
# get symbol table reference |
66
|
61
|
|
|
|
|
112
|
my $stash = _getstash($target); |
67
|
|
|
|
|
|
|
# grab all *non-constant* (stash slot is not a scalarref) subs present |
68
|
|
|
|
|
|
|
# in the symbol table and store their refaddrs (no need to forcibly |
69
|
|
|
|
|
|
|
# inflate constant subs into real subs) with a map to the coderefs in |
70
|
|
|
|
|
|
|
# case of copying or re-use |
71
|
61
|
50
|
66
|
|
|
789
|
my @not_methods = map +(ref $_ eq 'CODE' ? $_ : ref $_ ? () : *$_{CODE}||()), values %$stash; |
|
|
50
|
|
|
|
|
|
72
|
61
|
|
|
|
|
94
|
@{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods; |
|
61
|
|
|
|
|
360
|
|
73
|
|
|
|
|
|
|
# a role does itself |
74
|
61
|
|
|
|
|
148
|
$APPLIED_TO{$target} = { $target => undef }; |
75
|
61
|
|
|
|
|
10657
|
foreach my $hook (@ON_ROLE_CREATE) { |
76
|
2
|
|
|
|
|
7
|
$hook->($target); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
sub _install_subs { |
81
|
61
|
|
|
61
|
|
143
|
my ($me, $target) = @_; |
82
|
61
|
50
|
|
|
|
120
|
return if $me->is_role($target); |
83
|
|
|
|
|
|
|
# install before/after/around subs |
84
|
61
|
|
|
|
|
149
|
foreach my $type (qw(before after around)) { |
85
|
183
|
|
|
|
|
424
|
*{_getglob "${target}::${type}"} = sub { |
86
|
3
|
|
50
|
3
|
|
4036
|
push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ]; |
|
3
|
|
|
|
|
23
|
|
87
|
3
|
|
|
|
|
7
|
return; |
88
|
183
|
|
|
|
|
592
|
}; |
89
|
|
|
|
|
|
|
} |
90
|
61
|
|
|
|
|
129
|
*{_getglob "${target}::requires"} = sub { |
91
|
13
|
|
50
|
13
|
|
4498
|
push @{$INFO{$target}{requires}||=[]}, @_; |
|
13
|
|
|
|
|
79
|
|
92
|
13
|
|
|
|
|
173
|
return; |
93
|
61
|
|
|
|
|
177
|
}; |
94
|
61
|
|
|
|
|
142
|
*{_getglob "${target}::with"} = sub { |
95
|
14
|
|
|
14
|
|
2678
|
$me->apply_roles_to_package($target, @_); |
96
|
13
|
|
|
|
|
44
|
return; |
97
|
61
|
|
|
|
|
197
|
}; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
sub role_application_steps { |
101
|
41
|
|
|
41
|
0
|
127
|
qw(_install_methods _check_requires _install_modifiers _copy_applied_list); |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub apply_single_role_to_package { |
105
|
33
|
|
|
33
|
0
|
81
|
my ($me, $to, $role) = @_; |
106
|
|
|
|
|
|
|
|
107
|
33
|
|
|
|
|
87
|
_load_module($role); |
108
|
|
|
|
|
|
|
|
109
|
32
|
50
|
|
|
|
93
|
croak "This is apply_role_to_package" if ref($to); |
110
|
32
|
50
|
|
|
|
85
|
croak "${role} is not a Role::Tiny" unless $me->is_role($role); |
111
|
|
|
|
|
|
|
|
112
|
32
|
|
|
|
|
92
|
foreach my $step ($me->role_application_steps) { |
113
|
118
|
|
|
|
|
321
|
$me->$step($to, $role); |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub _copy_applied_list { |
118
|
45
|
|
|
45
|
|
113
|
my ($me, $to, $role) = @_; |
119
|
|
|
|
|
|
|
# copy our role list into the target's |
120
|
45
|
|
100
|
|
|
63
|
@{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = (); |
|
45
|
|
|
|
|
3068
|
|
|
45
|
|
|
|
|
112
|
|
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub apply_roles_to_object { |
124
|
39
|
|
|
39
|
1
|
7625
|
my ($me, $object, @roles) = @_; |
125
|
39
|
50
|
|
|
|
85
|
croak "No roles supplied!" unless @roles; |
126
|
39
|
|
|
|
|
66
|
my $class = ref($object); |
127
|
|
|
|
|
|
|
# on perl < 5.8.9, magic isn't copied to all ref copies. bless the parameter |
128
|
|
|
|
|
|
|
# directly, so at least the variable passed to us will get any magic applied |
129
|
39
|
|
|
|
|
76
|
bless($_[1], $me->create_class_with_roles($class, @roles)); |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
my $role_suffix = 'A000'; |
133
|
|
|
|
|
|
|
sub _composite_name { |
134
|
43
|
|
|
43
|
|
80
|
my ($me, $superclass, @roles) = @_; |
135
|
|
|
|
|
|
|
|
136
|
43
|
|
|
|
|
116
|
my $new_name = join( |
137
|
|
|
|
|
|
|
'__WITH__', $superclass, my $compose_name = join '__AND__', @roles |
138
|
|
|
|
|
|
|
); |
139
|
|
|
|
|
|
|
|
140
|
43
|
100
|
|
|
|
101
|
if (length($new_name) > 252) { |
141
|
7
|
|
33
|
|
|
25
|
$new_name = $COMPOSED{abbrev}{$new_name} ||= do { |
142
|
7
|
|
|
|
|
17
|
my $abbrev = substr $new_name, 0, 250 - length $role_suffix; |
143
|
7
|
|
|
|
|
24
|
$abbrev =~ s/(?
|
144
|
7
|
|
|
|
|
24
|
$abbrev.'__'.$role_suffix++; |
145
|
|
|
|
|
|
|
}; |
146
|
|
|
|
|
|
|
} |
147
|
43
|
50
|
|
|
|
159
|
return wantarray ? ($new_name, $compose_name) : $new_name; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
sub create_class_with_roles { |
151
|
45
|
|
|
45
|
1
|
454
|
my ($me, $superclass, @roles) = @_; |
152
|
|
|
|
|
|
|
|
153
|
45
|
50
|
|
|
|
85
|
croak "No roles supplied!" unless @roles; |
154
|
|
|
|
|
|
|
|
155
|
45
|
|
|
|
|
107
|
_load_module($superclass); |
156
|
|
|
|
|
|
|
{ |
157
|
44
|
|
|
|
|
107
|
my %seen; |
|
44
|
|
|
|
|
68
|
|
158
|
44
|
100
|
|
|
|
178
|
if (my @dupes = grep 1 == $seen{$_}++, @roles) { |
159
|
1
|
|
|
|
|
6
|
croak "Duplicated roles: ".join(', ', @dupes); |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
43
|
|
|
|
|
131
|
my ($new_name, $compose_name) = $me->_composite_name($superclass, @roles); |
164
|
|
|
|
|
|
|
|
165
|
43
|
50
|
|
|
|
112
|
return $new_name if $COMPOSED{class}{$new_name}; |
166
|
|
|
|
|
|
|
|
167
|
43
|
|
|
|
|
88
|
foreach my $role (@roles) { |
168
|
44
|
|
|
|
|
85
|
_load_module($role); |
169
|
44
|
50
|
|
|
|
112
|
croak "${role} is not a Role::Tiny" unless $me->is_role($role); |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
43
|
|
|
|
|
193
|
require(_MRO_MODULE); |
173
|
|
|
|
|
|
|
|
174
|
43
|
|
|
|
|
118
|
my $composite_info = $me->_composite_info_for(@roles); |
175
|
43
|
|
|
|
|
59
|
my %conflicts = %{$composite_info->{conflicts}}; |
|
43
|
|
|
|
|
77
|
|
176
|
43
|
100
|
|
|
|
85
|
if (keys %conflicts) { |
177
|
|
|
|
|
|
|
my $fail = |
178
|
|
|
|
|
|
|
join "\n", |
179
|
|
|
|
|
|
|
map { |
180
|
1
|
|
|
|
|
2
|
"Method name conflict for '$_' between roles " |
181
|
1
|
|
|
|
|
2
|
."'".join("' and '", sort values %{$conflicts{$_}})."'" |
|
1
|
|
|
|
|
8
|
|
182
|
|
|
|
|
|
|
.", cannot apply these simultaneously to an object." |
183
|
|
|
|
|
|
|
} keys %conflicts; |
184
|
1
|
|
|
|
|
4
|
croak $fail; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
42
|
|
|
|
|
100
|
my @composable = map $me->_composable_package_for($_), reverse @roles; |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# some methods may not exist in the role, but get generated by |
190
|
|
|
|
|
|
|
# _composable_package_for (Moose accessors via Moo). filter out anything |
191
|
|
|
|
|
|
|
# provided by the composable packages, excluding the subs we generated to |
192
|
|
|
|
|
|
|
# make modifiers work. |
193
|
|
|
|
|
|
|
my @requires = grep { |
194
|
2
|
|
|
|
|
3
|
my $method = $_; |
195
|
2
|
|
66
|
|
|
17
|
!grep $_->can($method) && !$COMPOSED{role}{$_}{modifiers_only}{$method}, |
196
|
|
|
|
|
|
|
@composable |
197
|
42
|
|
|
|
|
59
|
} @{$composite_info->{requires}}; |
|
42
|
|
|
|
|
75
|
|
198
|
|
|
|
|
|
|
|
199
|
42
|
|
|
|
|
111
|
$me->_check_requires( |
200
|
|
|
|
|
|
|
$superclass, $compose_name, \@requires |
201
|
|
|
|
|
|
|
); |
202
|
|
|
|
|
|
|
|
203
|
41
|
|
|
|
|
75
|
*{_getglob("${new_name}::ISA")} = [ @composable, $superclass ]; |
|
41
|
|
|
|
|
107
|
|
204
|
|
|
|
|
|
|
|
205
|
41
|
|
50
|
|
|
190
|
@{$APPLIED_TO{$new_name}||={}}{ |
206
|
41
|
|
|
|
|
100
|
map keys %{$APPLIED_TO{$_}}, @roles |
|
41
|
|
|
|
|
126
|
|
207
|
|
|
|
|
|
|
} = (); |
208
|
|
|
|
|
|
|
|
209
|
41
|
|
|
|
|
93
|
$COMPOSED{class}{$new_name} = 1; |
210
|
41
|
|
|
|
|
216
|
return $new_name; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
# preserved for compat, and apply_roles_to_package calls it to allow an |
214
|
|
|
|
|
|
|
# updated Role::Tiny to use a non-updated Moo::Role |
215
|
|
|
|
|
|
|
|
216
|
31
|
|
|
31
|
0
|
2015
|
sub apply_role_to_package { shift->apply_single_role_to_package(@_) } |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
sub apply_roles_to_package { |
219
|
38
|
|
|
38
|
1
|
3316
|
my ($me, $to, @roles) = @_; |
220
|
|
|
|
|
|
|
|
221
|
38
|
100
|
|
|
|
153
|
return $me->apply_role_to_package($to, $roles[0]) if @roles == 1; |
222
|
|
|
|
|
|
|
|
223
|
12
|
|
|
|
|
23
|
my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}}; |
|
12
|
|
|
|
|
40
|
|
224
|
12
|
|
|
|
|
62
|
my @have = grep $to->can($_), keys %conflicts; |
225
|
12
|
|
|
|
|
28
|
delete @conflicts{@have}; |
226
|
|
|
|
|
|
|
|
227
|
12
|
100
|
|
|
|
33
|
if (keys %conflicts) { |
228
|
|
|
|
|
|
|
my $fail = |
229
|
|
|
|
|
|
|
join "\n", |
230
|
|
|
|
|
|
|
map { |
231
|
2
|
|
|
|
|
6
|
"Due to a method name conflict between roles " |
232
|
2
|
|
|
|
|
3
|
."'".join(' and ', sort values %{$conflicts{$_}})."'" |
|
2
|
|
|
|
|
32
|
|
233
|
|
|
|
|
|
|
.", the method '$_' must be implemented by '${to}'" |
234
|
|
|
|
|
|
|
} keys %conflicts; |
235
|
2
|
|
|
|
|
94
|
croak $fail; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# conflicting methods are supposed to be treated as required by the |
239
|
|
|
|
|
|
|
# composed role. we don't have an actual composed role, but because |
240
|
|
|
|
|
|
|
# we know the target class already provides them, we can instead |
241
|
|
|
|
|
|
|
# pretend that the roles don't do for the duration of application. |
242
|
10
|
|
|
|
|
40
|
my @role_methods = map $me->_concrete_methods_of($_), @roles; |
243
|
|
|
|
|
|
|
# separate loops, since local ..., delete ... for ...; creates a scope |
244
|
10
|
|
|
|
|
26
|
local @{$_}{@have} for @role_methods; |
|
20
|
|
|
|
|
36
|
|
245
|
10
|
|
|
|
|
20
|
delete @{$_}{@have} for @role_methods; |
|
20
|
|
|
|
|
31
|
|
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# the if guard here is essential since otherwise we accidentally create |
248
|
|
|
|
|
|
|
# a $INFO for something that isn't a Role::Tiny (or Moo::Role) because |
249
|
|
|
|
|
|
|
# autovivification hates us and wants us to die() |
250
|
10
|
100
|
|
|
|
27
|
if ($INFO{$to}) { |
251
|
2
|
|
|
|
|
5
|
delete $INFO{$to}{methods}; # reset since we're about to add methods |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# backcompat: allow subclasses to use apply_single_role_to_package |
255
|
|
|
|
|
|
|
# to apply changes. set a local var so ours does nothing. |
256
|
10
|
|
|
|
|
13
|
our %BACKCOMPAT_HACK; |
257
|
10
|
50
|
66
|
|
|
70
|
if($me ne __PACKAGE__ |
|
|
100
|
100
|
|
|
|
|
258
|
|
|
|
|
|
|
and exists $BACKCOMPAT_HACK{$me} ? $BACKCOMPAT_HACK{$me} : |
259
|
|
|
|
|
|
|
$BACKCOMPAT_HACK{$me} = |
260
|
|
|
|
|
|
|
$me->can('role_application_steps') |
261
|
|
|
|
|
|
|
== \&role_application_steps |
262
|
|
|
|
|
|
|
&& $me->can('apply_single_role_to_package') |
263
|
|
|
|
|
|
|
!= \&apply_single_role_to_package |
264
|
|
|
|
|
|
|
) { |
265
|
1
|
|
|
|
|
3
|
foreach my $role (@roles) { |
266
|
2
|
|
|
|
|
11
|
$me->apply_single_role_to_package($to, $role); |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
else { |
270
|
9
|
|
|
|
|
23
|
foreach my $step ($me->role_application_steps) { |
271
|
36
|
|
|
|
|
197
|
foreach my $role (@roles) { |
272
|
72
|
|
|
|
|
335
|
$me->$step($to, $role); |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
} |
276
|
10
|
|
|
|
|
147
|
$APPLIED_TO{$to}{join('|',@roles)} = 1; |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub _composite_info_for { |
280
|
55
|
|
|
55
|
|
157
|
my ($me, @roles) = @_; |
281
|
55
|
|
66
|
|
|
277
|
$COMPOSITE_INFO{join('|', sort @roles)} ||= do { |
282
|
23
|
|
|
|
|
49
|
foreach my $role (@roles) { |
283
|
34
|
|
|
|
|
64
|
_load_module($role); |
284
|
|
|
|
|
|
|
} |
285
|
23
|
|
|
|
|
40
|
my %methods; |
286
|
23
|
|
|
|
|
43
|
foreach my $role (@roles) { |
287
|
34
|
|
|
|
|
86
|
my $this_methods = $me->_concrete_methods_of($role); |
288
|
34
|
|
|
|
|
175
|
$methods{$_}{$this_methods->{$_}} = $role for keys %$this_methods; |
289
|
|
|
|
|
|
|
} |
290
|
23
|
|
|
|
|
36
|
my %requires; |
291
|
23
|
100
|
|
|
|
46
|
@requires{map @{$INFO{$_}{requires}||[]}, @roles} = (); |
|
34
|
|
|
|
|
144
|
|
292
|
23
|
|
|
|
|
75
|
delete $requires{$_} for keys %methods; |
293
|
23
|
|
|
|
|
47
|
delete $methods{$_} for grep keys(%{$methods{$_}}) == 1, keys %methods; |
|
26
|
|
|
|
|
84
|
|
294
|
23
|
|
|
|
|
131
|
+{ conflicts => \%methods, requires => [keys %requires] } |
295
|
|
|
|
|
|
|
}; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub _composable_package_for { |
299
|
42
|
|
|
42
|
|
106
|
my ($me, $role) = @_; |
300
|
42
|
|
|
|
|
92
|
my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role; |
301
|
42
|
100
|
|
|
|
125
|
return $composed_name if $COMPOSED{role}{$composed_name}; |
302
|
12
|
|
|
|
|
44
|
$me->_install_methods($composed_name, $role); |
303
|
12
|
|
|
|
|
30
|
my $base_name = $composed_name.'::_BASE'; |
304
|
|
|
|
|
|
|
# force stash to exist so ->can doesn't complain |
305
|
12
|
|
|
|
|
32
|
_getstash($base_name); |
306
|
|
|
|
|
|
|
# Not using _getglob, since setting @ISA via the typeglob breaks |
307
|
|
|
|
|
|
|
# inheritance on 5.10.0 if the stash has previously been accessed an |
308
|
|
|
|
|
|
|
# then a method called on the class (in that order!), which |
309
|
|
|
|
|
|
|
# ->_install_methods (with the help of ->_install_does) ends up doing. |
310
|
17
|
|
|
17
|
|
143
|
{ no strict 'refs'; @{"${composed_name}::ISA"} = ( $base_name ); } |
|
17
|
|
|
|
|
33
|
|
|
17
|
|
|
|
|
6573
|
|
|
12
|
|
|
|
|
21
|
|
|
12
|
|
|
|
|
16
|
|
|
12
|
|
|
|
|
189
|
|
311
|
12
|
|
50
|
|
|
71
|
my $modifiers = $INFO{$role}{modifiers}||[]; |
312
|
12
|
|
|
|
|
22
|
my @mod_base; |
313
|
|
|
|
|
|
|
my @modifiers = grep !$composed_name->can($_), |
314
|
12
|
|
|
|
|
18
|
do { my %h; @h{map @{$_}[1..$#$_-1], @$modifiers} = (); keys %h }; |
|
12
|
|
|
|
|
15
|
|
|
12
|
|
|
|
|
26
|
|
|
0
|
|
|
|
|
0
|
|
|
12
|
|
|
|
|
27
|
|
315
|
12
|
|
|
|
|
26
|
foreach my $modified (@modifiers) { |
316
|
0
|
|
|
|
|
0
|
push @mod_base, "sub ${modified} { shift->next::method(\@_) }"; |
317
|
|
|
|
|
|
|
} |
318
|
12
|
|
|
|
|
17
|
my $e; |
319
|
|
|
|
|
|
|
{ |
320
|
12
|
|
|
|
|
15
|
local $@; |
|
12
|
|
|
|
|
21
|
|
321
|
12
|
|
|
|
|
428
|
eval(my $code = join "\n", "package ${base_name};", @mod_base); |
322
|
12
|
50
|
|
|
|
57
|
$e = "Evaling failed: $@\nTrying to eval:\n${code}" if $@; |
323
|
|
|
|
|
|
|
} |
324
|
12
|
50
|
|
|
|
27
|
die $e if $e; |
325
|
12
|
|
|
|
|
40
|
$me->_install_modifiers($composed_name, $role); |
326
|
|
|
|
|
|
|
$COMPOSED{role}{$composed_name} = { |
327
|
12
|
|
|
|
|
43
|
modifiers_only => { map { $_ => 1 } @modifiers }, |
|
0
|
|
|
|
|
0
|
|
328
|
|
|
|
|
|
|
}; |
329
|
12
|
|
|
|
|
47
|
return $composed_name; |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
sub _check_requires { |
333
|
92
|
|
|
92
|
|
195
|
my ($me, $to, $name, $requires) = @_; |
334
|
92
|
100
|
100
|
|
|
118
|
return unless my @requires = @{$requires||$INFO{$name}{requires}||[]}; |
|
92
|
100
|
|
|
|
444
|
|
335
|
22
|
100
|
|
|
|
200
|
if (my @requires_fail = grep !$to->can($_), @requires) { |
336
|
|
|
|
|
|
|
# role -> role, add to requires, role -> class, error out |
337
|
11
|
100
|
|
|
|
36
|
if (my $to_info = $INFO{$to}) { |
338
|
5
|
|
100
|
|
|
12
|
push @{$to_info->{requires}||=[]}, @requires_fail; |
|
5
|
|
|
|
|
29
|
|
339
|
|
|
|
|
|
|
} else { |
340
|
6
|
|
|
|
|
360
|
croak "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail); |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
sub _concrete_methods_of { |
346
|
119
|
|
|
119
|
|
694
|
my ($me, $role) = @_; |
347
|
119
|
|
|
|
|
180
|
my $info = $INFO{$role}; |
348
|
|
|
|
|
|
|
# grab role symbol table |
349
|
119
|
|
|
|
|
180
|
my $stash = _getstash($role); |
350
|
|
|
|
|
|
|
# reverse so our keys become the values (captured coderefs) in case |
351
|
|
|
|
|
|
|
# they got copied or re-used since |
352
|
119
|
100
|
|
|
|
168
|
my $not_methods = { reverse %{$info->{not_methods}||{}} }; |
|
119
|
|
|
|
|
730
|
|
353
|
|
|
|
|
|
|
$info->{methods} ||= +{ |
354
|
|
|
|
|
|
|
# grab all code entries that aren't in the not_methods list |
355
|
|
|
|
|
|
|
map {; |
356
|
17
|
|
|
17
|
|
114
|
no strict 'refs'; |
|
17
|
|
|
|
|
35
|
|
|
17
|
|
|
|
|
4107
|
|
357
|
363
|
100
|
|
|
|
448
|
my $code = exists &{"${role}::$_"} ? \&{"${role}::$_"} : undef; |
|
363
|
|
|
|
|
840
|
|
|
297
|
|
|
|
|
537
|
|
358
|
363
|
100
|
100
|
|
|
1325
|
( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code) |
359
|
119
|
|
33
|
|
|
723
|
} grep +(!ref($stash->{$_}) || ref($stash->{$_}) eq 'CODE'), keys %$stash |
|
|
|
100
|
|
|
|
|
360
|
|
|
|
|
|
|
}; |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
sub methods_provided_by { |
364
|
2
|
|
|
2
|
0
|
1114
|
my ($me, $role) = @_; |
365
|
2
|
100
|
|
|
|
6
|
croak "${role} is not a Role::Tiny" unless $me->is_role($role); |
366
|
1
|
50
|
|
|
|
2
|
(keys %{$me->_concrete_methods_of($role)}, @{$INFO{$role}->{requires}||[]}); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
7
|
|
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
sub _install_methods { |
370
|
62
|
|
|
62
|
|
131
|
my ($me, $to, $role) = @_; |
371
|
|
|
|
|
|
|
|
372
|
62
|
|
|
|
|
95
|
my $info = $INFO{$role}; |
373
|
|
|
|
|
|
|
|
374
|
62
|
|
|
|
|
132
|
my $methods = $me->_concrete_methods_of($role); |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# grab target symbol table |
377
|
62
|
|
|
|
|
137
|
my $stash = _getstash($to); |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# determine already extant methods of target |
380
|
62
|
|
|
|
|
95
|
my %has_methods; |
381
|
|
|
|
|
|
|
@has_methods{grep |
382
|
62
|
|
50
|
|
|
229
|
+(ref($stash->{$_}) || *{$stash->{$_}}{CODE}), |
383
|
|
|
|
|
|
|
keys %$stash |
384
|
|
|
|
|
|
|
} = (); |
385
|
|
|
|
|
|
|
|
386
|
62
|
|
|
|
|
224
|
foreach my $i (grep !exists $has_methods{$_}, keys %$methods) { |
387
|
17
|
|
|
17
|
|
113
|
no warnings 'once'; |
|
17
|
|
|
|
|
37
|
|
|
17
|
|
|
|
|
8241
|
|
388
|
68
|
|
|
|
|
203
|
my $glob = _getglob "${to}::${i}"; |
389
|
68
|
|
|
|
|
170
|
*$glob = $methods->{$i}; |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
# overloads using method names have the method stored in the scalar slot |
392
|
|
|
|
|
|
|
# and &overload::nil in the code slot. |
393
|
|
|
|
|
|
|
next |
394
|
|
|
|
|
|
|
unless $i =~ /^\(/ |
395
|
|
|
|
|
|
|
&& ((defined &overload::nil && $methods->{$i} == \&overload::nil) |
396
|
68
|
50
|
66
|
|
|
285
|
|| (defined &overload::_nil && $methods->{$i} == \&overload::_nil)); |
|
|
|
66
|
|
|
|
|
397
|
|
|
|
|
|
|
|
398
|
9
|
|
|
|
|
17
|
my $overload = ${ *{_getglob "${role}::${i}"}{SCALAR} }; |
|
9
|
|
|
|
|
14
|
|
|
9
|
|
|
|
|
25
|
|
399
|
|
|
|
|
|
|
next |
400
|
9
|
100
|
|
|
|
25
|
unless defined $overload; |
401
|
|
|
|
|
|
|
|
402
|
6
|
|
|
|
|
14
|
*$glob = \$overload; |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
|
405
|
62
|
|
|
|
|
171
|
$me->_install_does($to); |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
sub _install_modifiers { |
409
|
57
|
|
|
57
|
|
122
|
my ($me, $to, $name) = @_; |
410
|
57
|
100
|
|
|
|
171
|
return unless my $modifiers = $INFO{$name}{modifiers}; |
411
|
2
|
|
|
|
|
3
|
my $info = $INFO{$to}; |
412
|
2
|
50
|
100
|
|
|
13
|
my $existing = ($info ? $info->{modifiers} : $COMPOSED{modifiers}{$to}) ||= []; |
413
|
|
|
|
|
|
|
my @modifiers = grep { |
414
|
2
|
|
|
|
|
6
|
my $modifier = $_; |
415
|
2
|
|
|
|
|
9
|
!grep $_ == $modifier, @$existing; |
416
|
2
|
50
|
|
|
|
5
|
} @{$modifiers||[]}; |
|
2
|
|
|
|
|
8
|
|
417
|
2
|
|
|
|
|
6
|
push @$existing, @modifiers; |
418
|
|
|
|
|
|
|
|
419
|
2
|
50
|
|
|
|
7
|
if (!$info) { |
420
|
2
|
|
|
|
|
4
|
foreach my $modifier (@modifiers) { |
421
|
2
|
|
|
|
|
8
|
$me->_install_single_modifier($to, @$modifier); |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
my $vcheck_error; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
sub _install_single_modifier { |
429
|
2
|
|
|
2
|
|
6
|
my ($me, @args) = @_; |
430
|
2
|
100
|
|
|
|
7
|
defined($vcheck_error) or $vcheck_error = do { |
431
|
1
|
|
|
|
|
5
|
local $@; |
432
|
1
|
50
|
|
|
|
2
|
eval { |
433
|
1
|
|
|
|
|
6
|
require Class::Method::Modifiers; |
434
|
1
|
|
|
|
|
19
|
Class::Method::Modifiers->VERSION(1.05); |
435
|
1
|
|
|
|
|
6
|
1; |
436
|
|
|
|
|
|
|
} ? 0 : $@; |
437
|
|
|
|
|
|
|
}; |
438
|
2
|
50
|
|
|
|
5
|
$vcheck_error and die $vcheck_error; |
439
|
2
|
|
|
|
|
6
|
Class::Method::Modifiers::install_modifier(@args); |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
my $FALLBACK = sub { 0 }; |
443
|
|
|
|
|
|
|
sub _install_does { |
444
|
62
|
|
|
62
|
|
120
|
my ($me, $to) = @_; |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# only add does() method to classes |
447
|
62
|
100
|
|
|
|
121
|
return if $me->is_role($to); |
448
|
|
|
|
|
|
|
|
449
|
46
|
|
|
|
|
262
|
my $does = $me->can('does_role'); |
450
|
|
|
|
|
|
|
# add does() only if they don't have one |
451
|
46
|
100
|
|
|
|
426
|
*{_getglob "${to}::does"} = $does unless $to->can('does'); |
|
34
|
|
|
|
|
107
|
|
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
return |
454
|
46
|
100
|
50
|
|
|
465
|
if $to->can('DOES') and $to->can('DOES') != (UNIVERSAL->can('DOES') || 0); |
|
|
|
66
|
|
|
|
|
455
|
|
|
|
|
|
|
|
456
|
33
|
|
33
|
|
|
153
|
my $existing = $to->can('DOES') || $to->can('isa') || $FALLBACK; |
457
|
|
|
|
|
|
|
my $new_sub = sub { |
458
|
4
|
|
|
4
|
|
8
|
my ($proto, $role) = @_; |
459
|
4
|
50
|
|
|
|
9
|
$proto->$does($role) or $proto->$existing($role); |
460
|
33
|
|
|
|
|
149
|
}; |
461
|
17
|
|
|
17
|
|
113
|
no warnings 'redefine'; |
|
17
|
|
|
|
|
30
|
|
|
17
|
|
|
|
|
2988
|
|
462
|
33
|
|
|
|
|
62
|
return *{_getglob "${to}::DOES"} = $new_sub; |
|
33
|
|
|
|
|
87
|
|
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
sub does_role { |
466
|
34
|
|
|
34
|
1
|
6525
|
my ($proto, $role) = @_; |
467
|
34
|
|
|
|
|
161
|
require(_MRO_MODULE); |
468
|
34
|
|
66
|
|
|
51
|
foreach my $class (@{mro::get_linear_isa(ref($proto)||$proto)}) { |
|
34
|
|
|
|
|
188
|
|
469
|
41
|
100
|
|
|
|
177
|
return 1 if exists $APPLIED_TO{$class}{$role}; |
470
|
|
|
|
|
|
|
} |
471
|
9
|
|
|
|
|
45
|
return 0; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
sub is_role { |
475
|
264
|
|
|
264
|
1
|
2642
|
my ($me, $role) = @_; |
476
|
264
|
|
66
|
|
|
1260
|
return !!($INFO{$role} && ($INFO{$role}{is_role} || $INFO{$role}{not_methods})); |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
1; |
480
|
|
|
|
|
|
|
__END__ |