line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package MOP::Internal::Util; |
2
|
|
|
|
|
|
|
# ABSTRACT: For MOP Internal Use Only |
3
|
|
|
|
|
|
|
|
4
|
35
|
|
|
35
|
|
197
|
use strict; |
|
35
|
|
|
|
|
52
|
|
|
35
|
|
|
|
|
794
|
|
5
|
35
|
|
|
35
|
|
129
|
use warnings; |
|
35
|
|
|
|
|
65
|
|
|
35
|
|
|
|
|
671
|
|
6
|
|
|
|
|
|
|
|
7
|
35
|
|
|
35
|
|
133
|
use B (); # nasty stuff, all nasty stuff |
|
35
|
|
|
|
|
52
|
|
|
35
|
|
|
|
|
346
|
|
8
|
35
|
|
|
35
|
|
173
|
use Carp (); # errors and stuff |
|
35
|
|
|
|
|
57
|
|
|
35
|
|
|
|
|
393
|
|
9
|
35
|
|
|
35
|
|
3808
|
use Sub::Util (); # handling some sub stuff |
|
35
|
|
|
|
|
2861
|
|
|
35
|
|
|
|
|
465
|
|
10
|
35
|
|
|
35
|
|
12487
|
use Sub::Metadata (); # handling other sub stuff |
|
35
|
|
|
|
|
16116
|
|
|
35
|
|
|
|
|
625
|
|
11
|
35
|
|
|
35
|
|
12354
|
use Symbol (); # creating the occasional symbol |
|
35
|
|
|
|
|
21659
|
|
|
35
|
|
|
|
|
650
|
|
12
|
35
|
|
|
35
|
|
172
|
use Scalar::Util (); # I think I use blessed somewhere in here ... |
|
35
|
|
|
|
|
167
|
|
|
35
|
|
|
|
|
391
|
|
13
|
35
|
|
|
35
|
|
12740
|
use Devel::OverloadInfo (); # Sometimes I need to know about overloading |
|
35
|
|
|
|
|
356125
|
|
|
35
|
|
|
|
|
647
|
|
14
|
35
|
|
|
35
|
|
11552
|
use Devel::Hook (); # for scheduling UNITCHECK blocks ... |
|
35
|
|
|
|
|
25605
|
|
|
35
|
|
|
|
|
14022
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
our $VERSION = '0.14'; |
17
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:STEVAN'; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
## ------------------------------------------------------------------ |
20
|
|
|
|
|
|
|
## Basic Glob access |
21
|
|
|
|
|
|
|
## ------------------------------------------------------------------ |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub IS_VALID_MODULE_NAME { |
24
|
117
|
|
|
117
|
0
|
198
|
my ($name) = @_; |
25
|
117
|
|
|
|
|
667
|
$name =~ /[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/ |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub IS_STASH_REF { |
29
|
4
|
|
|
4
|
0
|
7
|
my ($stash) = @_; |
30
|
4
|
50
|
|
|
|
8
|
Carp::confess('[ARGS] You must specify a stash') |
31
|
|
|
|
|
|
|
unless defined $stash; |
32
|
4
|
100
|
|
|
|
19
|
if ( my $name = B::svref_2object( $stash )->NAME ) { |
33
|
2
|
|
|
|
|
5
|
return IS_VALID_MODULE_NAME( $name ); |
34
|
|
|
|
|
|
|
} |
35
|
2
|
|
|
|
|
6
|
return; |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub GET_NAME { |
39
|
1135
|
|
|
1135
|
0
|
1395
|
my ($stash) = @_; |
40
|
1135
|
50
|
|
|
|
1709
|
Carp::confess('[ARGS] You must specify a stash') |
41
|
|
|
|
|
|
|
unless defined $stash; |
42
|
1135
|
|
|
|
|
3799
|
B::svref_2object( $stash )->NAME |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub GET_STASH_NAME { |
46
|
91
|
|
|
91
|
0
|
163
|
my ($stash) = @_; |
47
|
91
|
50
|
|
|
|
160
|
Carp::confess('[ARGS] You must specify a stash') |
48
|
|
|
|
|
|
|
unless defined $stash; |
49
|
91
|
|
|
|
|
1178
|
B::svref_2object( $stash )->STASH->NAME |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub GET_GLOB_NAME { |
53
|
546
|
|
|
546
|
0
|
686
|
my ($stash) = @_; |
54
|
546
|
50
|
|
|
|
765
|
Carp::confess('[ARGS] You must specify a stash') |
55
|
|
|
|
|
|
|
unless defined $stash; |
56
|
546
|
|
|
|
|
1807
|
B::svref_2object( $stash )->GV->NAME |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub GET_GLOB_STASH_NAME { |
60
|
611
|
|
|
611
|
0
|
731
|
my ($stash) = @_; |
61
|
611
|
50
|
|
|
|
872
|
Carp::confess('[ARGS] You must specify a stash') |
62
|
|
|
|
|
|
|
unless defined $stash; |
63
|
611
|
|
|
|
|
3013
|
B::svref_2object( $stash )->GV->STASH->NAME |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub GET_GLOB_SLOT { |
67
|
1627
|
|
|
1627
|
0
|
2273
|
my ($stash, $name, $slot) = @_; |
68
|
|
|
|
|
|
|
|
69
|
1627
|
50
|
|
|
|
2360
|
Carp::confess('[ARGS] You must specify a stash') |
70
|
|
|
|
|
|
|
unless defined $stash; |
71
|
1627
|
50
|
|
|
|
2036
|
Carp::confess('[ARGS] You must specify a name') |
72
|
|
|
|
|
|
|
unless defined $name; |
73
|
1627
|
50
|
|
|
|
2037
|
Carp::confess('[ARGS] You must specify a slot') |
74
|
|
|
|
|
|
|
unless defined $slot; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# do my best to not autovivify, and |
77
|
|
|
|
|
|
|
# return undef if not |
78
|
1627
|
100
|
|
|
|
2495
|
return unless exists $stash->{ $name }; |
79
|
|
|
|
|
|
|
# occasionally we need to auto-inflate |
80
|
|
|
|
|
|
|
# the optimized version of a required |
81
|
|
|
|
|
|
|
# method, its annoying, but the XS side |
82
|
|
|
|
|
|
|
# should not have to care about this so |
83
|
|
|
|
|
|
|
# it can be removed eventually. |
84
|
1471
|
50
|
100
|
|
|
6449
|
if (( $slot eq 'CODE' && $stash->{ $name } eq "-1" ) || ref $stash->{ $name } ne 'GLOB') { |
|
|
|
66
|
|
|
|
|
85
|
1471
|
|
|
|
|
5729
|
B::svref_2object( $stash )->NAME->can( $name ); |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
# return the reference stored in the glob |
90
|
|
|
|
|
|
|
# which might be undef, but that can be |
91
|
|
|
|
|
|
|
# handled by the caller |
92
|
1471
|
|
|
|
|
2428
|
return *{ $stash->{ $name } }{ $slot }; |
|
1471
|
|
|
|
|
4796
|
|
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub SET_GLOB_SLOT { |
96
|
4
|
|
|
4
|
0
|
11
|
my ($stash, $name, $value_ref) = @_; |
97
|
|
|
|
|
|
|
|
98
|
4
|
50
|
|
|
|
12
|
Carp::confess('[ARGS] You must specify a stash') |
99
|
|
|
|
|
|
|
unless defined $stash; |
100
|
4
|
50
|
|
|
|
9
|
Carp::confess('[ARGS] You must specify a name') |
101
|
|
|
|
|
|
|
unless defined $name; |
102
|
4
|
50
|
|
|
|
17
|
Carp::confess('[ARGS] You must specify a value REF') |
103
|
|
|
|
|
|
|
unless defined $value_ref; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
{ |
106
|
35
|
|
|
35
|
|
235
|
no strict 'refs'; |
|
35
|
|
|
|
|
72
|
|
|
35
|
|
|
|
|
1161
|
|
|
4
|
|
|
|
|
7
|
|
107
|
35
|
|
|
35
|
|
191
|
no warnings 'once'; |
|
35
|
|
|
|
|
68
|
|
|
35
|
|
|
|
|
18395
|
|
108
|
|
|
|
|
|
|
# get the name of the stash, we could have |
109
|
|
|
|
|
|
|
# passed this in, but it is easy to get in |
110
|
|
|
|
|
|
|
# XS, and so we can punt that down the road |
111
|
|
|
|
|
|
|
# for the time being |
112
|
4
|
|
|
|
|
23
|
my $pkg = B::svref_2object( $stash )->NAME; |
113
|
4
|
|
|
|
|
8
|
*{ $pkg . '::' . $name } = $value_ref; |
|
4
|
|
|
|
|
26
|
|
114
|
|
|
|
|
|
|
} |
115
|
4
|
|
|
|
|
10
|
return; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
## ------------------------------------------------------------------ |
119
|
|
|
|
|
|
|
## UNITCHECK hook |
120
|
|
|
|
|
|
|
## ------------------------------------------------------------------ |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub ADD_UNITCHECK_HOOK { |
123
|
5
|
|
|
5
|
0
|
8
|
my ($cv) = @_; |
124
|
5
|
50
|
|
|
|
24
|
Carp::confess('[ARGS] You must specify a CODE reference') |
125
|
|
|
|
|
|
|
unless $cv; |
126
|
5
|
50
|
33
|
|
|
26
|
Carp::confess('[ARGS] You must specify a CODE reference') |
127
|
|
|
|
|
|
|
unless $cv && ref $cv eq 'CODE'; |
128
|
5
|
|
|
|
|
23
|
Devel::Hook->push_UNITCHECK_hook( $cv ); |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
## ------------------------------------------------------------------ |
132
|
|
|
|
|
|
|
## CV/Glob introspection |
133
|
|
|
|
|
|
|
## ------------------------------------------------------------------ |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub CAN_COERCE_TO_CODE_REF { |
136
|
119
|
|
|
119
|
0
|
192
|
my ($object) = @_; |
137
|
119
|
100
|
66
|
|
|
842
|
return 0 unless $object && Scalar::Util::blessed( $object ); |
138
|
|
|
|
|
|
|
# might be just a blessed CODE ref ... |
139
|
26
|
50
|
|
|
|
112
|
return 1 if Scalar::Util::reftype( $object ) eq 'CODE'; |
140
|
|
|
|
|
|
|
# or might be overloaded object ... |
141
|
0
|
0
|
|
|
|
0
|
return 0 unless Devel::OverloadInfo::is_overloaded( $object ); |
142
|
0
|
|
|
|
|
0
|
return exists Devel::OverloadInfo::overload_info( $object )->{'&{}'}; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub IS_CV_NULL { |
146
|
929
|
|
|
929
|
0
|
1067
|
my ($cv) = @_; |
147
|
929
|
50
|
|
|
|
1240
|
Carp::confess('[ARGS] You must specify a CODE reference') |
148
|
|
|
|
|
|
|
unless $cv; |
149
|
929
|
50
|
33
|
|
|
2311
|
Carp::confess('[ARGS] You must specify a CODE reference') |
|
|
|
33
|
|
|
|
|
150
|
|
|
|
|
|
|
unless $cv && ref $cv eq 'CODE' |
151
|
|
|
|
|
|
|
|| CAN_COERCE_TO_CODE_REF( $cv ); |
152
|
929
|
|
|
|
|
2257
|
return Sub::Metadata::sub_body_type( $cv ) eq 'UNDEF'; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub DOES_GLOB_HAVE_NULL_CV { |
156
|
166
|
|
|
166
|
0
|
462
|
my ($glob) = @_; |
157
|
166
|
50
|
|
|
|
309
|
Carp::confess('[ARGS] You must specify a GLOB') |
158
|
|
|
|
|
|
|
unless $glob; |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# The glob may be -1 or a string, which is perl’s way |
161
|
|
|
|
|
|
|
# of optimizing null sub declarations like ‘sub foo;’ |
162
|
|
|
|
|
|
|
# and ‘sub bar($);’. |
163
|
166
|
100
|
66
|
|
|
419
|
return 1 if ref \$glob eq 'SCALAR' && defined $glob; |
164
|
|
|
|
|
|
|
# We may have a reference to a scalar or array, which |
165
|
|
|
|
|
|
|
# represents a constant, so is not a null sub. |
166
|
165
|
50
|
33
|
|
|
355
|
return 0 if ref $glob and ref $glob ne 'CODE'; |
167
|
|
|
|
|
|
|
# next lets see if we have a CODE slot (or a code |
168
|
|
|
|
|
|
|
# reference instead of a glob) ... |
169
|
165
|
50
|
|
|
|
258
|
if ( my $code = ref $glob ? $glob : *{ $glob }{CODE} ) { |
|
165
|
100
|
|
|
|
514
|
|
170
|
141
|
|
|
|
|
792
|
return Sub::Metadata::sub_body_type( $code ) eq 'UNDEF'; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
# if we had no CODE slot, it can't be a NULL CV ... |
174
|
24
|
|
|
|
|
70
|
return 0; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub CREATE_NULL_CV { |
178
|
3
|
|
|
3
|
0
|
6
|
my ($in_pkg, $name) = @_; |
179
|
3
|
50
|
|
|
|
6
|
Carp::confess('[ARGS] You must specify a package name') |
180
|
|
|
|
|
|
|
unless defined $in_pkg; |
181
|
3
|
50
|
|
|
|
5
|
Carp::confess('[ARGS] You must specify a name') |
182
|
|
|
|
|
|
|
unless defined $name; |
183
|
|
|
|
|
|
|
# this just tries to eval the NULL CV into |
184
|
|
|
|
|
|
|
# place, it is ugly, but works for now |
185
|
3
|
100
|
|
|
|
140
|
eval "sub ${in_pkg}::${name}; 1;" or do { Carp::confess($@) }; |
|
1
|
|
|
|
|
146
|
|
186
|
2
|
|
|
|
|
6
|
return; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub SET_COMP_STASH_FOR_CV { |
190
|
3
|
|
|
3
|
0
|
8
|
my ($cv, $in_pkg) = @_; |
191
|
3
|
50
|
|
|
|
9
|
Carp::confess('[ARGS] You must specify a CODE reference') |
192
|
|
|
|
|
|
|
unless $cv; |
193
|
3
|
50
|
|
|
|
8
|
Carp::confess('[ARGS] You must specify a package name') |
194
|
|
|
|
|
|
|
unless defined $in_pkg; |
195
|
3
|
50
|
66
|
|
|
20
|
Carp::confess('[ARGS] You must specify a CODE reference') |
|
|
|
66
|
|
|
|
|
196
|
|
|
|
|
|
|
unless $cv && ref $cv eq 'CODE' |
197
|
|
|
|
|
|
|
|| CAN_COERCE_TO_CODE_REF( $cv ); |
198
|
3
|
|
|
|
|
14
|
Sub::Metadata::mutate_sub_package( $cv, $in_pkg ); |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
sub INSTALL_CV { |
202
|
422
|
|
|
422
|
0
|
678
|
my ($in_pkg, $name, $cv, %opts) = @_; |
203
|
|
|
|
|
|
|
|
204
|
422
|
50
|
|
|
|
619
|
Carp::confess('[ARGS] You must specify a package name') |
205
|
|
|
|
|
|
|
unless defined $in_pkg; |
206
|
422
|
50
|
|
|
|
514
|
Carp::confess('[ARGS] You must specify a name') |
207
|
|
|
|
|
|
|
unless defined $name; |
208
|
422
|
50
|
33
|
|
|
1061
|
Carp::confess('[ARGS] You must specify a CODE reference') |
|
|
|
33
|
|
|
|
|
209
|
|
|
|
|
|
|
unless $cv && ref $cv eq 'CODE' |
210
|
|
|
|
|
|
|
|| CAN_COERCE_TO_CODE_REF( $cv ); |
211
|
|
|
|
|
|
|
Carp::confess("[ARGS] You must specify a boolean value for `set_subname` option") |
212
|
422
|
50
|
|
|
|
559
|
if not exists $opts{set_subname}; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
{ |
215
|
35
|
|
|
35
|
|
224
|
no strict 'refs'; |
|
35
|
|
|
|
|
63
|
|
|
35
|
|
|
|
|
1052
|
|
|
422
|
|
|
|
|
408
|
|
216
|
35
|
|
|
35
|
|
171
|
no warnings 'once', 'redefine'; |
|
35
|
|
|
|
|
62
|
|
|
35
|
|
|
|
|
5885
|
|
217
|
|
|
|
|
|
|
|
218
|
422
|
|
|
|
|
590
|
my $fullname = $in_pkg.'::'.$name; |
219
|
422
|
100
|
|
|
|
559
|
*{$fullname} = $opts{set_subname} ? Sub::Util::set_subname($fullname, $cv) : $cv; |
|
422
|
|
|
|
|
1374
|
|
220
|
|
|
|
|
|
|
} |
221
|
422
|
|
|
|
|
760
|
return; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub REMOVE_CV_FROM_GLOB { |
225
|
4
|
|
|
4
|
0
|
9
|
my ($stash, $name) = @_; |
226
|
|
|
|
|
|
|
|
227
|
4
|
50
|
33
|
|
|
27
|
Carp::confess('[ARGS] You must specify a stash') |
228
|
|
|
|
|
|
|
unless $stash && ref $stash eq 'HASH'; |
229
|
4
|
50
|
|
|
|
14
|
Carp::confess('[ARGS] You must specify a name') |
230
|
|
|
|
|
|
|
unless defined $name; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# find the glob we are looking for |
233
|
|
|
|
|
|
|
# which might not exist, in which |
234
|
|
|
|
|
|
|
# case we do nothing .... |
235
|
4
|
50
|
|
|
|
15
|
if ( my $glob = $stash->{ $name } ) { |
236
|
|
|
|
|
|
|
# once we find it, extract all the |
237
|
|
|
|
|
|
|
# slots we need, note the missing |
238
|
|
|
|
|
|
|
# CODE slot since we don't need |
239
|
|
|
|
|
|
|
# that in our new glob ... |
240
|
4
|
|
|
|
|
16
|
my %to_save; |
241
|
4
|
|
|
|
|
11
|
foreach my $slot (qw[ SCALAR ARRAY HASH FORMAT IO ]) { |
242
|
20
|
100
|
|
|
|
22
|
if ( my $val = *{ $glob }{ $slot } ) { |
|
20
|
|
|
|
|
67
|
|
243
|
4
|
|
|
|
|
16
|
$to_save{ $slot } = $val; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
# replace the old glob with a new one ... |
247
|
4
|
|
|
|
|
16
|
$stash->{ $name } = Symbol::gensym(); |
248
|
|
|
|
|
|
|
# now go about constructing our new |
249
|
|
|
|
|
|
|
# glob by restoring the other slots |
250
|
|
|
|
|
|
|
{ |
251
|
35
|
|
|
35
|
|
203
|
no strict 'refs'; |
|
35
|
|
|
|
|
62
|
|
|
35
|
|
|
|
|
1049
|
|
|
4
|
|
|
|
|
61
|
|
252
|
35
|
|
|
35
|
|
195
|
no warnings 'once'; |
|
35
|
|
|
|
|
60
|
|
|
35
|
|
|
|
|
26057
|
|
253
|
|
|
|
|
|
|
# get the name of the stash, we could have |
254
|
|
|
|
|
|
|
# passed this in, but it is easy to get in |
255
|
|
|
|
|
|
|
# XS, and so we can punt that down the road |
256
|
|
|
|
|
|
|
# for the time being |
257
|
4
|
|
|
|
|
16
|
my $pkg = B::svref_2object( $stash )->NAME; |
258
|
4
|
|
|
|
|
15
|
foreach my $type ( keys %to_save ) { |
259
|
4
|
|
|
|
|
6
|
*{ $pkg . '::' . $name } = $to_save{ $type }; |
|
4
|
|
|
|
|
15
|
|
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
# ... the end |
264
|
4
|
|
|
|
|
13
|
return; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
## ------------------------------------------------------------------ |
268
|
|
|
|
|
|
|
## Role application and composition |
269
|
|
|
|
|
|
|
## ------------------------------------------------------------------ |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
sub APPLY_ROLES { |
272
|
16
|
|
|
16
|
0
|
291
|
my ($meta, $roles) = @_; |
273
|
|
|
|
|
|
|
|
274
|
16
|
50
|
|
|
|
59
|
Carp::confess('[ARGS] You must specify a metaclass to apply roles to') |
275
|
|
|
|
|
|
|
unless Scalar::Util::blessed( $meta ); |
276
|
16
|
50
|
33
|
|
|
296
|
Carp::confess('[ARGS] You must specify a least one roles to apply as an ARRAY ref') |
|
|
|
33
|
|
|
|
|
277
|
|
|
|
|
|
|
unless $roles && ref $roles eq 'ARRAY' && scalar( @$roles ) != 0; |
278
|
|
|
|
|
|
|
|
279
|
16
|
|
|
|
|
57
|
foreach my $r ( $meta->roles ) { |
280
|
|
|
|
|
|
|
Carp::confess("[ERROR] Could not find role ($_) in the set of roles in $meta (" . $meta->name . ")") |
281
|
18
|
50
|
|
|
|
31
|
unless scalar grep { $r eq $_ } @$roles; |
|
22
|
|
|
|
|
76
|
|
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
16
|
|
|
|
|
29
|
my @meta_roles = map { MOP::Role->new( name => $_ ) } @$roles; |
|
18
|
|
|
|
|
108
|
|
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
my ( |
287
|
16
|
|
|
|
|
234
|
$slots, |
288
|
|
|
|
|
|
|
$slot_conflicts |
289
|
|
|
|
|
|
|
) = COMPOSE_ALL_ROLE_SLOTS( @meta_roles ); |
290
|
|
|
|
|
|
|
|
291
|
16
|
50
|
|
|
|
55
|
Carp::confess("[CONFLICT] There should be no conflicting slots when composing (" . (join ', ' => @$roles) . ") into (" . $meta->name . ")") |
292
|
|
|
|
|
|
|
if scalar keys %$slot_conflicts; |
293
|
|
|
|
|
|
|
|
294
|
16
|
|
|
|
|
37
|
foreach my $name ( keys %$slots ) { |
295
|
|
|
|
|
|
|
# if we have a slot already by that name ... |
296
|
0
|
0
|
|
|
|
0
|
Carp::confess("[CONFLICT] Role Conflict, cannot compose slot ($name) into (" . $meta->name . ") because ($name) already exists") |
297
|
|
|
|
|
|
|
if $meta->has_slot( $name ); |
298
|
|
|
|
|
|
|
# otherwise alias it ... |
299
|
0
|
|
|
|
|
0
|
$meta->alias_slot( $name, $slots->{ $name } ); |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
my ( |
303
|
16
|
|
|
|
|
32
|
$methods, |
304
|
|
|
|
|
|
|
$method_conflicts, |
305
|
|
|
|
|
|
|
$required_methods |
306
|
|
|
|
|
|
|
) = COMPOSE_ALL_ROLE_METHODS( @meta_roles ); |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
Carp::confess("[CONFLICT] There should be no conflicting methods when composing (" . (join ', ' => @$roles) . ") into (" . $meta->name . ") but instead we found (" . (join ', ' => keys %$method_conflicts) . ")") |
309
|
|
|
|
|
|
|
if (scalar keys %$method_conflicts) # do we have any conflicts ... |
310
|
|
|
|
|
|
|
# and the conflicts are not satisfied by the composing item ... |
311
|
16
|
0
|
50
|
|
|
67
|
&& (scalar grep { !$meta->has_method( $_ ) } keys %$method_conflicts); |
|
0
|
|
|
|
|
0
|
|
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# check the required method set and |
314
|
|
|
|
|
|
|
# see if what we are composing into |
315
|
|
|
|
|
|
|
# happens to fulfill them |
316
|
16
|
|
|
|
|
37
|
foreach my $name ( keys %$required_methods ) { |
317
|
3
|
50
|
|
|
|
7
|
delete $required_methods->{ $name } |
318
|
|
|
|
|
|
|
if $meta->name->can( $name ); |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
16
|
50
|
|
|
|
39
|
Carp::confess("[CONFLICT] There should be no required methods when composing (" . (join ', ' => @$roles) . ") into (" . $meta->name . ") but instead we found (" . (join ', ' => keys %$required_methods) . ")") |
322
|
|
|
|
|
|
|
if scalar keys %$required_methods; # do we have required methods ... |
323
|
|
|
|
|
|
|
|
324
|
16
|
|
|
|
|
71
|
foreach my $name ( keys %$methods ) { |
325
|
|
|
|
|
|
|
# if we have a method already by that name ... |
326
|
419
|
50
|
|
|
|
646
|
next if $meta->has_method( $name ); |
327
|
|
|
|
|
|
|
# otherwise, alias it ... |
328
|
419
|
|
|
|
|
663
|
$meta->alias_method( $name, $methods->{ $name } ); |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
# if we still have keys in $required, it is |
332
|
|
|
|
|
|
|
# because we are a role (class would have |
333
|
|
|
|
|
|
|
# died above), so we can just stuff in the |
334
|
|
|
|
|
|
|
# required methods ... |
335
|
16
|
|
|
|
|
61
|
$meta->add_required_method( $_ ) for keys %$required_methods; |
336
|
|
|
|
|
|
|
|
337
|
16
|
|
|
|
|
106
|
return; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
sub COMPOSE_ALL_ROLE_SLOTS { |
341
|
16
|
|
|
16
|
0
|
38
|
my @roles = @_; |
342
|
|
|
|
|
|
|
|
343
|
16
|
50
|
|
|
|
41
|
Carp::confess('[ARGS] You must specify a least one role to compose slots in') |
344
|
|
|
|
|
|
|
if scalar( @roles ) == 0; |
345
|
|
|
|
|
|
|
|
346
|
16
|
|
|
|
|
31
|
my (%slots, %conflicts); |
347
|
|
|
|
|
|
|
|
348
|
16
|
|
|
|
|
26
|
foreach my $role ( @roles ) { |
349
|
18
|
|
|
|
|
43
|
foreach my $slot ( $role->slots ) { |
350
|
0
|
|
|
|
|
0
|
my $name = $slot->name; |
351
|
|
|
|
|
|
|
# if we have one already, but |
352
|
|
|
|
|
|
|
# it is not the same refaddr ... |
353
|
0
|
0
|
0
|
|
|
0
|
if ( exists $slots{ $name } && $slots{ $name } != $slot->initializer ) { |
354
|
|
|
|
|
|
|
# mark it as a conflict ... |
355
|
0
|
|
|
|
|
0
|
$conflicts{ $name } = undef; |
356
|
|
|
|
|
|
|
# and remove it from our slot set ... |
357
|
0
|
|
|
|
|
0
|
delete $slots{ $name }; |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
# if we don't have it already ... |
360
|
|
|
|
|
|
|
else { |
361
|
|
|
|
|
|
|
# make a note of it |
362
|
0
|
|
|
|
|
0
|
$slots{ $name } = $slot->initializer; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
16
|
|
|
|
|
40
|
return \%slots, \%conflicts; |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# TODO: |
372
|
|
|
|
|
|
|
# We should track the name of the role |
373
|
|
|
|
|
|
|
# where the required method was composed |
374
|
|
|
|
|
|
|
# from, as well as the two classes in |
375
|
|
|
|
|
|
|
# which a method conflicted. |
376
|
|
|
|
|
|
|
# - SL |
377
|
|
|
|
|
|
|
sub COMPOSE_ALL_ROLE_METHODS { |
378
|
16
|
|
|
16
|
0
|
26
|
my @roles = @_; |
379
|
|
|
|
|
|
|
|
380
|
16
|
50
|
|
|
|
44
|
Carp::confess('[ARGS] You must specify a least one role to compose methods in') |
381
|
|
|
|
|
|
|
if scalar( @roles ) == 0; |
382
|
|
|
|
|
|
|
|
383
|
16
|
|
|
|
|
25
|
my (%methods, %conflicts, %required); |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
# flatten the set of required methods ... |
386
|
16
|
|
|
|
|
25
|
foreach my $r ( @roles ) { |
387
|
18
|
|
|
|
|
72
|
foreach my $m ( $r->required_methods ) { |
388
|
3
|
|
|
|
|
7
|
$required{ $m->name } = undef; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
# for every role ... |
393
|
16
|
|
|
|
|
1301
|
foreach my $r ( @roles ) { |
394
|
|
|
|
|
|
|
# and every method in that role ... |
395
|
18
|
|
|
|
|
64
|
foreach my $m ( $r->methods ) { |
396
|
419
|
|
|
|
|
617
|
my $name = $m->name; |
397
|
|
|
|
|
|
|
# if we have already seen the method, |
398
|
|
|
|
|
|
|
# but it is not the same refaddr |
399
|
|
|
|
|
|
|
# it is a conflict, which means: |
400
|
419
|
50
|
33
|
|
|
766
|
if ( exists $methods{ $name } && $methods{ $name } != $m->body ) { |
401
|
|
|
|
|
|
|
# we need to add it to our required-method map |
402
|
0
|
|
|
|
|
0
|
$required{ $name } = undef; |
403
|
|
|
|
|
|
|
# and note that it is also a conflict ... |
404
|
0
|
|
|
|
|
0
|
$conflicts{ $name } = undef; |
405
|
|
|
|
|
|
|
# and remove it from our method map |
406
|
0
|
|
|
|
|
0
|
delete $methods{ $name }; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
# if we haven't seen the method ... |
409
|
|
|
|
|
|
|
else { |
410
|
|
|
|
|
|
|
# add it to the method map |
411
|
419
|
|
|
|
|
589
|
$methods{ $name } = $m->body; |
412
|
|
|
|
|
|
|
# and remove it from the required-method map |
413
|
|
|
|
|
|
|
delete $required{ $name } |
414
|
|
|
|
|
|
|
# if it actually exists in it, and ... |
415
|
|
|
|
|
|
|
if exists $required{ $name } |
416
|
|
|
|
|
|
|
# is not also a conflict ... |
417
|
419
|
50
|
33
|
|
|
765
|
&& !exists $conflicts{ $name }; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
#use Data::Dumper; |
423
|
|
|
|
|
|
|
#warn Dumper [ [ map { $_->name } @roles ], \%methods, \%conflicts, \%required ]; |
424
|
|
|
|
|
|
|
|
425
|
16
|
|
|
|
|
1307
|
return \%methods, \%conflicts, \%required; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
1; |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
__END__ |