line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Role::Basic; |
2
|
|
|
|
|
|
|
|
3
|
335
|
|
|
335
|
|
363
|
sub _getglob { \*{ $_[0] } } |
|
335
|
|
|
|
|
16465
|
|
4
|
|
|
|
|
|
|
|
5
|
37
|
|
|
37
|
|
870672
|
use strict; |
|
36
|
|
|
|
|
88
|
|
|
36
|
|
|
|
|
1106
|
|
6
|
37
|
|
|
37
|
|
781
|
use warnings FATAL => 'all'; |
|
36
|
|
|
|
|
64
|
|
|
36
|
|
|
|
|
1400
|
|
7
|
|
|
|
|
|
|
|
8
|
34
|
|
|
34
|
|
808
|
use B qw/svref_2object/; |
|
34
|
|
|
|
|
67
|
|
|
34
|
|
|
|
|
1486
|
|
9
|
30
|
|
|
30
|
|
26911
|
use Storable (); |
|
29
|
|
|
|
|
88933
|
|
|
29
|
|
|
|
|
668
|
|
10
|
29
|
|
|
29
|
|
235
|
use Carp (); |
|
29
|
|
|
|
|
72
|
|
|
29
|
|
|
|
|
598
|
|
11
|
28
|
|
|
28
|
|
5042
|
use Data::Dumper (); |
|
28
|
|
|
|
|
48902
|
|
|
28
|
|
|
|
|
25828
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $VERSION = '0.13'; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# eventually clean these up |
16
|
|
|
|
|
|
|
my ( %IS_ROLE, %REQUIRED_BY, %HAS_ROLES, %ALLOWED_BY, %PROVIDES ); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub import { |
19
|
131
|
|
|
131
|
|
17857
|
my $class = shift; |
20
|
131
|
|
|
|
|
262
|
my $target = caller; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
# everybody gets 'with' and 'DOES' |
23
|
131
|
|
|
|
|
771
|
*{ _getglob "${target}::with" } = sub { |
24
|
85
|
|
|
85
|
|
67309
|
$class->apply_roles_to_package( $target, @_ ); |
25
|
131
|
|
|
|
|
554
|
}; |
26
|
|
|
|
|
|
|
# everybody gets 'with' and 'DOES' |
27
|
131
|
|
|
|
|
328
|
*{ _getglob "${target}::DOES" } = sub { |
28
|
46
|
|
|
46
|
|
17015
|
my ( $proto, $role ) = @_; |
29
|
46
|
|
66
|
|
|
201
|
my $class_or_role = ref $proto || $proto; |
30
|
46
|
100
|
|
|
|
161
|
return 1 if $class_or_role eq $role; |
31
|
39
|
100
|
|
|
|
278
|
return exists $HAS_ROLES{$class_or_role}{$role} ? 1 : 0; |
32
|
131
|
|
|
|
|
590
|
}; |
33
|
131
|
100
|
100
|
|
|
2080
|
if ( 1 == @_ && 'with' eq $_[0] ) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# this is a class which is consuming roles |
36
|
56
|
|
|
|
|
38016
|
return; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
elsif ( 2 == @_ && 'allow' eq $_[0] ) { |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# this is a role which allows methods from a foreign class |
41
|
2
|
|
|
|
|
5
|
my $foreign_class = $_[1]; |
42
|
2
|
|
|
|
|
3
|
push @{ $ALLOWED_BY{$foreign_class} } => $target; |
|
2
|
|
|
|
|
7
|
|
43
|
2
|
|
|
|
|
8
|
$class->_declare_role($target); |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
elsif (@_) { |
46
|
2
|
|
|
|
|
6
|
my $args = join ', ' => @_; # more explicit than $" |
47
|
2
|
|
|
|
|
596
|
Carp::confess( |
48
|
|
|
|
|
|
|
"Multiple or unknown argument(s) in import list: ($args)"); |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
else { |
51
|
71
|
|
|
|
|
196
|
$class->_declare_role($target); |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub _declare_role { |
56
|
73
|
|
|
73
|
|
138
|
my ($class, $target) = @_; |
57
|
73
|
|
|
|
|
167
|
$IS_ROLE{$target} = 1; |
58
|
73
|
|
|
|
|
198
|
*{ _getglob "${target}::requires" } = sub { |
59
|
12
|
|
|
12
|
|
3155
|
$class->add_to_requirements( $target, @_ ); |
60
|
73
|
|
|
|
|
252
|
}; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
sub add_to_requirements { |
64
|
72
|
|
|
72
|
0
|
192
|
my ( $class, $role, @methods ) = @_; |
65
|
|
|
|
|
|
|
|
66
|
72
|
|
100
|
|
|
316
|
$REQUIRED_BY{$role} ||= []; |
67
|
72
|
|
|
|
|
90
|
push @{ $REQUIRED_BY{$role} } => @methods; |
|
72
|
|
|
|
|
154
|
|
68
|
72
|
|
|
|
|
167
|
my %seen; |
69
|
72
|
|
|
|
|
251
|
@{ $REQUIRED_BY{$role} } = |
|
99
|
|
|
|
|
1638
|
|
70
|
72
|
|
|
|
|
112
|
grep { not $seen{$_}++ } @{ $REQUIRED_BY{$role} }; |
|
72
|
|
|
|
|
221
|
|
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub get_required_by { |
74
|
283
|
|
|
283
|
0
|
1325
|
my ( $class, $role ) = @_; |
75
|
283
|
100
|
|
|
|
931
|
return unless my $requirements = $REQUIRED_BY{$role}; |
76
|
115
|
|
|
|
|
310
|
return @$requirements; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
sub requires_method { |
80
|
13
|
|
|
13
|
0
|
17679
|
my ( $class, $role, $method ) = @_; |
81
|
13
|
50
|
|
|
|
55
|
return unless $IS_ROLE{$role}; |
82
|
13
|
|
|
|
|
44
|
my %requires = map { $_ => 1 } $class->get_required_by($role); |
|
9
|
|
|
|
|
41
|
|
83
|
13
|
|
|
|
|
69
|
return $requires{$method}; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
sub _roles { |
87
|
130
|
|
|
130
|
|
186
|
my ( $class, $target ) = @_; |
88
|
130
|
100
|
|
|
|
710
|
return unless $HAS_ROLES{$target}; |
89
|
17
|
|
|
|
|
30
|
my @roles; |
90
|
|
|
|
|
|
|
my %seen; |
91
|
17
|
|
|
|
|
24
|
foreach my $role ( keys %{ $HAS_ROLES{$target} } ) { |
|
17
|
|
|
|
|
48
|
|
92
|
22
|
|
|
|
|
43
|
my $modifiers = $HAS_ROLES{$target}{$role}; |
93
|
22
|
|
|
|
|
56
|
my $role_name = $class->_get_role_name($role,$modifiers); |
94
|
22
|
50
|
|
|
|
1019
|
unless ( $seen{$role_name} ) { |
95
|
22
|
|
|
|
|
86
|
push @roles => $role_name, $class->_roles($role); |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
} |
98
|
17
|
|
|
|
|
60
|
return @roles; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub apply_roles_to_package { |
102
|
85
|
|
|
85
|
0
|
278
|
my ( $class, $target, @roles ) = @_; |
103
|
|
|
|
|
|
|
|
104
|
85
|
100
|
|
|
|
280
|
if ( $HAS_ROLES{$target} ) { |
105
|
2
|
|
|
|
|
579
|
Carp::confess("with() may not be called more than once for $target"); |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
83
|
|
|
|
|
132
|
my ( %provided_by, %requires ); |
109
|
|
|
|
|
|
|
|
110
|
0
|
|
|
|
|
0
|
my %is_applied; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# these are roles which a class does not use directly, but are contained in |
113
|
|
|
|
|
|
|
# the roles the class consumes. |
114
|
0
|
|
|
|
|
0
|
my %contained_roles; |
115
|
|
|
|
|
|
|
|
116
|
83
|
|
|
|
|
252
|
while ( my $role = shift @roles ) { |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# will need to verify that they're actually a role! |
119
|
|
|
|
|
|
|
|
120
|
117
|
100
|
|
|
|
440
|
my $role_modifiers = shift @roles if ref $roles[0]; |
121
|
117
|
|
100
|
|
|
411
|
$role_modifiers ||= {}; |
122
|
117
|
|
|
|
|
328
|
my $role_name = $class->_get_role_name( $role, $role_modifiers ); |
123
|
117
|
|
|
|
|
17908
|
$is_applied{$role_name} = 1; |
124
|
117
|
|
|
|
|
524
|
$class->_load_role( $role, $role_modifiers->{'-version'} ); |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# XXX this is awful. Don't tell anyone I wrote this |
127
|
114
|
|
|
|
|
416
|
my $role_methods = $class->_add_role_methods_to_target( |
128
|
|
|
|
|
|
|
$role, |
129
|
|
|
|
|
|
|
$target, |
130
|
|
|
|
|
|
|
$role_modifiers |
131
|
|
|
|
|
|
|
); |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# DOES() in some cases |
134
|
108
|
100
|
|
|
|
306
|
if ( my $roles = $HAS_ROLES{$role} ) { |
135
|
17
|
|
|
|
|
47
|
foreach my $role ( keys %$roles ) { |
136
|
22
|
|
|
|
|
66
|
$HAS_ROLES{$target}{$role} = $roles->{$role}; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
108
|
|
|
|
|
335
|
foreach my $method ( $class->get_required_by($role) ) { |
141
|
46
|
|
|
|
|
55
|
push @{ $requires{$method} } => $role; |
|
46
|
|
|
|
|
149
|
|
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# roles consuming roles should have the same requirements. |
145
|
108
|
100
|
|
|
|
284
|
if ( $IS_ROLE{$target} ) { |
146
|
33
|
|
|
|
|
86
|
$class->add_to_requirements( $target, |
147
|
|
|
|
|
|
|
$class->get_required_by($role) ); |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
108
|
|
|
|
|
371
|
while ( my ( $method, $data ) = each %$role_methods ) { |
151
|
152
|
|
66
|
|
|
870
|
$PROVIDES{$role_name}{$method} ||= $data; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# any extra roles contained in applied roles must be added |
155
|
|
|
|
|
|
|
# (helps with conflict resolution) |
156
|
108
|
|
|
|
|
197
|
$contained_roles{$role_name} = 1; |
157
|
108
|
|
|
|
|
306
|
foreach my $contained_role ( $class->_roles($role) ) { |
158
|
22
|
100
|
|
|
|
60
|
next if $is_applied{$contained_role}; |
159
|
21
|
|
|
|
|
39
|
$contained_roles{$contained_role} = 1; |
160
|
21
|
|
|
|
|
88
|
$is_applied{$contained_role} = 1; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
} |
163
|
74
|
|
|
|
|
184
|
foreach my $contained_role (keys %contained_roles) { |
164
|
126
|
|
|
|
|
408
|
my ( $role, $modifiers ) = split /-/ => $contained_role, 2; |
165
|
126
|
|
|
|
|
310
|
foreach my $method ( $class->get_required_by($role) ) { |
166
|
49
|
|
|
|
|
62
|
push @{ $requires{$method} } => $role; |
|
49
|
|
|
|
|
131
|
|
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
# a role is not a name. A role is a role plus its alias/exclusion. We |
169
|
|
|
|
|
|
|
# now store those in $HAS_ROLE so pull from them |
170
|
126
|
100
|
|
|
|
359
|
if ( my $methods = $PROVIDES{$contained_role} ) { |
171
|
106
|
|
|
|
|
214
|
foreach my $method (keys %$methods) { |
172
|
178
|
|
|
|
|
184
|
push @{ $provided_by{$method} } => $methods->{$method}; |
|
178
|
|
|
|
|
617
|
|
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
74
|
|
|
|
|
7674
|
$class->_check_conflicts( $target, \%provided_by ); |
178
|
64
|
|
|
|
|
227
|
$class->_check_requirements( $target, \%requires ); |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub _uniq (@) { |
182
|
20
|
|
|
20
|
|
33
|
my %seen = (); |
183
|
20
|
|
|
|
|
31
|
grep { not $seen{$_}++ } @_; |
|
42
|
|
|
|
|
141
|
|
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub _check_conflicts { |
187
|
74
|
|
|
74
|
|
117
|
my ( $class, $target, $provided_by ) = @_; |
188
|
74
|
|
|
|
|
130
|
my @errors; |
189
|
74
|
|
|
|
|
196
|
foreach my $method (keys %$provided_by) { |
190
|
136
|
|
|
|
|
325
|
my $sources = $provided_by->{$method}; |
191
|
136
|
100
|
|
|
|
386
|
next if 1 == @$sources; |
192
|
|
|
|
|
|
|
|
193
|
37
|
|
|
|
|
48
|
my %seen; |
194
|
|
|
|
|
|
|
# what we're doing here is checking to see if code references point to |
195
|
|
|
|
|
|
|
# the same reference. If they do, they can't possibly be in conflict |
196
|
|
|
|
|
|
|
# because they're the same method. This seems strange, but it does |
197
|
|
|
|
|
|
|
# follow the original spec. |
198
|
37
|
|
|
|
|
44
|
my @sources = do { |
199
|
23
|
|
|
23
|
|
202
|
no warnings 'uninitialized'; |
|
23
|
|
|
|
|
59
|
|
|
23
|
|
|
|
|
10332
|
|
200
|
56
|
|
|
|
|
157
|
map { $_->{source} } |
|
79
|
|
|
|
|
293
|
|
201
|
37
|
|
|
|
|
58
|
grep { !$seen{ $_->{code} }++ } @$sources; |
202
|
|
|
|
|
|
|
}; |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
# more than one role provides the method and it's not overridden by |
205
|
|
|
|
|
|
|
# the consuming class having that method |
206
|
37
|
100
|
100
|
|
|
281
|
if ( @sources > 1 && $target ne _sub_package( $target->can($method) ) ) |
207
|
|
|
|
|
|
|
{ |
208
|
13
|
|
|
|
|
59
|
my $sources = join "' and '" => sort @sources; |
209
|
13
|
|
|
|
|
78
|
push @errors => |
210
|
|
|
|
|
|
|
"Due to a method name conflict in roles '$sources', the method '$method' must be implemented or excluded by '$target'"; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
} |
213
|
74
|
100
|
|
|
|
308
|
if ( my $errors = join "\n" => @errors ) { |
214
|
10
|
|
|
|
|
1981
|
Carp::confess($errors); |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
sub _check_requirements { |
219
|
64
|
|
|
64
|
|
241
|
my ( $class, $target, $requires ) = @_; |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
# we return if the target is a role because requirements can be deferred |
222
|
|
|
|
|
|
|
# until final composition |
223
|
64
|
100
|
|
|
|
293
|
return if $IS_ROLE{$target}; |
224
|
43
|
|
|
|
|
60
|
my @errors; |
225
|
43
|
|
|
|
|
152
|
foreach my $method ( keys %$requires ) { |
226
|
37
|
100
|
|
|
|
391
|
unless ( $target->can($method) ) { |
227
|
20
|
|
|
|
|
30
|
my $roles = join '|' => _uniq sort @{ $requires->{$method} }; |
|
20
|
|
|
|
|
80
|
|
228
|
20
|
|
|
|
|
130
|
push @errors => |
229
|
|
|
|
|
|
|
"'$roles' requires the method '$method' to be implemented by '$target'"; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
} |
232
|
43
|
100
|
|
|
|
333
|
if (@errors) { |
233
|
9
|
|
|
|
|
1720
|
Carp::confess( join "\n" => @errors ); |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
sub _get_role_name { |
238
|
253
|
|
|
253
|
|
390
|
my ( $class, $role, $modifiers ) = @_; |
239
|
253
|
|
|
|
|
346
|
local $Data::Dumper::Indent = 0; |
240
|
253
|
|
|
|
|
313
|
local $Data::Dumper::Terse = 1; |
241
|
253
|
|
|
|
|
285
|
local $Data::Dumper::Sortkeys = 1; |
242
|
253
|
|
|
|
|
909
|
return "$role-" . Data::Dumper::Dumper($modifiers); |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
sub _add_role_methods_to_target { |
246
|
114
|
|
|
114
|
|
224
|
my ( $class, $role, $target, $role_modifiers) = @_; |
247
|
|
|
|
|
|
|
|
248
|
114
|
|
|
|
|
4312
|
my $copied_modifiers = Storable::dclone($role_modifiers); |
249
|
114
|
|
|
|
|
322
|
my $role_name = $class->_get_role_name( $role, $copied_modifiers ); |
250
|
|
|
|
|
|
|
|
251
|
114
|
|
|
|
|
6035
|
my $target_methods = $class->_get_methods($target); |
252
|
114
|
|
|
|
|
204
|
my $is_loaded = $PROVIDES{$role_name}; |
253
|
114
|
|
66
|
|
|
372
|
my $code_for = $is_loaded || $class->_get_methods($role); |
254
|
114
|
|
|
|
|
501
|
my %original_code_for = %$code_for; |
255
|
|
|
|
|
|
|
|
256
|
114
|
|
|
|
|
202
|
delete $role_modifiers->{'-version'}; |
257
|
114
|
|
|
|
|
345
|
my ( $is_excluded, $aliases ) = |
258
|
|
|
|
|
|
|
$class->_get_excludes_and_aliases( $target, $role, $role_modifiers ); |
259
|
|
|
|
|
|
|
|
260
|
16
|
|
|
16
|
|
109
|
my $stash = do { no strict 'refs'; \%{"${target}::"} }; |
|
16
|
|
|
|
|
38
|
|
|
16
|
|
|
|
|
6016
|
|
|
114
|
|
|
|
|
148
|
|
|
114
|
|
|
|
|
121
|
|
|
114
|
|
|
|
|
324
|
|
261
|
114
|
|
|
|
|
391
|
while ( my ( $old_method, $new_method ) = each %$aliases ) { |
262
|
27
|
100
|
|
|
|
58
|
if ( !$is_loaded ) { |
263
|
16
|
50
|
66
|
|
|
64
|
if ( exists $code_for->{$new_method} && !$is_excluded->{$new_method} ) { |
264
|
0
|
|
|
|
|
0
|
Carp::confess( |
265
|
|
|
|
|
|
|
"Cannot alias '$old_method' to existing method '$new_method' in $role" |
266
|
|
|
|
|
|
|
); |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
else { |
269
|
16
|
|
|
|
|
43
|
$code_for->{$new_method} = $original_code_for{$old_method}; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
# We do this because $target->can($new_method) wouldn't be appropriate |
274
|
|
|
|
|
|
|
# since it's OK for a role method to -alias over an inherited one. You |
275
|
|
|
|
|
|
|
# can -alias directly on top of an existing method, though. |
276
|
27
|
100
|
|
|
|
108
|
if ( exists $stash->{$new_method} ) { |
277
|
5
|
|
|
|
|
973
|
Carp::confess("Cannot alias '$old_method' to '$new_method' as a method of that name already exists in $target"); |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
109
|
|
|
|
|
247
|
my %was_aliased = reverse %$aliases; |
282
|
109
|
|
|
|
|
247
|
foreach my $method ( keys %$code_for ) { |
283
|
180
|
100
|
|
|
|
388
|
if ( $is_excluded->{$method} ) { |
284
|
30
|
100
|
|
|
|
71
|
unless ($was_aliased{$method}) { |
285
|
27
|
|
|
|
|
46
|
delete $code_for->{$method}; |
286
|
27
|
|
|
|
|
79
|
$class->add_to_requirements( $target, $method ); |
287
|
27
|
|
|
|
|
66
|
next; |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
153
|
100
|
|
|
|
315
|
if ( exists $target_methods->{$method} ) { |
292
|
21
|
100
|
|
|
|
68
|
if ( $ENV{PERL_ROLE_OVERRIDE_DIE} ) { |
293
|
1
|
|
|
|
|
164
|
Carp::confess( |
294
|
|
|
|
|
|
|
"Role '$role' not overriding method '$method' in '$target'" |
295
|
|
|
|
|
|
|
); |
296
|
|
|
|
|
|
|
} |
297
|
20
|
50
|
|
|
|
53
|
if ( $ENV{PERL_ROLE_OVERRIDE_WARN} ) { |
298
|
0
|
|
|
|
|
0
|
Carp::carp( |
299
|
|
|
|
|
|
|
"Role '$role' not overriding method '$method' in '$target'" |
300
|
|
|
|
|
|
|
); |
301
|
|
|
|
|
|
|
} |
302
|
20
|
|
|
|
|
36
|
next; |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
# XXX we're going to handle this ourselves |
305
|
16
|
|
|
16
|
|
91
|
no strict 'refs'; |
|
16
|
|
|
|
|
33
|
|
|
16
|
|
|
|
|
540
|
|
306
|
16
|
|
|
16
|
|
255
|
no warnings 'redefine'; |
|
16
|
|
|
|
|
51
|
|
|
16
|
|
|
|
|
6992
|
|
307
|
132
|
|
|
|
|
204
|
*{"${target}::$method"} = $code_for->{$method}{code}; |
|
132
|
|
|
|
|
663
|
|
308
|
|
|
|
|
|
|
} |
309
|
108
|
|
|
|
|
327
|
$HAS_ROLES{$target}{$role} = $copied_modifiers; |
310
|
108
|
|
|
|
|
521
|
return $code_for; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
sub _get_excludes_and_aliases { |
314
|
114
|
|
|
114
|
|
203
|
my ( $class, $target, $role, $role_modifiers ) = @_; |
315
|
|
|
|
|
|
|
# figure out which methods to exclude |
316
|
114
|
|
100
|
|
|
479
|
my $excludes = delete $role_modifiers->{'-excludes'} || []; |
317
|
114
|
|
100
|
|
|
441
|
my $aliases = delete $role_modifiers->{'-alias'} || {}; |
318
|
114
|
|
100
|
|
|
432
|
my $renames = delete $role_modifiers->{'-rename'} || {}; |
319
|
|
|
|
|
|
|
|
320
|
114
|
100
|
|
|
|
288
|
$excludes = [$excludes] unless ref $excludes; |
321
|
114
|
|
|
|
|
230
|
my %is_excluded = map { $_ => 1 } @$excludes; |
|
33
|
|
|
|
|
105
|
|
322
|
|
|
|
|
|
|
|
323
|
114
|
|
|
|
|
430
|
while ( my ( $old_method, $new_method ) = each %$renames ) { |
324
|
6
|
|
|
|
|
11
|
$is_excluded{$old_method} = 1; |
325
|
6
|
|
|
|
|
24
|
$aliases->{$old_method} = $new_method; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
114
|
50
|
|
|
|
304
|
unless ( 'ARRAY' eq ref $excludes ) { |
329
|
0
|
|
|
|
|
0
|
Carp::confess( |
330
|
|
|
|
|
|
|
"Argument to '-excludes' in package $target must be a scalar or array reference" |
331
|
|
|
|
|
|
|
); |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
# rename methods to alias |
335
|
114
|
50
|
|
|
|
277
|
unless ( 'HASH' eq ref $aliases ) { |
336
|
0
|
|
|
|
|
0
|
Carp::confess( |
337
|
|
|
|
|
|
|
"Argument to '-alias' in package $target must be a hash reference" |
338
|
|
|
|
|
|
|
); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
114
|
50
|
|
|
|
329
|
if ( my $unknown = join ', ' => keys %$role_modifiers ) { |
342
|
0
|
|
|
|
|
0
|
Carp::confess("Unknown arguments in 'with()' statement for $role"); |
343
|
|
|
|
|
|
|
} |
344
|
114
|
|
|
|
|
477
|
return ( \%is_excluded, $aliases ); |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
# We can cache this at some point, but for now, the return value is munged |
348
|
|
|
|
|
|
|
sub _get_methods { |
349
|
193
|
|
|
193
|
|
309
|
my ( $class, $target ) = @_; |
350
|
|
|
|
|
|
|
|
351
|
16
|
|
|
16
|
|
91
|
my $stash = do { no strict 'refs'; \%{"${target}::"} }; |
|
16
|
|
|
|
|
41
|
|
|
16
|
|
|
|
|
9820
|
|
|
193
|
|
|
|
|
202
|
|
|
193
|
|
|
|
|
207
|
|
|
193
|
|
|
|
|
549
|
|
352
|
|
|
|
|
|
|
|
353
|
193
|
|
|
|
|
253
|
my %methods; |
354
|
193
|
|
|
|
|
456
|
foreach my $item ( values %$stash ) { |
355
|
|
|
|
|
|
|
|
356
|
1172
|
100
|
|
|
|
1914
|
next unless my $code = _get_valid_method( $target, $item ); |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# this prevents a "modification of read-only value" error. |
359
|
234
|
|
|
|
|
499
|
my $name = $item; |
360
|
234
|
|
|
|
|
3809
|
$name =~ s/^\*$target\:://; |
361
|
234
|
|
|
|
|
601
|
my $source = _sub_package($code); |
362
|
234
|
|
|
|
|
1103
|
$methods{$name} = { |
363
|
|
|
|
|
|
|
code => $code, |
364
|
|
|
|
|
|
|
source => $source, |
365
|
|
|
|
|
|
|
}; |
366
|
|
|
|
|
|
|
} |
367
|
193
|
|
|
|
|
573
|
return \%methods; |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
sub _get_valid_method { |
371
|
1172
|
|
|
1172
|
|
2430
|
my ( $target, $item ) = @_; |
372
|
1172
|
100
|
|
|
|
2231
|
return if ref $item; |
373
|
1162
|
100
|
|
|
|
4143
|
my $code = *$item{CODE} or return; |
374
|
|
|
|
|
|
|
|
375
|
770
|
50
|
|
|
|
1638
|
my $source = _sub_package($code) or return; |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
# XXX There's a potential bug where some idiot could use Role::Basic to |
378
|
|
|
|
|
|
|
# create exportable functions and those get exported into a role. That's |
379
|
|
|
|
|
|
|
# far-fetched enough that I'm not worried about it. |
380
|
770
|
|
66
|
|
|
16591
|
my $is_valid = |
381
|
|
|
|
|
|
|
# declared in package, not imported |
382
|
|
|
|
|
|
|
$target eq $source |
383
|
|
|
|
|
|
|
|| |
384
|
|
|
|
|
|
|
# unless we're a role and they're composed from another role |
385
|
|
|
|
|
|
|
$IS_ROLE{$target} && $IS_ROLE{$source}; |
386
|
|
|
|
|
|
|
|
387
|
770
|
100
|
|
|
|
1621
|
unless ($is_valid) { |
388
|
546
|
|
|
|
|
608
|
foreach my $role (@{ $ALLOWED_BY{$source} }) { |
|
546
|
|
|
|
|
4225
|
|
389
|
10
|
50
|
|
|
|
42
|
return $code if $target->DOES($role); |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
} |
392
|
760
|
100
|
|
|
|
3130
|
return $is_valid ? $code : (); |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
sub _sub_package { |
396
|
1022
|
|
|
1022
|
|
1208
|
my ($code) = @_; |
397
|
1022
|
|
|
|
|
989
|
my $source_package; |
398
|
1022
|
|
|
|
|
1105
|
eval { |
399
|
1022
|
|
|
|
|
4971
|
my $stash = svref_2object($code)->STASH; |
400
|
1022
|
50
|
33
|
|
|
6038
|
if ( $stash && $stash->can('NAME') ) { |
401
|
1022
|
|
|
|
|
2839
|
$source_package = $stash->NAME; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
else { |
404
|
0
|
|
|
|
|
0
|
$source_package = ''; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
}; |
407
|
1022
|
50
|
|
|
|
3614
|
if ( my $error = $@ ) { |
408
|
0
|
|
|
|
|
0
|
warn "Could not determine calling source_package: $error"; |
409
|
|
|
|
|
|
|
} |
410
|
1022
|
|
50
|
|
|
3219
|
return $source_package || ''; |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
sub _load_role { |
414
|
121
|
|
|
121
|
|
3002
|
my ( $class, $role, $version ) = @_; |
415
|
|
|
|
|
|
|
|
416
|
121
|
|
100
|
|
|
714
|
$version ||= ''; |
417
|
16
|
|
|
16
|
|
97
|
my $stash = do { no strict 'refs'; \%{"${role}::"} }; |
|
16
|
|
|
|
|
28
|
|
|
16
|
|
|
|
|
4547
|
|
|
121
|
|
|
|
|
132
|
|
|
121
|
|
|
|
|
133
|
|
|
121
|
|
|
|
|
476
|
|
418
|
121
|
100
|
|
|
|
359
|
if ( exists $stash->{requires} ) { |
419
|
115
|
|
|
|
|
150
|
my $package = $role; |
420
|
115
|
|
|
|
|
379
|
$package =~ s{::}{/}g; |
421
|
115
|
|
|
|
|
182
|
$package .= ".pm"; |
422
|
115
|
100
|
|
|
|
333
|
if ( not exists $INC{$package} ) { |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
# embedded role, not a separate package |
425
|
58
|
|
|
|
|
208
|
$INC{"$package"} = "added to inc by $class"; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
} |
428
|
121
|
|
|
15
|
|
7931
|
eval "use $role $version"; |
|
15
|
|
|
|
|
1591
|
|
|
15
|
|
|
|
|
196
|
|
|
14
|
|
|
|
|
243
|
|
429
|
121
|
100
|
|
|
|
1795
|
Carp::confess($@) if $@; |
430
|
|
|
|
|
|
|
|
431
|
117
|
100
|
|
|
|
451
|
return 1 if $IS_ROLE{$role}; |
432
|
|
|
|
|
|
|
|
433
|
1
|
|
|
|
|
8
|
my $requires = $role->can('requires'); |
434
|
1
|
50
|
33
|
|
|
6
|
if ( !$requires || $class ne _sub_package($requires) ) { |
435
|
1
|
|
|
|
|
298
|
Carp::confess( |
436
|
|
|
|
|
|
|
"Only roles defined with $class may be loaded with _load_role. '$role' is not allowed."); |
437
|
|
|
|
|
|
|
} |
438
|
0
|
|
|
|
|
0
|
$IS_ROLE{$role} = 1; |
439
|
0
|
|
|
|
|
0
|
return 1; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
1; |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
__END__ |