line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# This file was generated by tool/generate-mouse-tiny.pl from Mouse v2.4.9. |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# ANY CHANGES MADE HERE WILL BE LOST! |
4
|
4
|
|
|
4
|
|
34393
|
use strict; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
110
|
|
5
|
4
|
|
|
4
|
|
17
|
use warnings; |
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
4586
|
|
6
|
|
|
|
|
|
|
# if regular Mouse is loaded, bail out |
7
|
|
|
|
|
|
|
unless ($INC{'Mouse.pm'}) { |
8
|
|
|
|
|
|
|
# tell Perl we already have all of the Mouse files loaded: |
9
|
|
|
|
|
|
|
$INC{'Mouse.pm'} = __FILE__; |
10
|
|
|
|
|
|
|
$INC{'Mouse/Exporter.pm'} = __FILE__; |
11
|
|
|
|
|
|
|
$INC{'Mouse/Object.pm'} = __FILE__; |
12
|
|
|
|
|
|
|
$INC{'Mouse/Util.pm'} = __FILE__; |
13
|
|
|
|
|
|
|
$INC{'Mouse/Role.pm'} = __FILE__; |
14
|
|
|
|
|
|
|
$INC{'Mouse/PurePerl.pm'} = __FILE__; |
15
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Module.pm'} = __FILE__; |
16
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Attribute.pm'} = __FILE__; |
17
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Method.pm'} = __FILE__; |
18
|
|
|
|
|
|
|
$INC{'Mouse/Meta/TypeConstraint.pm'} = __FILE__; |
19
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Role.pm'} = __FILE__; |
20
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Class.pm'} = __FILE__; |
21
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Method/Constructor.pm'} = __FILE__; |
22
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Method/Delegation.pm'} = __FILE__; |
23
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Method/Accessor.pm'} = __FILE__; |
24
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Method/Destructor.pm'} = __FILE__; |
25
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Role/Application.pm'} = __FILE__; |
26
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Role/Method.pm'} = __FILE__; |
27
|
|
|
|
|
|
|
$INC{'Mouse/Meta/Role/Composite.pm'} = __FILE__; |
28
|
|
|
|
|
|
|
$INC{'Mouse/Util/MetaRole.pm'} = __FILE__; |
29
|
|
|
|
|
|
|
$INC{'Mouse/Util/TypeConstraints.pm'} = __FILE__; |
30
|
|
|
|
|
|
|
eval sprintf("#line %d %s\n", __LINE__, __FILE__) . <<'END_OF_TINY'; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# and now their contents |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/PurePerl.pm |
35
|
|
|
|
|
|
|
package Mouse::PurePerl; |
36
|
|
|
|
|
|
|
# The pure Perl backend for Mouse |
37
|
2
|
|
|
2
|
|
11
|
package Mouse::Util; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
37
|
|
38
|
2
|
|
|
2
|
|
6
|
use strict; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
79
|
|
39
|
2
|
|
|
2
|
|
7
|
use warnings; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
73
|
|
40
|
|
|
|
|
|
|
use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl twice |
41
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
28
|
|
42
|
2
|
|
|
2
|
|
7
|
use Scalar::Util (); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
891
|
|
43
|
|
|
|
|
|
|
use B (); |
44
|
2
|
|
|
2
|
|
8
|
|
45
|
|
|
|
|
|
|
require Mouse::Util; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# taken from Class/MOP.pm |
48
|
8
|
|
|
8
|
0
|
8
|
sub is_valid_class_name { |
49
|
|
|
|
|
|
|
my $class = shift; |
50
|
8
|
50
|
|
|
|
22
|
|
51
|
8
|
50
|
|
|
|
13
|
return 0 if ref($class); |
52
|
|
|
|
|
|
|
return 0 unless defined($class); |
53
|
8
|
50
|
|
|
|
64
|
|
54
|
|
|
|
|
|
|
return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms; |
55
|
0
|
|
|
|
|
0
|
|
56
|
|
|
|
|
|
|
return 0; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
8
|
|
|
8
|
1
|
9
|
sub is_class_loaded { |
60
|
|
|
|
|
|
|
my $class = shift; |
61
|
8
|
50
|
33
|
|
|
51
|
|
|
|
|
33
|
|
|
|
|
62
|
|
|
|
|
|
|
return 0 if ref($class) || !defined($class) || !length($class); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# walk the symbol table tree to avoid autovififying |
65
|
|
|
|
|
|
|
# \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar:: |
66
|
8
|
|
|
|
|
10
|
|
67
|
8
|
|
|
|
|
30
|
my $pack = \%::; |
68
|
24
|
|
|
|
|
17
|
foreach my $part (split('::', $class)) { |
69
|
24
|
50
|
|
|
|
37
|
$part .= '::'; |
70
|
|
|
|
|
|
|
return 0 if !exists $pack->{$part}; |
71
|
24
|
|
|
|
|
21
|
|
72
|
24
|
50
|
|
|
|
39
|
my $entry = \$pack->{$part}; |
73
|
24
|
|
|
|
|
16
|
return 0 if ref($entry) ne 'GLOB'; |
|
24
|
|
|
|
|
34
|
|
74
|
|
|
|
|
|
|
$pack = *{$entry}{HASH}; |
75
|
|
|
|
|
|
|
} |
76
|
8
|
50
|
|
|
|
10
|
|
|
8
|
|
|
|
|
30
|
|
77
|
|
|
|
|
|
|
return 0 if !%{$pack}; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# check for $VERSION or @ISA |
80
|
8
|
0
|
33
|
|
|
23
|
return 1 if exists $pack->{VERSION} |
|
0
|
|
33
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
81
|
|
|
|
|
|
|
&& defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} }; |
82
|
8
|
0
|
33
|
|
|
16
|
return 1 if exists $pack->{ISA} |
|
0
|
|
33
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
83
|
|
|
|
|
|
|
&& defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0; |
84
|
|
|
|
|
|
|
|
85
|
8
|
|
|
|
|
19
|
# check for any method |
|
8
|
|
|
|
|
25
|
|
86
|
11
|
|
|
|
|
13
|
foreach my $name( keys %{$pack} ) { |
87
|
11
|
100
|
66
|
|
|
21
|
my $entry = \$pack->{$name}; |
|
11
|
|
|
|
|
48
|
|
88
|
|
|
|
|
|
|
return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE}; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
0
|
|
|
|
|
0
|
# fail |
92
|
|
|
|
|
|
|
return 0; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# taken from Sub::Identify |
97
|
12
|
|
|
12
|
1
|
11
|
sub get_code_info { |
98
|
12
|
50
|
|
|
|
22
|
my ($coderef) = @_; |
99
|
|
|
|
|
|
|
ref($coderef) or return; |
100
|
12
|
|
|
|
|
36
|
|
101
|
12
|
50
|
|
|
|
70
|
my $cv = B::svref_2object($coderef); |
102
|
|
|
|
|
|
|
$cv->isa('B::CV') or return; |
103
|
12
|
|
|
|
|
28
|
|
104
|
12
|
50
|
|
|
|
35
|
my $gv = $cv->GV; |
105
|
|
|
|
|
|
|
$gv->isa('B::GV') or return; |
106
|
12
|
|
|
|
|
66
|
|
107
|
|
|
|
|
|
|
return ($gv->STASH->NAME, $gv->NAME); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
0
|
|
|
0
|
1
|
0
|
sub get_code_package{ |
111
|
|
|
|
|
|
|
my($coderef) = @_; |
112
|
0
|
|
|
|
|
0
|
|
113
|
0
|
0
|
|
|
|
0
|
my $cv = B::svref_2object($coderef); |
114
|
|
|
|
|
|
|
$cv->isa('B::CV') or return ''; |
115
|
0
|
|
|
|
|
0
|
|
116
|
0
|
0
|
|
|
|
0
|
my $gv = $cv->GV; |
117
|
|
|
|
|
|
|
$gv->isa('B::GV') or return ''; |
118
|
0
|
|
|
|
|
0
|
|
119
|
|
|
|
|
|
|
return $gv->STASH->NAME; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
0
|
|
|
0
|
1
|
0
|
sub get_code_ref{ |
123
|
2
|
|
|
2
|
|
10
|
my($package, $name) = @_; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
74
|
|
124
|
2
|
|
|
2
|
|
9
|
no strict 'refs'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
106
|
|
125
|
2
|
|
|
2
|
|
9
|
no warnings 'once'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
1919
|
|
126
|
0
|
|
|
|
|
0
|
use warnings FATAL => 'uninitialized'; |
|
0
|
|
|
|
|
0
|
|
127
|
|
|
|
|
|
|
return *{$package . '::' . $name}{CODE}; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
4
|
|
|
4
|
0
|
6
|
sub generate_isa_predicate_for { |
131
|
|
|
|
|
|
|
my($for_class, $name) = @_; |
132
|
4
|
0
|
|
0
|
|
10
|
|
|
0
|
|
|
|
|
0
|
|
133
|
|
|
|
|
|
|
my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) }; |
134
|
4
|
50
|
|
|
|
7
|
|
135
|
0
|
|
|
|
|
0
|
if(defined $name){ |
136
|
0
|
|
|
|
|
0
|
Mouse::Util::install_subroutines(scalar caller, $name => $predicate); |
137
|
|
|
|
|
|
|
return; |
138
|
|
|
|
|
|
|
} |
139
|
4
|
|
|
|
|
9
|
|
140
|
|
|
|
|
|
|
return $predicate; |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
|
143
|
6
|
|
|
6
|
0
|
7
|
sub generate_can_predicate_for { |
144
|
|
|
|
|
|
|
my($methods_ref, $name) = @_; |
145
|
6
|
|
|
|
|
4
|
|
|
6
|
|
|
|
|
10
|
|
146
|
|
|
|
|
|
|
my @methods = @{$methods_ref}; |
147
|
|
|
|
|
|
|
|
148
|
8
|
|
|
8
|
|
7
|
my $predicate = sub{ |
149
|
8
|
50
|
|
|
|
27
|
my($instance) = @_; |
150
|
0
|
|
|
|
|
0
|
if(Scalar::Util::blessed($instance)){ |
151
|
0
|
0
|
|
|
|
0
|
foreach my $method(@methods){ |
152
|
0
|
|
|
|
|
0
|
if(!$instance->can($method)){ |
153
|
|
|
|
|
|
|
return 0; |
154
|
|
|
|
|
|
|
} |
155
|
0
|
|
|
|
|
0
|
} |
156
|
|
|
|
|
|
|
return 1; |
157
|
8
|
|
|
|
|
34
|
} |
158
|
6
|
|
|
|
|
14
|
return 0; |
159
|
|
|
|
|
|
|
}; |
160
|
6
|
50
|
|
|
|
11
|
|
161
|
6
|
|
|
|
|
9
|
if(defined $name){ |
162
|
6
|
|
|
|
|
7
|
Mouse::Util::install_subroutines(scalar caller, $name => $predicate); |
163
|
|
|
|
|
|
|
return; |
164
|
|
|
|
|
|
|
} |
165
|
0
|
|
|
|
|
0
|
|
166
|
|
|
|
|
|
|
return $predicate; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
package Mouse::Util::TypeConstraints; |
170
|
|
|
|
|
|
|
|
171
|
0
|
|
|
0
|
0
|
0
|
|
172
|
0
|
|
|
0
|
0
|
0
|
sub Any { 1 } |
173
|
|
|
|
|
|
|
sub Item { 1 } |
174
|
0
|
0
|
|
0
|
0
|
0
|
|
175
|
0
|
|
|
0
|
0
|
0
|
sub Bool { !$_[0] || $_[0] eq '1' } |
176
|
0
|
|
|
0
|
0
|
0
|
sub Undef { !defined($_[0]) } |
177
|
0
|
0
|
|
0
|
0
|
0
|
sub Defined { defined($_[0]) } |
178
|
0
|
|
|
0
|
0
|
0
|
sub Value { defined($_[0]) && !ref($_[0]) } |
179
|
|
|
|
|
|
|
sub Num { Scalar::Util::looks_like_number($_[0]) } |
180
|
|
|
|
|
|
|
sub Str { |
181
|
|
|
|
|
|
|
# We need to use a copy here to flatten MAGICs, for instance as in |
182
|
0
|
|
|
0
|
0
|
0
|
# Str( substr($_, 0, 42) ). |
183
|
0
|
|
0
|
|
|
0
|
my($value) = @_; |
184
|
|
|
|
|
|
|
return defined($value) && ref(\$value) eq 'SCALAR'; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
sub Int { |
187
|
0
|
|
|
0
|
0
|
0
|
# We need to use a copy here to save the original internal SV flags. |
188
|
0
|
|
0
|
|
|
0
|
my($value) = @_; |
189
|
|
|
|
|
|
|
return defined($value) && $value =~ /\A -? [0-9]+ \z/xms; |
190
|
|
|
|
|
|
|
} |
191
|
0
|
|
|
0
|
0
|
0
|
|
192
|
|
|
|
|
|
|
sub Ref { ref($_[0]) } |
193
|
0
|
|
|
0
|
0
|
0
|
sub ScalarRef { |
194
|
0
|
|
0
|
|
|
0
|
my($value) = @_; |
195
|
|
|
|
|
|
|
return ref($value) eq 'SCALAR' || ref($value) eq 'REF'; |
196
|
0
|
|
|
0
|
0
|
0
|
} |
197
|
0
|
|
|
0
|
0
|
0
|
sub ArrayRef { ref($_[0]) eq 'ARRAY' } |
198
|
0
|
|
|
0
|
0
|
0
|
sub HashRef { ref($_[0]) eq 'HASH' } |
199
|
0
|
|
|
0
|
0
|
0
|
sub CodeRef { ref($_[0]) eq 'CODE' } |
200
|
0
|
|
|
0
|
0
|
0
|
sub RegexpRef { ref($_[0]) eq 'Regexp' } |
201
|
|
|
|
|
|
|
sub GlobRef { ref($_[0]) eq 'GLOB' } |
202
|
|
|
|
|
|
|
|
203
|
0
|
|
|
0
|
0
|
0
|
sub FileHandle { |
204
|
0
|
|
0
|
|
|
0
|
my($value) = @_; |
205
|
|
|
|
|
|
|
return Scalar::Util::openhandle($value) |
206
|
|
|
|
|
|
|
|| (Scalar::Util::blessed($value) && $value->isa("IO::Handle")) |
207
|
|
|
|
|
|
|
} |
208
|
0
|
0
|
|
0
|
0
|
0
|
|
209
|
|
|
|
|
|
|
sub Object { Scalar::Util::blessed($_[0]) && ref($_[0]) ne 'Regexp' } |
210
|
0
|
|
|
0
|
0
|
0
|
|
211
|
0
|
|
0
|
0
|
0
|
0
|
sub ClassName { Mouse::Util::is_class_loaded($_[0]) } |
212
|
|
|
|
|
|
|
sub RoleName { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') } |
213
|
|
|
|
|
|
|
|
214
|
0
|
|
|
0
|
|
0
|
sub _parameterize_ArrayRef_for { |
215
|
0
|
|
|
|
|
0
|
my($type_parameter) = @_; |
216
|
|
|
|
|
|
|
my $check = $type_parameter->_compiled_type_constraint; |
217
|
|
|
|
|
|
|
|
218
|
0
|
|
|
0
|
|
0
|
return sub { |
|
0
|
|
|
|
|
0
|
|
219
|
0
|
0
|
|
|
|
0
|
foreach my $value (@{$_}) { |
220
|
|
|
|
|
|
|
return undef unless $check->($value); |
221
|
0
|
|
|
|
|
0
|
} |
222
|
|
|
|
|
|
|
return 1; |
223
|
0
|
|
|
|
|
0
|
} |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
0
|
|
|
0
|
|
0
|
sub _parameterize_HashRef_for { |
227
|
0
|
|
|
|
|
0
|
my($type_parameter) = @_; |
228
|
|
|
|
|
|
|
my $check = $type_parameter->_compiled_type_constraint; |
229
|
|
|
|
|
|
|
|
230
|
0
|
|
|
0
|
|
0
|
return sub { |
|
0
|
|
|
|
|
0
|
|
231
|
0
|
0
|
|
|
|
0
|
foreach my $value(values %{$_}){ |
232
|
|
|
|
|
|
|
return undef unless $check->($value); |
233
|
0
|
|
|
|
|
0
|
} |
234
|
0
|
|
|
|
|
0
|
return 1; |
235
|
|
|
|
|
|
|
}; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# 'Maybe' type accepts 'Any', so it requires parameters |
239
|
0
|
|
|
0
|
|
0
|
sub _parameterize_Maybe_for { |
240
|
0
|
|
|
|
|
0
|
my($type_parameter) = @_; |
241
|
|
|
|
|
|
|
my $check = $type_parameter->_compiled_type_constraint; |
242
|
|
|
|
|
|
|
|
243
|
0
|
|
0
|
0
|
|
0
|
return sub{ |
244
|
0
|
|
|
|
|
0
|
return !defined($_) || $check->($_); |
245
|
|
|
|
|
|
|
}; |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
package Mouse::Meta::Module; |
249
|
20
|
|
|
20
|
0
|
57
|
|
250
|
|
|
|
|
|
|
sub name { $_[0]->{package} } |
251
|
0
|
|
|
0
|
|
0
|
|
252
|
0
|
|
|
0
|
|
0
|
sub _method_map { $_[0]->{methods} } |
253
|
|
|
|
|
|
|
sub _attribute_map{ $_[0]->{attributes} } |
254
|
|
|
|
|
|
|
|
255
|
0
|
|
|
0
|
0
|
0
|
sub namespace{ |
256
|
2
|
|
|
2
|
|
11
|
my $name = $_[0]->{package}; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
377
|
|
257
|
0
|
|
|
|
|
0
|
no strict 'refs'; |
|
0
|
|
|
|
|
0
|
|
258
|
|
|
|
|
|
|
return \%{ $name . '::' }; |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
8
|
|
|
8
|
0
|
10
|
sub add_method { |
262
|
|
|
|
|
|
|
my($self, $name, $code) = @_; |
263
|
8
|
50
|
|
|
|
18
|
|
264
|
0
|
|
|
|
|
0
|
if(!defined $name){ |
265
|
|
|
|
|
|
|
$self->throw_error('You must pass a defined name'); |
266
|
8
|
50
|
|
|
|
16
|
} |
267
|
0
|
|
|
|
|
0
|
if(!defined $code){ |
268
|
|
|
|
|
|
|
$self->throw_error('You must pass a defined code'); |
269
|
|
|
|
|
|
|
} |
270
|
8
|
50
|
|
|
|
16
|
|
271
|
0
|
|
|
|
|
0
|
if(ref($code) ne 'CODE'){ |
|
0
|
|
|
|
|
0
|
|
272
|
|
|
|
|
|
|
$code = \&{$code}; # coerce |
273
|
|
|
|
|
|
|
} |
274
|
8
|
|
|
|
|
17
|
|
275
|
|
|
|
|
|
|
$self->{methods}->{$name} = $code; # Moose stores meta object here. |
276
|
8
|
|
|
|
|
16
|
|
277
|
|
|
|
|
|
|
Mouse::Util::install_subroutines($self->name, |
278
|
|
|
|
|
|
|
$name => $code, |
279
|
8
|
|
|
|
|
7
|
); |
280
|
|
|
|
|
|
|
return; |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
2
|
|
|
|
|
2
|
my $generate_class_accessor = sub { |
284
|
|
|
|
|
|
|
my($name) = @_; |
285
|
4
|
|
|
4
|
|
5
|
return sub { |
286
|
4
|
50
|
|
|
|
7
|
my $self = shift; |
287
|
0
|
|
|
|
|
0
|
if(@_) { |
288
|
|
|
|
|
|
|
return $self->{$name} = shift; |
289
|
|
|
|
|
|
|
} |
290
|
4
|
|
|
|
|
7
|
|
291
|
8
|
100
|
|
|
|
9
|
foreach my $class($self->linearized_isa) { |
292
|
|
|
|
|
|
|
my $meta = Mouse::Util::get_metaclass_by_name($class) |
293
|
|
|
|
|
|
|
or next; |
294
|
4
|
50
|
|
|
|
9
|
|
295
|
0
|
|
|
|
|
0
|
if(exists $meta->{$name}) { |
296
|
|
|
|
|
|
|
return $meta->{$name}; |
297
|
|
|
|
|
|
|
} |
298
|
4
|
|
|
|
|
6
|
} |
299
|
2
|
|
|
|
|
8
|
return undef; |
300
|
2
|
|
|
|
|
9
|
}; |
301
|
|
|
|
|
|
|
}; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
package Mouse::Meta::Class; |
305
|
2
|
|
|
2
|
|
9
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
32
|
|
306
|
2
|
|
|
2
|
|
6
|
use Mouse::Meta::Method::Constructor; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4872
|
|
307
|
|
|
|
|
|
|
use Mouse::Meta::Method::Destructor; |
308
|
0
|
0
|
|
0
|
0
|
0
|
|
309
|
4
|
50
|
|
4
|
0
|
32
|
sub method_metaclass { $_[0]->{method_metaclass} || 'Mouse::Meta::Method' } |
310
|
|
|
|
|
|
|
sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' } |
311
|
4
|
50
|
|
4
|
0
|
19
|
|
312
|
0
|
0
|
|
0
|
0
|
0
|
sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' } |
313
|
|
|
|
|
|
|
sub destructor_class { $_[0]->{destructor_class} || 'Mouse::Meta::Method::Destructor' } |
314
|
|
|
|
|
|
|
|
315
|
4
|
|
|
4
|
0
|
9
|
sub is_anon_class{ |
316
|
|
|
|
|
|
|
return exists $_[0]->{anon_serial_id}; |
317
|
|
|
|
|
|
|
} |
318
|
0
|
|
|
0
|
0
|
0
|
|
319
|
|
|
|
|
|
|
sub roles { $_[0]->{roles} } |
320
|
8
|
|
|
8
|
1
|
5
|
|
|
8
|
|
|
|
|
39
|
|
321
|
|
|
|
|
|
|
sub linearized_isa { @{ Mouse::Util::get_linear_isa($_[0]->{package}) } } |
322
|
|
|
|
|
|
|
|
323
|
4
|
|
|
4
|
1
|
5
|
sub new_object { |
324
|
4
|
50
|
|
|
|
9
|
my $meta = shift; |
|
4
|
|
|
|
|
14
|
|
325
|
|
|
|
|
|
|
my %args = (@_ == 1 ? %{$_[0]} : @_); |
326
|
4
|
|
|
|
|
8
|
|
327
|
|
|
|
|
|
|
my $object = bless {}, $meta->name; |
328
|
4
|
|
|
|
|
11
|
|
329
|
|
|
|
|
|
|
$meta->_initialize_object($object, \%args, 0); |
330
|
4
|
50
|
|
|
|
28
|
# BUILDALL |
331
|
0
|
|
|
|
|
0
|
if( $object->can('BUILD') ) { |
332
|
0
|
|
0
|
|
|
0
|
for my $class (reverse $meta->linearized_isa) { |
333
|
|
|
|
|
|
|
my $build = Mouse::Util::get_code_ref($class, 'BUILD') |
334
|
|
|
|
|
|
|
|| next; |
335
|
0
|
|
|
|
|
0
|
|
336
|
|
|
|
|
|
|
$object->$build(\%args); |
337
|
|
|
|
|
|
|
} |
338
|
4
|
|
|
|
|
20
|
} |
339
|
|
|
|
|
|
|
return $object; |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
0
|
|
|
0
|
1
|
0
|
sub clone_object { |
343
|
0
|
|
|
|
|
0
|
my $class = shift; |
344
|
0
|
|
|
|
|
0
|
my $object = shift; |
345
|
|
|
|
|
|
|
my $args = $object->Mouse::Object::BUILDARGS(@_); |
346
|
0
|
0
|
0
|
|
|
0
|
|
347
|
|
|
|
|
|
|
(Scalar::Util::blessed($object) && $object->isa($class->name)) |
348
|
|
|
|
|
|
|
|| $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)"); |
349
|
0
|
|
|
|
|
0
|
|
350
|
0
|
|
|
|
|
0
|
my $cloned = bless { %$object }, ref $object; |
351
|
0
|
|
|
|
|
0
|
$class->_initialize_object($cloned, $args, 1); |
352
|
|
|
|
|
|
|
return $cloned; |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
4
|
|
|
4
|
|
6
|
sub _initialize_object{ |
356
|
|
|
|
|
|
|
my($self, $object, $args, $is_cloning) = @_; |
357
|
|
|
|
|
|
|
# The initializer, which is used everywhere, must be clear |
358
|
|
|
|
|
|
|
# when an attribute is added. See Mouse::Meta::Class::add_attribute. |
359
|
4
|
|
33
|
|
|
20
|
my $initializer = $self->{_mouse_cache}{_initialize_object} ||= |
360
|
|
|
|
|
|
|
Mouse::Util::load_class($self->constructor_class) |
361
|
4
|
|
|
|
|
6
|
->_generate_initialize_object($self); |
|
4
|
|
|
|
|
9
|
|
362
|
|
|
|
|
|
|
goto &{$initializer}; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
4
|
|
|
4
|
1
|
3
|
sub get_all_attributes { |
366
|
4
|
|
|
|
|
31
|
my($self) = @_; |
367
|
4
|
|
33
|
|
|
17
|
return @{ $self->{_mouse_cache}{all_attributes} |
368
|
|
|
|
|
|
|
||= $self->_calculate_all_attributes }; |
369
|
|
|
|
|
|
|
} |
370
|
0
|
|
|
0
|
0
|
0
|
|
371
|
|
|
|
|
|
|
sub is_immutable { $_[0]->{is_immutable} } |
372
|
|
|
|
|
|
|
|
373
|
2
|
|
|
|
|
4
|
sub strict_constructor; |
374
|
|
|
|
|
|
|
*strict_constructor = $generate_class_accessor->('strict_constructor'); |
375
|
|
|
|
|
|
|
|
376
|
4
|
|
|
4
|
|
6
|
sub _invalidate_metaclass_cache { |
377
|
4
|
|
|
|
|
3
|
my($self) = @_; |
378
|
4
|
|
|
|
|
6
|
delete $self->{_mouse_cache}; |
379
|
|
|
|
|
|
|
return; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
|
382
|
0
|
|
|
0
|
|
0
|
sub _report_unknown_args { |
383
|
|
|
|
|
|
|
my($metaclass, $attrs, $args) = @_; |
384
|
0
|
|
|
|
|
0
|
|
385
|
|
|
|
|
|
|
my @unknowns; |
386
|
0
|
|
|
|
|
0
|
my %init_args; |
|
0
|
|
|
|
|
0
|
|
387
|
0
|
|
|
|
|
0
|
foreach my $attr(@{$attrs}){ |
388
|
0
|
0
|
|
|
|
0
|
my $init_arg = $attr->init_arg; |
389
|
0
|
|
|
|
|
0
|
if(defined $init_arg){ |
390
|
|
|
|
|
|
|
$init_args{$init_arg}++; |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
} |
393
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
394
|
0
|
0
|
|
|
|
0
|
while(my $key = each %{$args}){ |
395
|
0
|
|
|
|
|
0
|
if(!exists $init_args{$key}){ |
396
|
|
|
|
|
|
|
push @unknowns, $key; |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
} |
399
|
0
|
|
|
|
|
0
|
|
400
|
|
|
|
|
|
|
$metaclass->throw_error( sprintf |
401
|
|
|
|
|
|
|
"Unknown attribute passed to the constructor of %s: %s", |
402
|
|
|
|
|
|
|
$metaclass->name, Mouse::Util::english_list(@unknowns), |
403
|
|
|
|
|
|
|
); |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
package Mouse::Meta::Role; |
407
|
0
|
0
|
|
0
|
0
|
0
|
|
408
|
|
|
|
|
|
|
sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' } |
409
|
|
|
|
|
|
|
|
410
|
0
|
|
|
0
|
0
|
0
|
sub is_anon_role{ |
411
|
|
|
|
|
|
|
return exists $_[0]->{anon_serial_id}; |
412
|
|
|
|
|
|
|
} |
413
|
0
|
|
|
0
|
0
|
0
|
|
414
|
|
|
|
|
|
|
sub get_roles { $_[0]->{roles} } |
415
|
|
|
|
|
|
|
|
416
|
0
|
|
|
0
|
0
|
0
|
sub add_before_method_modifier { |
417
|
|
|
|
|
|
|
my ($self, $method_name, $method) = @_; |
418
|
0
|
|
0
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
419
|
0
|
|
|
|
|
0
|
push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method; |
420
|
|
|
|
|
|
|
return; |
421
|
|
|
|
|
|
|
} |
422
|
0
|
|
|
0
|
0
|
0
|
sub add_around_method_modifier { |
423
|
|
|
|
|
|
|
my ($self, $method_name, $method) = @_; |
424
|
0
|
|
0
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
425
|
0
|
|
|
|
|
0
|
push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method; |
426
|
|
|
|
|
|
|
return; |
427
|
|
|
|
|
|
|
} |
428
|
0
|
|
|
0
|
0
|
0
|
sub add_after_method_modifier { |
429
|
|
|
|
|
|
|
my ($self, $method_name, $method) = @_; |
430
|
0
|
|
0
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
431
|
0
|
|
|
|
|
0
|
push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method; |
432
|
|
|
|
|
|
|
return; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
0
|
|
|
0
|
0
|
0
|
sub get_before_method_modifiers { |
436
|
0
|
|
0
|
|
|
0
|
my ($self, $method_name) = @_; |
|
0
|
|
|
|
|
0
|
|
437
|
|
|
|
|
|
|
return @{ $self->{before_method_modifiers}{$method_name} ||= [] } |
438
|
|
|
|
|
|
|
} |
439
|
0
|
|
|
0
|
0
|
0
|
sub get_around_method_modifiers { |
440
|
0
|
|
0
|
|
|
0
|
my ($self, $method_name) = @_; |
|
0
|
|
|
|
|
0
|
|
441
|
|
|
|
|
|
|
return @{ $self->{around_method_modifiers}{$method_name} ||= [] } |
442
|
|
|
|
|
|
|
} |
443
|
0
|
|
|
0
|
0
|
0
|
sub get_after_method_modifiers { |
444
|
0
|
|
0
|
|
|
0
|
my ($self, $method_name) = @_; |
|
0
|
|
|
|
|
0
|
|
445
|
|
|
|
|
|
|
return @{ $self->{after_method_modifiers}{$method_name} ||= [] } |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
0
|
|
|
0
|
0
|
0
|
sub add_metaclass_accessor { # for meta roles (a.k.a. traits) |
449
|
0
|
|
|
|
|
0
|
my($meta, $name) = @_; |
450
|
0
|
|
|
|
|
0
|
$meta->add_method($name => $generate_class_accessor->($name)); |
451
|
|
|
|
|
|
|
return; |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
package Mouse::Meta::Attribute; |
455
|
2
|
|
|
|
|
6
|
|
456
|
|
|
|
|
|
|
require Mouse::Meta::Method::Accessor; |
457
|
4
|
50
|
|
4
|
0
|
16
|
|
458
|
|
|
|
|
|
|
sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' } |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
# readers |
461
|
12
|
|
|
12
|
0
|
27
|
|
462
|
4
|
|
|
4
|
0
|
6
|
sub name { $_[0]->{name} } |
463
|
|
|
|
|
|
|
sub associated_class { $_[0]->{associated_class} } |
464
|
0
|
|
|
0
|
0
|
0
|
|
465
|
0
|
|
|
0
|
0
|
0
|
sub accessor { $_[0]->{accessor} } |
466
|
0
|
|
|
0
|
0
|
0
|
sub reader { $_[0]->{reader} } |
467
|
0
|
|
|
0
|
0
|
0
|
sub writer { $_[0]->{writer} } |
468
|
0
|
|
|
0
|
0
|
0
|
sub predicate { $_[0]->{predicate} } |
469
|
0
|
|
|
0
|
0
|
0
|
sub clearer { $_[0]->{clearer} } |
470
|
|
|
|
|
|
|
sub handles { $_[0]->{handles} } |
471
|
0
|
|
|
0
|
|
0
|
|
472
|
4
|
|
|
4
|
0
|
12
|
sub _is_metadata { $_[0]->{is} } |
473
|
|
|
|
|
|
|
sub is_required { $_[0]->{required} } |
474
|
4
|
|
|
4
|
0
|
6
|
sub default { |
475
|
4
|
|
|
|
|
5
|
my($self, $instance) = @_; |
476
|
4
|
50
|
33
|
|
|
9
|
my $value = $self->{default}; |
477
|
4
|
|
|
|
|
6
|
$value = $value->($instance) if defined($instance) and ref($value) eq "CODE"; |
478
|
|
|
|
|
|
|
return $value; |
479
|
4
|
|
|
4
|
0
|
11
|
} |
480
|
0
|
|
|
0
|
0
|
0
|
sub is_lazy { $_[0]->{lazy} } |
481
|
8
|
|
|
8
|
0
|
9
|
sub is_lazy_build { $_[0]->{lazy_build} } |
482
|
4
|
|
|
4
|
0
|
6
|
sub is_weak_ref { $_[0]->{weak_ref} } |
483
|
12
|
|
|
12
|
0
|
20
|
sub init_arg { $_[0]->{init_arg} } |
484
|
|
|
|
|
|
|
sub type_constraint { $_[0]->{type_constraint} } |
485
|
4
|
|
|
4
|
1
|
6
|
|
486
|
4
|
|
|
4
|
0
|
5
|
sub trigger { $_[0]->{trigger} } |
487
|
4
|
|
|
4
|
0
|
4
|
sub builder { $_[0]->{builder} } |
488
|
0
|
|
|
0
|
0
|
0
|
sub should_auto_deref { $_[0]->{auto_deref} } |
489
|
|
|
|
|
|
|
sub should_coerce { $_[0]->{coerce} } |
490
|
0
|
|
|
0
|
0
|
0
|
|
491
|
0
|
|
|
0
|
0
|
0
|
sub documentation { $_[0]->{documentation} } |
492
|
|
|
|
|
|
|
sub insertion_order { $_[0]->{insertion_order} } |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# predicates |
495
|
0
|
|
|
0
|
0
|
0
|
|
496
|
0
|
|
|
0
|
0
|
0
|
sub has_accessor { exists $_[0]->{accessor} } |
497
|
0
|
|
|
0
|
0
|
0
|
sub has_reader { exists $_[0]->{reader} } |
498
|
0
|
|
|
0
|
0
|
0
|
sub has_writer { exists $_[0]->{writer} } |
499
|
0
|
|
|
0
|
0
|
0
|
sub has_predicate { exists $_[0]->{predicate} } |
500
|
0
|
|
|
0
|
0
|
0
|
sub has_clearer { exists $_[0]->{clearer} } |
501
|
|
|
|
|
|
|
sub has_handles { exists $_[0]->{handles} } |
502
|
4
|
|
|
4
|
0
|
14
|
|
503
|
0
|
|
|
0
|
0
|
0
|
sub has_default { exists $_[0]->{default} } |
504
|
4
|
|
|
4
|
0
|
10
|
sub has_type_constraint { exists $_[0]->{type_constraint} } |
505
|
4
|
|
|
4
|
0
|
20
|
sub has_trigger { exists $_[0]->{trigger} } |
506
|
|
|
|
|
|
|
sub has_builder { exists $_[0]->{builder} } |
507
|
0
|
|
|
0
|
0
|
0
|
|
508
|
|
|
|
|
|
|
sub has_documentation { exists $_[0]->{documentation} } |
509
|
|
|
|
|
|
|
|
510
|
4
|
|
|
4
|
|
6
|
sub _process_options{ |
511
|
|
|
|
|
|
|
my($class, $name, $args) = @_; |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
# taken from Class::MOP::Attribute::new |
514
|
4
|
50
|
|
|
|
8
|
|
515
|
|
|
|
|
|
|
defined($name) |
516
|
|
|
|
|
|
|
or $class->throw_error('You must provide a name for the attribute'); |
517
|
4
|
50
|
|
|
|
8
|
|
518
|
4
|
|
|
|
|
7
|
if(!exists $args->{init_arg}){ |
519
|
|
|
|
|
|
|
$args->{init_arg} = $name; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
4
|
|
|
|
|
7
|
# 'required' requires either 'init_arg', 'builder', or 'default' |
523
|
|
|
|
|
|
|
my $can_be_required = defined( $args->{init_arg} ); |
524
|
4
|
50
|
|
|
|
12
|
|
|
|
50
|
|
|
|
|
|
525
|
|
|
|
|
|
|
if(exists $args->{builder}){ |
526
|
|
|
|
|
|
|
# XXX: |
527
|
|
|
|
|
|
|
# Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility |
528
|
|
|
|
|
|
|
# This feature will be changed in a future. (gfx) |
529
|
|
|
|
|
|
|
$class->throw_error('builder must be a defined scalar value which is a method name') |
530
|
0
|
0
|
|
|
|
0
|
#if ref $args->{builder} || !defined $args->{builder}; |
531
|
|
|
|
|
|
|
if !defined $args->{builder}; |
532
|
0
|
|
|
|
|
0
|
|
533
|
|
|
|
|
|
|
$can_be_required++; |
534
|
|
|
|
|
|
|
} |
535
|
0
|
0
|
0
|
|
|
0
|
elsif(exists $args->{default}){ |
536
|
0
|
|
|
|
|
0
|
if(ref $args->{default} && ref($args->{default}) ne 'CODE'){ |
537
|
|
|
|
|
|
|
$class->throw_error("References are not allowed as default values, you must " |
538
|
|
|
|
|
|
|
. "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"); |
539
|
0
|
|
|
|
|
0
|
} |
540
|
|
|
|
|
|
|
$can_be_required++; |
541
|
|
|
|
|
|
|
} |
542
|
4
|
50
|
33
|
|
|
11
|
|
543
|
0
|
|
|
|
|
0
|
if( $args->{required} && !$can_be_required ) { |
544
|
|
|
|
|
|
|
$class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg"); |
545
|
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# taken from Mouse::Meta::Attribute->new and ->_process_args |
548
|
4
|
50
|
|
|
|
8
|
|
549
|
4
|
|
|
|
|
7
|
if(exists $args->{is}){ |
550
|
|
|
|
|
|
|
my $is = $args->{is}; |
551
|
4
|
50
|
|
|
|
11
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
552
|
0
|
|
0
|
|
|
0
|
if($is eq 'ro'){ |
553
|
|
|
|
|
|
|
$args->{reader} ||= $name; |
554
|
|
|
|
|
|
|
} |
555
|
4
|
50
|
|
|
|
7
|
elsif($is eq 'rw'){ |
556
|
0
|
|
0
|
|
|
0
|
if(exists $args->{writer}){ |
557
|
|
|
|
|
|
|
$args->{reader} ||= $name; |
558
|
|
|
|
|
|
|
} |
559
|
4
|
|
33
|
|
|
16
|
else{ |
560
|
|
|
|
|
|
|
$args->{accessor} ||= $name; |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
elsif($is eq 'bare'){ |
564
|
|
|
|
|
|
|
# do nothing, but don't complain (later) about missing methods |
565
|
|
|
|
|
|
|
} |
566
|
0
|
0
|
|
|
|
0
|
else{ |
567
|
0
|
|
|
|
|
0
|
$is = 'undef' if !defined $is; |
568
|
|
|
|
|
|
|
$class->throw_error("I do not understand this option (is => $is) on attribute ($name)"); |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
} |
571
|
4
|
|
|
|
|
4
|
|
572
|
4
|
50
|
|
|
|
10
|
my $tc; |
573
|
0
|
|
|
|
|
0
|
if(exists $args->{isa}){ |
574
|
|
|
|
|
|
|
$tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa}); |
575
|
|
|
|
|
|
|
} |
576
|
4
|
50
|
|
|
|
8
|
|
577
|
0
|
0
|
|
|
|
0
|
if(exists $args->{does}){ |
578
|
0
|
|
|
|
|
0
|
if(defined $tc){ # both isa and does supplied |
579
|
0
|
|
|
|
|
0
|
my $does_ok = do{ |
580
|
0
|
|
|
|
|
0
|
local $@; |
|
0
|
|
|
|
|
0
|
|
581
|
|
|
|
|
|
|
eval{ "$tc"->does($args->{does}) }; |
582
|
0
|
0
|
|
|
|
0
|
}; |
583
|
0
|
|
|
|
|
0
|
if(!$does_ok){ |
584
|
|
|
|
|
|
|
$class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)"); |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
} |
587
|
0
|
|
|
|
|
0
|
else { |
588
|
|
|
|
|
|
|
$tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does}); |
589
|
|
|
|
|
|
|
} |
590
|
|
|
|
|
|
|
} |
591
|
4
|
50
|
|
|
|
11
|
|
592
|
0
|
0
|
|
|
|
0
|
if($args->{coerce}){ |
593
|
|
|
|
|
|
|
defined($tc) |
594
|
|
|
|
|
|
|
|| $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)"); |
595
|
|
|
|
|
|
|
|
596
|
0
|
0
|
|
|
|
0
|
$args->{weak_ref} |
597
|
|
|
|
|
|
|
&& $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)"); |
598
|
|
|
|
|
|
|
} |
599
|
4
|
50
|
|
|
|
9
|
|
600
|
|
|
|
|
|
|
if ($args->{lazy_build}) { |
601
|
0
|
0
|
|
|
|
0
|
exists($args->{default}) |
602
|
|
|
|
|
|
|
&& $class->throw_error("You can not use lazy_build and default for the same attribute ($name)"); |
603
|
0
|
|
|
|
|
0
|
|
604
|
0
|
|
0
|
|
|
0
|
$args->{lazy} = 1; |
605
|
0
|
0
|
|
|
|
0
|
$args->{builder} ||= "_build_${name}"; |
606
|
0
|
|
0
|
|
|
0
|
if ($name =~ /^_/) { |
607
|
0
|
|
0
|
|
|
0
|
$args->{clearer} ||= "_clear${name}"; |
608
|
|
|
|
|
|
|
$args->{predicate} ||= "_has${name}"; |
609
|
|
|
|
|
|
|
} |
610
|
0
|
|
0
|
|
|
0
|
else { |
611
|
0
|
|
0
|
|
|
0
|
$args->{clearer} ||= "clear_${name}"; |
612
|
|
|
|
|
|
|
$args->{predicate} ||= "has_${name}"; |
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
} |
615
|
4
|
50
|
|
|
|
9
|
|
616
|
0
|
0
|
|
|
|
0
|
if ($args->{auto_deref}) { |
617
|
|
|
|
|
|
|
defined($tc) |
618
|
|
|
|
|
|
|
|| $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)"); |
619
|
0
|
0
|
0
|
|
|
0
|
|
620
|
|
|
|
|
|
|
( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') ) |
621
|
|
|
|
|
|
|
|| $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)"); |
622
|
|
|
|
|
|
|
} |
623
|
4
|
50
|
|
|
|
8
|
|
624
|
|
|
|
|
|
|
if (exists $args->{trigger}) { |
625
|
0
|
0
|
|
|
|
0
|
('CODE' eq ref $args->{trigger}) |
626
|
|
|
|
|
|
|
|| $class->throw_error("Trigger must be a CODE ref on attribute ($name)"); |
627
|
|
|
|
|
|
|
} |
628
|
4
|
50
|
|
|
|
36
|
|
629
|
|
|
|
|
|
|
if ($args->{lazy}) { |
630
|
0
|
0
|
0
|
|
|
0
|
(exists $args->{default} || defined $args->{builder}) |
631
|
|
|
|
|
|
|
|| $class->throw_error("You cannot have a lazy attribute ($name) without specifying a default value for it"); |
632
|
|
|
|
|
|
|
} |
633
|
4
|
|
|
|
|
4
|
|
634
|
|
|
|
|
|
|
return; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
package Mouse::Meta::TypeConstraint; |
639
|
|
|
|
|
|
|
|
640
|
2
|
|
|
|
|
9
|
use overload |
641
|
|
|
|
|
|
|
'""' => '_as_string', |
642
|
|
|
|
|
|
|
'0+' => '_identity', |
643
|
|
|
|
|
|
|
'|' => '_unite', |
644
|
2
|
|
|
2
|
|
2005
|
|
|
2
|
|
|
|
|
1408
|
|
645
|
|
|
|
|
|
|
fallback => 1; |
646
|
0
|
|
|
0
|
1
|
0
|
|
647
|
0
|
|
|
0
|
1
|
0
|
sub name { $_[0]->{name} } |
648
|
0
|
|
|
0
|
1
|
0
|
sub parent { $_[0]->{parent} } |
649
|
|
|
|
|
|
|
sub message { $_[0]->{message} } |
650
|
0
|
|
|
0
|
|
0
|
|
651
|
|
|
|
|
|
|
sub _identity { Scalar::Util::refaddr($_[0]) } # overload 0+ |
652
|
0
|
|
|
0
|
0
|
0
|
|
653
|
0
|
|
|
0
|
|
0
|
sub type_parameter { $_[0]->{type_parameter} } |
654
|
|
|
|
|
|
|
sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} } |
655
|
0
|
|
|
0
|
|
0
|
|
656
|
0
|
|
|
0
|
1
|
0
|
sub __is_parameterized { exists $_[0]->{type_parameter} } |
657
|
|
|
|
|
|
|
sub has_coercion { exists $_[0]->{_compiled_type_coercion} } |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
|
660
|
6
|
|
|
6
|
0
|
5
|
sub compile_type_constraint{ |
661
|
|
|
|
|
|
|
my($self) = @_; |
662
|
|
|
|
|
|
|
|
663
|
6
|
|
|
|
|
4
|
# add parents first |
664
|
6
|
|
|
|
|
55
|
my @checks; |
665
|
6
|
50
|
|
|
|
22
|
for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){ |
|
|
50
|
|
|
|
|
|
666
|
0
|
|
|
|
|
0
|
if($parent->{hand_optimized_type_constraint}){ |
667
|
0
|
|
|
|
|
0
|
unshift @checks, $parent->{hand_optimized_type_constraint}; |
668
|
|
|
|
|
|
|
last; # a hand optimized constraint must include all the parents |
669
|
|
|
|
|
|
|
} |
670
|
0
|
|
|
|
|
0
|
elsif($parent->{constraint}){ |
671
|
|
|
|
|
|
|
unshift @checks, $parent->{constraint}; |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
} |
674
|
|
|
|
|
|
|
|
675
|
6
|
50
|
|
|
|
11
|
# then add child |
676
|
0
|
|
|
|
|
0
|
if($self->{constraint}){ |
677
|
|
|
|
|
|
|
push @checks, $self->{constraint}; |
678
|
|
|
|
|
|
|
} |
679
|
6
|
50
|
|
|
|
11
|
|
680
|
0
|
|
|
|
|
0
|
if($self->{type_constraints}){ # Union |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
681
|
|
|
|
|
|
|
my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} }; |
682
|
0
|
|
|
0
|
|
0
|
push @checks, sub{ |
683
|
0
|
0
|
|
|
|
0
|
foreach my $c(@types){ |
684
|
|
|
|
|
|
|
return 1 if $c->($_[0]); |
685
|
0
|
|
|
|
|
0
|
} |
686
|
0
|
|
|
|
|
0
|
return 0; |
687
|
|
|
|
|
|
|
}; |
688
|
|
|
|
|
|
|
} |
689
|
6
|
50
|
|
|
|
8
|
|
690
|
6
|
|
|
|
|
8
|
if(@checks == 0){ |
691
|
|
|
|
|
|
|
$self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any; |
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
else{ |
694
|
0
|
|
|
0
|
|
0
|
$self->{compiled_type_constraint} = sub{ |
695
|
0
|
|
|
|
|
0
|
my(@args) = @_; |
696
|
0
|
|
|
|
|
0
|
for ($args[0]) { # local $_ will cancel tie-ness due to perl's bug |
697
|
0
|
0
|
|
|
|
0
|
foreach my $c(@checks){ |
698
|
|
|
|
|
|
|
return undef if !$c->(@args); |
699
|
|
|
|
|
|
|
} |
700
|
0
|
|
|
|
|
0
|
} |
701
|
0
|
|
|
|
|
0
|
return 1; |
702
|
|
|
|
|
|
|
}; |
703
|
6
|
|
|
|
|
7
|
} |
704
|
|
|
|
|
|
|
return; |
705
|
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
|
707
|
0
|
|
|
0
|
1
|
0
|
sub check { |
708
|
0
|
|
|
|
|
0
|
my $self = shift; |
709
|
|
|
|
|
|
|
return $self->_compiled_type_constraint->(@_); |
710
|
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
package Mouse::Object; |
714
|
|
|
|
|
|
|
|
715
|
8
|
|
|
8
|
1
|
7
|
sub BUILDARGS { |
716
|
|
|
|
|
|
|
my $class = shift; |
717
|
8
|
50
|
|
|
|
23
|
|
718
|
0
|
0
|
|
|
|
0
|
if (scalar @_ == 1) { |
719
|
|
|
|
|
|
|
(ref($_[0]) eq 'HASH') |
720
|
|
|
|
|
|
|
|| $class->meta->throw_error("Single parameters to new() must be a HASH ref"); |
721
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
722
|
|
|
|
|
|
|
return {%{$_[0]}}; |
723
|
|
|
|
|
|
|
} |
724
|
8
|
|
|
|
|
20
|
else { |
725
|
|
|
|
|
|
|
return {@_}; |
726
|
|
|
|
|
|
|
} |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
|
729
|
4
|
|
|
4
|
1
|
21
|
sub new { |
730
|
4
|
|
|
|
|
15
|
my $class = shift; |
731
|
4
|
|
|
|
|
11
|
my $args = $class->BUILDARGS(@_); |
732
|
|
|
|
|
|
|
return $class->meta->new_object($args); |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
4
|
|
|
4
|
|
2134
|
sub DESTROY { |
736
|
|
|
|
|
|
|
my $self = shift; |
737
|
4
|
50
|
|
|
|
80
|
|
738
|
|
|
|
|
|
|
return unless $self->can('DEMOLISH'); # short circuit |
739
|
0
|
|
|
|
|
0
|
|
740
|
0
|
|
|
|
|
0
|
my $e = do{ |
741
|
0
|
|
|
|
|
0
|
local $?; |
742
|
0
|
|
|
|
|
0
|
local $@; |
743
|
|
|
|
|
|
|
eval{ |
744
|
|
|
|
|
|
|
# DEMOLISHALL |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
# We cannot count on being able to retrieve a previously made |
747
|
|
|
|
|
|
|
# metaclass, _or_ being able to make a new one during global |
748
|
|
|
|
|
|
|
# destruction. However, we should still be able to use mro at |
749
|
|
|
|
|
|
|
# that time (at least tests suggest so ;) |
750
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
751
|
0
|
|
0
|
|
|
0
|
foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) { |
752
|
|
|
|
|
|
|
my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH') |
753
|
|
|
|
|
|
|
|| next; |
754
|
0
|
|
|
|
|
0
|
|
755
|
|
|
|
|
|
|
$self->$demolish(Mouse::Util::in_global_destruction()); |
756
|
|
|
|
|
|
|
} |
757
|
0
|
|
|
|
|
0
|
}; |
758
|
|
|
|
|
|
|
$@; |
759
|
|
|
|
|
|
|
}; |
760
|
2
|
|
|
2
|
|
1134
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
281
|
|
761
|
0
|
0
|
|
|
|
0
|
no warnings 'misc'; |
762
|
|
|
|
|
|
|
die $e if $e; # rethrow |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
|
765
|
0
|
|
|
0
|
1
|
0
|
sub BUILDALL { |
766
|
|
|
|
|
|
|
my $self = shift; |
767
|
|
|
|
|
|
|
|
768
|
0
|
0
|
|
|
|
0
|
# short circuit |
769
|
|
|
|
|
|
|
return unless $self->can('BUILD'); |
770
|
0
|
|
|
|
|
0
|
|
771
|
0
|
|
0
|
|
|
0
|
for my $class (reverse $self->meta->linearized_isa) { |
772
|
|
|
|
|
|
|
my $build = Mouse::Util::get_code_ref($class, 'BUILD') |
773
|
|
|
|
|
|
|
|| next; |
774
|
0
|
|
|
|
|
0
|
|
775
|
|
|
|
|
|
|
$self->$build(@_); |
776
|
0
|
|
|
|
|
0
|
} |
777
|
|
|
|
|
|
|
return; |
778
|
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
|
780
|
2
|
|
|
|
|
50
|
sub DEMOLISHALL; |
781
|
|
|
|
|
|
|
*DEMOLISHALL = \&DESTROY; |
782
|
|
|
|
|
|
|
|
783
|
0
|
|
|
|
|
0
|
} |
784
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Exporter.pm |
785
|
2
|
|
|
2
|
|
6
|
package Mouse::Exporter; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
32
|
|
786
|
2
|
|
|
2
|
|
4
|
use strict; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
47
|
|
787
|
2
|
|
|
2
|
|
4
|
use warnings; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
548
|
|
788
|
|
|
|
|
|
|
use Carp (); |
789
|
2
|
|
|
2
|
|
3
|
|
790
|
|
|
|
|
|
|
my %SPEC; |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
# it must be "require", because Mouse::Util depends on Mouse::Exporter, |
793
|
2
|
|
|
|
|
92
|
# which depends on Mouse::Util::import() |
794
|
|
|
|
|
|
|
require Mouse::Util; |
795
|
|
|
|
|
|
|
|
796
|
8
|
|
|
8
|
|
27
|
sub import{ |
797
|
8
|
|
|
|
|
116
|
strict->import; |
798
|
8
|
|
|
|
|
261
|
warnings->import('all', FATAL => 'recursion'); |
799
|
|
|
|
|
|
|
return; |
800
|
|
|
|
|
|
|
} |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
|
803
|
10
|
|
|
10
|
1
|
26
|
sub setup_import_methods{ |
804
|
|
|
|
|
|
|
my($class, %args) = @_; |
805
|
10
|
|
33
|
|
|
59
|
|
806
|
|
|
|
|
|
|
my $exporting_package = $args{exporting_package} ||= caller(); |
807
|
10
|
|
|
|
|
28
|
|
808
|
|
|
|
|
|
|
my($import, $unimport) = $class->build_import_methods(%args); |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
Mouse::Util::install_subroutines($exporting_package, |
811
|
|
|
|
|
|
|
import => $import, |
812
|
|
|
|
|
|
|
unimport => $unimport, |
813
|
|
|
|
|
|
|
|
814
|
0
|
|
|
0
|
|
0
|
export_to_level => sub { |
815
|
0
|
|
|
|
|
0
|
my($package, $level, undef, @args) = @_; # the third argument is redundant |
816
|
|
|
|
|
|
|
$package->import({ into_level => $level + 1 }, @args); |
817
|
|
|
|
|
|
|
}, |
818
|
0
|
|
|
0
|
|
0
|
export => sub { |
819
|
0
|
|
|
|
|
0
|
my($package, $into, @args) = @_; |
820
|
|
|
|
|
|
|
$package->import({ into => $into }, @args); |
821
|
10
|
|
|
|
|
59
|
}, |
822
|
10
|
|
|
|
|
78
|
); |
823
|
|
|
|
|
|
|
return; |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
10
|
|
|
10
|
1
|
18
|
sub build_import_methods{ |
827
|
|
|
|
|
|
|
my($self, %args) = @_; |
828
|
10
|
|
33
|
|
|
22
|
|
829
|
|
|
|
|
|
|
my $exporting_package = $args{exporting_package} ||= caller(); |
830
|
10
|
|
|
|
|
14
|
|
831
|
|
|
|
|
|
|
$SPEC{$exporting_package} = \%args; |
832
|
|
|
|
|
|
|
|
833
|
10
|
|
|
|
|
10
|
# canonicalize args |
834
|
10
|
100
|
|
|
|
32
|
my @export_from; |
835
|
2
|
|
|
|
|
3
|
if($args{also}){ |
836
|
2
|
|
|
|
|
5
|
my %seen; |
837
|
|
|
|
|
|
|
my @stack = ($exporting_package); |
838
|
2
|
|
|
|
|
96
|
|
839
|
4
|
|
|
|
|
4
|
while(my $current = shift @stack){ |
840
|
|
|
|
|
|
|
push @export_from, $current; |
841
|
4
|
100
|
|
|
|
17
|
|
842
|
2
|
50
|
|
|
|
6
|
my $also = $SPEC{$current}{also} or next; |
|
2
|
|
|
|
|
12
|
|
|
0
|
|
|
|
|
0
|
|
843
|
|
|
|
|
|
|
push @stack, grep{ !$seen{$_}++ } ref($also) ? @{ $also } : $also; |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
} |
846
|
8
|
|
|
|
|
16
|
else{ |
847
|
|
|
|
|
|
|
@export_from = ($exporting_package); |
848
|
|
|
|
|
|
|
} |
849
|
10
|
|
|
|
|
10
|
|
850
|
|
|
|
|
|
|
my %exports; |
851
|
0
|
|
|
|
|
0
|
my @removables; |
852
|
|
|
|
|
|
|
my @all; |
853
|
0
|
|
|
|
|
0
|
|
854
|
|
|
|
|
|
|
my @init_meta_methods; |
855
|
10
|
|
|
|
|
15
|
|
856
|
12
|
50
|
|
|
|
28
|
foreach my $package(@export_from){ |
857
|
|
|
|
|
|
|
my $spec = $SPEC{$package} or next; |
858
|
12
|
100
|
|
|
|
20
|
|
859
|
10
|
|
|
|
|
10
|
if(my $as_is = $spec->{as_is}){ |
|
10
|
|
|
|
|
16
|
|
860
|
140
|
|
|
|
|
85
|
foreach my $thingy (@{$as_is}){ |
861
|
|
|
|
|
|
|
my($code_package, $code_name, $code); |
862
|
140
|
100
|
|
|
|
130
|
|
863
|
12
|
|
|
|
|
10
|
if(ref($thingy)){ |
864
|
12
|
|
|
|
|
20
|
$code = $thingy; |
865
|
|
|
|
|
|
|
($code_package, $code_name) = Mouse::Util::get_code_info($code); |
866
|
|
|
|
|
|
|
} |
867
|
128
|
|
|
|
|
72
|
else{ |
868
|
128
|
|
|
|
|
86
|
$code_package = $package; |
869
|
2
|
|
|
2
|
|
7
|
$code_name = $thingy; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
1225
|
|
870
|
128
|
|
|
|
|
57
|
no strict 'refs'; |
|
128
|
|
|
|
|
218
|
|
871
|
|
|
|
|
|
|
$code = \&{ $code_package . '::' . $code_name }; |
872
|
|
|
|
|
|
|
} |
873
|
140
|
|
|
|
|
125
|
|
874
|
140
|
|
|
|
|
149
|
push @all, $code_name; |
875
|
140
|
100
|
|
|
|
196
|
$exports{$code_name} = $code; |
876
|
128
|
|
|
|
|
138
|
if($code_package eq $package){ |
877
|
|
|
|
|
|
|
push @removables, $code_name; |
878
|
|
|
|
|
|
|
} |
879
|
|
|
|
|
|
|
} |
880
|
|
|
|
|
|
|
} |
881
|
12
|
100
|
|
|
|
122
|
|
882
|
6
|
50
|
|
|
|
14
|
if(my $init_meta = $package->can('init_meta')){ |
|
0
|
|
|
|
|
0
|
|
883
|
6
|
|
|
|
|
12
|
if(!grep{ $_ == $init_meta } @init_meta_methods){ |
884
|
|
|
|
|
|
|
push @init_meta_methods, $init_meta; |
885
|
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
} |
887
|
10
|
|
|
|
|
17
|
} |
888
|
10
|
|
|
|
|
11
|
$args{EXPORTS} = \%exports; |
889
|
|
|
|
|
|
|
$args{REMOVABLES} = \@removables; |
890
|
10
|
|
50
|
|
|
37
|
|
891
|
|
|
|
|
|
|
$args{groups}{all} ||= \@all; |
892
|
10
|
100
|
|
|
|
19
|
|
893
|
2
|
|
|
|
|
2
|
if(my $default_list = $args{groups}{default}){ |
894
|
2
|
|
|
|
|
1
|
my %default; |
|
2
|
|
|
|
|
3
|
|
895
|
0
|
|
0
|
|
|
0
|
foreach my $keyword(@{$default_list}){ |
896
|
|
|
|
|
|
|
$default{$keyword} = $exports{$keyword} |
897
|
|
|
|
|
|
|
|| Carp::confess(qq{The $exporting_package package does not export "$keyword"}); |
898
|
2
|
|
|
|
|
3
|
} |
899
|
|
|
|
|
|
|
$args{DEFAULT} = \%default; |
900
|
|
|
|
|
|
|
} |
901
|
8
|
|
50
|
|
|
28
|
else{ |
902
|
8
|
|
|
|
|
9
|
$args{groups}{default} ||= \@all; |
903
|
|
|
|
|
|
|
$args{DEFAULT} = $args{EXPORTS}; |
904
|
|
|
|
|
|
|
} |
905
|
10
|
100
|
|
|
|
20
|
|
906
|
6
|
|
|
|
|
5
|
if(@init_meta_methods){ |
907
|
|
|
|
|
|
|
$args{INIT_META} = \@init_meta_methods; |
908
|
|
|
|
|
|
|
} |
909
|
10
|
|
|
|
|
29
|
|
910
|
|
|
|
|
|
|
return (\&do_import, \&do_unimport); |
911
|
|
|
|
|
|
|
} |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
# the entity of general import() |
914
|
36
|
|
|
36
|
0
|
78
|
sub do_import { |
915
|
|
|
|
|
|
|
my($package, @args) = @_; |
916
|
36
|
|
33
|
|
|
86
|
|
917
|
|
|
|
|
|
|
my $spec = $SPEC{$package} |
918
|
|
|
|
|
|
|
|| Carp::confess("The package $package package does not use Mouse::Exporter"); |
919
|
36
|
50
|
|
|
|
72
|
|
920
|
|
|
|
|
|
|
my $into = _get_caller_package(ref($args[0]) ? shift @args : undef); |
921
|
36
|
|
|
|
|
30
|
|
922
|
|
|
|
|
|
|
my @exports; |
923
|
|
|
|
|
|
|
my @traits; |
924
|
36
|
|
|
|
|
65
|
|
925
|
28
|
|
|
|
|
26
|
while(@args){ |
926
|
28
|
50
|
|
|
|
122
|
my $arg = shift @args; |
|
|
100
|
|
|
|
|
|
927
|
0
|
0
|
|
|
|
0
|
if($arg =~ s/^-//){ |
928
|
0
|
0
|
|
|
|
0
|
if($arg eq 'traits'){ |
|
0
|
|
|
|
|
0
|
|
929
|
|
|
|
|
|
|
push @traits, ref($args[0]) ? @{shift(@args)} : shift(@args); |
930
|
|
|
|
|
|
|
} |
931
|
0
|
|
|
|
|
0
|
else { |
932
|
|
|
|
|
|
|
Mouse::Util::not_supported("-$arg"); |
933
|
|
|
|
|
|
|
} |
934
|
|
|
|
|
|
|
} |
935
|
22
|
|
33
|
|
|
52
|
elsif($arg =~ s/^://){ |
936
|
|
|
|
|
|
|
my $group = $spec->{groups}{$arg} |
937
|
22
|
|
|
|
|
17
|
|| Carp::confess(qq{The $package package does not export the group "$arg"}); |
|
22
|
|
|
|
|
68
|
|
938
|
|
|
|
|
|
|
push @exports, @{$group}; |
939
|
|
|
|
|
|
|
} |
940
|
6
|
|
|
|
|
11
|
else{ |
941
|
|
|
|
|
|
|
push @exports, $arg; |
942
|
|
|
|
|
|
|
} |
943
|
|
|
|
|
|
|
} |
944
|
36
|
|
|
|
|
106
|
|
945
|
36
|
|
|
|
|
462
|
strict->import; |
946
|
|
|
|
|
|
|
warnings->import('all', FATAL => 'recursion'); |
947
|
36
|
100
|
|
|
|
87
|
|
|
|
50
|
|
|
|
|
|
948
|
4
|
|
|
|
|
5
|
if($spec->{INIT_META}){ |
949
|
4
|
|
|
|
|
3
|
my $meta; |
|
4
|
|
|
|
|
9
|
|
950
|
4
|
|
|
|
|
7
|
foreach my $init_meta(@{$spec->{INIT_META}}){ |
951
|
|
|
|
|
|
|
$meta = $package->$init_meta(for_class => $into); |
952
|
|
|
|
|
|
|
} |
953
|
4
|
50
|
|
|
|
7
|
|
954
|
0
|
|
|
|
|
0
|
if(@traits){ |
955
|
|
|
|
|
|
|
my $type = (split /::/, ref $meta)[-1]; # e.g. "Class" for "My::Meta::Class" |
956
|
0
|
0
|
|
|
|
0
|
@traits = map{ |
|
0
|
|
|
|
|
0
|
|
957
|
|
|
|
|
|
|
ref($_) |
958
|
|
|
|
|
|
|
? $_ |
959
|
|
|
|
|
|
|
: Mouse::Util::resolve_metaclass_alias($type => $_, trait => 1) |
960
|
|
|
|
|
|
|
} @traits; |
961
|
0
|
|
|
|
|
0
|
|
962
|
0
|
0
|
|
|
|
0
|
require Mouse::Util::MetaRole; |
963
|
|
|
|
|
|
|
Mouse::Util::MetaRole::apply_metaroles( |
964
|
|
|
|
|
|
|
for => $into, |
965
|
|
|
|
|
|
|
Mouse::Util::is_a_metarole($into->meta) |
966
|
|
|
|
|
|
|
? (role_metaroles => { role => \@traits }) |
967
|
|
|
|
|
|
|
: (class_metaroles => { class => \@traits }), |
968
|
|
|
|
|
|
|
); |
969
|
|
|
|
|
|
|
} |
970
|
|
|
|
|
|
|
} |
971
|
0
|
|
|
|
|
0
|
elsif(@traits){ |
972
|
|
|
|
|
|
|
Carp::confess("Cannot provide traits when $package does not have an init_meta() method"); |
973
|
|
|
|
|
|
|
} |
974
|
36
|
100
|
|
|
|
46
|
|
975
|
24
|
|
|
|
|
17
|
if(@exports){ |
976
|
24
|
|
|
|
|
31
|
my @export_table; |
977
|
|
|
|
|
|
|
foreach my $keyword(@exports){ |
978
|
94
|
|
33
|
|
|
156
|
push @export_table, |
979
|
|
|
|
|
|
|
$keyword => ($spec->{EXPORTS}{$keyword} |
980
|
|
|
|
|
|
|
|| Carp::confess(qq{The $package package does not export "$keyword"}) |
981
|
|
|
|
|
|
|
); |
982
|
24
|
|
|
|
|
67
|
} |
983
|
|
|
|
|
|
|
Mouse::Util::install_subroutines($into, @export_table); |
984
|
|
|
|
|
|
|
} |
985
|
12
|
|
|
|
|
9
|
else{ |
|
12
|
|
|
|
|
39
|
|
986
|
|
|
|
|
|
|
Mouse::Util::install_subroutines($into, %{$spec->{DEFAULT}}); |
987
|
36
|
|
|
|
|
6613
|
} |
988
|
|
|
|
|
|
|
return; |
989
|
|
|
|
|
|
|
} |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
# the entity of general unimport() |
992
|
0
|
|
|
0
|
0
|
0
|
sub do_unimport { |
993
|
|
|
|
|
|
|
my($package, $arg) = @_; |
994
|
0
|
|
0
|
|
|
0
|
|
995
|
|
|
|
|
|
|
my $spec = $SPEC{$package} |
996
|
|
|
|
|
|
|
|| Carp::confess("The package $package does not use Mouse::Exporter"); |
997
|
0
|
|
|
|
|
0
|
|
998
|
|
|
|
|
|
|
my $from = _get_caller_package($arg); |
999
|
0
|
|
|
|
|
0
|
|
1000
|
2
|
|
|
2
|
|
10
|
my $stash = do{ |
|
2
|
|
|
|
|
1
|
|
|
2
|
|
|
|
|
328
|
|
1001
|
0
|
|
|
|
|
0
|
no strict 'refs'; |
|
0
|
|
|
|
|
0
|
|
1002
|
|
|
|
|
|
|
\%{$from . '::'} |
1003
|
|
|
|
|
|
|
}; |
1004
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1005
|
0
|
0
|
|
|
|
0
|
for my $keyword (@{ $spec->{REMOVABLES} }) { |
1006
|
0
|
|
|
|
|
0
|
next if !exists $stash->{$keyword}; |
1007
|
|
|
|
|
|
|
my $gv = \$stash->{$keyword}; |
1008
|
|
|
|
|
|
|
|
1009
|
0
|
0
|
0
|
|
|
0
|
# remove what is from us |
|
0
|
|
|
|
|
0
|
|
1010
|
0
|
|
|
|
|
0
|
if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ |
1011
|
|
|
|
|
|
|
delete $stash->{$keyword}; |
1012
|
|
|
|
|
|
|
} |
1013
|
0
|
|
|
|
|
0
|
} |
1014
|
|
|
|
|
|
|
return; |
1015
|
|
|
|
|
|
|
} |
1016
|
|
|
|
|
|
|
|
1017
|
36
|
|
|
36
|
|
30
|
sub _get_caller_package { |
1018
|
|
|
|
|
|
|
my($arg) = @_; |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
# We need one extra level because it's called by import so there's a layer |
1021
|
36
|
50
|
|
|
|
44
|
# of indirection |
1022
|
|
|
|
|
|
|
if(ref $arg){ |
1023
|
|
|
|
|
|
|
return defined($arg->{into}) ? $arg->{into} |
1024
|
0
|
0
|
|
|
|
0
|
: defined($arg->{into_level}) ? scalar caller(1 + $arg->{into_level}) |
|
|
0
|
|
|
|
|
|
1025
|
|
|
|
|
|
|
: scalar caller(1); |
1026
|
|
|
|
|
|
|
} |
1027
|
36
|
|
|
|
|
77
|
else{ |
1028
|
|
|
|
|
|
|
return scalar caller(1); |
1029
|
|
|
|
|
|
|
} |
1030
|
|
|
|
|
|
|
} |
1031
|
|
|
|
|
|
|
|
1032
|
0
|
|
|
|
|
0
|
} |
1033
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Util.pm |
1034
|
2
|
|
|
2
|
|
6
|
package Mouse::Util; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4
|
|
1035
|
|
|
|
|
|
|
use Mouse::Exporter; # enables strict and warnings |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
# Note that those which don't exist here are defined in XS or Mouse::PurePerl |
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
# must be here because it will be referred by other modules loaded |
1040
|
|
|
|
|
|
|
sub get_linear_isa($;$); ## no critic |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
# must be here because it will called in Mouse::Exporter |
1043
|
60
|
|
|
60
|
0
|
57
|
sub install_subroutines { |
1044
|
|
|
|
|
|
|
my $into = shift; |
1045
|
60
|
|
|
|
|
141
|
|
1046
|
2
|
|
|
2
|
|
8
|
while(my($name, $code) = splice @_, 0, 2){ |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
45
|
|
1047
|
2
|
|
|
2
|
|
5
|
no strict 'refs'; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
59
|
|
1048
|
2
|
|
|
2
|
|
6
|
no warnings 'once', 'redefine'; |
|
2
|
|
|
|
|
1
|
|
|
2
|
|
|
|
|
476
|
|
1049
|
196
|
|
|
|
|
109
|
use warnings FATAL => 'uninitialized'; |
|
196
|
|
|
|
|
788
|
|
|
196
|
|
|
|
|
151
|
|
1050
|
|
|
|
|
|
|
*{$into . '::' . $name} = \&{$code}; |
1051
|
60
|
|
|
|
|
70
|
} |
1052
|
|
|
|
|
|
|
return; |
1053
|
|
|
|
|
|
|
} |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
BEGIN{ |
1056
|
2
|
|
|
2
|
|
11
|
# This is used in Mouse::PurePerl |
1057
|
|
|
|
|
|
|
Mouse::Exporter->setup_import_methods( |
1058
|
|
|
|
|
|
|
as_is => [qw( |
1059
|
|
|
|
|
|
|
find_meta |
1060
|
|
|
|
|
|
|
does_role |
1061
|
|
|
|
|
|
|
resolve_metaclass_alias |
1062
|
|
|
|
|
|
|
apply_all_roles |
1063
|
|
|
|
|
|
|
english_list |
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
load_class |
1066
|
|
|
|
|
|
|
is_class_loaded |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
get_linear_isa |
1069
|
|
|
|
|
|
|
get_code_info |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
get_code_package |
1072
|
|
|
|
|
|
|
get_code_ref |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
not_supported |
1075
|
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
|
does meta throw_error dump |
1077
|
|
|
|
|
|
|
)], |
1078
|
|
|
|
|
|
|
groups => { |
1079
|
|
|
|
|
|
|
default => [], # export no functions by default |
1080
|
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
|
# The ':meta' group is 'use metaclass' for Mouse |
1082
|
|
|
|
|
|
|
meta => [qw(does meta dump throw_error)], |
1083
|
|
|
|
|
|
|
}, |
1084
|
|
|
|
|
|
|
); |
1085
|
2
|
|
|
|
|
2
|
|
1086
|
|
|
|
|
|
|
our $VERSION = 'v2.4.9'; |
1087
|
2
|
|
0
|
|
|
7
|
|
1088
|
|
|
|
|
|
|
my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY}); |
1089
|
|
|
|
|
|
|
|
1090
|
|
|
|
|
|
|
# Because Mouse::Util is loaded first in all the Mouse sub-modules, |
1091
|
2
|
50
|
|
|
|
4
|
# XSLoader must be placed here, not in Mouse.pm. |
1092
|
|
|
|
|
|
|
if($xs){ |
1093
|
|
|
|
|
|
|
# XXX: XSLoader tries to get the object path from caller's file name |
1094
|
0
|
|
|
|
|
0
|
# $hack_mouse_file fools its mechanism |
1095
|
0
|
|
0
|
|
|
0
|
(my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm |
1096
|
|
|
|
|
|
|
$xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{ |
1097
|
|
|
|
|
|
|
local $^W = 0; # workaround 'redefine' warning to &install_subroutines |
1098
|
|
|
|
|
|
|
require XSLoader; |
1099
|
|
|
|
|
|
|
XSLoader::load('Mouse', $VERSION); |
1100
|
|
|
|
|
|
|
Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta'); |
1101
|
|
|
|
|
|
|
Mouse::Util->import({ into => 'Mouse::Meta::Method::Destructor::XS' }, ':meta'); |
1102
|
|
|
|
|
|
|
Mouse::Util->import({ into => 'Mouse::Meta::Method::Accessor::XS' }, ':meta'); |
1103
|
|
|
|
|
|
|
return 1; |
1104
|
0
|
0
|
0
|
|
|
0
|
} || 0; |
1105
|
|
|
|
|
|
|
warn $@ if $@ && $ENV{MOUSE_XS}; |
1106
|
|
|
|
|
|
|
} |
1107
|
2
|
50
|
|
|
|
4
|
|
1108
|
2
|
|
|
|
|
8
|
if(!$xs){ |
1109
|
|
|
|
|
|
|
require 'Mouse/PurePerl.pm'; # we don't want to create its namespace |
1110
|
|
|
|
|
|
|
} |
1111
|
|
|
|
|
|
|
|
1112
|
2
|
|
|
|
|
1
|
{ |
|
2
|
|
|
|
|
3
|
|
1113
|
2
|
|
|
|
|
13
|
my $value = $xs; # avoid "Constants from lexical variables potentially modified elsewhere are deprecated" |
|
0
|
|
|
|
|
0
|
|
1114
|
|
|
|
|
|
|
*MOUSE_XS = sub(){ $value }; |
1115
|
|
|
|
|
|
|
} |
1116
|
|
|
|
|
|
|
|
1117
|
2
|
|
|
|
|
2
|
# definition of mro::get_linear_isa() |
1118
|
2
|
50
|
|
|
|
6
|
my $get_linear_isa; |
1119
|
2
|
|
|
|
|
849
|
if ($] >= 5.010_000) { |
1120
|
2
|
|
|
|
|
1225
|
require 'mro.pm'; |
1121
|
|
|
|
|
|
|
$get_linear_isa = \&mro::get_linear_isa; |
1122
|
|
|
|
|
|
|
} |
1123
|
|
|
|
|
|
|
else { |
1124
|
0
|
|
|
|
|
0
|
# this code is based on MRO::Compat::__get_linear_isa |
1125
|
|
|
|
|
|
|
my $_get_linear_isa_dfs; # this recurses so it isn't pretty |
1126
|
0
|
|
|
|
|
0
|
$_get_linear_isa_dfs = sub { |
1127
|
|
|
|
|
|
|
my($classname) = @_; |
1128
|
0
|
|
|
|
|
0
|
|
1129
|
0
|
|
|
|
|
0
|
my @lin = ($classname); |
1130
|
|
|
|
|
|
|
my %stored; |
1131
|
2
|
|
|
2
|
|
8
|
|
|
2
|
|
|
|
|
1
|
|
|
2
|
|
|
|
|
336
|
|
1132
|
0
|
|
|
|
|
0
|
no strict 'refs'; |
|
0
|
|
|
|
|
0
|
|
1133
|
0
|
|
|
|
|
0
|
foreach my $parent (@{"$classname\::ISA"}) { |
|
0
|
|
|
|
|
0
|
|
1134
|
0
|
0
|
|
|
|
0
|
foreach my $p(@{ $_get_linear_isa_dfs->($parent) }) { |
1135
|
0
|
|
|
|
|
0
|
next if exists $stored{$p}; |
1136
|
0
|
|
|
|
|
0
|
push(@lin, $p); |
1137
|
|
|
|
|
|
|
$stored{$p} = 1; |
1138
|
|
|
|
|
|
|
} |
1139
|
0
|
|
|
|
|
0
|
} |
1140
|
0
|
|
|
|
|
0
|
return \@lin; |
1141
|
|
|
|
|
|
|
}; |
1142
|
|
|
|
|
|
|
|
1143
|
0
|
|
|
|
|
0
|
{ |
1144
|
|
|
|
|
|
|
package # hide from PAUSE |
1145
|
0
|
|
|
|
|
0
|
Class::C3; |
1146
|
|
|
|
|
|
|
our %MRO; # avoid 'once' warnings |
1147
|
|
|
|
|
|
|
} |
1148
|
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
# MRO::Compat::__get_linear_isa has no prototype, so |
1150
|
|
|
|
|
|
|
# we define a prototyped version for compatibility with core's |
1151
|
|
|
|
|
|
|
# See also MRO::Compat::__get_linear_isa. |
1152
|
0
|
|
|
|
|
0
|
$get_linear_isa = sub ($;$){ |
1153
|
|
|
|
|
|
|
my($classname, $type) = @_; |
1154
|
0
|
0
|
|
|
|
0
|
|
1155
|
0
|
0
|
|
|
|
0
|
if(!defined $type){ |
1156
|
|
|
|
|
|
|
$type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs'; |
1157
|
0
|
0
|
|
|
|
0
|
} |
1158
|
0
|
|
|
|
|
0
|
if($type eq 'c3'){ |
1159
|
0
|
|
|
|
|
0
|
require Class::C3; |
1160
|
|
|
|
|
|
|
return [Class::C3::calculateMRO($classname)]; |
1161
|
|
|
|
|
|
|
} |
1162
|
0
|
|
|
|
|
0
|
else{ |
1163
|
|
|
|
|
|
|
return $_get_linear_isa_dfs->($classname); |
1164
|
0
|
|
|
|
|
0
|
} |
1165
|
|
|
|
|
|
|
}; |
1166
|
|
|
|
|
|
|
} |
1167
|
2
|
|
|
|
|
40
|
|
1168
|
|
|
|
|
|
|
*get_linear_isa = $get_linear_isa; |
1169
|
|
|
|
|
|
|
} |
1170
|
2
|
|
|
2
|
|
8
|
|
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
22
|
|
1171
|
2
|
|
|
2
|
|
4
|
use Carp (); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
2032
|
|
1172
|
|
|
|
|
|
|
use Scalar::Util (); |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
# aliases as public APIs |
1175
|
2
|
|
|
2
|
|
9
|
# it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util |
1176
|
|
|
|
|
|
|
require Mouse::Meta::Module; # for the entities of metaclass cache utilities |
1177
|
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
|
# aliases |
1179
|
2
|
|
|
|
|
2
|
{ |
|
2
|
|
|
|
|
6
|
|
1180
|
2
|
|
|
|
|
4
|
*class_of = \&Mouse::Meta::Module::_class_of; |
1181
|
2
|
|
|
|
|
2
|
*get_metaclass_by_name = \&Mouse::Meta::Module::_get_metaclass_by_name; |
1182
|
2
|
|
|
|
|
3
|
*get_all_metaclass_instances = \&Mouse::Meta::Module::_get_all_metaclass_instances; |
1183
|
|
|
|
|
|
|
*get_all_metaclass_names = \&Mouse::Meta::Module::_get_all_metaclass_names; |
1184
|
2
|
|
|
|
|
3
|
|
1185
|
2
|
|
|
|
|
6
|
*Mouse::load_class = \&load_class; |
1186
|
|
|
|
|
|
|
*Mouse::is_class_loaded = \&is_class_loaded; |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
# is-a predicates |
1189
|
|
|
|
|
|
|
#generate_isa_predicate_for('Mouse::Meta::TypeConstraint' => 'is_a_type_constraint'); |
1190
|
|
|
|
|
|
|
#generate_isa_predicate_for('Mouse::Meta::Class' => 'is_a_metaclass'); |
1191
|
|
|
|
|
|
|
#generate_isa_predicate_for('Mouse::Meta::Role' => 'is_a_metarole'); |
1192
|
|
|
|
|
|
|
|
1193
|
2
|
|
|
|
|
9
|
# duck type predicates |
1194
|
2
|
|
|
|
|
4
|
generate_can_predicate_for(['_compiled_type_constraint'] => 'is_a_type_constraint'); |
1195
|
2
|
|
|
|
|
3
|
generate_can_predicate_for(['create_anon_class'] => 'is_a_metaclass'); |
1196
|
|
|
|
|
|
|
generate_can_predicate_for(['create_anon_role'] => 'is_a_metarole'); |
1197
|
|
|
|
|
|
|
} |
1198
|
|
|
|
|
|
|
|
1199
|
|
|
|
|
|
|
sub in_global_destruction; |
1200
|
2
|
50
|
|
|
|
7
|
|
1201
|
|
|
|
|
|
|
if (defined ${^GLOBAL_PHASE}) { |
1202
|
0
|
|
|
0
|
|
0
|
*in_global_destruction = sub { |
1203
|
2
|
|
|
|
|
8
|
return ${^GLOBAL_PHASE} eq 'DESTRUCT'; |
1204
|
|
|
|
|
|
|
}; |
1205
|
|
|
|
|
|
|
} |
1206
|
0
|
|
|
|
|
0
|
else { |
1207
|
2
|
|
|
2
|
|
10
|
my $in_global_destruction = 0; |
1208
|
|
|
|
|
|
|
END { $in_global_destruction = 1 } |
1209
|
0
|
|
|
|
|
0
|
*in_global_destruction = sub { |
1210
|
0
|
|
|
|
|
0
|
return $in_global_destruction; |
1211
|
|
|
|
|
|
|
}; |
1212
|
|
|
|
|
|
|
} |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
# Moose::Util compatible utilities |
1215
|
|
|
|
|
|
|
|
1216
|
0
|
|
|
0
|
1
|
0
|
sub find_meta{ |
1217
|
|
|
|
|
|
|
return class_of( $_[0] ); |
1218
|
|
|
|
|
|
|
} |
1219
|
|
|
|
|
|
|
|
1220
|
0
|
|
|
0
|
|
0
|
sub _does_role_impl { |
1221
|
|
|
|
|
|
|
my ($class_or_obj, $role_name) = @_; |
1222
|
0
|
|
|
|
|
0
|
|
1223
|
|
|
|
|
|
|
my $meta = class_of($class_or_obj); |
1224
|
0
|
0
|
0
|
|
|
0
|
|
1225
|
|
|
|
|
|
|
(defined $role_name) |
1226
|
|
|
|
|
|
|
|| ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()"); |
1227
|
0
|
|
0
|
|
|
0
|
|
1228
|
|
|
|
|
|
|
return defined($meta) && $meta->does_role($role_name); |
1229
|
|
|
|
|
|
|
} |
1230
|
|
|
|
|
|
|
|
1231
|
0
|
|
|
0
|
1
|
0
|
sub does_role { |
1232
|
|
|
|
|
|
|
my($thing, $role_name) = @_; |
1233
|
0
|
0
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
|
|
1234
|
|
|
|
|
|
|
if( (Scalar::Util::blessed($thing) || is_class_loaded($thing)) |
1235
|
0
|
|
|
|
|
0
|
&& $thing->can('does')) { |
1236
|
|
|
|
|
|
|
return $thing->does($role_name); |
1237
|
0
|
|
|
|
|
0
|
} |
1238
|
|
|
|
|
|
|
goto &_does_role_impl; |
1239
|
|
|
|
|
|
|
} |
1240
|
|
|
|
|
|
|
|
1241
|
|
|
|
|
|
|
# taken from Mouse::Util (0.90) |
1242
|
2
|
|
|
|
|
59
|
{ |
|
0
|
|
|
|
|
0
|
|
1243
|
|
|
|
|
|
|
my %cache; |
1244
|
|
|
|
|
|
|
|
1245
|
0
|
|
|
0
|
1
|
0
|
sub resolve_metaclass_alias { |
1246
|
|
|
|
|
|
|
my ( $type, $metaclass_name, %options ) = @_; |
1247
|
0
|
0
|
|
|
|
0
|
|
1248
|
|
|
|
|
|
|
my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); |
1249
|
0
|
|
0
|
|
|
0
|
|
1250
|
|
|
|
|
|
|
return $cache{$cache_key}{$metaclass_name} ||= do{ |
1251
|
|
|
|
|
|
|
|
1252
|
0
|
0
|
|
|
|
0
|
my $possible_full_name = join '::', |
1253
|
|
|
|
|
|
|
'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name |
1254
|
|
|
|
|
|
|
; |
1255
|
0
|
|
|
|
|
0
|
|
1256
|
|
|
|
|
|
|
my $loaded_class = load_first_existing_class( |
1257
|
|
|
|
|
|
|
$possible_full_name, |
1258
|
|
|
|
|
|
|
$metaclass_name |
1259
|
|
|
|
|
|
|
); |
1260
|
0
|
0
|
|
|
|
0
|
|
1261
|
|
|
|
|
|
|
$loaded_class->can('register_implementation') |
1262
|
|
|
|
|
|
|
? $loaded_class->register_implementation |
1263
|
|
|
|
|
|
|
: $loaded_class; |
1264
|
|
|
|
|
|
|
}; |
1265
|
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
|
} |
1267
|
|
|
|
|
|
|
|
1268
|
|
|
|
|
|
|
# Utilities from Class::MOP |
1269
|
2
|
|
|
|
|
2
|
|
1270
|
|
|
|
|
|
|
sub get_code_info; |
1271
|
|
|
|
|
|
|
sub get_code_package; |
1272
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
sub is_valid_class_name; |
1274
|
|
|
|
|
|
|
sub is_class_loaded; |
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
# taken from Class/MOP.pm |
1277
|
0
|
0
|
|
0
|
0
|
0
|
sub load_first_existing_class { |
1278
|
|
|
|
|
|
|
my @classes = @_ |
1279
|
|
|
|
|
|
|
or return; |
1280
|
0
|
|
|
|
|
0
|
|
1281
|
0
|
|
|
|
|
0
|
my %exceptions; |
1282
|
0
|
|
|
|
|
0
|
for my $class (@classes) { |
1283
|
|
|
|
|
|
|
my $e = _try_load_one_class($class); |
1284
|
0
|
0
|
|
|
|
0
|
|
1285
|
0
|
|
|
|
|
0
|
if ($e) { |
1286
|
|
|
|
|
|
|
$exceptions{$class} = $e; |
1287
|
|
|
|
|
|
|
} |
1288
|
0
|
|
|
|
|
0
|
else { |
1289
|
|
|
|
|
|
|
return $class; |
1290
|
|
|
|
|
|
|
} |
1291
|
|
|
|
|
|
|
} |
1292
|
|
|
|
|
|
|
|
1293
|
|
|
|
|
|
|
# not found |
1294
|
|
|
|
|
|
|
Carp::confess join( |
1295
|
|
|
|
|
|
|
"\n", |
1296
|
0
|
|
|
|
|
0
|
map { |
1297
|
0
|
|
|
|
|
0
|
sprintf( "Could not load class (%s) because : %s", |
1298
|
|
|
|
|
|
|
$_, $exceptions{$_} ) |
1299
|
|
|
|
|
|
|
} @classes |
1300
|
|
|
|
|
|
|
); |
1301
|
|
|
|
|
|
|
} |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
# taken from Class/MOP.pm |
1304
|
8
|
|
|
8
|
|
6
|
sub _try_load_one_class { |
1305
|
|
|
|
|
|
|
my $class = shift; |
1306
|
8
|
50
|
|
|
|
16
|
|
1307
|
0
|
0
|
|
|
|
0
|
unless ( is_valid_class_name($class) ) { |
1308
|
0
|
|
|
|
|
0
|
my $display = defined($class) ? $class : 'undef'; |
1309
|
|
|
|
|
|
|
Carp::confess "Invalid class name ($display)"; |
1310
|
|
|
|
|
|
|
} |
1311
|
8
|
50
|
|
|
|
16
|
|
1312
|
|
|
|
|
|
|
return '' if is_class_loaded($class); |
1313
|
0
|
|
|
|
|
0
|
|
1314
|
0
|
|
|
|
|
0
|
$class =~ s{::}{/}g; |
1315
|
|
|
|
|
|
|
$class .= '.pm'; |
1316
|
0
|
|
|
|
|
0
|
|
1317
|
0
|
|
|
|
|
0
|
return do { |
1318
|
0
|
|
|
|
|
0
|
local $@; |
|
0
|
|
|
|
|
0
|
|
1319
|
0
|
|
|
|
|
0
|
eval { require $class }; |
1320
|
|
|
|
|
|
|
$@; |
1321
|
|
|
|
|
|
|
}; |
1322
|
|
|
|
|
|
|
} |
1323
|
|
|
|
|
|
|
|
1324
|
|
|
|
|
|
|
|
1325
|
8
|
|
|
8
|
1
|
8
|
sub load_class { |
1326
|
8
|
|
|
|
|
18
|
my $class = shift; |
1327
|
8
|
50
|
|
|
|
18
|
my $e = _try_load_one_class($class); |
1328
|
|
|
|
|
|
|
Carp::confess "Could not load class ($class) because : $e" if $e; |
1329
|
8
|
|
|
|
|
19
|
|
1330
|
|
|
|
|
|
|
return $class; |
1331
|
|
|
|
|
|
|
} |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
|
1334
|
0
|
0
|
|
0
|
1
|
0
|
sub apply_all_roles { |
1335
|
|
|
|
|
|
|
my $consumer = Scalar::Util::blessed($_[0]) |
1336
|
|
|
|
|
|
|
? $_[0] # instance |
1337
|
|
|
|
|
|
|
: Mouse::Meta::Class->initialize($_[0]); # class or role name |
1338
|
0
|
|
|
|
|
0
|
|
1339
|
|
|
|
|
|
|
my @roles; |
1340
|
|
|
|
|
|
|
|
1341
|
0
|
|
|
|
|
0
|
# Basis of Data::OptList |
1342
|
0
|
|
|
|
|
0
|
my $max = scalar(@_); |
1343
|
0
|
|
|
|
|
0
|
for (my $i = 1; $i < $max ; $i++) { |
1344
|
0
|
|
|
|
|
0
|
my $role = $_[$i]; |
1345
|
0
|
0
|
|
|
|
0
|
my $role_name; |
1346
|
0
|
|
|
|
|
0
|
if(ref $role) { |
1347
|
|
|
|
|
|
|
$role_name = $role->name; |
1348
|
|
|
|
|
|
|
} |
1349
|
0
|
|
|
|
|
0
|
else { |
1350
|
0
|
|
|
|
|
0
|
$role_name = $role; |
1351
|
0
|
|
|
|
|
0
|
load_class($role_name); |
1352
|
|
|
|
|
|
|
$role = get_metaclass_by_name($role_name); |
1353
|
|
|
|
|
|
|
} |
1354
|
0
|
0
|
0
|
|
|
0
|
|
1355
|
0
|
|
|
|
|
0
|
if ($i + 1 < $max && ref($_[$i + 1]) eq 'HASH') { |
1356
|
|
|
|
|
|
|
push @roles, [ $role => $_[++$i] ]; |
1357
|
0
|
|
|
|
|
0
|
} else { |
1358
|
|
|
|
|
|
|
push @roles, [ $role => undef ]; |
1359
|
0
|
0
|
|
|
|
0
|
} |
1360
|
|
|
|
|
|
|
is_a_metarole($role) |
1361
|
|
|
|
|
|
|
|| $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role"); |
1362
|
|
|
|
|
|
|
} |
1363
|
0
|
0
|
|
|
|
0
|
|
1364
|
0
|
|
|
|
|
0
|
if ( scalar @roles == 1 ) { |
|
0
|
|
|
|
|
0
|
|
1365
|
0
|
0
|
|
|
|
0
|
my ( $role, $params ) = @{ $roles[0] }; |
1366
|
|
|
|
|
|
|
$role->apply( $consumer, defined $params ? $params : () ); |
1367
|
|
|
|
|
|
|
} |
1368
|
0
|
|
|
|
|
0
|
else { |
1369
|
|
|
|
|
|
|
Mouse::Meta::Role->combine(@roles)->apply($consumer); |
1370
|
0
|
|
|
|
|
0
|
} |
1371
|
|
|
|
|
|
|
return; |
1372
|
|
|
|
|
|
|
} |
1373
|
|
|
|
|
|
|
|
1374
|
|
|
|
|
|
|
# taken from Moose::Util 0.90 |
1375
|
0
|
0
|
|
0
|
0
|
0
|
sub english_list { |
1376
|
|
|
|
|
|
|
return $_[0] if @_ == 1; |
1377
|
0
|
|
|
|
|
0
|
|
1378
|
|
|
|
|
|
|
my @items = sort @_; |
1379
|
0
|
0
|
|
|
|
0
|
|
1380
|
|
|
|
|
|
|
return "$items[0] and $items[1]" if @items == 2; |
1381
|
0
|
|
|
|
|
0
|
|
1382
|
|
|
|
|
|
|
my $tail = pop @items; |
1383
|
0
|
|
|
|
|
0
|
|
1384
|
|
|
|
|
|
|
return join q{, }, @items, "and $tail"; |
1385
|
|
|
|
|
|
|
} |
1386
|
|
|
|
|
|
|
|
1387
|
0
|
|
|
0
|
0
|
0
|
sub quoted_english_list { |
|
0
|
|
|
|
|
0
|
|
1388
|
|
|
|
|
|
|
return english_list(map { qq{'$_'} } @_); |
1389
|
|
|
|
|
|
|
} |
1390
|
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
|
# common utilities |
1392
|
|
|
|
|
|
|
|
1393
|
0
|
|
|
0
|
1
|
0
|
sub not_supported{ |
1394
|
|
|
|
|
|
|
my($feature) = @_; |
1395
|
0
|
|
0
|
|
|
0
|
|
1396
|
|
|
|
|
|
|
$feature ||= ( caller(1) )[3] . '()'; # subroutine name |
1397
|
0
|
|
|
|
|
0
|
|
1398
|
0
|
|
|
|
|
0
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
1399
|
|
|
|
|
|
|
Carp::confess("Mouse does not currently support $feature"); |
1400
|
|
|
|
|
|
|
} |
1401
|
|
|
|
|
|
|
|
1402
|
|
|
|
|
|
|
# general meta() method |
1403
|
0
|
|
0
|
0
|
0
|
0
|
sub meta :method{ |
1404
|
|
|
|
|
|
|
return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]); |
1405
|
|
|
|
|
|
|
} |
1406
|
|
|
|
|
|
|
|
1407
|
|
|
|
|
|
|
# general throw_error() method |
1408
|
|
|
|
|
|
|
# $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess) |
1409
|
0
|
|
|
0
|
0
|
0
|
sub throw_error :method { |
1410
|
|
|
|
|
|
|
my($self, $message, %args) = @_; |
1411
|
0
|
|
0
|
|
|
0
|
|
1412
|
0
|
|
|
|
|
0
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1 + ($args{depth} || 0); |
1413
|
|
|
|
|
|
|
local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though |
1414
|
0
|
0
|
0
|
|
|
0
|
|
1415
|
0
|
|
|
|
|
0
|
if(exists $args{longmess} && !$args{longmess}) { |
1416
|
|
|
|
|
|
|
Carp::croak($message); |
1417
|
|
|
|
|
|
|
} |
1418
|
0
|
|
|
|
|
0
|
else{ |
1419
|
|
|
|
|
|
|
Carp::confess($message); |
1420
|
|
|
|
|
|
|
} |
1421
|
|
|
|
|
|
|
} |
1422
|
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
# general dump() method |
1424
|
0
|
|
|
0
|
0
|
0
|
sub dump :method { |
1425
|
|
|
|
|
|
|
my($self, $maxdepth) = @_; |
1426
|
0
|
|
|
|
|
0
|
|
1427
|
0
|
|
|
|
|
0
|
require 'Data/Dumper.pm'; # we don't want to create its namespace |
1428
|
0
|
0
|
|
|
|
0
|
my $dd = Data::Dumper->new([$self]); |
1429
|
0
|
|
|
|
|
0
|
$dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3); |
1430
|
0
|
|
|
|
|
0
|
$dd->Indent(1); |
1431
|
0
|
|
|
|
|
0
|
$dd->Sortkeys(1); |
1432
|
0
|
|
|
|
|
0
|
$dd->Quotekeys(0); |
1433
|
|
|
|
|
|
|
return $dd->Dump(); |
1434
|
|
|
|
|
|
|
} |
1435
|
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
|
# general does() method |
1437
|
0
|
|
|
0
|
0
|
0
|
sub does :method { |
1438
|
|
|
|
|
|
|
goto &_does_role_impl; |
1439
|
|
|
|
|
|
|
} |
1440
|
|
|
|
|
|
|
|
1441
|
0
|
|
|
|
|
0
|
} |
1442
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/TypeConstraint.pm |
1443
|
2
|
|
|
2
|
|
6
|
package Mouse::Meta::TypeConstraint; |
|
2
|
|
|
0
|
|
2
|
|
|
2
|
|
|
|
|
6
|
|
1444
|
|
|
|
|
|
|
use Mouse::Util qw(:meta); # enables strict and warnings |
1445
|
|
|
|
|
|
|
|
1446
|
46
|
|
|
46
|
1
|
44
|
sub new { |
1447
|
46
|
50
|
|
|
|
93
|
my $class = shift; |
|
0
|
|
|
|
|
0
|
|
1448
|
|
|
|
|
|
|
my %args = @_ == 1 ? %{$_[0]} : @_; |
1449
|
46
|
50
|
|
|
|
59
|
|
1450
|
|
|
|
|
|
|
$args{name} = '__ANON__' if !defined $args{name}; |
1451
|
46
|
|
|
|
|
32
|
|
1452
|
46
|
100
|
|
|
|
54
|
my $type_parameter; |
1453
|
44
|
|
|
|
|
25
|
if(defined $args{parent}) { # subtyping |
|
44
|
|
|
|
|
159
|
|
1454
|
|
|
|
|
|
|
%args = (%{$args{parent}}, %args); |
1455
|
|
|
|
|
|
|
|
1456
|
|
|
|
|
|
|
# a child type must not inherit 'compiled_type_constraint' |
1457
|
44
|
|
|
|
|
60
|
# and 'hand_optimized_type_constraint' from the parent |
1458
|
44
|
|
|
|
|
27
|
delete $args{compiled_type_constraint}; # don't inherit it |
1459
|
|
|
|
|
|
|
delete $args{hand_optimized_type_constraint}; # don't inherit it |
1460
|
44
|
|
|
|
|
29
|
|
1461
|
44
|
50
|
|
|
|
68
|
$type_parameter = $args{type_parameter}; |
1462
|
0
|
0
|
|
|
|
0
|
if(defined(my $parent_tp = $args{parent}{type_parameter})) { |
1463
|
0
|
0
|
|
|
|
0
|
if($parent_tp != $type_parameter) { |
1464
|
|
|
|
|
|
|
$type_parameter->is_a_type_of($parent_tp) |
1465
|
|
|
|
|
|
|
or $class->throw_error( |
1466
|
|
|
|
|
|
|
"$type_parameter is not a subtype of $parent_tp", |
1467
|
|
|
|
|
|
|
); |
1468
|
|
|
|
|
|
|
} |
1469
|
0
|
|
|
|
|
0
|
else { |
1470
|
|
|
|
|
|
|
$type_parameter = undef; |
1471
|
|
|
|
|
|
|
} |
1472
|
|
|
|
|
|
|
} |
1473
|
|
|
|
|
|
|
} |
1474
|
46
|
|
|
|
|
26
|
|
1475
|
|
|
|
|
|
|
my $check; |
1476
|
46
|
100
|
|
|
|
56
|
|
|
|
50
|
|
|
|
|
|
1477
|
40
|
|
|
|
|
28
|
if($check = delete $args{optimized}) { # likely to be builtins |
1478
|
40
|
|
|
|
|
30
|
$args{hand_optimized_type_constraint} = $check; |
1479
|
|
|
|
|
|
|
$args{compiled_type_constraint} = $check; |
1480
|
|
|
|
|
|
|
} |
1481
|
|
|
|
|
|
|
elsif(defined $type_parameter) { # parameterizing |
1482
|
0
|
|
0
|
|
|
0
|
my $generator = $args{constraint_generator} |
1483
|
|
|
|
|
|
|
|| $class->throw_error( |
1484
|
|
|
|
|
|
|
"The $args{name} constraint cannot be used," |
1485
|
|
|
|
|
|
|
. " because $type_parameter doesn't subtype" |
1486
|
|
|
|
|
|
|
. " from a parameterizable type"); |
1487
|
0
|
|
|
|
|
0
|
|
1488
|
0
|
0
|
|
|
|
0
|
my $parameterized_check = $generator->($type_parameter); |
1489
|
|
|
|
|
|
|
if(defined(my $my_check = $args{constraint})) { |
1490
|
0
|
|
0
|
0
|
|
0
|
$check = sub { |
1491
|
0
|
|
|
|
|
0
|
return $parameterized_check->($_) && $my_check->($_); |
1492
|
|
|
|
|
|
|
}; |
1493
|
|
|
|
|
|
|
} |
1494
|
0
|
|
|
|
|
0
|
else { |
1495
|
|
|
|
|
|
|
$check = $parameterized_check; |
1496
|
0
|
|
|
|
|
0
|
} |
1497
|
|
|
|
|
|
|
$args{constraint} = $check; |
1498
|
|
|
|
|
|
|
} |
1499
|
6
|
|
|
|
|
5
|
else { # common cases |
1500
|
|
|
|
|
|
|
$check = $args{constraint}; |
1501
|
|
|
|
|
|
|
} |
1502
|
46
|
50
|
66
|
|
|
128
|
|
1503
|
0
|
|
|
|
|
0
|
if(defined($check) && ref($check) ne 'CODE'){ |
1504
|
|
|
|
|
|
|
$class->throw_error( |
1505
|
|
|
|
|
|
|
"Constraint for $args{name} is not a CODE reference"); |
1506
|
|
|
|
|
|
|
} |
1507
|
46
|
|
|
|
|
45
|
|
1508
|
|
|
|
|
|
|
my $self = bless \%args, $class; |
1509
|
46
|
100
|
|
|
|
92
|
$self->compile_type_constraint() |
1510
|
|
|
|
|
|
|
if !$args{hand_optimized_type_constraint}; |
1511
|
46
|
50
|
|
|
|
52
|
|
1512
|
0
|
|
|
|
|
0
|
if($args{type_constraints}) { # union types |
|
0
|
|
|
|
|
0
|
|
1513
|
0
|
0
|
|
|
|
0
|
foreach my $type(@{$self->{type_constraints}}){ |
1514
|
|
|
|
|
|
|
if($type->has_coercion){ |
1515
|
0
|
|
|
|
|
0
|
# set undef for has_coercion() |
1516
|
0
|
|
|
|
|
0
|
$self->{_compiled_type_coercion} = undef; |
1517
|
|
|
|
|
|
|
last; |
1518
|
|
|
|
|
|
|
} |
1519
|
|
|
|
|
|
|
} |
1520
|
|
|
|
|
|
|
} |
1521
|
46
|
|
|
|
|
115
|
|
1522
|
|
|
|
|
|
|
return $self; |
1523
|
|
|
|
|
|
|
} |
1524
|
|
|
|
|
|
|
|
1525
|
0
|
|
|
0
|
1
|
0
|
sub create_child_type { |
1526
|
0
|
|
|
|
|
0
|
my $self = shift; |
1527
|
|
|
|
|
|
|
return ref($self)->new(@_, parent => $self); |
1528
|
|
|
|
|
|
|
} |
1529
|
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
sub name; |
1531
|
|
|
|
|
|
|
sub parent; |
1532
|
|
|
|
|
|
|
sub message; |
1533
|
|
|
|
|
|
|
sub has_coercion; |
1534
|
|
|
|
|
|
|
|
1535
|
|
|
|
|
|
|
sub check; |
1536
|
|
|
|
|
|
|
|
1537
|
|
|
|
|
|
|
sub type_parameter; |
1538
|
|
|
|
|
|
|
sub __is_parameterized; |
1539
|
|
|
|
|
|
|
|
1540
|
|
|
|
|
|
|
sub _compiled_type_constraint; |
1541
|
|
|
|
|
|
|
sub _compiled_type_coercion; |
1542
|
|
|
|
|
|
|
|
1543
|
|
|
|
|
|
|
sub compile_type_constraint; |
1544
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
|
1546
|
0
|
|
|
0
|
|
0
|
sub _add_type_coercions { # ($self, @pairs) |
1547
|
|
|
|
|
|
|
my $self = shift; |
1548
|
0
|
0
|
|
|
|
0
|
|
1549
|
0
|
|
|
|
|
0
|
if(exists $self->{type_constraints}){ # union type |
1550
|
|
|
|
|
|
|
$self->throw_error( |
1551
|
|
|
|
|
|
|
"Cannot add additional type coercions to Union types '$self'"); |
1552
|
|
|
|
|
|
|
} |
1553
|
0
|
|
0
|
|
|
0
|
|
1554
|
0
|
|
|
|
|
0
|
my $coercion_map = ($self->{coercion_map} ||= []); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1555
|
|
|
|
|
|
|
my %has = map{ $_->[0]->name => undef } @{$coercion_map}; |
1556
|
0
|
|
|
|
|
0
|
|
1557
|
0
|
|
|
|
|
0
|
for(my $i = 0; $i < @_; $i++){ |
1558
|
0
|
|
|
|
|
0
|
my $from = $_[ $i]; |
1559
|
|
|
|
|
|
|
my $action = $_[++$i]; |
1560
|
0
|
0
|
|
|
|
0
|
|
1561
|
0
|
|
|
|
|
0
|
if(exists $has{$from}){ |
1562
|
|
|
|
|
|
|
$self->throw_error("A coercion action already exists for '$from'"); |
1563
|
|
|
|
|
|
|
} |
1564
|
0
|
0
|
|
|
|
0
|
|
1565
|
|
|
|
|
|
|
my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from) |
1566
|
|
|
|
|
|
|
or $self->throw_error( |
1567
|
|
|
|
|
|
|
"Could not find the type constraint ($from) to coerce from"); |
1568
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1569
|
|
|
|
|
|
|
push @{$coercion_map}, [ $type => $action ]; |
1570
|
|
|
|
|
|
|
} |
1571
|
0
|
|
|
|
|
0
|
|
1572
|
0
|
|
|
|
|
0
|
$self->{_compiled_type_coercion} = undef; |
1573
|
|
|
|
|
|
|
return; |
1574
|
|
|
|
|
|
|
} |
1575
|
|
|
|
|
|
|
|
1576
|
0
|
|
|
0
|
|
0
|
sub _compiled_type_coercion { |
1577
|
|
|
|
|
|
|
my($self) = @_; |
1578
|
0
|
|
|
|
|
0
|
|
1579
|
0
|
0
|
|
|
|
0
|
my $coercion = $self->{_compiled_type_coercion}; |
1580
|
|
|
|
|
|
|
return $coercion if defined $coercion; |
1581
|
0
|
0
|
|
|
|
0
|
|
1582
|
0
|
|
|
|
|
0
|
if(!$self->{type_constraints}) { |
1583
|
0
|
|
|
|
|
0
|
my @coercions; |
|
0
|
|
|
|
|
0
|
|
1584
|
0
|
|
|
|
|
0
|
foreach my $pair(@{$self->{coercion_map}}) { |
1585
|
|
|
|
|
|
|
push @coercions, |
1586
|
|
|
|
|
|
|
[ $pair->[0]->_compiled_type_constraint, $pair->[1] ]; |
1587
|
|
|
|
|
|
|
} |
1588
|
|
|
|
|
|
|
|
1589
|
0
|
|
|
0
|
|
0
|
$coercion = sub { |
1590
|
0
|
|
|
|
|
0
|
my($thing) = @_; |
1591
|
|
|
|
|
|
|
foreach my $pair (@coercions) { |
1592
|
0
|
0
|
|
|
|
0
|
#my ($constraint, $converter) = @$pair; |
1593
|
0
|
|
|
|
|
0
|
if ($pair->[0]->($thing)) { |
1594
|
|
|
|
|
|
|
return $pair->[1]->($thing) for $thing; # local $_ will cancel tie-ness due to perl's bug |
1595
|
|
|
|
|
|
|
} |
1596
|
0
|
|
|
|
|
0
|
} |
1597
|
0
|
|
|
|
|
0
|
return $thing; |
1598
|
|
|
|
|
|
|
}; |
1599
|
|
|
|
|
|
|
} |
1600
|
0
|
|
|
|
|
0
|
else { # for union type |
1601
|
0
|
|
|
|
|
0
|
my @coercions; |
|
0
|
|
|
|
|
0
|
|
1602
|
0
|
0
|
|
|
|
0
|
foreach my $type(@{$self->{type_constraints}}){ |
1603
|
0
|
|
|
|
|
0
|
if($type->has_coercion){ |
1604
|
|
|
|
|
|
|
push @coercions, $type; |
1605
|
|
|
|
|
|
|
} |
1606
|
0
|
0
|
|
|
|
0
|
} |
1607
|
|
|
|
|
|
|
if(@coercions){ |
1608
|
0
|
|
|
0
|
|
0
|
$coercion = sub { |
1609
|
0
|
|
|
|
|
0
|
my($thing) = @_; |
1610
|
0
|
|
|
|
|
0
|
foreach my $type(@coercions){ |
1611
|
0
|
0
|
|
|
|
0
|
my $value = $type->coerce($thing); |
1612
|
|
|
|
|
|
|
return $value if $self->check($value); |
1613
|
0
|
|
|
|
|
0
|
} |
1614
|
0
|
|
|
|
|
0
|
return $thing; |
1615
|
|
|
|
|
|
|
}; |
1616
|
|
|
|
|
|
|
} |
1617
|
|
|
|
|
|
|
} |
1618
|
0
|
|
|
|
|
0
|
|
1619
|
|
|
|
|
|
|
return( $self->{_compiled_type_coercion} = $coercion ); |
1620
|
|
|
|
|
|
|
} |
1621
|
|
|
|
|
|
|
|
1622
|
0
|
|
|
0
|
1
|
0
|
sub coerce { |
1623
|
0
|
0
|
|
|
|
0
|
my $self = shift; |
1624
|
|
|
|
|
|
|
return $_[0] if $self->check(@_); |
1625
|
0
|
0
|
|
|
|
0
|
|
1626
|
|
|
|
|
|
|
my $coercion = $self->_compiled_type_coercion |
1627
|
0
|
|
|
|
|
0
|
or $self->throw_error("Cannot coerce without a type coercion"); |
1628
|
|
|
|
|
|
|
return $coercion->(@_); |
1629
|
|
|
|
|
|
|
} |
1630
|
|
|
|
|
|
|
|
1631
|
0
|
|
|
0
|
1
|
0
|
sub get_message { |
1632
|
0
|
0
|
|
|
|
0
|
my ($self, $value) = @_; |
1633
|
0
|
|
|
|
|
0
|
if ( my $msg = $self->message ) { |
1634
|
|
|
|
|
|
|
return $msg->($value) for $value; # local $_ will cancel tie-ness due to perl's bug |
1635
|
|
|
|
|
|
|
} |
1636
|
0
|
0
|
0
|
|
|
0
|
else { |
|
|
0
|
|
|
|
|
|
1637
|
0
|
|
|
|
|
0
|
if(not defined $value) { |
1638
|
|
|
|
|
|
|
$value = 'undef'; |
1639
|
|
|
|
|
|
|
} |
1640
|
0
|
|
|
|
|
0
|
elsif( ref($value) && defined(&overload::StrVal) ) { |
1641
|
|
|
|
|
|
|
$value = overload::StrVal($value); |
1642
|
0
|
|
|
|
|
0
|
} |
1643
|
|
|
|
|
|
|
return "Validation failed for '$self' with value $value"; |
1644
|
|
|
|
|
|
|
} |
1645
|
|
|
|
|
|
|
} |
1646
|
|
|
|
|
|
|
|
1647
|
0
|
|
|
0
|
1
|
0
|
sub is_a_type_of { |
1648
|
|
|
|
|
|
|
my($self, $other) = @_; |
1649
|
|
|
|
|
|
|
|
1650
|
0
|
0
|
0
|
|
|
0
|
# ->is_a_type_of('__ANON__') is always false |
1651
|
|
|
|
|
|
|
return 0 if !ref($other) && $other eq '__ANON__'; |
1652
|
0
|
|
|
|
|
0
|
|
1653
|
|
|
|
|
|
|
(my $other_name = $other) =~ s/\s+//g; |
1654
|
0
|
0
|
|
|
|
0
|
|
1655
|
|
|
|
|
|
|
return 1 if $self->name eq $other_name; |
1656
|
0
|
0
|
|
|
|
0
|
|
1657
|
0
|
|
|
|
|
0
|
if(exists $self->{type_constraints}){ # union |
|
0
|
|
|
|
|
0
|
|
1658
|
0
|
0
|
|
|
|
0
|
foreach my $type(@{$self->{type_constraints}}) { |
1659
|
|
|
|
|
|
|
return 1 if $type->name eq $other_name; |
1660
|
|
|
|
|
|
|
} |
1661
|
|
|
|
|
|
|
} |
1662
|
0
|
|
|
|
|
0
|
|
1663
|
0
|
0
|
|
|
|
0
|
for(my $p = $self->parent; defined $p; $p = $p->parent) { |
1664
|
|
|
|
|
|
|
return 1 if $p->name eq $other_name; |
1665
|
|
|
|
|
|
|
} |
1666
|
0
|
|
|
|
|
0
|
|
1667
|
|
|
|
|
|
|
return 0; |
1668
|
|
|
|
|
|
|
} |
1669
|
|
|
|
|
|
|
|
1670
|
|
|
|
|
|
|
# See also Moose::Meta::TypeConstraint::Parameterizable |
1671
|
0
|
|
|
0
|
0
|
0
|
sub parameterize { |
1672
|
|
|
|
|
|
|
my($self, $param, $name) = @_; |
1673
|
0
|
0
|
|
|
|
0
|
|
1674
|
0
|
|
|
|
|
0
|
if(!ref $param){ |
1675
|
0
|
|
|
|
|
0
|
require Mouse::Util::TypeConstraints; |
1676
|
|
|
|
|
|
|
$param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param); |
1677
|
|
|
|
|
|
|
} |
1678
|
0
|
|
0
|
|
|
0
|
|
1679
|
0
|
|
|
|
|
0
|
$name ||= sprintf '%s[%s]', $self->name, $param->name; |
1680
|
|
|
|
|
|
|
return Mouse::Meta::TypeConstraint->new( |
1681
|
|
|
|
|
|
|
name => $name, |
1682
|
|
|
|
|
|
|
parent => $self, |
1683
|
|
|
|
|
|
|
type_parameter => $param, |
1684
|
|
|
|
|
|
|
); |
1685
|
|
|
|
|
|
|
} |
1686
|
|
|
|
|
|
|
|
1687
|
0
|
|
|
0
|
1
|
0
|
sub assert_valid { |
1688
|
|
|
|
|
|
|
my ($self, $value) = @_; |
1689
|
0
|
0
|
|
|
|
0
|
|
1690
|
0
|
|
|
|
|
0
|
if(!$self->check($value)){ |
1691
|
|
|
|
|
|
|
$self->throw_error($self->get_message($value)); |
1692
|
0
|
|
|
|
|
0
|
} |
1693
|
|
|
|
|
|
|
return 1; |
1694
|
|
|
|
|
|
|
} |
1695
|
|
|
|
|
|
|
|
1696
|
|
|
|
|
|
|
# overloading stuff |
1697
|
0
|
|
|
0
|
|
0
|
|
1698
|
|
|
|
|
|
|
sub _as_string { $_[0]->name } # overload "" |
1699
|
|
|
|
|
|
|
sub _identity; # overload 0+ |
1700
|
|
|
|
|
|
|
|
1701
|
0
|
|
|
0
|
|
0
|
sub _unite { # overload infix:<|> |
1702
|
0
|
|
|
|
|
0
|
my($lhs, $rhs) = @_; |
1703
|
0
|
|
|
|
|
0
|
require Mouse::Util::TypeConstraints; |
1704
|
|
|
|
|
|
|
return Mouse::Util::TypeConstraints::_find_or_create_union_type( |
1705
|
|
|
|
|
|
|
$lhs, |
1706
|
|
|
|
|
|
|
Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($rhs), |
1707
|
|
|
|
|
|
|
); |
1708
|
|
|
|
|
|
|
} |
1709
|
|
|
|
|
|
|
|
1710
|
0
|
|
|
|
|
0
|
} |
1711
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Util/TypeConstraints.pm |
1712
|
2
|
|
|
2
|
|
10
|
package Mouse::Util::TypeConstraints; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4
|
|
1713
|
|
|
|
|
|
|
use Mouse::Util; # enables strict and warnings |
1714
|
2
|
|
|
2
|
|
8
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
31
|
|
1715
|
2
|
|
|
2
|
|
6
|
use Mouse::Meta::TypeConstraint; |
|
2
|
|
|
|
|
1
|
|
|
2
|
|
|
|
|
6
|
|
1716
|
|
|
|
|
|
|
use Mouse::Exporter; |
1717
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
19
|
|
1718
|
2
|
|
|
2
|
|
5
|
use Carp (); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4133
|
|
1719
|
|
|
|
|
|
|
use Scalar::Util (); |
1720
|
2
|
|
|
2
|
|
9
|
|
1721
|
|
|
|
|
|
|
Mouse::Exporter->setup_import_methods( |
1722
|
|
|
|
|
|
|
as_is => [qw( |
1723
|
|
|
|
|
|
|
as where message optimize_as |
1724
|
|
|
|
|
|
|
from via |
1725
|
|
|
|
|
|
|
|
1726
|
|
|
|
|
|
|
type subtype class_type role_type maybe_type duck_type |
1727
|
|
|
|
|
|
|
enum |
1728
|
|
|
|
|
|
|
coerce |
1729
|
|
|
|
|
|
|
|
1730
|
|
|
|
|
|
|
find_type_constraint |
1731
|
|
|
|
|
|
|
register_type_constraint |
1732
|
|
|
|
|
|
|
)], |
1733
|
|
|
|
|
|
|
); |
1734
|
2
|
|
|
|
|
3
|
|
1735
|
|
|
|
|
|
|
our @CARP_NOT = qw(Mouse::Meta::Attribute); |
1736
|
2
|
|
|
|
|
2
|
|
1737
|
|
|
|
|
|
|
my %TYPE; |
1738
|
|
|
|
|
|
|
|
1739
|
2
|
|
|
|
|
5
|
# The root type |
1740
|
|
|
|
|
|
|
$TYPE{Any} = Mouse::Meta::TypeConstraint->new( |
1741
|
|
|
|
|
|
|
name => 'Any', |
1742
|
|
|
|
|
|
|
); |
1743
|
2
|
|
|
|
|
20
|
|
1744
|
|
|
|
|
|
|
my @builtins = ( |
1745
|
|
|
|
|
|
|
# $name => $parent, $code, |
1746
|
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
|
# the base type |
1748
|
|
|
|
|
|
|
Item => 'Any', undef, |
1749
|
|
|
|
|
|
|
|
1750
|
|
|
|
|
|
|
# the maybe[] type |
1751
|
|
|
|
|
|
|
Maybe => 'Item', undef, |
1752
|
|
|
|
|
|
|
|
1753
|
|
|
|
|
|
|
# value types |
1754
|
|
|
|
|
|
|
Undef => 'Item', \&Undef, |
1755
|
|
|
|
|
|
|
Defined => 'Item', \&Defined, |
1756
|
|
|
|
|
|
|
Bool => 'Item', \&Bool, |
1757
|
|
|
|
|
|
|
Value => 'Defined', \&Value, |
1758
|
|
|
|
|
|
|
Str => 'Value', \&Str, |
1759
|
|
|
|
|
|
|
Num => 'Str', \&Num, |
1760
|
|
|
|
|
|
|
Int => 'Num', \&Int, |
1761
|
|
|
|
|
|
|
|
1762
|
|
|
|
|
|
|
# ref types |
1763
|
|
|
|
|
|
|
Ref => 'Defined', \&Ref, |
1764
|
|
|
|
|
|
|
ScalarRef => 'Ref', \&ScalarRef, |
1765
|
|
|
|
|
|
|
ArrayRef => 'Ref', \&ArrayRef, |
1766
|
|
|
|
|
|
|
HashRef => 'Ref', \&HashRef, |
1767
|
|
|
|
|
|
|
CodeRef => 'Ref', \&CodeRef, |
1768
|
|
|
|
|
|
|
RegexpRef => 'Ref', \&RegexpRef, |
1769
|
|
|
|
|
|
|
GlobRef => 'Ref', \&GlobRef, |
1770
|
|
|
|
|
|
|
|
1771
|
|
|
|
|
|
|
# object types |
1772
|
|
|
|
|
|
|
FileHandle => 'GlobRef', \&FileHandle, |
1773
|
|
|
|
|
|
|
Object => 'Ref', \&Object, |
1774
|
|
|
|
|
|
|
|
1775
|
|
|
|
|
|
|
# special string types |
1776
|
|
|
|
|
|
|
ClassName => 'Str', \&ClassName, |
1777
|
|
|
|
|
|
|
RoleName => 'ClassName', \&RoleName, |
1778
|
|
|
|
|
|
|
); |
1779
|
2
|
|
|
|
|
6
|
|
1780
|
|
|
|
|
|
|
while (my ($name, $parent, $code) = splice @builtins, 0, 3) { |
1781
|
|
|
|
|
|
|
$TYPE{$name} = Mouse::Meta::TypeConstraint->new( |
1782
|
40
|
|
|
|
|
49
|
name => $name, |
1783
|
|
|
|
|
|
|
parent => $TYPE{$parent}, |
1784
|
|
|
|
|
|
|
optimized => $code, |
1785
|
|
|
|
|
|
|
); |
1786
|
|
|
|
|
|
|
} |
1787
|
|
|
|
|
|
|
|
1788
|
2
|
|
|
|
|
4
|
# parametarizable types |
1789
|
2
|
|
|
|
|
2
|
$TYPE{Maybe} {constraint_generator} = \&_parameterize_Maybe_for; |
1790
|
2
|
|
|
|
|
2
|
$TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for; |
1791
|
|
|
|
|
|
|
$TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for; |
1792
|
|
|
|
|
|
|
|
1793
|
0
|
|
|
0
|
1
|
0
|
# sugars |
1794
|
0
|
|
|
0
|
1
|
0
|
sub as ($) { (as => $_[0]) } ## no critic |
1795
|
0
|
|
|
0
|
0
|
0
|
sub where (&) { (where => $_[0]) } ## no critic |
1796
|
0
|
|
|
0
|
0
|
0
|
sub message (&) { (message => $_[0]) } ## no critic |
1797
|
|
|
|
|
|
|
sub optimize_as (&) { (optimize_as => $_[0]) } ## no critic |
1798
|
0
|
|
|
0
|
1
|
0
|
|
1799
|
0
|
|
|
0
|
1
|
0
|
sub from { @_ } |
1800
|
|
|
|
|
|
|
sub via (&) { $_[0] } ## no critic |
1801
|
|
|
|
|
|
|
|
1802
|
|
|
|
|
|
|
# type utilities |
1803
|
|
|
|
|
|
|
|
1804
|
0
|
|
|
0
|
0
|
0
|
sub optimized_constraints { # DEPRECATED |
1805
|
0
|
|
|
|
|
0
|
Carp::cluck('optimized_constraints() has been deprecated'); |
1806
|
|
|
|
|
|
|
return \%TYPE; |
1807
|
|
|
|
|
|
|
} |
1808
|
2
|
|
|
|
|
4
|
|
1809
|
2
|
|
|
|
|
77
|
undef @builtins; # free the allocated memory |
1810
|
0
|
|
|
0
|
1
|
0
|
@builtins = keys %TYPE; # reuse it |
1811
|
0
|
|
|
0
|
1
|
0
|
sub list_all_builtin_type_constraints { @builtins } |
1812
|
|
|
|
|
|
|
sub list_all_type_constraints { keys %TYPE } |
1813
|
|
|
|
|
|
|
|
1814
|
4
|
|
|
4
|
|
3
|
sub _define_type { |
1815
|
4
|
|
|
|
|
4
|
my $is_subtype = shift; |
1816
|
|
|
|
|
|
|
my $name; |
1817
|
|
|
|
|
|
|
my %args; |
1818
|
4
|
50
|
33
|
|
|
21
|
|
|
|
50
|
33
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1819
|
0
|
|
|
|
|
0
|
if(@_ == 1 && ref $_[0] ){ # @_ : { name => $name, where => ... } |
|
0
|
|
|
|
|
0
|
|
1820
|
|
|
|
|
|
|
%args = %{$_[0]}; |
1821
|
|
|
|
|
|
|
} |
1822
|
0
|
|
|
|
|
0
|
elsif(@_ == 2 && ref $_[1]) { # @_ : $name => { where => ... } |
1823
|
0
|
|
|
|
|
0
|
$name = $_[0]; |
|
0
|
|
|
|
|
0
|
|
1824
|
|
|
|
|
|
|
%args = %{$_[1]}; |
1825
|
|
|
|
|
|
|
} |
1826
|
4
|
|
|
|
|
14
|
elsif(@_ % 2) { # @_ : $name => ( where => ... ) |
1827
|
|
|
|
|
|
|
($name, %args) = @_; |
1828
|
|
|
|
|
|
|
} |
1829
|
0
|
|
|
|
|
0
|
else{ # @_ : (name => $name, where => ...) |
1830
|
|
|
|
|
|
|
%args = @_; |
1831
|
|
|
|
|
|
|
} |
1832
|
4
|
50
|
|
|
|
8
|
|
1833
|
0
|
|
|
|
|
0
|
if(!defined $name){ |
1834
|
|
|
|
|
|
|
$name = $args{name}; |
1835
|
|
|
|
|
|
|
} |
1836
|
4
|
|
|
|
|
5
|
|
1837
|
|
|
|
|
|
|
$args{name} = $name; |
1838
|
4
|
|
|
|
|
6
|
|
1839
|
4
|
50
|
33
|
|
|
15
|
my $parent = delete $args{as}; |
1840
|
0
|
|
|
|
|
0
|
if($is_subtype && !$parent){ |
1841
|
0
|
|
|
|
|
0
|
$parent = delete $args{name}; |
1842
|
|
|
|
|
|
|
$name = undef; |
1843
|
|
|
|
|
|
|
} |
1844
|
4
|
50
|
|
|
|
7
|
|
1845
|
4
|
|
|
|
|
6
|
if(defined $parent) { |
1846
|
|
|
|
|
|
|
$args{parent} = find_or_create_isa_type_constraint($parent); |
1847
|
|
|
|
|
|
|
} |
1848
|
4
|
50
|
|
|
|
6
|
|
1849
|
|
|
|
|
|
|
if(defined $name){ |
1850
|
4
|
|
|
|
|
5
|
# set 'package_defined_in' only if it is not a core package |
1851
|
4
|
50
|
|
|
|
7
|
my $this = $args{package_defined_in}; |
1852
|
4
|
|
|
|
|
5
|
if(!$this){ |
1853
|
4
|
50
|
|
|
|
15
|
$this = caller(1); |
1854
|
0
|
|
|
|
|
0
|
if($this !~ /\A Mouse \b/xms){ |
1855
|
|
|
|
|
|
|
$args{package_defined_in} = $this; |
1856
|
|
|
|
|
|
|
} |
1857
|
|
|
|
|
|
|
} |
1858
|
4
|
50
|
|
|
|
16
|
|
1859
|
0
|
|
0
|
|
|
0
|
if(defined $TYPE{$name}){ |
1860
|
0
|
0
|
|
|
|
0
|
my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__; |
1861
|
0
|
|
|
|
|
0
|
if($this ne $that) { |
1862
|
0
|
0
|
|
|
|
0
|
my $note = ''; |
1863
|
|
|
|
|
|
|
if($that eq __PACKAGE__) { |
1864
|
|
|
|
|
|
|
$note = sprintf " ('%s' is %s type constraint)", |
1865
|
0
|
0
|
|
|
|
0
|
$name, |
|
0
|
|
|
|
|
0
|
|
1866
|
|
|
|
|
|
|
scalar(grep { $name eq $_ } list_all_builtin_type_constraints()) |
1867
|
|
|
|
|
|
|
? 'a builtin' |
1868
|
|
|
|
|
|
|
: 'an implicitly created'; |
1869
|
0
|
|
|
|
|
0
|
} |
1870
|
|
|
|
|
|
|
Carp::croak("The type constraint '$name' has already been created in $that" |
1871
|
|
|
|
|
|
|
. " and cannot be created again in $this" . $note); |
1872
|
|
|
|
|
|
|
} |
1873
|
|
|
|
|
|
|
} |
1874
|
|
|
|
|
|
|
} |
1875
|
4
|
50
|
|
|
|
8
|
|
1876
|
4
|
50
|
|
|
|
8
|
$args{constraint} = delete $args{where} if exists $args{where}; |
1877
|
|
|
|
|
|
|
$args{optimized} = delete $args{optimized_as} if exists $args{optimized_as}; |
1878
|
4
|
|
|
|
|
14
|
|
1879
|
|
|
|
|
|
|
my $constraint = Mouse::Meta::TypeConstraint->new(%args); |
1880
|
4
|
50
|
|
|
|
8
|
|
1881
|
4
|
|
|
|
|
10
|
if(defined $name){ |
1882
|
|
|
|
|
|
|
return $TYPE{$name} = $constraint; |
1883
|
|
|
|
|
|
|
} |
1884
|
0
|
|
|
|
|
0
|
else{ |
1885
|
|
|
|
|
|
|
return $constraint; |
1886
|
|
|
|
|
|
|
} |
1887
|
|
|
|
|
|
|
} |
1888
|
|
|
|
|
|
|
|
1889
|
0
|
|
|
0
|
1
|
0
|
sub type { |
1890
|
|
|
|
|
|
|
return _define_type 0, @_; |
1891
|
|
|
|
|
|
|
} |
1892
|
|
|
|
|
|
|
|
1893
|
4
|
|
|
4
|
1
|
10
|
sub subtype { |
1894
|
|
|
|
|
|
|
return _define_type 1, @_; |
1895
|
|
|
|
|
|
|
} |
1896
|
|
|
|
|
|
|
|
1897
|
0
|
|
|
0
|
1
|
0
|
sub coerce { # coerce $type, from $from, via { ... }, ... |
1898
|
0
|
0
|
|
|
|
0
|
my $type_name = shift; |
1899
|
|
|
|
|
|
|
my $type = find_type_constraint($type_name) |
1900
|
|
|
|
|
|
|
or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it"); |
1901
|
0
|
|
|
|
|
0
|
|
1902
|
0
|
|
|
|
|
0
|
$type->_add_type_coercions(@_); |
1903
|
|
|
|
|
|
|
return; |
1904
|
|
|
|
|
|
|
} |
1905
|
|
|
|
|
|
|
|
1906
|
4
|
|
|
4
|
1
|
4
|
sub class_type { |
1907
|
4
|
|
33
|
|
|
16
|
my($name, $options) = @_; |
1908
|
|
|
|
|
|
|
my $class = $options->{class} || $name; |
1909
|
|
|
|
|
|
|
|
1910
|
4
|
|
|
|
|
7
|
# ClassType |
1911
|
|
|
|
|
|
|
return subtype $name => ( |
1912
|
|
|
|
|
|
|
as => 'Object', |
1913
|
|
|
|
|
|
|
optimized_as => Mouse::Util::generate_isa_predicate_for($class), |
1914
|
|
|
|
|
|
|
class => $class, |
1915
|
|
|
|
|
|
|
); |
1916
|
|
|
|
|
|
|
} |
1917
|
|
|
|
|
|
|
|
1918
|
0
|
|
|
0
|
1
|
0
|
sub role_type { |
1919
|
0
|
|
0
|
|
|
0
|
my($name, $options) = @_; |
1920
|
|
|
|
|
|
|
my $role = $options->{role} || $name; |
1921
|
|
|
|
|
|
|
|
1922
|
|
|
|
|
|
|
# RoleType |
1923
|
|
|
|
|
|
|
return subtype $name => ( |
1924
|
|
|
|
|
|
|
as => 'Object', |
1925
|
0
|
|
0
|
0
|
|
0
|
optimized_as => sub { |
1926
|
|
|
|
|
|
|
return Scalar::Util::blessed($_[0]) |
1927
|
|
|
|
|
|
|
&& Mouse::Util::does_role($_[0], $role); |
1928
|
0
|
|
|
|
|
0
|
}, |
1929
|
|
|
|
|
|
|
role => $role, |
1930
|
|
|
|
|
|
|
); |
1931
|
|
|
|
|
|
|
} |
1932
|
|
|
|
|
|
|
|
1933
|
0
|
|
|
0
|
0
|
0
|
sub maybe_type { |
1934
|
0
|
|
|
|
|
0
|
my $param = shift; |
1935
|
|
|
|
|
|
|
return _find_or_create_parameterized_type($TYPE{Maybe}, $param); |
1936
|
|
|
|
|
|
|
} |
1937
|
|
|
|
|
|
|
|
1938
|
0
|
|
|
0
|
1
|
0
|
sub duck_type { |
1939
|
|
|
|
|
|
|
my($name, @methods); |
1940
|
0
|
0
|
|
|
|
0
|
|
1941
|
0
|
|
|
|
|
0
|
if(ref($_[0]) ne 'ARRAY'){ |
1942
|
|
|
|
|
|
|
$name = shift; |
1943
|
|
|
|
|
|
|
} |
1944
|
0
|
0
|
0
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1945
|
|
|
|
|
|
|
@methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_; |
1946
|
|
|
|
|
|
|
|
1947
|
|
|
|
|
|
|
# DuckType |
1948
|
|
|
|
|
|
|
return _define_type 1, $name => ( |
1949
|
|
|
|
|
|
|
as => 'Object', |
1950
|
|
|
|
|
|
|
optimized_as => Mouse::Util::generate_can_predicate_for(\@methods), |
1951
|
0
|
|
|
0
|
|
0
|
message => sub { |
1952
|
0
|
|
|
|
|
0
|
my($object) = @_; |
|
0
|
|
|
|
|
0
|
|
1953
|
0
|
|
|
|
|
0
|
my @missing = grep { !$object->can($_) } @methods; |
1954
|
|
|
|
|
|
|
return ref($object) |
1955
|
|
|
|
|
|
|
. ' is missing methods ' |
1956
|
|
|
|
|
|
|
. Mouse::Util::quoted_english_list(@missing); |
1957
|
0
|
|
|
|
|
0
|
}, |
1958
|
|
|
|
|
|
|
methods => \@methods, |
1959
|
|
|
|
|
|
|
); |
1960
|
|
|
|
|
|
|
} |
1961
|
|
|
|
|
|
|
|
1962
|
0
|
|
|
0
|
1
|
0
|
sub enum { |
1963
|
|
|
|
|
|
|
my($name, %valid); |
1964
|
0
|
0
|
0
|
|
|
0
|
|
1965
|
0
|
|
|
|
|
0
|
if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){ |
1966
|
|
|
|
|
|
|
$name = shift; |
1967
|
|
|
|
|
|
|
} |
1968
|
0
|
|
|
|
|
0
|
|
1969
|
0
|
0
|
0
|
|
|
0
|
%valid = map{ $_ => undef } |
|
0
|
|
|
|
|
0
|
|
1970
|
|
|
|
|
|
|
(@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_); |
1971
|
|
|
|
|
|
|
|
1972
|
|
|
|
|
|
|
# EnumType |
1973
|
|
|
|
|
|
|
return _define_type 1, $name => ( |
1974
|
|
|
|
|
|
|
as => 'Str', |
1975
|
0
|
|
0
|
0
|
|
0
|
optimized_as => sub{ |
1976
|
|
|
|
|
|
|
return defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]}; |
1977
|
0
|
|
|
|
|
0
|
}, |
1978
|
|
|
|
|
|
|
); |
1979
|
|
|
|
|
|
|
} |
1980
|
|
|
|
|
|
|
|
1981
|
0
|
|
|
0
|
|
0
|
sub _find_or_create_regular_type{ |
1982
|
|
|
|
|
|
|
my($spec, $create) = @_; |
1983
|
0
|
0
|
|
|
|
0
|
|
1984
|
|
|
|
|
|
|
return $TYPE{$spec} if exists $TYPE{$spec}; |
1985
|
0
|
|
|
|
|
0
|
|
1986
|
|
|
|
|
|
|
my $meta = Mouse::Util::get_metaclass_by_name($spec); |
1987
|
0
|
0
|
|
|
|
0
|
|
1988
|
0
|
0
|
|
|
|
0
|
if(!defined $meta){ |
1989
|
|
|
|
|
|
|
return $create ? class_type($spec) : undef; |
1990
|
|
|
|
|
|
|
} |
1991
|
0
|
0
|
|
|
|
0
|
|
1992
|
0
|
|
|
|
|
0
|
if(Mouse::Util::is_a_metarole($meta)){ |
1993
|
|
|
|
|
|
|
return role_type($spec); |
1994
|
|
|
|
|
|
|
} |
1995
|
0
|
|
|
|
|
0
|
else{ |
1996
|
|
|
|
|
|
|
return class_type($spec); |
1997
|
|
|
|
|
|
|
} |
1998
|
|
|
|
|
|
|
} |
1999
|
|
|
|
|
|
|
|
2000
|
0
|
|
|
0
|
|
0
|
sub _find_or_create_parameterized_type{ |
2001
|
|
|
|
|
|
|
my($base, $param) = @_; |
2002
|
0
|
|
|
|
|
0
|
|
2003
|
|
|
|
|
|
|
my $name = sprintf '%s[%s]', $base->name, $param->name; |
2004
|
0
|
|
0
|
|
|
0
|
|
2005
|
|
|
|
|
|
|
$TYPE{$name} ||= $base->parameterize($param, $name); |
2006
|
|
|
|
|
|
|
} |
2007
|
|
|
|
|
|
|
|
2008
|
0
|
0
|
|
0
|
|
0
|
sub _find_or_create_union_type{ |
|
0
|
|
|
|
|
0
|
|
2009
|
|
|
|
|
|
|
return if grep{ not defined } @_; # all things must be defined |
2010
|
0
|
0
|
|
|
|
0
|
my @types = sort |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2011
|
|
|
|
|
|
|
map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; |
2012
|
0
|
|
|
|
|
0
|
|
2013
|
|
|
|
|
|
|
my $name = join '|', @types; |
2014
|
|
|
|
|
|
|
|
2015
|
0
|
|
0
|
|
|
0
|
# UnionType |
2016
|
|
|
|
|
|
|
$TYPE{$name} ||= Mouse::Meta::TypeConstraint->new( |
2017
|
|
|
|
|
|
|
name => $name, |
2018
|
|
|
|
|
|
|
type_constraints => \@types, |
2019
|
|
|
|
|
|
|
); |
2020
|
|
|
|
|
|
|
} |
2021
|
|
|
|
|
|
|
|
2022
|
|
|
|
|
|
|
# The type parser |
2023
|
|
|
|
|
|
|
|
2024
|
|
|
|
|
|
|
# param : '[' type ']' | NOTHING |
2025
|
0
|
|
|
0
|
|
0
|
sub _parse_param { |
2026
|
|
|
|
|
|
|
my($c) = @_; |
2027
|
0
|
0
|
|
|
|
0
|
|
2028
|
0
|
|
|
|
|
0
|
if($c->{spec} =~ s/^\[//){ |
2029
|
|
|
|
|
|
|
my $type = _parse_type($c, 1); |
2030
|
0
|
0
|
|
|
|
0
|
|
2031
|
0
|
|
|
|
|
0
|
if($c->{spec} =~ s/^\]//){ |
2032
|
|
|
|
|
|
|
return $type; |
2033
|
0
|
|
|
|
|
0
|
} |
2034
|
|
|
|
|
|
|
Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'"); |
2035
|
|
|
|
|
|
|
} |
2036
|
0
|
|
|
|
|
0
|
|
2037
|
|
|
|
|
|
|
return undef; |
2038
|
|
|
|
|
|
|
} |
2039
|
|
|
|
|
|
|
|
2040
|
|
|
|
|
|
|
# name : [\w.:]+ |
2041
|
0
|
|
|
0
|
|
0
|
sub _parse_name { |
2042
|
|
|
|
|
|
|
my($c, $create) = @_; |
2043
|
0
|
0
|
|
|
|
0
|
|
2044
|
0
|
|
|
|
|
0
|
if($c->{spec} =~ s/\A ([\w.:]+) //xms){ |
2045
|
|
|
|
|
|
|
return _find_or_create_regular_type($1, $create); |
2046
|
0
|
|
|
|
|
0
|
} |
2047
|
|
|
|
|
|
|
Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'"); |
2048
|
|
|
|
|
|
|
} |
2049
|
|
|
|
|
|
|
|
2050
|
|
|
|
|
|
|
# single_type : name param |
2051
|
0
|
|
|
0
|
|
0
|
sub _parse_single_type { |
2052
|
|
|
|
|
|
|
my($c, $create) = @_; |
2053
|
0
|
|
|
|
|
0
|
|
2054
|
0
|
|
|
|
|
0
|
my $type = _parse_name($c, $create); |
2055
|
|
|
|
|
|
|
my $param = _parse_param($c); |
2056
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
2057
|
0
|
0
|
|
|
|
0
|
if(defined $type){ |
2058
|
0
|
|
|
|
|
0
|
if(defined $param){ |
2059
|
|
|
|
|
|
|
return _find_or_create_parameterized_type($type, $param); |
2060
|
|
|
|
|
|
|
} |
2061
|
0
|
|
|
|
|
0
|
else { |
2062
|
|
|
|
|
|
|
return $type; |
2063
|
|
|
|
|
|
|
} |
2064
|
|
|
|
|
|
|
} |
2065
|
0
|
|
|
|
|
0
|
elsif(defined $param){ |
2066
|
|
|
|
|
|
|
Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'"); |
2067
|
|
|
|
|
|
|
} |
2068
|
0
|
|
|
|
|
0
|
else{ |
2069
|
|
|
|
|
|
|
return undef; |
2070
|
|
|
|
|
|
|
} |
2071
|
|
|
|
|
|
|
} |
2072
|
|
|
|
|
|
|
|
2073
|
|
|
|
|
|
|
# type : single_type ('|' single_type)* |
2074
|
0
|
|
|
0
|
|
0
|
sub _parse_type { |
2075
|
|
|
|
|
|
|
my($c, $create) = @_; |
2076
|
0
|
|
|
|
|
0
|
|
2077
|
0
|
0
|
|
|
|
0
|
my $type = _parse_single_type($c, $create); |
2078
|
0
|
|
|
|
|
0
|
if($c->{spec}){ # can be an union type |
2079
|
0
|
|
|
|
|
0
|
my @types; |
2080
|
0
|
|
|
|
|
0
|
while($c->{spec} =~ s/^\|//){ |
2081
|
|
|
|
|
|
|
push @types, _parse_single_type($c, $create); |
2082
|
0
|
0
|
|
|
|
0
|
} |
2083
|
0
|
|
|
|
|
0
|
if(@types){ |
2084
|
|
|
|
|
|
|
return _find_or_create_union_type($type, @types); |
2085
|
|
|
|
|
|
|
} |
2086
|
0
|
|
|
|
|
0
|
} |
2087
|
|
|
|
|
|
|
return $type; |
2088
|
|
|
|
|
|
|
} |
2089
|
|
|
|
|
|
|
|
2090
|
|
|
|
|
|
|
|
2091
|
4
|
|
|
4
|
1
|
4
|
sub find_type_constraint { |
2092
|
4
|
50
|
33
|
|
|
8
|
my($spec) = @_; |
2093
|
|
|
|
|
|
|
return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec; |
2094
|
4
|
|
|
|
|
10
|
|
2095
|
4
|
|
|
|
|
14
|
$spec =~ s/\s+//g; |
2096
|
|
|
|
|
|
|
return $TYPE{$spec}; |
2097
|
|
|
|
|
|
|
} |
2098
|
|
|
|
|
|
|
|
2099
|
0
|
|
|
0
|
0
|
0
|
sub register_type_constraint { |
2100
|
0
|
0
|
|
|
|
0
|
my($constraint) = @_; |
2101
|
|
|
|
|
|
|
Carp::croak("No type supplied / type is not a valid type constraint") |
2102
|
0
|
|
|
|
|
0
|
unless Mouse::Util::is_a_type_constraint($constraint); |
2103
|
|
|
|
|
|
|
return $TYPE{$constraint->name} = $constraint; |
2104
|
|
|
|
|
|
|
} |
2105
|
|
|
|
|
|
|
|
2106
|
4
|
|
|
4
|
0
|
2
|
sub find_or_parse_type_constraint { |
2107
|
4
|
50
|
33
|
|
|
5
|
my($spec) = @_; |
2108
|
|
|
|
|
|
|
return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec; |
2109
|
4
|
|
|
|
|
7
|
|
2110
|
|
|
|
|
|
|
$spec =~ tr/ \t\r\n//d; |
2111
|
4
|
|
|
|
|
6
|
|
2112
|
4
|
50
|
|
|
|
5
|
my $tc = $TYPE{$spec}; |
2113
|
4
|
|
|
|
|
6
|
if(defined $tc) { |
2114
|
|
|
|
|
|
|
return $tc; |
2115
|
|
|
|
|
|
|
} |
2116
|
0
|
|
|
|
|
0
|
|
2117
|
|
|
|
|
|
|
my %context = ( |
2118
|
|
|
|
|
|
|
spec => $spec, |
2119
|
|
|
|
|
|
|
orig => $spec, |
2120
|
0
|
|
|
|
|
0
|
); |
2121
|
|
|
|
|
|
|
$tc = _parse_type(\%context); |
2122
|
0
|
0
|
|
|
|
0
|
|
2123
|
0
|
|
|
|
|
0
|
if($context{spec}){ |
2124
|
|
|
|
|
|
|
Carp::croak("Syntax error: extra elements '$context{spec}' in '$context{orig}'"); |
2125
|
|
|
|
|
|
|
} |
2126
|
0
|
|
|
|
|
0
|
|
2127
|
|
|
|
|
|
|
return $TYPE{$spec} = $tc; |
2128
|
|
|
|
|
|
|
} |
2129
|
|
|
|
|
|
|
|
2130
|
|
|
|
|
|
|
sub find_or_create_does_type_constraint{ |
2131
|
0
|
|
|
0
|
0
|
0
|
# XXX: Moose does not register a new role_type, but Mouse does. |
2132
|
0
|
0
|
|
|
|
0
|
my $tc = find_or_parse_type_constraint(@_); |
2133
|
|
|
|
|
|
|
return defined($tc) ? $tc : role_type(@_); |
2134
|
|
|
|
|
|
|
} |
2135
|
|
|
|
|
|
|
|
2136
|
|
|
|
|
|
|
sub find_or_create_isa_type_constraint { |
2137
|
4
|
|
|
4
|
0
|
10
|
# XXX: Moose does not register a new class_type, but Mouse does. |
2138
|
4
|
50
|
|
|
|
12
|
my $tc = find_or_parse_type_constraint(@_); |
2139
|
|
|
|
|
|
|
return defined($tc) ? $tc : class_type(@_); |
2140
|
|
|
|
|
|
|
} |
2141
|
|
|
|
|
|
|
|
2142
|
0
|
|
|
|
|
0
|
} |
2143
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse.pm |
2144
|
2
|
|
|
2
|
|
50
|
package Mouse; |
|
2
|
|
|
|
|
4
|
|
2145
|
|
|
|
|
|
|
use 5.008_005; |
2146
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
4
|
|
2147
|
|
|
|
|
|
|
use Mouse::Exporter; # enables strict and warnings |
2148
|
2
|
|
|
2
|
|
4
|
|
2149
|
|
|
|
|
|
|
our $VERSION = 'v2.4.9'; |
2150
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
19
|
|
2151
|
2
|
|
|
2
|
|
6
|
use Carp (); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
23
|
|
2152
|
|
|
|
|
|
|
use Scalar::Util (); |
2153
|
2
|
|
|
2
|
|
5
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
27
|
|
2154
|
|
|
|
|
|
|
use Mouse::Util (); |
2155
|
2
|
|
|
2
|
|
6
|
|
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
38
|
|
2156
|
2
|
|
|
2
|
|
7
|
use Mouse::Meta::Module; |
|
2
|
|
|
|
|
1
|
|
|
2
|
|
|
|
|
36
|
|
2157
|
2
|
|
|
2
|
|
5
|
use Mouse::Meta::Class; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
49
|
|
2158
|
2
|
|
|
2
|
|
5
|
use Mouse::Meta::Role; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
48
|
|
2159
|
2
|
|
|
2
|
|
5
|
use Mouse::Meta::Attribute; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
38
|
|
2160
|
2
|
|
|
2
|
|
6
|
use Mouse::Object; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
1098
|
|
2161
|
|
|
|
|
|
|
use Mouse::Util::TypeConstraints (); |
2162
|
2
|
|
|
|
|
11
|
|
2163
|
|
|
|
|
|
|
Mouse::Exporter->setup_import_methods( |
2164
|
|
|
|
|
|
|
as_is => [qw( |
2165
|
|
|
|
|
|
|
extends with |
2166
|
|
|
|
|
|
|
has |
2167
|
|
|
|
|
|
|
before after around |
2168
|
|
|
|
|
|
|
override super |
2169
|
|
|
|
|
|
|
augment inner |
2170
|
|
|
|
|
|
|
), |
2171
|
|
|
|
|
|
|
\&Scalar::Util::blessed, |
2172
|
|
|
|
|
|
|
\&Carp::confess, |
2173
|
|
|
|
|
|
|
], |
2174
|
|
|
|
|
|
|
); |
2175
|
|
|
|
|
|
|
|
2176
|
|
|
|
|
|
|
|
2177
|
0
|
|
|
0
|
1
|
0
|
sub extends { |
2178
|
0
|
|
|
|
|
0
|
Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_); |
2179
|
|
|
|
|
|
|
return; |
2180
|
|
|
|
|
|
|
} |
2181
|
|
|
|
|
|
|
|
2182
|
0
|
|
|
0
|
0
|
0
|
sub with { |
2183
|
0
|
|
|
|
|
0
|
Mouse::Util::apply_all_roles(scalar(caller), @_); |
2184
|
|
|
|
|
|
|
return; |
2185
|
|
|
|
|
|
|
} |
2186
|
|
|
|
|
|
|
|
2187
|
4
|
|
|
4
|
1
|
56
|
sub has { |
2188
|
4
|
|
|
|
|
8
|
my $meta = Mouse::Meta::Class->initialize(scalar caller); |
2189
|
|
|
|
|
|
|
my $name = shift; |
2190
|
4
|
50
|
|
|
|
13
|
|
2191
|
|
|
|
|
|
|
$meta->throw_error(q{Usage: has 'name' => ( key => value, ... )}) |
2192
|
|
|
|
|
|
|
if @_ % 2; # odd number of arguments |
2193
|
4
|
50
|
|
|
|
13
|
|
|
0
|
|
|
|
|
0
|
|
2194
|
4
|
|
|
|
|
13
|
for my $n(ref($name) ? @{$name} : $name){ |
2195
|
|
|
|
|
|
|
$meta->add_attribute($n => @_); |
2196
|
4
|
|
|
|
|
7
|
} |
2197
|
|
|
|
|
|
|
return; |
2198
|
|
|
|
|
|
|
} |
2199
|
|
|
|
|
|
|
|
2200
|
0
|
|
|
0
|
1
|
0
|
sub before { |
2201
|
0
|
|
|
|
|
0
|
my $meta = Mouse::Meta::Class->initialize(scalar caller); |
2202
|
0
|
|
|
|
|
0
|
my $code = pop; |
2203
|
0
|
|
|
|
|
0
|
for my $name($meta->_collect_methods(@_)) { |
2204
|
|
|
|
|
|
|
$meta->add_before_method_modifier($name => $code); |
2205
|
0
|
|
|
|
|
0
|
} |
2206
|
|
|
|
|
|
|
return; |
2207
|
|
|
|
|
|
|
} |
2208
|
|
|
|
|
|
|
|
2209
|
0
|
|
|
0
|
1
|
0
|
sub after { |
2210
|
0
|
|
|
|
|
0
|
my $meta = Mouse::Meta::Class->initialize(scalar caller); |
2211
|
0
|
|
|
|
|
0
|
my $code = pop; |
2212
|
0
|
|
|
|
|
0
|
for my $name($meta->_collect_methods(@_)) { |
2213
|
|
|
|
|
|
|
$meta->add_after_method_modifier($name => $code); |
2214
|
0
|
|
|
|
|
0
|
} |
2215
|
|
|
|
|
|
|
return; |
2216
|
|
|
|
|
|
|
} |
2217
|
|
|
|
|
|
|
|
2218
|
0
|
|
|
0
|
1
|
0
|
sub around { |
2219
|
0
|
|
|
|
|
0
|
my $meta = Mouse::Meta::Class->initialize(scalar caller); |
2220
|
0
|
|
|
|
|
0
|
my $code = pop; |
2221
|
0
|
|
|
|
|
0
|
for my $name($meta->_collect_methods(@_)) { |
2222
|
|
|
|
|
|
|
$meta->add_around_method_modifier($name => $code); |
2223
|
0
|
|
|
|
|
0
|
} |
2224
|
|
|
|
|
|
|
return; |
2225
|
|
|
|
|
|
|
} |
2226
|
2
|
|
|
|
|
2
|
|
2227
|
2
|
|
|
|
|
2
|
our $SUPER_PACKAGE; |
2228
|
2
|
|
|
|
|
4
|
our $SUPER_BODY; |
2229
|
|
|
|
|
|
|
our @SUPER_ARGS; |
2230
|
|
|
|
|
|
|
|
2231
|
|
|
|
|
|
|
sub super { |
2232
|
|
|
|
|
|
|
# This check avoids a recursion loop - see |
2233
|
0
|
0
|
0
|
0
|
0
|
0
|
# t/100_bugs/020_super_recursion.t |
2234
|
0
|
0
|
|
|
|
0
|
return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller(); |
2235
|
0
|
|
|
|
|
0
|
return if !defined $SUPER_BODY; |
2236
|
|
|
|
|
|
|
$SUPER_BODY->(@SUPER_ARGS); |
2237
|
|
|
|
|
|
|
} |
2238
|
|
|
|
|
|
|
|
2239
|
|
|
|
|
|
|
sub override { |
2240
|
0
|
|
|
0
|
0
|
0
|
# my($name, $method) = @_; |
2241
|
|
|
|
|
|
|
Mouse::Meta::Class->initialize(scalar caller)->add_override_method_modifier(@_); |
2242
|
|
|
|
|
|
|
} |
2243
|
2
|
|
|
|
|
1
|
|
2244
|
2
|
|
|
|
|
71
|
our %INNER_BODY; |
2245
|
|
|
|
|
|
|
our %INNER_ARGS; |
2246
|
|
|
|
|
|
|
|
2247
|
0
|
|
|
0
|
0
|
0
|
sub inner { |
2248
|
0
|
0
|
|
|
|
0
|
my $pkg = caller(); |
2249
|
0
|
|
|
|
|
0
|
if ( my $body = $INNER_BODY{$pkg} ) { |
2250
|
0
|
|
|
|
|
0
|
my $args = $INNER_ARGS{$pkg}; |
2251
|
0
|
|
|
|
|
0
|
local $INNER_ARGS{$pkg}; |
2252
|
0
|
|
|
|
|
0
|
local $INNER_BODY{$pkg}; |
|
0
|
|
|
|
|
0
|
|
2253
|
|
|
|
|
|
|
return $body->(@{$args}); |
2254
|
|
|
|
|
|
|
} |
2255
|
0
|
|
|
|
|
0
|
else { |
2256
|
|
|
|
|
|
|
return; |
2257
|
|
|
|
|
|
|
} |
2258
|
|
|
|
|
|
|
} |
2259
|
|
|
|
|
|
|
|
2260
|
|
|
|
|
|
|
sub augment { |
2261
|
0
|
|
|
0
|
0
|
0
|
#my($name, $method) = @_; |
2262
|
0
|
|
|
|
|
0
|
Mouse::Meta::Class->initialize(scalar caller)->add_augment_method_modifier(@_); |
2263
|
|
|
|
|
|
|
return; |
2264
|
|
|
|
|
|
|
} |
2265
|
|
|
|
|
|
|
|
2266
|
4
|
|
|
4
|
0
|
4
|
sub init_meta { |
2267
|
4
|
|
|
|
|
7
|
shift; |
2268
|
|
|
|
|
|
|
my %args = @_; |
2269
|
|
|
|
|
|
|
|
2270
|
4
|
50
|
|
|
|
10
|
my $class = $args{for_class} |
2271
|
|
|
|
|
|
|
or confess("Cannot call init_meta without specifying a for_class"); |
2272
|
4
|
|
50
|
|
|
14
|
|
2273
|
4
|
|
50
|
|
|
13
|
my $base_class = $args{base_class} || 'Mouse::Object'; |
2274
|
|
|
|
|
|
|
my $metaclass = $args{metaclass} || 'Mouse::Meta::Class'; |
2275
|
4
|
|
|
|
|
15
|
|
2276
|
|
|
|
|
|
|
my $meta = $metaclass->initialize($class); |
2277
|
|
|
|
|
|
|
|
2278
|
4
|
|
33
|
4
|
|
22
|
$meta->add_method(meta => sub{ |
2279
|
4
|
|
|
|
|
26
|
return $metaclass->initialize(ref($_[0]) || $_[0]); |
2280
|
|
|
|
|
|
|
}); |
2281
|
4
|
50
|
|
|
|
10
|
|
2282
|
|
|
|
|
|
|
$meta->superclasses($base_class) |
2283
|
|
|
|
|
|
|
unless $meta->superclasses; |
2284
|
|
|
|
|
|
|
|
2285
|
4
|
50
|
|
|
|
9
|
# make a class type for each Mouse class |
2286
|
|
|
|
|
|
|
Mouse::Util::TypeConstraints::class_type($class) |
2287
|
|
|
|
|
|
|
unless Mouse::Util::TypeConstraints::find_type_constraint($class); |
2288
|
4
|
|
|
|
|
9
|
|
2289
|
|
|
|
|
|
|
return $meta; |
2290
|
|
|
|
|
|
|
} |
2291
|
|
|
|
|
|
|
|
2292
|
0
|
|
|
|
|
0
|
} |
2293
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Attribute.pm |
2294
|
2
|
|
|
2
|
|
8
|
package Mouse::Meta::Attribute; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4
|
|
2295
|
|
|
|
|
|
|
use Mouse::Util qw(:meta); # enables strict and warnings |
2296
|
2
|
|
|
2
|
|
8
|
|
|
2
|
|
|
|
|
1
|
|
|
2
|
|
|
|
|
24
|
|
2297
|
|
|
|
|
|
|
use Carp (); |
2298
|
2
|
|
|
2
|
|
8
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
2541
|
|
2299
|
|
|
|
|
|
|
use Mouse::Meta::TypeConstraint; |
2300
|
2
|
|
|
2
|
|
4
|
|
|
58
|
|
|
|
|
59
|
|
2301
|
|
|
|
|
|
|
my %valid_options = map { $_ => undef } ( |
2302
|
|
|
|
|
|
|
'accessor', |
2303
|
|
|
|
|
|
|
'auto_deref', |
2304
|
|
|
|
|
|
|
'builder', |
2305
|
|
|
|
|
|
|
'clearer', |
2306
|
|
|
|
|
|
|
'coerce', |
2307
|
|
|
|
|
|
|
'default', |
2308
|
|
|
|
|
|
|
'documentation', |
2309
|
|
|
|
|
|
|
'does', |
2310
|
|
|
|
|
|
|
'handles', |
2311
|
|
|
|
|
|
|
'init_arg', |
2312
|
|
|
|
|
|
|
'insertion_order', |
2313
|
|
|
|
|
|
|
'is', |
2314
|
|
|
|
|
|
|
'isa', |
2315
|
|
|
|
|
|
|
'lazy', |
2316
|
|
|
|
|
|
|
'lazy_build', |
2317
|
|
|
|
|
|
|
'name', |
2318
|
|
|
|
|
|
|
'predicate', |
2319
|
|
|
|
|
|
|
'reader', |
2320
|
|
|
|
|
|
|
'required', |
2321
|
|
|
|
|
|
|
'traits', |
2322
|
|
|
|
|
|
|
'trigger', |
2323
|
|
|
|
|
|
|
'type_constraint', |
2324
|
|
|
|
|
|
|
'weak_ref', |
2325
|
|
|
|
|
|
|
'writer', |
2326
|
|
|
|
|
|
|
|
2327
|
|
|
|
|
|
|
# internally used |
2328
|
|
|
|
|
|
|
'associated_class', |
2329
|
|
|
|
|
|
|
'associated_methods', |
2330
|
|
|
|
|
|
|
'__METACLASS__', |
2331
|
|
|
|
|
|
|
|
2332
|
|
|
|
|
|
|
# Moose defines, but Mouse doesn't |
2333
|
|
|
|
|
|
|
#'definition_context', |
2334
|
|
|
|
|
|
|
#'initializer', |
2335
|
|
|
|
|
|
|
|
2336
|
|
|
|
|
|
|
# special case for AttributeHelpers |
2337
|
|
|
|
|
|
|
'provides', |
2338
|
|
|
|
|
|
|
'curries', |
2339
|
|
|
|
|
|
|
); |
2340
|
2
|
|
|
|
|
55
|
|
2341
|
|
|
|
|
|
|
our @CARP_NOT = qw(Mouse::Meta::Class); |
2342
|
|
|
|
|
|
|
|
2343
|
4
|
|
|
4
|
1
|
4
|
sub new { |
2344
|
4
|
|
|
|
|
6
|
my $class = shift; |
2345
|
|
|
|
|
|
|
my $name = shift; |
2346
|
4
|
|
|
|
|
18
|
|
2347
|
|
|
|
|
|
|
my $args = $class->Mouse::Object::BUILDARGS(@_); |
2348
|
4
|
|
|
|
|
11
|
|
2349
|
|
|
|
|
|
|
$class->_process_options($name, $args); |
2350
|
4
|
|
|
|
|
6
|
|
2351
|
|
|
|
|
|
|
$args->{name} = $name; |
2352
|
|
|
|
|
|
|
|
2353
|
|
|
|
|
|
|
# check options |
2354
|
4
|
|
|
|
|
6
|
# (1) known by core |
|
16
|
|
|
|
|
25
|
|
|
4
|
|
|
|
|
9
|
|
2355
|
|
|
|
|
|
|
my @bad = grep{ !exists $valid_options{$_} } keys %{$args}; |
2356
|
|
|
|
|
|
|
|
2357
|
4
|
50
|
33
|
|
|
12
|
# (2) known by subclasses |
2358
|
|
|
|
|
|
|
if(@bad && $class ne __PACKAGE__){ |
2359
|
0
|
|
|
|
|
0
|
my %valid_attrs = ( |
2360
|
0
|
|
|
|
|
0
|
map { $_ => undef } |
2361
|
0
|
|
|
|
|
0
|
grep { defined } |
|
0
|
|
|
|
|
0
|
|
2362
|
|
|
|
|
|
|
map { $_->init_arg() } |
2363
|
|
|
|
|
|
|
$class->meta->get_all_attributes() |
2364
|
0
|
|
|
|
|
0
|
); |
|
0
|
|
|
|
|
0
|
|
2365
|
|
|
|
|
|
|
@bad = grep{ !exists $valid_attrs{$_} } @bad; |
2366
|
|
|
|
|
|
|
} |
2367
|
|
|
|
|
|
|
|
2368
|
4
|
50
|
|
|
|
9
|
# (3) bad options found |
2369
|
0
|
|
|
|
|
0
|
if(@bad){ |
2370
|
|
|
|
|
|
|
Carp::carp( |
2371
|
|
|
|
|
|
|
"Found unknown argument(s) passed to '$name' attribute constructor in '$class': " |
2372
|
|
|
|
|
|
|
. Mouse::Util::english_list(@bad)); |
2373
|
|
|
|
|
|
|
} |
2374
|
4
|
|
|
|
|
7
|
|
2375
|
4
|
50
|
|
|
|
7
|
my $self = bless $args, $class; |
2376
|
0
|
|
|
|
|
0
|
if($class ne __PACKAGE__){ |
2377
|
|
|
|
|
|
|
$class->meta->_initialize_object($self, $args); |
2378
|
4
|
|
|
|
|
10
|
} |
2379
|
|
|
|
|
|
|
return $self; |
2380
|
|
|
|
|
|
|
} |
2381
|
0
|
0
|
|
0
|
0
|
0
|
|
2382
|
0
|
0
|
|
0
|
0
|
0
|
sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } |
2383
|
|
|
|
|
|
|
sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } |
2384
|
0
|
0
|
|
0
|
0
|
0
|
|
2385
|
0
|
0
|
|
0
|
0
|
0
|
sub get_read_method { $_[0]->reader || $_[0]->accessor } |
2386
|
|
|
|
|
|
|
sub get_write_method { $_[0]->writer || $_[0]->accessor } |
2387
|
|
|
|
|
|
|
|
2388
|
0
|
|
|
0
|
1
|
0
|
sub get_read_method_ref{ |
2389
|
|
|
|
|
|
|
my($self) = @_; |
2390
|
0
|
|
0
|
|
|
0
|
return $self->{_mouse_cache_read_method_ref} |
2391
|
|
|
|
|
|
|
||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader'); |
2392
|
|
|
|
|
|
|
} |
2393
|
|
|
|
|
|
|
|
2394
|
0
|
|
|
0
|
1
|
0
|
sub get_write_method_ref{ |
2395
|
|
|
|
|
|
|
my($self) = @_; |
2396
|
0
|
|
0
|
|
|
0
|
return $self->{_mouse_cache_write_method_ref} |
2397
|
|
|
|
|
|
|
||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer'); |
2398
|
|
|
|
|
|
|
} |
2399
|
|
|
|
|
|
|
|
2400
|
4
|
|
|
4
|
0
|
5
|
sub interpolate_class{ |
2401
|
|
|
|
|
|
|
my($class, $args) = @_; |
2402
|
4
|
50
|
|
|
|
12
|
|
2403
|
0
|
|
|
|
|
0
|
if(my $metaclass = delete $args->{metaclass}){ |
2404
|
|
|
|
|
|
|
$class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass ); |
2405
|
|
|
|
|
|
|
} |
2406
|
4
|
|
|
|
|
5
|
|
2407
|
4
|
50
|
|
|
|
9
|
my @traits; |
2408
|
|
|
|
|
|
|
if(my $traits_ref = delete $args->{traits}){ |
2409
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2410
|
0
|
|
|
|
|
0
|
for (my $i = 0; $i < @{$traits_ref}; $i++) { |
2411
|
|
|
|
|
|
|
my $trait = Mouse::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1); |
2412
|
0
|
0
|
|
|
|
0
|
|
2413
|
|
|
|
|
|
|
next if $class->does($trait); |
2414
|
0
|
|
|
|
|
0
|
|
2415
|
|
|
|
|
|
|
push @traits, $trait; |
2416
|
|
|
|
|
|
|
|
2417
|
0
|
0
|
|
|
|
0
|
# are there options? |
2418
|
|
|
|
|
|
|
push @traits, $traits_ref->[++$i] |
2419
|
|
|
|
|
|
|
if ref($traits_ref->[$i+1]); |
2420
|
|
|
|
|
|
|
} |
2421
|
0
|
0
|
|
|
|
0
|
|
2422
|
0
|
|
|
|
|
0
|
if (@traits) { |
2423
|
|
|
|
|
|
|
$class = Mouse::Meta::Class->create_anon_class( |
2424
|
|
|
|
|
|
|
superclasses => [ $class ], |
2425
|
|
|
|
|
|
|
roles => \@traits, |
2426
|
|
|
|
|
|
|
cache => 1, |
2427
|
|
|
|
|
|
|
)->name; |
2428
|
|
|
|
|
|
|
} |
2429
|
|
|
|
|
|
|
} |
2430
|
4
|
|
|
|
|
9
|
|
2431
|
|
|
|
|
|
|
return( $class, @traits ); |
2432
|
|
|
|
|
|
|
} |
2433
|
|
|
|
|
|
|
|
2434
|
0
|
|
|
0
|
1
|
0
|
sub verify_against_type_constraint { |
2435
|
|
|
|
|
|
|
my ($self, $value) = @_; |
2436
|
0
|
|
|
|
|
0
|
|
2437
|
0
|
0
|
|
|
|
0
|
my $type_constraint = $self->{type_constraint}; |
2438
|
0
|
0
|
|
|
|
0
|
return 1 if !$type_constraint; |
2439
|
|
|
|
|
|
|
return 1 if $type_constraint->check($value); |
2440
|
0
|
|
|
|
|
0
|
|
2441
|
|
|
|
|
|
|
$self->_throw_type_constraint_error($value, $type_constraint); |
2442
|
|
|
|
|
|
|
} |
2443
|
|
|
|
|
|
|
|
2444
|
0
|
|
|
0
|
|
0
|
sub _throw_type_constraint_error { |
2445
|
|
|
|
|
|
|
my($self, $value, $type) = @_; |
2446
|
0
|
|
|
|
|
0
|
|
2447
|
|
|
|
|
|
|
$self->throw_error( |
2448
|
|
|
|
|
|
|
sprintf q{Attribute (%s) does not pass the type constraint because: %s}, |
2449
|
|
|
|
|
|
|
$self->name, |
2450
|
|
|
|
|
|
|
$type->get_message($value), |
2451
|
|
|
|
|
|
|
); |
2452
|
|
|
|
|
|
|
} |
2453
|
|
|
|
|
|
|
|
2454
|
0
|
|
|
0
|
0
|
0
|
sub illegal_options_for_inheritance { |
2455
|
|
|
|
|
|
|
return qw(reader writer accessor clearer predicate); |
2456
|
|
|
|
|
|
|
} |
2457
|
|
|
|
|
|
|
|
2458
|
0
|
|
|
0
|
1
|
0
|
sub clone_and_inherit_options{ |
2459
|
0
|
|
|
|
|
0
|
my $self = shift; |
2460
|
|
|
|
|
|
|
my $args = $self->Mouse::Object::BUILDARGS(@_); |
2461
|
0
|
|
|
|
|
0
|
|
2462
|
0
|
0
|
0
|
|
|
0
|
foreach my $illegal($self->illegal_options_for_inheritance) { |
2463
|
0
|
|
|
|
|
0
|
if(exists $args->{$illegal} and exists $self->{$illegal}) { |
2464
|
|
|
|
|
|
|
$self->throw_error("Illegal inherited option: $illegal"); |
2465
|
|
|
|
|
|
|
} |
2466
|
|
|
|
|
|
|
} |
2467
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2468
|
0
|
0
|
|
|
|
0
|
foreach my $name(keys %{$self}){ |
2469
|
0
|
|
|
|
|
0
|
if(!exists $args->{$name}){ |
2470
|
|
|
|
|
|
|
$args->{$name} = $self->{$name}; # inherit from self |
2471
|
|
|
|
|
|
|
} |
2472
|
|
|
|
|
|
|
} |
2473
|
0
|
|
|
|
|
0
|
|
2474
|
0
|
0
|
|
|
|
0
|
my($attribute_class, @traits) = ref($self)->interpolate_class($args); |
2475
|
|
|
|
|
|
|
$args->{traits} = \@traits if @traits; |
2476
|
|
|
|
|
|
|
|
2477
|
0
|
|
|
|
|
0
|
# remove temporary caches |
|
0
|
|
|
|
|
0
|
|
2478
|
0
|
0
|
|
|
|
0
|
foreach my $attr(keys %{$args}){ |
2479
|
0
|
|
|
|
|
0
|
if($attr =~ /\A _mouse_cache_/xms){ |
2480
|
|
|
|
|
|
|
delete $args->{$attr}; |
2481
|
|
|
|
|
|
|
} |
2482
|
|
|
|
|
|
|
} |
2483
|
|
|
|
|
|
|
|
2484
|
0
|
0
|
|
|
|
0
|
# remove default if lazy_build => 1 |
2485
|
0
|
|
|
|
|
0
|
if($args->{lazy_build}) { |
2486
|
|
|
|
|
|
|
delete $args->{default}; |
2487
|
|
|
|
|
|
|
} |
2488
|
0
|
|
|
|
|
0
|
|
2489
|
|
|
|
|
|
|
return $attribute_class->new($self->name, $args); |
2490
|
|
|
|
|
|
|
} |
2491
|
|
|
|
|
|
|
|
2492
|
|
|
|
|
|
|
|
2493
|
0
|
|
|
0
|
|
0
|
sub _get_accessor_method_ref { |
2494
|
|
|
|
|
|
|
my($self, $type, $generator) = @_; |
2495
|
0
|
|
0
|
|
|
0
|
|
2496
|
|
|
|
|
|
|
my $metaclass = $self->associated_class |
2497
|
|
|
|
|
|
|
|| $self->throw_error('No asocciated class for ' . $self->name); |
2498
|
0
|
|
|
|
|
0
|
|
2499
|
0
|
0
|
|
|
|
0
|
my $accessor = $self->$type(); |
2500
|
0
|
|
|
|
|
0
|
if($accessor){ |
2501
|
|
|
|
|
|
|
return $metaclass->get_method_body($accessor); |
2502
|
|
|
|
|
|
|
} |
2503
|
0
|
|
|
|
|
0
|
else{ |
2504
|
|
|
|
|
|
|
return $self->accessor_metaclass->$generator($self, $metaclass); |
2505
|
|
|
|
|
|
|
} |
2506
|
|
|
|
|
|
|
} |
2507
|
|
|
|
|
|
|
|
2508
|
0
|
|
|
0
|
0
|
0
|
sub set_value { |
2509
|
0
|
|
|
|
|
0
|
my($self, $object, $value) = @_; |
2510
|
|
|
|
|
|
|
return $self->get_write_method_ref()->($object, $value); |
2511
|
|
|
|
|
|
|
} |
2512
|
|
|
|
|
|
|
|
2513
|
0
|
|
|
0
|
0
|
0
|
sub get_value { |
2514
|
0
|
|
|
|
|
0
|
my($self, $object) = @_; |
2515
|
|
|
|
|
|
|
return $self->get_read_method_ref()->($object); |
2516
|
|
|
|
|
|
|
} |
2517
|
|
|
|
|
|
|
|
2518
|
0
|
|
|
0
|
0
|
0
|
sub has_value { |
2519
|
|
|
|
|
|
|
my($self, $object) = @_; |
2520
|
0
|
|
0
|
|
|
0
|
my $accessor_ref = $self->{_mouse_cache_predicate_ref} |
2521
|
|
|
|
|
|
|
||= $self->_get_accessor_method_ref('predicate', '_generate_predicate'); |
2522
|
0
|
|
|
|
|
0
|
|
2523
|
|
|
|
|
|
|
return $accessor_ref->($object); |
2524
|
|
|
|
|
|
|
} |
2525
|
|
|
|
|
|
|
|
2526
|
0
|
|
|
0
|
0
|
0
|
sub clear_value { |
2527
|
|
|
|
|
|
|
my($self, $object) = @_; |
2528
|
0
|
|
0
|
|
|
0
|
my $accessor_ref = $self->{_mouse_cache_crealer_ref} |
2529
|
|
|
|
|
|
|
||= $self->_get_accessor_method_ref('clearer', '_generate_clearer'); |
2530
|
0
|
|
|
|
|
0
|
|
2531
|
|
|
|
|
|
|
return $accessor_ref->($object); |
2532
|
|
|
|
|
|
|
} |
2533
|
|
|
|
|
|
|
|
2534
|
|
|
|
|
|
|
sub associate_method{ |
2535
|
4
|
|
|
4
|
1
|
4
|
#my($attribute, $method_name) = @_; |
2536
|
4
|
|
|
|
|
8
|
my($attribute) = @_; |
2537
|
4
|
|
|
|
|
7
|
$attribute->{associated_methods}++; |
2538
|
|
|
|
|
|
|
return; |
2539
|
|
|
|
|
|
|
} |
2540
|
|
|
|
|
|
|
|
2541
|
4
|
|
|
4
|
0
|
6
|
sub install_accessors{ |
2542
|
|
|
|
|
|
|
my($attribute) = @_; |
2543
|
4
|
|
|
|
|
8
|
|
2544
|
4
|
|
|
|
|
10
|
my $metaclass = $attribute->associated_class; |
2545
|
|
|
|
|
|
|
my $accessor_class = $attribute->accessor_metaclass; |
2546
|
4
|
|
|
|
|
7
|
|
2547
|
20
|
100
|
|
|
|
30
|
foreach my $type(qw(accessor reader writer predicate clearer)){ |
2548
|
4
|
|
|
|
|
8
|
if(exists $attribute->{$type}){ |
2549
|
4
|
|
|
|
|
25
|
my $generator = '_generate_' . $type; |
2550
|
4
|
|
|
|
|
5
|
my $code = $accessor_class->$generator($attribute, $metaclass); |
2551
|
|
|
|
|
|
|
my $name = $attribute->{$type}; |
2552
|
|
|
|
|
|
|
# TODO: do something for compatibility |
2553
|
|
|
|
|
|
|
# if( $metaclass->name->can($name) ) { |
2554
|
|
|
|
|
|
|
# my $t = $metaclass->has_method($name) ? 'method' : 'function'; |
2555
|
|
|
|
|
|
|
# Carp::cluck("You are overwriting a locally defined $t" |
2556
|
|
|
|
|
|
|
# . " ($name) with an accessor"); |
2557
|
4
|
|
|
|
|
16
|
# } |
2558
|
4
|
|
|
|
|
8
|
$metaclass->add_method($name => $code); |
2559
|
|
|
|
|
|
|
$attribute->associate_method($name); |
2560
|
|
|
|
|
|
|
} |
2561
|
|
|
|
|
|
|
} |
2562
|
|
|
|
|
|
|
|
2563
|
4
|
50
|
|
|
|
12
|
# install delegation |
2564
|
0
|
|
|
|
|
0
|
if(exists $attribute->{handles}){ |
2565
|
0
|
|
|
|
|
0
|
my %handles = $attribute->_canonicalize_handles(); |
2566
|
0
|
0
|
|
|
|
0
|
while(my($handle, $method_to_call) = each %handles){ |
2567
|
|
|
|
|
|
|
next if Mouse::Object->can($handle); |
2568
|
0
|
0
|
|
|
|
0
|
|
2569
|
0
|
|
|
|
|
0
|
if($metaclass->has_method($handle)) { |
2570
|
|
|
|
|
|
|
$attribute->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation"); |
2571
|
|
|
|
|
|
|
} |
2572
|
0
|
|
|
|
|
0
|
|
2573
|
|
|
|
|
|
|
$metaclass->add_method($handle => |
2574
|
|
|
|
|
|
|
$attribute->_make_delegation_method( |
2575
|
|
|
|
|
|
|
$handle, $method_to_call)); |
2576
|
0
|
|
|
|
|
0
|
|
2577
|
|
|
|
|
|
|
$attribute->associate_method($handle); |
2578
|
|
|
|
|
|
|
} |
2579
|
|
|
|
|
|
|
} |
2580
|
4
|
|
|
|
|
5
|
|
2581
|
|
|
|
|
|
|
return; |
2582
|
|
|
|
|
|
|
} |
2583
|
|
|
|
|
|
|
|
2584
|
|
|
|
|
|
|
sub delegation_metaclass() { ## no critic |
2585
|
|
|
|
|
|
|
'Mouse::Meta::Method::Delegation' |
2586
|
|
|
|
|
|
|
} |
2587
|
|
|
|
|
|
|
|
2588
|
0
|
|
|
0
|
|
0
|
sub _canonicalize_handles { |
2589
|
0
|
|
|
|
|
0
|
my($self) = @_; |
2590
|
|
|
|
|
|
|
my $handles = $self->{handles}; |
2591
|
0
|
|
|
|
|
0
|
|
2592
|
0
|
0
|
|
|
|
0
|
my $handle_type = ref $handles; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2593
|
0
|
|
|
|
|
0
|
if ($handle_type eq 'HASH') { |
2594
|
|
|
|
|
|
|
return %$handles; |
2595
|
|
|
|
|
|
|
} |
2596
|
0
|
|
|
|
|
0
|
elsif ($handle_type eq 'ARRAY') { |
|
0
|
|
|
|
|
0
|
|
2597
|
|
|
|
|
|
|
return map { $_ => $_ } @$handles; |
2598
|
|
|
|
|
|
|
} |
2599
|
0
|
|
|
|
|
0
|
elsif ($handle_type eq 'Regexp') { |
2600
|
0
|
|
|
|
|
0
|
my $meta = $self->_find_delegate_metaclass(); |
2601
|
0
|
0
|
|
|
|
0
|
return map { $_ => $_ } |
|
0
|
|
|
|
|
0
|
|
2602
|
|
|
|
|
|
|
grep { /$handles/ } |
2603
|
|
|
|
|
|
|
Mouse::Util::is_a_metarole($meta) |
2604
|
|
|
|
|
|
|
? $meta->get_method_list |
2605
|
|
|
|
|
|
|
: $meta->get_all_method_names; |
2606
|
|
|
|
|
|
|
} |
2607
|
0
|
|
|
|
|
0
|
elsif ($handle_type eq 'CODE') { |
2608
|
|
|
|
|
|
|
return $handles->( $self, $self->_find_delegate_metaclass() ); |
2609
|
|
|
|
|
|
|
} |
2610
|
0
|
|
|
|
|
0
|
else { |
2611
|
|
|
|
|
|
|
$self->throw_error("Unable to canonicalize the 'handles' option with $handles"); |
2612
|
|
|
|
|
|
|
} |
2613
|
|
|
|
|
|
|
} |
2614
|
|
|
|
|
|
|
|
2615
|
0
|
|
|
0
|
|
0
|
sub _find_delegate_metaclass { |
2616
|
0
|
|
|
|
|
0
|
my($self) = @_; |
2617
|
0
|
0
|
|
|
|
0
|
my $meta; |
|
|
0
|
|
|
|
|
|
2618
|
0
|
|
|
|
|
0
|
if($self->{isa}) { |
2619
|
|
|
|
|
|
|
$meta = Mouse::Meta::Class->initialize("$self->{isa}"); |
2620
|
|
|
|
|
|
|
} |
2621
|
0
|
|
|
|
|
0
|
elsif($self->{does}) { |
2622
|
|
|
|
|
|
|
$meta = Mouse::Util::get_metaclass_by_name("$self->{does}"); |
2623
|
0
|
0
|
|
|
|
0
|
} |
2624
|
|
|
|
|
|
|
defined($meta) or $self->throw_error( |
2625
|
0
|
|
|
|
|
0
|
"Cannot find delegate metaclass for attribute " . $self->name); |
2626
|
|
|
|
|
|
|
return $meta; |
2627
|
|
|
|
|
|
|
} |
2628
|
|
|
|
|
|
|
|
2629
|
|
|
|
|
|
|
|
2630
|
0
|
|
|
0
|
|
0
|
sub _make_delegation_method { |
2631
|
0
|
|
|
|
|
0
|
my($self, $handle, $method_to_call) = @_; |
2632
|
|
|
|
|
|
|
return Mouse::Util::load_class($self->delegation_metaclass) |
2633
|
|
|
|
|
|
|
->_generate_delegation($self, $handle, $method_to_call); |
2634
|
|
|
|
|
|
|
} |
2635
|
|
|
|
|
|
|
|
2636
|
0
|
|
|
|
|
0
|
} |
2637
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Class.pm |
2638
|
2
|
|
|
2
|
|
10
|
package Mouse::Meta::Class; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4
|
|
2639
|
|
|
|
|
|
|
use Mouse::Util qw/:meta/; # enables strict and warnings |
2640
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
31
|
|
2641
|
|
|
|
|
|
|
use Scalar::Util (); |
2642
|
2
|
|
|
2
|
|
4
|
|
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
159
|
|
2643
|
2
|
|
|
2
|
|
25
|
use Mouse::Meta::Module; |
2644
|
|
|
|
|
|
|
our @ISA = qw(Mouse::Meta::Module); |
2645
|
2
|
|
|
|
|
5
|
|
2646
|
|
|
|
|
|
|
our @CARP_NOT = qw(Mouse); # trust Mouse |
2647
|
|
|
|
|
|
|
|
2648
|
|
|
|
|
|
|
sub attribute_metaclass; |
2649
|
|
|
|
|
|
|
sub method_metaclass; |
2650
|
|
|
|
|
|
|
|
2651
|
|
|
|
|
|
|
sub constructor_class; |
2652
|
|
|
|
|
|
|
sub destructor_class; |
2653
|
|
|
|
|
|
|
|
2654
|
|
|
|
|
|
|
|
2655
|
4
|
|
|
4
|
|
7
|
sub _construct_meta { |
2656
|
|
|
|
|
|
|
my($class, %args) = @_; |
2657
|
4
|
|
|
|
|
7
|
|
2658
|
4
|
|
|
|
|
8
|
$args{attributes} = {}; |
2659
|
4
|
|
|
|
|
7
|
$args{methods} = {}; |
2660
|
|
|
|
|
|
|
$args{roles} = []; |
2661
|
4
|
|
|
|
|
2
|
|
2662
|
2
|
|
|
2
|
|
8
|
$args{superclasses} = do { |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
3746
|
|
2663
|
4
|
|
|
|
|
4
|
no strict 'refs'; |
|
4
|
|
|
|
|
17
|
|
2664
|
|
|
|
|
|
|
\@{ $args{package} . '::ISA' }; |
2665
|
|
|
|
|
|
|
}; |
2666
|
4
|
|
33
|
|
|
15
|
|
2667
|
4
|
50
|
|
|
|
9
|
my $self = bless \%args, ref($class) || $class; |
2668
|
0
|
|
|
|
|
0
|
if(ref($self) ne __PACKAGE__){ |
2669
|
|
|
|
|
|
|
$self->meta->_initialize_object($self, \%args); |
2670
|
4
|
|
|
|
|
24
|
} |
2671
|
|
|
|
|
|
|
return $self; |
2672
|
|
|
|
|
|
|
} |
2673
|
|
|
|
|
|
|
|
2674
|
0
|
|
|
0
|
0
|
0
|
sub create_anon_class{ |
2675
|
0
|
|
|
|
|
0
|
my $self = shift; |
2676
|
|
|
|
|
|
|
return $self->create(undef, @_); |
2677
|
|
|
|
|
|
|
} |
2678
|
|
|
|
|
|
|
|
2679
|
|
|
|
|
|
|
sub is_anon_class; |
2680
|
|
|
|
|
|
|
|
2681
|
|
|
|
|
|
|
sub roles; |
2682
|
|
|
|
|
|
|
|
2683
|
0
|
|
|
0
|
0
|
0
|
sub calculate_all_roles { |
2684
|
0
|
|
|
|
|
0
|
my $self = shift; |
2685
|
0
|
|
|
|
|
0
|
my %seen; |
2686
|
0
|
|
|
|
|
0
|
return grep { !$seen{ $_->name }++ } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2687
|
|
|
|
|
|
|
map { $_->calculate_all_roles } @{ $self->roles }; |
2688
|
|
|
|
|
|
|
} |
2689
|
|
|
|
|
|
|
|
2690
|
8
|
|
|
8
|
1
|
7
|
sub superclasses { |
2691
|
|
|
|
|
|
|
my $self = shift; |
2692
|
8
|
100
|
|
|
|
13
|
|
2693
|
4
|
|
|
|
|
5
|
if (@_) { |
2694
|
4
|
|
|
|
|
9
|
foreach my $super(@_){ |
2695
|
4
|
|
|
|
|
7
|
Mouse::Util::load_class($super); |
2696
|
4
|
50
|
|
|
|
9
|
my $meta = Mouse::Util::get_metaclass_by_name($super); |
2697
|
0
|
|
|
|
|
0
|
next if $self->verify_superclass($super, $meta); |
2698
|
|
|
|
|
|
|
$self->_reconcile_with_superclass_meta($meta); |
2699
|
4
|
|
|
|
|
5
|
} |
|
4
|
|
|
|
|
24
|
|
2700
|
|
|
|
|
|
|
return @{ $self->{superclasses} } = @_; |
2701
|
|
|
|
|
|
|
} |
2702
|
4
|
|
|
|
|
3
|
|
|
4
|
|
|
|
|
13
|
|
2703
|
|
|
|
|
|
|
return @{ $self->{superclasses} }; |
2704
|
|
|
|
|
|
|
} |
2705
|
|
|
|
|
|
|
|
2706
|
4
|
|
|
4
|
0
|
4
|
sub verify_superclass { |
2707
|
|
|
|
|
|
|
my($self, $super, $super_meta) = @_; |
2708
|
4
|
50
|
|
|
|
7
|
|
2709
|
0
|
0
|
|
|
|
0
|
if(defined $super_meta) { |
2710
|
0
|
|
|
|
|
0
|
if(Mouse::Util::is_a_metarole($super_meta)){ |
2711
|
|
|
|
|
|
|
$self->throw_error("You cannot inherit from a Mouse Role ($super)"); |
2712
|
|
|
|
|
|
|
} |
2713
|
|
|
|
|
|
|
} |
2714
|
|
|
|
|
|
|
else { |
2715
|
|
|
|
|
|
|
# The metaclass of $super is not initialized. |
2716
|
|
|
|
|
|
|
# i.e. it might be Mouse::Object, a mixin package (e.g. Exporter), |
2717
|
|
|
|
|
|
|
# or a foreign class including Moose classes. |
2718
|
4
|
|
|
|
|
16
|
# See also Mouse::Foreign::Meta::Role::Class. |
2719
|
4
|
50
|
33
|
|
|
18
|
my $mm = $super->can('meta'); |
2720
|
0
|
0
|
0
|
|
|
0
|
if(!($mm && $mm == \&Mouse::Util::meta)) { |
2721
|
0
|
|
|
|
|
0
|
if($super->can('new') or $super->can('DESTROY')) { |
2722
|
|
|
|
|
|
|
$self->inherit_from_foreign_class($super); |
2723
|
|
|
|
|
|
|
} |
2724
|
4
|
|
|
|
|
10
|
} |
2725
|
|
|
|
|
|
|
return 1; # always ok |
2726
|
|
|
|
|
|
|
} |
2727
|
0
|
|
|
|
|
0
|
|
2728
|
|
|
|
|
|
|
return $self->isa(ref $super_meta); # checks metaclass compatibility |
2729
|
|
|
|
|
|
|
} |
2730
|
|
|
|
|
|
|
|
2731
|
0
|
|
|
0
|
0
|
0
|
sub inherit_from_foreign_class { |
2732
|
0
|
0
|
|
|
|
0
|
my($class, $super) = @_; |
2733
|
0
|
|
|
|
|
0
|
if($ENV{PERL_MOUSE_STRICT}) { |
2734
|
|
|
|
|
|
|
Carp::carp("You inherit from non-Mouse class ($super)," |
2735
|
|
|
|
|
|
|
. " but it is unlikely to work correctly." |
2736
|
|
|
|
|
|
|
. " Please consider using MouseX::Foreign"); |
2737
|
0
|
|
|
|
|
0
|
} |
2738
|
|
|
|
|
|
|
return; |
2739
|
|
|
|
|
|
|
} |
2740
|
2
|
|
|
|
|
58
|
|
2741
|
|
|
|
|
|
|
my @MetaClassTypes = ( |
2742
|
|
|
|
|
|
|
'attribute', # Mouse::Meta::Attribute |
2743
|
|
|
|
|
|
|
'method', # Mouse::Meta::Method |
2744
|
|
|
|
|
|
|
'constructor', # Mouse::Meta::Method::Constructor |
2745
|
|
|
|
|
|
|
'destructor', # Mouse::Meta::Method::Destructor |
2746
|
|
|
|
|
|
|
); |
2747
|
|
|
|
|
|
|
|
2748
|
0
|
|
|
0
|
|
0
|
sub _reconcile_with_superclass_meta { |
2749
|
|
|
|
|
|
|
my($self, $other) = @_; |
2750
|
|
|
|
|
|
|
|
2751
|
0
|
|
|
|
|
0
|
# find incompatible traits |
2752
|
0
|
|
|
|
|
0
|
my %metaroles; |
2753
|
0
|
|
0
|
|
|
0
|
foreach my $metaclass_type(@MetaClassTypes){ |
2754
|
|
|
|
|
|
|
my $accessor = $self->can($metaclass_type . '_metaclass') |
2755
|
|
|
|
|
|
|
|| $self->can($metaclass_type . '_class'); |
2756
|
0
|
|
|
|
|
0
|
|
2757
|
0
|
|
|
|
|
0
|
my $other_c = $other->$accessor(); |
2758
|
|
|
|
|
|
|
my $self_c = $self->$accessor(); |
2759
|
0
|
0
|
|
|
|
0
|
|
2760
|
0
|
|
|
|
|
0
|
if(!$self_c->isa($other_c)){ |
2761
|
|
|
|
|
|
|
$metaroles{$metaclass_type} |
2762
|
|
|
|
|
|
|
= [ $self_c->meta->_collect_roles($other_c->meta) ]; |
2763
|
|
|
|
|
|
|
} |
2764
|
|
|
|
|
|
|
} |
2765
|
0
|
|
|
|
|
0
|
|
2766
|
|
|
|
|
|
|
$metaroles{class} = [$self->meta->_collect_roles($other->meta)]; |
2767
|
|
|
|
|
|
|
|
2768
|
|
|
|
|
|
|
#use Data::Dumper; print Data::Dumper->new([\%metaroles], ['*metaroles'])->Indent(1)->Dump; |
2769
|
0
|
|
|
|
|
0
|
|
2770
|
0
|
|
|
|
|
0
|
require Mouse::Util::MetaRole; |
2771
|
|
|
|
|
|
|
$_[0] = Mouse::Util::MetaRole::apply_metaroles( |
2772
|
|
|
|
|
|
|
for => $self, |
2773
|
|
|
|
|
|
|
class_metaroles => \%metaroles, |
2774
|
0
|
|
|
|
|
0
|
); |
2775
|
|
|
|
|
|
|
return; |
2776
|
|
|
|
|
|
|
} |
2777
|
|
|
|
|
|
|
|
2778
|
0
|
|
|
0
|
|
0
|
sub _collect_roles { |
2779
|
|
|
|
|
|
|
my ($self, $other) = @_; |
2780
|
|
|
|
|
|
|
|
2781
|
0
|
|
|
|
|
0
|
# find common ancestor |
2782
|
0
|
|
|
|
|
0
|
my @self_lin_isa = $self->linearized_isa; |
2783
|
|
|
|
|
|
|
my @other_lin_isa = $other->linearized_isa; |
2784
|
0
|
|
|
|
|
0
|
|
2785
|
0
|
|
|
|
|
0
|
my(@self_anon_supers, @other_anon_supers); |
2786
|
0
|
|
|
|
|
0
|
push @self_anon_supers, shift @self_lin_isa while $self_lin_isa[0]->meta->is_anon_class; |
2787
|
|
|
|
|
|
|
push @other_anon_supers, shift @other_lin_isa while $other_lin_isa[0]->meta->is_anon_class; |
2788
|
0
|
|
0
|
|
|
0
|
|
2789
|
|
|
|
|
|
|
my $common_ancestor = $self_lin_isa[0] eq $other_lin_isa[0] && $self_lin_isa[0]; |
2790
|
0
|
0
|
|
|
|
0
|
|
2791
|
0
|
|
|
|
|
0
|
if(!$common_ancestor){ |
2792
|
|
|
|
|
|
|
$self->throw_error(sprintf '%s cannot have %s as a super class because of their metaclass incompatibility', |
2793
|
|
|
|
|
|
|
$self->name, $other->name); |
2794
|
|
|
|
|
|
|
} |
2795
|
0
|
|
|
|
|
0
|
|
2796
|
0
|
|
|
|
|
0
|
my %seen; |
2797
|
0
|
|
|
|
|
0
|
return sort grep { !$seen{$_}++ } ## no critic |
|
0
|
|
|
|
|
0
|
|
2798
|
0
|
|
|
|
|
0
|
(map{ $_->name } map{ $_->meta->calculate_all_roles } @self_anon_supers), |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2799
|
|
|
|
|
|
|
(map{ $_->name } map{ $_->meta->calculate_all_roles } @other_anon_supers), |
2800
|
|
|
|
|
|
|
; |
2801
|
|
|
|
|
|
|
} |
2802
|
|
|
|
|
|
|
|
2803
|
|
|
|
|
|
|
|
2804
|
0
|
|
|
0
|
0
|
0
|
sub find_method_by_name { |
2805
|
0
|
0
|
|
|
|
0
|
my($self, $method_name) = @_; |
2806
|
|
|
|
|
|
|
defined($method_name) |
2807
|
|
|
|
|
|
|
or $self->throw_error('You must define a method name to find'); |
2808
|
0
|
|
|
|
|
0
|
|
2809
|
0
|
|
|
|
|
0
|
foreach my $class( $self->linearized_isa ){ |
2810
|
0
|
0
|
|
|
|
0
|
my $method = $self->initialize($class)->get_method($method_name); |
2811
|
|
|
|
|
|
|
return $method if defined $method; |
2812
|
0
|
|
|
|
|
0
|
} |
2813
|
|
|
|
|
|
|
return undef; |
2814
|
|
|
|
|
|
|
} |
2815
|
|
|
|
|
|
|
|
2816
|
0
|
|
|
0
|
1
|
0
|
sub get_all_methods { |
2817
|
0
|
|
|
|
|
0
|
my($self) = @_; |
|
0
|
|
|
|
|
0
|
|
2818
|
|
|
|
|
|
|
return map{ $self->find_method_by_name($_) } $self->get_all_method_names; |
2819
|
|
|
|
|
|
|
} |
2820
|
|
|
|
|
|
|
|
2821
|
0
|
|
|
0
|
0
|
0
|
sub get_all_method_names { |
2822
|
0
|
|
|
|
|
0
|
my $self = shift; |
2823
|
0
|
|
|
|
|
0
|
my %uniq; |
2824
|
0
|
|
|
|
|
0
|
return grep { $uniq{$_}++ == 0 } |
|
0
|
|
|
|
|
0
|
|
2825
|
|
|
|
|
|
|
map { Mouse::Meta::Class->initialize($_)->get_method_list() } |
2826
|
|
|
|
|
|
|
$self->linearized_isa; |
2827
|
|
|
|
|
|
|
} |
2828
|
|
|
|
|
|
|
|
2829
|
0
|
|
|
0
|
0
|
0
|
sub find_attribute_by_name { |
2830
|
0
|
0
|
|
|
|
0
|
my($self, $name) = @_; |
2831
|
|
|
|
|
|
|
defined($name) |
2832
|
0
|
|
|
|
|
0
|
or $self->throw_error('You must define an attribute name to find'); |
2833
|
0
|
0
|
|
|
|
0
|
foreach my $attr($self->get_all_attributes) { |
2834
|
|
|
|
|
|
|
return $attr if $attr->name eq $name; |
2835
|
0
|
|
|
|
|
0
|
} |
2836
|
|
|
|
|
|
|
return undef; |
2837
|
|
|
|
|
|
|
} |
2838
|
|
|
|
|
|
|
|
2839
|
4
|
|
|
4
|
1
|
5
|
sub add_attribute { |
2840
|
|
|
|
|
|
|
my $self = shift; |
2841
|
4
|
|
|
|
|
5
|
|
2842
|
|
|
|
|
|
|
my($attr, $name); |
2843
|
4
|
50
|
|
|
|
17
|
|
2844
|
0
|
|
|
|
|
0
|
if(Scalar::Util::blessed($_[0])){ |
2845
|
|
|
|
|
|
|
$attr = $_[0]; |
2846
|
0
|
0
|
|
|
|
0
|
|
2847
|
|
|
|
|
|
|
$attr->isa('Mouse::Meta::Attribute') |
2848
|
|
|
|
|
|
|
|| $self->throw_error("Your attribute must be an instance of Mouse::Meta::Attribute (or a subclass)"); |
2849
|
0
|
|
|
|
|
0
|
|
2850
|
|
|
|
|
|
|
$name = $attr->name; |
2851
|
|
|
|
|
|
|
} |
2852
|
|
|
|
|
|
|
else{ |
2853
|
4
|
|
|
|
|
5
|
# _process_attribute |
2854
|
|
|
|
|
|
|
$name = shift; |
2855
|
4
|
50
|
|
|
|
19
|
|
|
0
|
|
|
|
|
0
|
|
2856
|
|
|
|
|
|
|
my %args = (@_ == 1) ? %{$_[0]} : @_; |
2857
|
4
|
50
|
|
|
|
7
|
|
2858
|
|
|
|
|
|
|
defined($name) |
2859
|
|
|
|
|
|
|
or $self->throw_error('You must provide a name for the attribute'); |
2860
|
4
|
50
|
|
|
|
12
|
|
2861
|
|
|
|
|
|
|
if ($name =~ s/^\+//) { # inherited attributes |
2862
|
|
|
|
|
|
|
# Workaround for https://github.com/gfx/p5-Mouse/issues/64 |
2863
|
|
|
|
|
|
|
# Do not use find_attribute_by_name to avoid problems with cached attributes list |
2864
|
0
|
|
|
|
|
0
|
# because we're about to change it anyway |
2865
|
0
|
|
|
|
|
0
|
my $inherited_attr; |
|
0
|
|
|
|
|
0
|
|
2866
|
0
|
0
|
|
|
|
0
|
foreach my $i ( @{ $self->_calculate_all_attributes } ) { |
2867
|
0
|
|
|
|
|
0
|
if ( $i->name eq $name ) { |
2868
|
0
|
|
|
|
|
0
|
$inherited_attr = $i; |
2869
|
|
|
|
|
|
|
last; |
2870
|
|
|
|
|
|
|
} |
2871
|
0
|
0
|
|
|
|
0
|
} |
2872
|
|
|
|
|
|
|
$self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name) |
2873
|
|
|
|
|
|
|
unless $inherited_attr; |
2874
|
0
|
|
|
|
|
0
|
|
2875
|
|
|
|
|
|
|
$attr = $inherited_attr->clone_and_inherit_options(%args); |
2876
|
|
|
|
|
|
|
} |
2877
|
4
|
|
|
|
|
12
|
else{ |
2878
|
4
|
50
|
|
|
|
9
|
my($attribute_class, @traits) = $self->attribute_metaclass->interpolate_class(\%args); |
2879
|
|
|
|
|
|
|
$args{traits} = \@traits if @traits; |
2880
|
4
|
|
|
|
|
15
|
|
2881
|
|
|
|
|
|
|
$attr = $attribute_class->new($name, %args); |
2882
|
|
|
|
|
|
|
} |
2883
|
|
|
|
|
|
|
} |
2884
|
4
|
|
|
|
|
21
|
|
2885
|
|
|
|
|
|
|
Scalar::Util::weaken( $attr->{associated_class} = $self ); |
2886
|
|
|
|
|
|
|
|
2887
|
4
|
|
|
|
|
10
|
# install accessors first |
2888
|
|
|
|
|
|
|
$attr->install_accessors(); |
2889
|
|
|
|
|
|
|
|
2890
|
4
|
|
|
|
|
2
|
# then register the attribute to the metaclass |
|
4
|
|
|
|
|
11
|
|
2891
|
4
|
|
|
|
|
7
|
$attr->{insertion_order} = keys %{ $self->{attributes} }; |
2892
|
4
|
|
|
|
|
9
|
$self->{attributes}{$name} = $attr; |
2893
|
|
|
|
|
|
|
$self->_invalidate_metaclass_cache(); |
2894
|
4
|
50
|
0
|
|
|
10
|
|
|
|
|
33
|
|
|
|
|
2895
|
0
|
|
|
|
|
0
|
if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){ |
2896
|
|
|
|
|
|
|
Carp::carp(qq{Attribute ($name) of class }.$self->name |
2897
|
|
|
|
|
|
|
.qq{ has no associated methods (did you mean to provide an "is" argument?)}); |
2898
|
4
|
|
|
|
|
6
|
} |
2899
|
|
|
|
|
|
|
return $attr; |
2900
|
|
|
|
|
|
|
} |
2901
|
|
|
|
|
|
|
|
2902
|
4
|
|
|
4
|
|
5
|
sub _calculate_all_attributes { |
2903
|
4
|
|
|
|
|
4
|
my($self) = @_; |
2904
|
|
|
|
|
|
|
my %seen; |
2905
|
4
|
|
|
|
|
9
|
my @all_attrs; |
2906
|
8
|
100
|
|
|
|
13
|
foreach my $class($self->linearized_isa) { |
2907
|
4
|
|
|
|
|
5
|
my $meta = Mouse::Util::get_metaclass_by_name($class) or next; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
9
|
|
2908
|
|
|
|
|
|
|
my @attrs = grep { !$seen{$_->name}++ } values %{$meta->{attributes}}; |
2909
|
4
|
|
|
|
|
8
|
@attrs = sort { |
2910
|
0
|
|
|
|
|
0
|
$b->{insertion_order} <=> $a->{insertion_order} |
2911
|
4
|
|
|
|
|
6
|
} @attrs; |
2912
|
|
|
|
|
|
|
push @all_attrs, @attrs; |
2913
|
4
|
|
|
|
|
24
|
} |
2914
|
|
|
|
|
|
|
return [reverse @all_attrs]; |
2915
|
|
|
|
|
|
|
} |
2916
|
|
|
|
|
|
|
|
2917
|
|
|
|
|
|
|
sub linearized_isa; |
2918
|
|
|
|
|
|
|
|
2919
|
|
|
|
|
|
|
sub new_object; |
2920
|
|
|
|
|
|
|
sub clone_object; |
2921
|
|
|
|
|
|
|
|
2922
|
0
|
|
|
0
|
0
|
0
|
sub immutable_options { |
2923
|
|
|
|
|
|
|
my ( $self, @args ) = @_; |
2924
|
|
|
|
|
|
|
|
2925
|
0
|
|
|
|
|
0
|
return ( |
2926
|
|
|
|
|
|
|
inline_constructor => 1, |
2927
|
|
|
|
|
|
|
inline_destructor => 1, |
2928
|
|
|
|
|
|
|
constructor_name => 'new', |
2929
|
|
|
|
|
|
|
@args, |
2930
|
|
|
|
|
|
|
); |
2931
|
|
|
|
|
|
|
} |
2932
|
|
|
|
|
|
|
|
2933
|
0
|
|
|
0
|
0
|
0
|
sub make_immutable { |
2934
|
0
|
|
|
|
|
0
|
my $self = shift; |
2935
|
|
|
|
|
|
|
my %args = $self->immutable_options(@_); |
2936
|
0
|
|
|
|
|
0
|
|
2937
|
|
|
|
|
|
|
$self->{is_immutable}++; |
2938
|
0
|
0
|
|
|
|
0
|
|
2939
|
|
|
|
|
|
|
if ($args{inline_constructor}) { |
2940
|
0
|
|
|
|
|
0
|
$self->add_method($args{constructor_name} => |
2941
|
|
|
|
|
|
|
Mouse::Util::load_class($self->constructor_class) |
2942
|
|
|
|
|
|
|
->_generate_constructor($self, \%args)); |
2943
|
|
|
|
|
|
|
} |
2944
|
0
|
0
|
|
|
|
0
|
|
2945
|
0
|
|
|
|
|
0
|
if ($args{inline_destructor}) { |
2946
|
|
|
|
|
|
|
$self->add_method(DESTROY => |
2947
|
|
|
|
|
|
|
Mouse::Util::load_class($self->destructor_class) |
2948
|
|
|
|
|
|
|
->_generate_destructor($self, \%args)); |
2949
|
|
|
|
|
|
|
} |
2950
|
|
|
|
|
|
|
|
2951
|
|
|
|
|
|
|
# Moose's make_immutable returns true allowing calling code to skip |
2952
|
0
|
|
|
|
|
0
|
# setting an explicit true value at the end of a source file. |
2953
|
|
|
|
|
|
|
return 1; |
2954
|
|
|
|
|
|
|
} |
2955
|
|
|
|
|
|
|
|
2956
|
0
|
|
|
0
|
0
|
0
|
sub make_mutable { |
2957
|
0
|
|
|
|
|
0
|
my($self) = @_; |
2958
|
0
|
|
|
|
|
0
|
$self->{is_immutable} = 0; |
2959
|
|
|
|
|
|
|
return; |
2960
|
|
|
|
|
|
|
} |
2961
|
|
|
|
|
|
|
|
2962
|
0
|
|
|
0
|
0
|
0
|
sub is_immutable; |
2963
|
|
|
|
|
|
|
sub is_mutable { !$_[0]->is_immutable } |
2964
|
|
|
|
|
|
|
|
2965
|
0
|
|
|
0
|
|
0
|
sub _install_modifier { |
2966
|
0
|
|
|
|
|
0
|
my( $self, $type, $name, $code ) = @_; |
2967
|
|
|
|
|
|
|
my $into = $self->name; |
2968
|
0
|
0
|
|
|
|
0
|
|
2969
|
|
|
|
|
|
|
my $original = $into->can($name) |
2970
|
|
|
|
|
|
|
or $self->throw_error("The method '$name' was not found in the inheritance hierarchy for $into"); |
2971
|
0
|
|
|
|
|
0
|
|
2972
|
|
|
|
|
|
|
my $modifier_table = $self->{modifiers}{$name}; |
2973
|
0
|
0
|
|
|
|
0
|
|
2974
|
0
|
|
|
|
|
0
|
if(!$modifier_table){ |
2975
|
0
|
|
|
|
|
0
|
my(@before, @after, @around); |
2976
|
|
|
|
|
|
|
my $cache = $original; |
2977
|
0
|
0
|
|
0
|
|
0
|
my $modified = sub { |
2978
|
0
|
|
|
|
|
0
|
if(@before) { |
|
0
|
|
|
|
|
0
|
|
2979
|
|
|
|
|
|
|
for my $c (@before) { $c->(@_) } |
2980
|
0
|
0
|
|
|
|
0
|
} |
2981
|
0
|
|
|
|
|
0
|
unless(@after) { |
2982
|
|
|
|
|
|
|
return $cache->(@_); |
2983
|
|
|
|
|
|
|
} |
2984
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
2985
|
0
|
|
|
|
|
0
|
if(wantarray){ # list context |
2986
|
|
|
|
|
|
|
my @rval = $cache->(@_); |
2987
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2988
|
0
|
|
|
|
|
0
|
for my $c(@after){ $c->(@_) } |
2989
|
|
|
|
|
|
|
return @rval; |
2990
|
|
|
|
|
|
|
} |
2991
|
0
|
|
|
|
|
0
|
elsif(defined wantarray){ # scalar context |
2992
|
|
|
|
|
|
|
my $rval = $cache->(@_); |
2993
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2994
|
0
|
|
|
|
|
0
|
for my $c(@after){ $c->(@_) } |
2995
|
|
|
|
|
|
|
return $rval; |
2996
|
|
|
|
|
|
|
} |
2997
|
0
|
|
|
|
|
0
|
else{ # void context |
2998
|
|
|
|
|
|
|
$cache->(@_); |
2999
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3000
|
0
|
|
|
|
|
0
|
for my $c(@after){ $c->(@_) } |
3001
|
|
|
|
|
|
|
return; |
3002
|
0
|
|
|
|
|
0
|
} |
3003
|
|
|
|
|
|
|
}; |
3004
|
0
|
|
|
|
|
0
|
|
3005
|
|
|
|
|
|
|
$self->{modifiers}{$name} = $modifier_table = { |
3006
|
|
|
|
|
|
|
original => $original, |
3007
|
|
|
|
|
|
|
|
3008
|
|
|
|
|
|
|
before => \@before, |
3009
|
|
|
|
|
|
|
after => \@after, |
3010
|
|
|
|
|
|
|
around => \@around, |
3011
|
|
|
|
|
|
|
|
3012
|
|
|
|
|
|
|
cache => \$cache, # cache for around modifiers |
3013
|
|
|
|
|
|
|
}; |
3014
|
0
|
|
|
|
|
0
|
|
3015
|
|
|
|
|
|
|
$self->add_method($name => $modified); |
3016
|
|
|
|
|
|
|
} |
3017
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
3018
|
0
|
|
|
|
|
0
|
if($type eq 'before'){ |
|
0
|
|
|
|
|
0
|
|
3019
|
|
|
|
|
|
|
unshift @{$modifier_table->{before}}, $code; |
3020
|
|
|
|
|
|
|
} |
3021
|
0
|
|
|
|
|
0
|
elsif($type eq 'after'){ |
|
0
|
|
|
|
|
0
|
|
3022
|
|
|
|
|
|
|
push @{$modifier_table->{after}}, $code; |
3023
|
|
|
|
|
|
|
} |
3024
|
0
|
|
|
|
|
0
|
else{ # around |
|
0
|
|
|
|
|
0
|
|
3025
|
|
|
|
|
|
|
push @{$modifier_table->{around}}, $code; |
3026
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3027
|
0
|
|
|
0
|
|
0
|
my $next = ${ $modifier_table->{cache} }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3028
|
|
|
|
|
|
|
${ $modifier_table->{cache} } = sub{ $code->($next, @_) }; |
3029
|
|
|
|
|
|
|
} |
3030
|
0
|
|
|
|
|
0
|
|
3031
|
|
|
|
|
|
|
return; |
3032
|
|
|
|
|
|
|
} |
3033
|
|
|
|
|
|
|
|
3034
|
0
|
|
|
0
|
0
|
0
|
sub add_before_method_modifier { |
3035
|
0
|
|
|
|
|
0
|
my ( $self, $name, $code ) = @_; |
3036
|
|
|
|
|
|
|
$self->_install_modifier( 'before', $name, $code ); |
3037
|
|
|
|
|
|
|
} |
3038
|
|
|
|
|
|
|
|
3039
|
0
|
|
|
0
|
0
|
0
|
sub add_around_method_modifier { |
3040
|
0
|
|
|
|
|
0
|
my ( $self, $name, $code ) = @_; |
3041
|
|
|
|
|
|
|
$self->_install_modifier( 'around', $name, $code ); |
3042
|
|
|
|
|
|
|
} |
3043
|
|
|
|
|
|
|
|
3044
|
0
|
|
|
0
|
0
|
0
|
sub add_after_method_modifier { |
3045
|
0
|
|
|
|
|
0
|
my ( $self, $name, $code ) = @_; |
3046
|
|
|
|
|
|
|
$self->_install_modifier( 'after', $name, $code ); |
3047
|
|
|
|
|
|
|
} |
3048
|
|
|
|
|
|
|
|
3049
|
0
|
|
|
0
|
0
|
0
|
sub add_override_method_modifier { |
3050
|
|
|
|
|
|
|
my ($self, $name, $code) = @_; |
3051
|
0
|
0
|
|
|
|
0
|
|
3052
|
0
|
|
|
|
|
0
|
if($self->has_method($name)){ |
3053
|
|
|
|
|
|
|
$self->throw_error("Cannot add an override method if a local method is already present"); |
3054
|
|
|
|
|
|
|
} |
3055
|
0
|
|
|
|
|
0
|
|
3056
|
|
|
|
|
|
|
my $package = $self->name; |
3057
|
0
|
0
|
|
|
|
0
|
|
3058
|
|
|
|
|
|
|
my $super_body = $package->can($name) |
3059
|
|
|
|
|
|
|
or $self->throw_error("You cannot override '$name' because it has no super method"); |
3060
|
|
|
|
|
|
|
|
3061
|
0
|
|
|
0
|
|
0
|
$self->add_method($name => sub { |
3062
|
0
|
|
|
|
|
0
|
local $Mouse::SUPER_PACKAGE = $package; |
3063
|
0
|
|
|
|
|
0
|
local $Mouse::SUPER_BODY = $super_body; |
3064
|
0
|
|
|
|
|
0
|
local @Mouse::SUPER_ARGS = @_; |
|
0
|
|
|
|
|
0
|
|
3065
|
0
|
|
|
|
|
0
|
&{$code}; |
3066
|
0
|
|
|
|
|
0
|
}); |
3067
|
|
|
|
|
|
|
return; |
3068
|
|
|
|
|
|
|
} |
3069
|
|
|
|
|
|
|
|
3070
|
0
|
|
|
0
|
0
|
0
|
sub add_augment_method_modifier { |
3071
|
0
|
0
|
|
|
|
0
|
my ($self, $name, $code) = @_; |
3072
|
0
|
|
|
|
|
0
|
if($self->has_method($name)){ |
3073
|
|
|
|
|
|
|
$self->throw_error("Cannot add an augment method if a local method is already present"); |
3074
|
|
|
|
|
|
|
} |
3075
|
0
|
0
|
|
|
|
0
|
|
3076
|
|
|
|
|
|
|
my $super = $self->find_method_by_name($name) |
3077
|
|
|
|
|
|
|
or $self->throw_error("You cannot augment '$name' because it has no super method"); |
3078
|
0
|
|
|
|
|
0
|
|
3079
|
0
|
|
|
|
|
0
|
my $super_package = $super->package_name; |
3080
|
|
|
|
|
|
|
my $super_body = $super->body; |
3081
|
|
|
|
|
|
|
|
3082
|
0
|
|
|
0
|
|
0
|
$self->add_method($name => sub { |
3083
|
0
|
|
|
|
|
0
|
local $Mouse::INNER_BODY{$super_package} = $code; |
3084
|
0
|
|
|
|
|
0
|
local $Mouse::INNER_ARGS{$super_package} = [@_]; |
|
0
|
|
|
|
|
0
|
|
3085
|
0
|
|
|
|
|
0
|
&{$super_body}; |
3086
|
0
|
|
|
|
|
0
|
}); |
3087
|
|
|
|
|
|
|
return; |
3088
|
|
|
|
|
|
|
} |
3089
|
|
|
|
|
|
|
|
3090
|
0
|
|
|
0
|
0
|
0
|
sub does_role { |
3091
|
|
|
|
|
|
|
my ($self, $role_name) = @_; |
3092
|
0
|
0
|
|
|
|
0
|
|
3093
|
|
|
|
|
|
|
(defined $role_name) |
3094
|
|
|
|
|
|
|
|| $self->throw_error("You must supply a role name to look for"); |
3095
|
0
|
0
|
|
|
|
0
|
|
3096
|
|
|
|
|
|
|
$role_name = $role_name->name if ref $role_name; |
3097
|
0
|
|
|
|
|
0
|
|
3098
|
0
|
0
|
|
|
|
0
|
for my $class ($self->linearized_isa) { |
3099
|
|
|
|
|
|
|
my $meta = Mouse::Util::get_metaclass_by_name($class) |
3100
|
|
|
|
|
|
|
or next; |
3101
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3102
|
|
|
|
|
|
|
for my $role (@{ $meta->roles }) { |
3103
|
0
|
0
|
|
|
|
0
|
|
3104
|
|
|
|
|
|
|
return 1 if $role->does_role($role_name); |
3105
|
|
|
|
|
|
|
} |
3106
|
|
|
|
|
|
|
} |
3107
|
0
|
|
|
|
|
0
|
|
3108
|
|
|
|
|
|
|
return 0; |
3109
|
|
|
|
|
|
|
} |
3110
|
|
|
|
|
|
|
|
3111
|
0
|
|
|
|
|
0
|
} |
3112
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Method.pm |
3113
|
2
|
|
|
2
|
|
12
|
package Mouse::Meta::Method; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
5
|
|
3114
|
2
|
|
|
2
|
|
7
|
use Mouse::Util qw(:meta); # enables strict and warnings |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
88
|
|
3115
|
|
|
|
|
|
|
use Scalar::Util (); |
3116
|
|
|
|
|
|
|
|
3117
|
|
|
|
|
|
|
use overload |
3118
|
|
|
|
|
|
|
'==' => '_equal', |
3119
|
0
|
|
|
0
|
|
0
|
'eq' => '_equal', |
3120
|
2
|
|
|
|
|
18
|
'&{}' => sub{ $_[0]->body }, |
3121
|
2
|
|
|
2
|
|
7
|
fallback => 1, |
|
2
|
|
|
0
|
|
2
|
|
3122
|
|
|
|
|
|
|
; |
3123
|
|
|
|
|
|
|
|
3124
|
0
|
|
|
0
|
0
|
0
|
sub wrap { |
3125
|
0
|
0
|
|
|
|
0
|
my $class = shift; |
3126
|
0
|
|
|
|
|
0
|
unshift @_, 'body' if @_ % 2 != 0; |
3127
|
|
|
|
|
|
|
return $class->_new(@_); |
3128
|
|
|
|
|
|
|
} |
3129
|
|
|
|
|
|
|
|
3130
|
0
|
|
|
0
|
|
0
|
sub _new{ |
3131
|
0
|
|
|
|
|
0
|
my($class, %args) = @_; |
3132
|
|
|
|
|
|
|
my $self = bless \%args, $class; |
3133
|
0
|
0
|
|
|
|
0
|
|
3134
|
0
|
|
|
|
|
0
|
if($class ne __PACKAGE__){ |
3135
|
|
|
|
|
|
|
$self->meta->_initialize_object($self, \%args); |
3136
|
0
|
|
|
|
|
0
|
} |
3137
|
|
|
|
|
|
|
return $self; |
3138
|
|
|
|
|
|
|
} |
3139
|
0
|
|
|
0
|
0
|
0
|
|
3140
|
0
|
|
|
0
|
0
|
0
|
sub body { $_[0]->{body} } |
3141
|
0
|
|
|
0
|
0
|
0
|
sub name { $_[0]->{name} } |
3142
|
0
|
|
|
0
|
0
|
0
|
sub package_name { $_[0]->{package} } |
3143
|
|
|
|
|
|
|
sub associated_metaclass { $_[0]->{associated_metaclass} } |
3144
|
|
|
|
|
|
|
|
3145
|
0
|
|
|
0
|
0
|
0
|
sub fully_qualified_name { |
3146
|
0
|
|
|
|
|
0
|
my($self) = @_; |
3147
|
|
|
|
|
|
|
return $self->package_name . '::' . $self->name; |
3148
|
|
|
|
|
|
|
} |
3149
|
|
|
|
|
|
|
|
3150
|
|
|
|
|
|
|
# for Moose compat |
3151
|
0
|
|
|
0
|
|
0
|
sub _equal { |
3152
|
|
|
|
|
|
|
my($l, $r) = @_; |
3153
|
0
|
|
0
|
|
|
0
|
|
3154
|
|
|
|
|
|
|
return Scalar::Util::blessed($r) |
3155
|
|
|
|
|
|
|
&& $l->body == $r->body |
3156
|
|
|
|
|
|
|
&& $l->name eq $r->name |
3157
|
|
|
|
|
|
|
&& $l->package_name eq $r->package_name; |
3158
|
|
|
|
|
|
|
} |
3159
|
|
|
|
|
|
|
|
3160
|
0
|
|
|
|
|
0
|
} |
3161
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Method/Accessor.pm |
3162
|
2
|
|
|
2
|
|
555
|
package Mouse::Meta::Method::Accessor; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
4
|
|
3163
|
|
|
|
|
|
|
use Mouse::Util qw(:meta); # enables strict and warnings |
3164
|
2
|
50
|
|
2
|
|
9
|
|
|
2
|
|
|
0
|
|
2
|
|
|
2
|
|
|
|
|
1452
|
|
3165
|
|
|
|
|
|
|
use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0; |
3166
|
|
|
|
|
|
|
|
3167
|
4
|
|
|
4
|
|
8
|
sub _inline_slot{ |
3168
|
4
|
|
|
|
|
19
|
my(undef, $self_var, $attr_name) = @_; |
3169
|
|
|
|
|
|
|
return sprintf '%s->{q{%s}}', $self_var, $attr_name; |
3170
|
|
|
|
|
|
|
} |
3171
|
|
|
|
|
|
|
|
3172
|
4
|
|
|
4
|
|
5
|
sub _generate_accessor_any{ |
3173
|
|
|
|
|
|
|
my($method_class, $type, $attribute, $class) = @_; |
3174
|
4
|
|
|
|
|
9
|
|
3175
|
4
|
|
|
|
|
9
|
my $name = $attribute->name; |
3176
|
4
|
|
|
|
|
8
|
my $default = $attribute->default; |
3177
|
4
|
|
|
|
|
9
|
my $constraint = $attribute->type_constraint; |
3178
|
4
|
|
|
|
|
6
|
my $builder = $attribute->builder; |
3179
|
4
|
|
|
|
|
6
|
my $trigger = $attribute->trigger; |
3180
|
4
|
|
|
|
|
8
|
my $is_weak = $attribute->is_weak_ref; |
3181
|
4
|
|
33
|
|
|
12
|
my $should_deref = $attribute->should_auto_deref; |
3182
|
|
|
|
|
|
|
my $should_coerce = (defined($constraint) |
3183
|
|
|
|
|
|
|
&& $constraint->has_coercion |
3184
|
|
|
|
|
|
|
&& $attribute->should_coerce); |
3185
|
4
|
50
|
|
|
|
6
|
|
3186
|
|
|
|
|
|
|
my $compiled_type_constraint = defined($constraint) |
3187
|
|
|
|
|
|
|
? $constraint->_compiled_type_constraint |
3188
|
|
|
|
|
|
|
: undef; |
3189
|
4
|
|
|
|
|
5
|
|
3190
|
4
|
|
|
|
|
10
|
my $self = '$_[0]'; |
3191
|
|
|
|
|
|
|
my $slot = $method_class->_inline_slot($self, $name);; |
3192
|
4
|
|
|
|
|
12
|
|
3193
|
|
|
|
|
|
|
my $accessor = sprintf(qq{package %s;\n#line 1 "%s-accessor for %s (%s)"\n}, $class->name, $type, $name, __FILE__) |
3194
|
|
|
|
|
|
|
. "sub {\n"; |
3195
|
4
|
50
|
33
|
|
|
12
|
|
|
|
0
|
|
|
|
|
|
3196
|
4
|
50
|
|
|
|
8
|
if ($type eq 'rw' || $type eq 'wo') { |
3197
|
4
|
|
|
|
|
11
|
if($type eq 'rw'){ |
3198
|
|
|
|
|
|
|
$accessor .= |
3199
|
|
|
|
|
|
|
'if (scalar(@_) >= 2) {' . "\n"; |
3200
|
|
|
|
|
|
|
} |
3201
|
0
|
|
|
|
|
0
|
else{ # writer |
3202
|
|
|
|
|
|
|
$accessor .= |
3203
|
|
|
|
|
|
|
'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of $name") }'. |
3204
|
|
|
|
|
|
|
'{' . "\n"; |
3205
|
|
|
|
|
|
|
} |
3206
|
4
|
|
|
|
|
6
|
|
3207
|
|
|
|
|
|
|
my $value = '$_[1]'; |
3208
|
4
|
50
|
|
|
|
12
|
|
3209
|
0
|
0
|
|
|
|
0
|
if (defined $constraint) { |
3210
|
0
|
|
|
|
|
0
|
if ($should_coerce) { |
3211
|
|
|
|
|
|
|
$accessor .= |
3212
|
|
|
|
|
|
|
"\n". |
3213
|
0
|
|
|
|
|
0
|
'my $val = $constraint->coerce('.$value.');'; |
3214
|
|
|
|
|
|
|
$value = '$val'; |
3215
|
|
|
|
|
|
|
} |
3216
|
0
|
|
|
|
|
0
|
$accessor .= |
3217
|
|
|
|
|
|
|
"\n". |
3218
|
|
|
|
|
|
|
'$compiled_type_constraint->('.$value.') or |
3219
|
|
|
|
|
|
|
$attribute->_throw_type_constraint_error('.$value.', $constraint);' . "\n"; |
3220
|
|
|
|
|
|
|
} |
3221
|
|
|
|
|
|
|
|
3222
|
|
|
|
|
|
|
# if there's nothing left to do for the attribute we can return during |
3223
|
4
|
50
|
33
|
|
|
40
|
# this setter |
|
|
|
33
|
|
|
|
|
3224
|
|
|
|
|
|
|
$accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; |
3225
|
4
|
50
|
|
|
|
8
|
|
3226
|
4
|
|
|
|
|
9
|
$accessor .= "my \@old_value = exists $slot ? $slot : ();\n" if $trigger; |
3227
|
|
|
|
|
|
|
$accessor .= "$slot = $value;\n"; |
3228
|
4
|
50
|
|
|
|
6
|
|
3229
|
0
|
|
|
|
|
0
|
if ($is_weak) { |
3230
|
|
|
|
|
|
|
$accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; |
3231
|
|
|
|
|
|
|
} |
3232
|
4
|
50
|
|
|
|
7
|
|
3233
|
0
|
|
|
|
|
0
|
if ($trigger) { |
3234
|
|
|
|
|
|
|
$accessor .= '$trigger->('.$self.', '.$value.', @old_value);' . "\n"; |
3235
|
|
|
|
|
|
|
} |
3236
|
4
|
|
|
|
|
5
|
|
3237
|
|
|
|
|
|
|
$accessor .= "}\n"; |
3238
|
|
|
|
|
|
|
} |
3239
|
0
|
|
|
|
|
0
|
elsif($type eq 'ro') { |
3240
|
|
|
|
|
|
|
$accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor of $name") if scalar(@_) >= 2;' . "\n"; |
3241
|
|
|
|
|
|
|
} |
3242
|
0
|
|
|
|
|
0
|
else{ |
3243
|
|
|
|
|
|
|
$class->throw_error("Unknown accessor type '$type'"); |
3244
|
|
|
|
|
|
|
} |
3245
|
4
|
50
|
33
|
|
|
9
|
|
3246
|
0
|
|
|
|
|
0
|
if ($attribute->is_lazy and $type ne 'wo') { |
3247
|
|
|
|
|
|
|
my $value; |
3248
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
3249
|
0
|
|
|
|
|
0
|
if (defined $builder){ |
3250
|
|
|
|
|
|
|
$value = "$self->\$builder()"; |
3251
|
|
|
|
|
|
|
} |
3252
|
0
|
|
|
|
|
0
|
elsif (ref($default) eq 'CODE'){ |
3253
|
|
|
|
|
|
|
$value = "$self->\$default()"; |
3254
|
|
|
|
|
|
|
} |
3255
|
0
|
|
|
|
|
0
|
else{ |
3256
|
|
|
|
|
|
|
$value = '$default'; |
3257
|
|
|
|
|
|
|
} |
3258
|
0
|
0
|
|
|
|
0
|
|
3259
|
0
|
|
|
|
|
0
|
$accessor .= "els" if $type eq 'rw'; |
3260
|
0
|
0
|
|
|
|
0
|
$accessor .= "if(!exists $slot){\n"; |
|
|
0
|
|
|
|
|
|
3261
|
0
|
|
|
|
|
0
|
if($should_coerce){ |
3262
|
|
|
|
|
|
|
$accessor .= "$slot = \$constraint->coerce($value)"; |
3263
|
|
|
|
|
|
|
} |
3264
|
0
|
|
|
|
|
0
|
elsif(defined $constraint){ |
3265
|
0
|
|
|
|
|
0
|
$accessor .= "my \$tmp = $value;\n"; |
3266
|
0
|
|
|
|
|
0
|
$accessor .= "\$compiled_type_constraint->(\$tmp)"; |
3267
|
0
|
|
|
|
|
0
|
$accessor .= " || \$attribute->_throw_type_constraint_error(\$tmp, \$constraint);\n"; |
3268
|
|
|
|
|
|
|
$accessor .= "$slot = \$tmp;\n"; |
3269
|
|
|
|
|
|
|
} |
3270
|
0
|
|
|
|
|
0
|
else{ |
3271
|
|
|
|
|
|
|
$accessor .= "$slot = $value;\n"; |
3272
|
0
|
0
|
|
|
|
0
|
} |
3273
|
0
|
|
|
|
|
0
|
if ($is_weak) { |
3274
|
|
|
|
|
|
|
$accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; |
3275
|
0
|
|
|
|
|
0
|
} |
3276
|
|
|
|
|
|
|
$accessor .= "}\n"; |
3277
|
|
|
|
|
|
|
} |
3278
|
4
|
50
|
|
|
|
6
|
|
3279
|
0
|
0
|
|
|
|
0
|
if ($should_deref) { |
|
|
0
|
|
|
|
|
|
3280
|
0
|
|
|
|
|
0
|
if ($constraint->is_a_type_of('ArrayRef')) { |
3281
|
|
|
|
|
|
|
$accessor .= "return \@{ $slot || [] } if wantarray;\n"; |
3282
|
|
|
|
|
|
|
} |
3283
|
0
|
|
|
|
|
0
|
elsif($constraint->is_a_type_of('HashRef')){ |
3284
|
|
|
|
|
|
|
$accessor .= "return \%{ $slot || {} } if wantarray;\n"; |
3285
|
|
|
|
|
|
|
} |
3286
|
0
|
|
|
|
|
0
|
else{ |
3287
|
|
|
|
|
|
|
$class->throw_error("Can not auto de-reference the type constraint " . $constraint->name); |
3288
|
|
|
|
|
|
|
} |
3289
|
|
|
|
|
|
|
} |
3290
|
4
|
|
|
|
|
9
|
|
3291
|
|
|
|
|
|
|
$accessor .= "return $slot;\n}\n"; |
3292
|
4
|
|
|
|
|
3
|
|
3293
|
4
|
|
|
|
|
5
|
warn $accessor if _MOUSE_DEBUG; |
3294
|
4
|
|
|
|
|
4
|
my $code; |
3295
|
4
|
|
|
|
|
5
|
my $e = do{ |
3296
|
4
|
|
|
|
|
736
|
local $@; |
3297
|
4
|
|
|
|
|
42
|
$code = eval $accessor; |
3298
|
|
|
|
|
|
|
$@; |
3299
|
4
|
50
|
|
|
|
10
|
}; |
3300
|
|
|
|
|
|
|
die $e if $e; |
3301
|
4
|
|
|
|
|
10
|
|
3302
|
|
|
|
|
|
|
return $code; |
3303
|
|
|
|
|
|
|
} |
3304
|
|
|
|
|
|
|
|
3305
|
|
|
|
|
|
|
sub _generate_accessor{ |
3306
|
4
|
|
|
4
|
|
4
|
#my($self, $attribute, $metaclass) = @_; |
3307
|
4
|
|
|
|
|
12
|
my $self = shift; |
3308
|
|
|
|
|
|
|
return $self->_generate_accessor_any(rw => @_); |
3309
|
|
|
|
|
|
|
} |
3310
|
|
|
|
|
|
|
|
3311
|
|
|
|
|
|
|
sub _generate_reader { |
3312
|
0
|
|
|
0
|
|
0
|
#my($self, $attribute, $metaclass) = @_; |
3313
|
0
|
|
|
|
|
0
|
my $self = shift; |
3314
|
|
|
|
|
|
|
return $self->_generate_accessor_any(ro => @_); |
3315
|
|
|
|
|
|
|
} |
3316
|
|
|
|
|
|
|
|
3317
|
|
|
|
|
|
|
sub _generate_writer { |
3318
|
0
|
|
|
0
|
|
0
|
#my($self, $attribute, $metaclass) = @_; |
3319
|
0
|
|
|
|
|
0
|
my $self = shift; |
3320
|
|
|
|
|
|
|
return $self->_generate_accessor_any(wo => @_); |
3321
|
|
|
|
|
|
|
} |
3322
|
|
|
|
|
|
|
|
3323
|
|
|
|
|
|
|
sub _generate_predicate { |
3324
|
0
|
|
|
0
|
|
0
|
#my($self, $attribute, $metaclass) = @_; |
3325
|
|
|
|
|
|
|
my(undef, $attribute) = @_; |
3326
|
0
|
|
|
|
|
0
|
|
3327
|
|
|
|
|
|
|
my $slot = $attribute->name; |
3328
|
0
|
|
|
0
|
|
0
|
return sub{ |
3329
|
0
|
|
|
|
|
0
|
return exists $_[0]->{$slot}; |
3330
|
|
|
|
|
|
|
}; |
3331
|
|
|
|
|
|
|
} |
3332
|
|
|
|
|
|
|
|
3333
|
|
|
|
|
|
|
sub _generate_clearer { |
3334
|
0
|
|
|
0
|
|
0
|
#my($self, $attribute, $metaclass) = @_; |
3335
|
|
|
|
|
|
|
my(undef, $attribute) = @_; |
3336
|
0
|
|
|
|
|
0
|
|
3337
|
|
|
|
|
|
|
my $slot = $attribute->name; |
3338
|
0
|
|
|
0
|
|
0
|
return sub{ |
3339
|
0
|
|
|
|
|
0
|
delete $_[0]->{$slot}; |
3340
|
|
|
|
|
|
|
}; |
3341
|
|
|
|
|
|
|
} |
3342
|
|
|
|
|
|
|
|
3343
|
0
|
|
|
|
|
0
|
} |
3344
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Method/Constructor.pm |
3345
|
2
|
|
|
2
|
|
9
|
package Mouse::Meta::Method::Constructor; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
6
|
|
3346
|
|
|
|
|
|
|
use Mouse::Util qw(:meta); # enables strict and warnings |
3347
|
2
|
50
|
|
2
|
|
8
|
|
|
2
|
|
|
0
|
|
3
|
|
|
2
|
|
|
|
|
1767
|
|
3348
|
|
|
|
|
|
|
use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0; |
3349
|
|
|
|
|
|
|
|
3350
|
4
|
|
|
4
|
|
6
|
sub _inline_slot{ |
3351
|
4
|
|
|
|
|
13
|
my(undef, $self_var, $attr_name) = @_; |
3352
|
|
|
|
|
|
|
return sprintf '%s->{q{%s}}', $self_var, $attr_name; |
3353
|
|
|
|
|
|
|
} |
3354
|
|
|
|
|
|
|
|
3355
|
0
|
|
|
0
|
|
0
|
sub _generate_constructor { |
3356
|
|
|
|
|
|
|
my ($class, $metaclass, $args) = @_; |
3357
|
0
|
|
|
|
|
0
|
|
3358
|
|
|
|
|
|
|
my $associated_metaclass_name = $metaclass->name; |
3359
|
0
|
|
|
|
|
0
|
|
3360
|
0
|
|
|
|
|
0
|
my $buildall = $class->_generate_BUILDALL($metaclass); |
3361
|
|
|
|
|
|
|
my $buildargs = $class->_generate_BUILDARGS($metaclass); |
3362
|
0
|
|
0
|
|
|
0
|
my $initializer = $metaclass->{_mouse_cache}{_initialize_object} ||= |
3363
|
0
|
|
|
|
|
0
|
$class->_generate_initialize_object($metaclass); |
3364
|
|
|
|
|
|
|
my $source = sprintf(<<'EOT', __FILE__, $metaclass->name, $buildargs, $buildall); |
3365
|
|
|
|
|
|
|
#line 1 "%s" |
3366
|
|
|
|
|
|
|
package %s; |
3367
|
|
|
|
|
|
|
sub { |
3368
|
|
|
|
|
|
|
my $class = shift; |
3369
|
|
|
|
|
|
|
return $class->Mouse::Object::new(@_) |
3370
|
|
|
|
|
|
|
if $class ne __PACKAGE__; |
3371
|
|
|
|
|
|
|
# BUILDARGS |
3372
|
|
|
|
|
|
|
%s; |
3373
|
|
|
|
|
|
|
my $instance = bless {}, $class; |
3374
|
|
|
|
|
|
|
$metaclass->$initializer($instance, $args, 0); |
3375
|
|
|
|
|
|
|
# BUILDALL |
3376
|
|
|
|
|
|
|
%s; |
3377
|
|
|
|
|
|
|
return $instance; |
3378
|
|
|
|
|
|
|
} |
3379
|
0
|
|
|
|
|
0
|
EOT |
3380
|
0
|
|
|
|
|
0
|
warn $source if _MOUSE_DEBUG; |
3381
|
0
|
|
|
|
|
0
|
my $body; |
3382
|
0
|
|
|
|
|
0
|
my $e = do{ |
3383
|
0
|
|
|
|
|
0
|
local $@; |
3384
|
0
|
|
|
|
|
0
|
$body = eval $source; |
3385
|
|
|
|
|
|
|
$@; |
3386
|
0
|
0
|
|
|
|
0
|
}; |
3387
|
0
|
|
|
|
|
0
|
die $e if $e; |
3388
|
|
|
|
|
|
|
return $body; |
3389
|
|
|
|
|
|
|
} |
3390
|
|
|
|
|
|
|
|
3391
|
4
|
|
|
4
|
|
6
|
sub _generate_initialize_object { |
3392
|
4
|
|
|
|
|
10
|
my ($method_class, $metaclass) = @_; |
3393
|
|
|
|
|
|
|
my @attrs = $metaclass->get_all_attributes; |
3394
|
4
|
50
|
|
|
|
14
|
|
3395
|
4
|
|
|
|
|
10
|
my @checks = map { $_ && $_->_compiled_type_constraint } |
|
4
|
|
|
|
|
10
|
|
3396
|
|
|
|
|
|
|
map { $_->type_constraint } @attrs; |
3397
|
4
|
|
|
|
|
4
|
|
3398
|
|
|
|
|
|
|
my @res; |
3399
|
|
|
|
|
|
|
|
3400
|
4
|
|
|
|
|
10
|
my $has_triggers; |
3401
|
|
|
|
|
|
|
my $strict = $metaclass->strict_constructor; |
3402
|
4
|
50
|
|
|
|
8
|
|
3403
|
0
|
|
|
|
|
0
|
if($strict){ |
3404
|
|
|
|
|
|
|
push @res, 'my $used = 0;'; |
3405
|
|
|
|
|
|
|
} |
3406
|
4
|
|
|
|
|
12
|
|
3407
|
4
|
|
|
|
|
8
|
for my $index (0 .. @attrs - 1) { |
3408
|
|
|
|
|
|
|
my $code = ''; |
3409
|
4
|
|
|
|
|
5
|
|
3410
|
4
|
|
|
|
|
5
|
my $attr = $attrs[$index]; |
3411
|
|
|
|
|
|
|
my $key = $attr->name; |
3412
|
4
|
|
|
|
|
10
|
|
3413
|
4
|
|
|
|
|
6
|
my $init_arg = $attr->init_arg; |
3414
|
4
|
|
|
|
|
5
|
my $type_constraint = $attr->type_constraint; |
3415
|
4
|
|
|
|
|
4
|
my $is_weak_ref = $attr->is_weak_ref; |
3416
|
|
|
|
|
|
|
my $need_coercion; |
3417
|
4
|
|
|
|
|
11
|
|
3418
|
4
|
|
|
|
|
8
|
my $instance_slot = $method_class->_inline_slot('$instance', $key); |
3419
|
4
|
|
|
|
|
4
|
my $attr_var = "\$attrs[$index]"; |
3420
|
|
|
|
|
|
|
my $constraint_var; |
3421
|
4
|
50
|
|
|
|
9
|
|
3422
|
0
|
|
|
|
|
0
|
if(defined $type_constraint){ |
3423
|
0
|
|
0
|
|
|
0
|
$constraint_var = "$attr_var\->{type_constraint}"; |
3424
|
|
|
|
|
|
|
$need_coercion = ($attr->should_coerce && $type_constraint->has_coercion); |
3425
|
|
|
|
|
|
|
} |
3426
|
4
|
|
|
|
|
7
|
|
3427
|
|
|
|
|
|
|
$code .= "# initialize $key\n"; |
3428
|
4
|
|
|
|
|
5
|
|
3429
|
4
|
50
|
|
|
|
6
|
my $post_process = ''; |
3430
|
0
|
|
|
|
|
0
|
if(defined $type_constraint){ |
3431
|
0
|
|
|
|
|
0
|
$post_process .= "\$checks[$index]->($instance_slot)\n"; |
3432
|
|
|
|
|
|
|
$post_process .= " or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n"; |
3433
|
|
|
|
|
|
|
} |
3434
|
|
|
|
|
|
|
|
3435
|
4
|
50
|
|
|
|
10
|
# build cde for an attribute |
3436
|
4
|
|
|
|
|
5
|
if (defined $init_arg) { |
3437
|
|
|
|
|
|
|
my $value = "\$args->{q{$init_arg}}"; |
3438
|
4
|
|
|
|
|
8
|
|
3439
|
|
|
|
|
|
|
$code .= "if (exists $value) {\n"; |
3440
|
4
|
50
|
|
|
|
6
|
|
3441
|
0
|
|
|
|
|
0
|
if($need_coercion){ |
3442
|
|
|
|
|
|
|
$value = "$constraint_var->coerce($value)"; |
3443
|
|
|
|
|
|
|
} |
3444
|
4
|
|
|
|
|
7
|
|
3445
|
4
|
|
|
|
|
4
|
$code .= "$instance_slot = $value;\n"; |
3446
|
|
|
|
|
|
|
$code .= $post_process; |
3447
|
4
|
50
|
|
|
|
13
|
|
3448
|
0
|
|
|
|
|
0
|
if ($attr->has_trigger) { |
3449
|
0
|
|
|
|
|
0
|
$has_triggers++; |
3450
|
|
|
|
|
|
|
$code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n"; |
3451
|
|
|
|
|
|
|
} |
3452
|
4
|
50
|
|
|
|
7
|
|
3453
|
0
|
|
|
|
|
0
|
if ($strict){ |
3454
|
|
|
|
|
|
|
$code .= '++$used;' . "\n"; |
3455
|
|
|
|
|
|
|
} |
3456
|
4
|
|
|
|
|
10
|
|
3457
|
|
|
|
|
|
|
$code .= "\n} else {\n"; # $value exists |
3458
|
|
|
|
|
|
|
} |
3459
|
4
|
50
|
33
|
|
|
8
|
|
|
|
50
|
|
|
|
|
|
3460
|
0
|
0
|
|
|
|
0
|
if ($attr->has_default || $attr->has_builder) { |
3461
|
0
|
|
|
|
|
0
|
unless ($attr->is_lazy) { |
3462
|
0
|
|
|
|
|
0
|
my $default = $attr->default; |
3463
|
|
|
|
|
|
|
my $builder = $attr->builder; |
3464
|
0
|
|
|
|
|
0
|
|
3465
|
0
|
0
|
|
|
|
0
|
my $value; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
3466
|
0
|
|
|
|
|
0
|
if (defined($builder)) { |
3467
|
|
|
|
|
|
|
$value = "\$instance->$builder()"; |
3468
|
|
|
|
|
|
|
} |
3469
|
0
|
|
|
|
|
0
|
elsif (ref($default) eq 'CODE') { |
3470
|
|
|
|
|
|
|
$value = "$attr_var\->{default}->(\$instance)"; |
3471
|
|
|
|
|
|
|
} |
3472
|
0
|
|
|
|
|
0
|
elsif (defined($default)) { |
3473
|
|
|
|
|
|
|
$value = "$attr_var\->{default}"; |
3474
|
|
|
|
|
|
|
} |
3475
|
0
|
|
|
|
|
0
|
else { |
3476
|
|
|
|
|
|
|
$value = 'undef'; |
3477
|
|
|
|
|
|
|
} |
3478
|
0
|
0
|
|
|
|
0
|
|
3479
|
0
|
|
|
|
|
0
|
if($need_coercion){ |
3480
|
|
|
|
|
|
|
$value = "$constraint_var->coerce($value)"; |
3481
|
|
|
|
|
|
|
} |
3482
|
0
|
|
|
|
|
0
|
|
3483
|
0
|
|
|
|
|
0
|
$code .= "$instance_slot = $value;\n"; |
3484
|
|
|
|
|
|
|
$code .= $post_process; |
3485
|
|
|
|
|
|
|
} |
3486
|
|
|
|
|
|
|
} |
3487
|
0
|
|
|
|
|
0
|
elsif ($attr->is_required) { |
3488
|
0
|
|
|
|
|
0
|
$code .= "\$meta->throw_error('Attribute ($key) is required')"; |
3489
|
|
|
|
|
|
|
$code .= " unless \$is_cloning;\n"; |
3490
|
|
|
|
|
|
|
} |
3491
|
4
|
50
|
|
|
|
9
|
|
3492
|
|
|
|
|
|
|
$code .= "}\n" if defined $init_arg; |
3493
|
4
|
50
|
|
|
|
7
|
|
3494
|
0
|
|
|
|
|
0
|
if($is_weak_ref){ |
3495
|
|
|
|
|
|
|
$code .= "Scalar::Util::weaken($instance_slot) " |
3496
|
|
|
|
|
|
|
. "if ref $instance_slot and not Scalar::Util::isweak($instance_slot);\n"; |
3497
|
|
|
|
|
|
|
} |
3498
|
4
|
|
|
|
|
8
|
|
3499
|
|
|
|
|
|
|
push @res, $code; |
3500
|
|
|
|
|
|
|
} |
3501
|
4
|
50
|
|
|
|
7
|
|
3502
|
0
|
|
|
|
|
0
|
if($strict){ |
3503
|
|
|
|
|
|
|
push @res, q{if($used < keys %{$args})} |
3504
|
|
|
|
|
|
|
. q{{ $meta->_report_unknown_args(\@attrs, $args) }}; |
3505
|
|
|
|
|
|
|
} |
3506
|
4
|
50
|
|
|
|
8
|
|
3507
|
0
|
|
|
|
|
0
|
if($metaclass->is_anon_class){ |
3508
|
|
|
|
|
|
|
push @res, q{$instance->{__METACLASS__} = $meta;}; |
3509
|
|
|
|
|
|
|
} |
3510
|
4
|
50
|
|
|
|
8
|
|
3511
|
0
|
|
|
|
|
0
|
if($has_triggers){ |
3512
|
0
|
|
|
|
|
0
|
unshift @res, q{my @triggers;}; |
3513
|
|
|
|
|
|
|
push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;}; |
3514
|
|
|
|
|
|
|
} |
3515
|
4
|
|
|
|
|
6
|
|
3516
|
|
|
|
|
|
|
my $source = sprintf <<'EOT', __FILE__, $metaclass->name, join "\n", @res; |
3517
|
|
|
|
|
|
|
#line 1 "%s" |
3518
|
|
|
|
|
|
|
package %s; |
3519
|
|
|
|
|
|
|
sub { |
3520
|
|
|
|
|
|
|
my($meta, $instance, $args, $is_cloning) = @_; |
3521
|
|
|
|
|
|
|
%s; |
3522
|
|
|
|
|
|
|
return $instance; |
3523
|
|
|
|
|
|
|
} |
3524
|
4
|
|
|
|
|
4
|
EOT |
3525
|
4
|
|
|
|
|
2
|
warn $source if _MOUSE_DEBUG; |
3526
|
4
|
|
|
|
|
5
|
my $body; |
3527
|
4
|
|
|
|
|
9
|
my $e = do { |
3528
|
4
|
|
|
|
|
310
|
local $@; |
3529
|
4
|
|
|
|
|
7
|
$body = eval $source; |
3530
|
|
|
|
|
|
|
$@; |
3531
|
4
|
50
|
|
|
|
10
|
}; |
3532
|
4
|
|
|
|
|
14
|
die $e if $e; |
3533
|
|
|
|
|
|
|
return $body; |
3534
|
|
|
|
|
|
|
} |
3535
|
|
|
|
|
|
|
|
3536
|
0
|
|
|
0
|
|
0
|
sub _generate_BUILDARGS { |
3537
|
|
|
|
|
|
|
my(undef, $metaclass) = @_; |
3538
|
0
|
|
|
|
|
0
|
|
3539
|
0
|
0
|
0
|
|
|
0
|
my $class = $metaclass->name; |
3540
|
0
|
|
|
|
|
0
|
if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) { |
3541
|
|
|
|
|
|
|
return 'my $args = $class->BUILDARGS(@_)'; |
3542
|
|
|
|
|
|
|
} |
3543
|
0
|
|
|
|
|
0
|
|
3544
|
|
|
|
|
|
|
return <<'...'; |
3545
|
|
|
|
|
|
|
my $args; |
3546
|
|
|
|
|
|
|
if ( scalar @_ == 1 ) { |
3547
|
|
|
|
|
|
|
( ref( $_[0] ) eq 'HASH' ) |
3548
|
|
|
|
|
|
|
|| Carp::confess "Single parameters to new() must be a HASH ref"; |
3549
|
|
|
|
|
|
|
$args = +{ %{ $_[0] } }; |
3550
|
|
|
|
|
|
|
} |
3551
|
|
|
|
|
|
|
else { |
3552
|
|
|
|
|
|
|
$args = +{@_}; |
3553
|
|
|
|
|
|
|
} |
3554
|
|
|
|
|
|
|
... |
3555
|
|
|
|
|
|
|
} |
3556
|
|
|
|
|
|
|
|
3557
|
0
|
|
|
0
|
|
0
|
sub _generate_BUILDALL { |
3558
|
|
|
|
|
|
|
my (undef, $metaclass) = @_; |
3559
|
0
|
0
|
|
|
|
0
|
|
3560
|
|
|
|
|
|
|
return '' unless $metaclass->name->can('BUILD'); |
3561
|
0
|
|
|
|
|
0
|
|
3562
|
0
|
|
|
|
|
0
|
my @code; |
3563
|
0
|
0
|
|
|
|
0
|
for my $class ($metaclass->linearized_isa) { |
3564
|
0
|
|
|
|
|
0
|
if (Mouse::Util::get_code_ref($class, 'BUILD')) { |
3565
|
|
|
|
|
|
|
unshift @code, qq{${class}::BUILD(\$instance, \$args);}; |
3566
|
|
|
|
|
|
|
} |
3567
|
0
|
|
|
|
|
0
|
} |
3568
|
|
|
|
|
|
|
return join "\n", @code; |
3569
|
|
|
|
|
|
|
} |
3570
|
|
|
|
|
|
|
|
3571
|
0
|
|
|
|
|
0
|
} |
3572
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Method/Delegation.pm |
3573
|
2
|
|
|
2
|
|
12
|
package Mouse::Meta::Method::Delegation; |
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
4
|
|
3574
|
2
|
|
|
2
|
|
7
|
use Mouse::Util qw(:meta); # enables strict and warnings |
|
2
|
|
|
0
|
|
2
|
|
|
2
|
|
|
|
|
607
|
|
3575
|
|
|
|
|
|
|
use Scalar::Util; |
3576
|
|
|
|
|
|
|
|
3577
|
0
|
|
|
0
|
|
0
|
sub _generate_delegation{ |
3578
|
|
|
|
|
|
|
my (undef, $attr, $handle_name, $method_to_call) = @_; |
3579
|
0
|
|
|
|
|
0
|
|
3580
|
0
|
0
|
|
|
|
0
|
my @curried_args; |
3581
|
0
|
|
|
|
|
0
|
if(ref($method_to_call) eq 'ARRAY'){ |
|
0
|
|
|
|
|
0
|
|
3582
|
|
|
|
|
|
|
($method_to_call, @curried_args) = @{$method_to_call}; |
3583
|
|
|
|
|
|
|
} |
3584
|
|
|
|
|
|
|
|
3585
|
0
|
|
0
|
|
|
0
|
# If it has a reader, we must use it to make method modifiers work |
3586
|
|
|
|
|
|
|
my $reader = $attr->get_read_method() || $attr->get_read_method_ref(); |
3587
|
0
|
|
|
|
|
0
|
|
3588
|
|
|
|
|
|
|
my $can_be_optimized = $attr->{_mouse_cache_method_delegation_can_be_optimized}; |
3589
|
0
|
0
|
|
|
|
0
|
|
3590
|
0
|
|
|
|
|
0
|
if(!defined $can_be_optimized){ |
3591
|
|
|
|
|
|
|
my $tc = $attr->type_constraint; |
3592
|
0
|
|
0
|
|
|
0
|
$attr->{_mouse_cache_method_delegation_can_be_optimized} = |
3593
|
|
|
|
|
|
|
(defined($tc) && $tc->is_a_type_of('Object')) |
3594
|
|
|
|
|
|
|
&& ($attr->is_required || $attr->has_default || $attr->has_builder) |
3595
|
|
|
|
|
|
|
&& ($attr->is_lazy || !$attr->has_clearer); |
3596
|
|
|
|
|
|
|
} |
3597
|
0
|
0
|
|
|
|
0
|
|
3598
|
|
|
|
|
|
|
if($can_be_optimized){ |
3599
|
|
|
|
|
|
|
# need not check the attribute value |
3600
|
0
|
|
|
0
|
|
0
|
return sub { |
3601
|
0
|
|
|
|
|
0
|
return shift()->$reader()->$method_to_call(@curried_args, @_); |
3602
|
|
|
|
|
|
|
}; |
3603
|
|
|
|
|
|
|
} |
3604
|
|
|
|
|
|
|
else { |
3605
|
|
|
|
|
|
|
# need to check the attribute value |
3606
|
0
|
|
|
0
|
|
0
|
return sub { |
3607
|
0
|
|
|
|
|
0
|
my $instance = shift; |
3608
|
|
|
|
|
|
|
my $proxy = $instance->$reader(); |
3609
|
0
|
0
|
0
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
3610
|
|
|
|
|
|
|
my $error = !defined($proxy) ? ' is not defined' |
3611
|
|
|
|
|
|
|
: ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')} |
3612
|
0
|
0
|
|
|
|
0
|
: undef; |
3613
|
0
|
|
|
|
|
0
|
if ($error) { |
3614
|
|
|
|
|
|
|
$instance->meta->throw_error( |
3615
|
|
|
|
|
|
|
"Cannot delegate $handle_name to $method_to_call because " |
3616
|
|
|
|
|
|
|
. "the value of " |
3617
|
|
|
|
|
|
|
. $attr->name |
3618
|
|
|
|
|
|
|
. $error |
3619
|
|
|
|
|
|
|
); |
3620
|
0
|
|
|
|
|
0
|
} |
3621
|
0
|
|
|
|
|
0
|
$proxy->$method_to_call(@curried_args, @_); |
3622
|
|
|
|
|
|
|
}; |
3623
|
|
|
|
|
|
|
} |
3624
|
|
|
|
|
|
|
} |
3625
|
|
|
|
|
|
|
|
3626
|
|
|
|
|
|
|
|
3627
|
0
|
|
|
|
|
0
|
} |
3628
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Method/Destructor.pm |
3629
|
2
|
|
|
2
|
|
12
|
package Mouse::Meta::Method::Destructor; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
5
|
|
3630
|
|
|
|
|
|
|
use Mouse::Util qw(:meta); # enables strict and warnings |
3631
|
2
|
50
|
|
2
|
|
7
|
|
|
2
|
|
|
0
|
|
3
|
|
|
2
|
|
|
|
|
369
|
|
3632
|
|
|
|
|
|
|
use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0; |
3633
|
|
|
|
|
|
|
|
3634
|
0
|
|
|
0
|
|
0
|
sub _generate_destructor{ |
3635
|
|
|
|
|
|
|
my (undef, $metaclass) = @_; |
3636
|
0
|
|
|
|
|
0
|
|
3637
|
0
|
|
|
|
|
0
|
my $demolishall = ''; |
3638
|
0
|
0
|
|
|
|
0
|
for my $class ($metaclass->linearized_isa) { |
3639
|
0
|
|
|
|
|
0
|
if (Mouse::Util::get_code_ref($class, 'DEMOLISH')) { |
3640
|
|
|
|
|
|
|
$demolishall .= ' ' . $class |
3641
|
|
|
|
|
|
|
. '::DEMOLISH($self, Mouse::Util::in_global_destruction());' |
3642
|
|
|
|
|
|
|
. "\n", |
3643
|
|
|
|
|
|
|
} |
3644
|
|
|
|
|
|
|
} |
3645
|
0
|
0
|
|
|
|
0
|
|
3646
|
0
|
|
|
|
|
0
|
if($demolishall) { |
3647
|
|
|
|
|
|
|
$demolishall = sprintf <<'EOT', $demolishall; |
3648
|
|
|
|
|
|
|
my $e = do{ |
3649
|
|
|
|
|
|
|
local $?; |
3650
|
|
|
|
|
|
|
local $@; |
3651
|
|
|
|
|
|
|
eval{ |
3652
|
|
|
|
|
|
|
%s; |
3653
|
|
|
|
|
|
|
}; |
3654
|
|
|
|
|
|
|
$@; |
3655
|
|
|
|
|
|
|
}; |
3656
|
|
|
|
|
|
|
no warnings 'misc'; |
3657
|
|
|
|
|
|
|
die $e if $e; # rethrow |
3658
|
|
|
|
|
|
|
EOT |
3659
|
|
|
|
|
|
|
} |
3660
|
0
|
|
|
|
|
0
|
|
3661
|
0
|
|
|
|
|
0
|
my $name = $metaclass->name; |
3662
|
|
|
|
|
|
|
my $source = sprintf(<<'EOT', __FILE__, $name, $demolishall); |
3663
|
|
|
|
|
|
|
#line 1 "%s" |
3664
|
|
|
|
|
|
|
package %s; |
3665
|
|
|
|
|
|
|
sub { |
3666
|
|
|
|
|
|
|
my($self) = @_; |
3667
|
|
|
|
|
|
|
return $self->Mouse::Object::DESTROY() |
3668
|
|
|
|
|
|
|
if ref($self) ne __PACKAGE__; |
3669
|
|
|
|
|
|
|
# DEMOLISHALL |
3670
|
|
|
|
|
|
|
%s; |
3671
|
|
|
|
|
|
|
return; |
3672
|
|
|
|
|
|
|
} |
3673
|
|
|
|
|
|
|
EOT |
3674
|
0
|
|
|
|
|
0
|
|
3675
|
|
|
|
|
|
|
warn $source if _MOUSE_DEBUG; |
3676
|
0
|
|
|
|
|
0
|
|
3677
|
0
|
|
|
|
|
0
|
my $code; |
3678
|
0
|
|
|
|
|
0
|
my $e = do{ |
3679
|
0
|
|
|
|
|
0
|
local $@; |
3680
|
0
|
|
|
|
|
0
|
$code = eval $source; |
3681
|
|
|
|
|
|
|
$@; |
3682
|
0
|
0
|
|
|
|
0
|
}; |
3683
|
0
|
|
|
|
|
0
|
die $e if $e; |
3684
|
|
|
|
|
|
|
return $code; |
3685
|
|
|
|
|
|
|
} |
3686
|
|
|
|
|
|
|
|
3687
|
0
|
|
|
|
|
0
|
} |
3688
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Module.pm |
3689
|
2
|
|
|
2
|
|
9
|
package Mouse::Meta::Module; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4
|
|
3690
|
|
|
|
|
|
|
use Mouse::Util qw/:meta/; # enables strict and warnings |
3691
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
20
|
|
3692
|
2
|
|
|
2
|
|
5
|
use Carp (); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
1679
|
|
3693
|
|
|
|
|
|
|
use Scalar::Util (); |
3694
|
2
|
|
|
2
|
|
5
|
|
3695
|
|
|
|
|
|
|
my %METAS; |
3696
|
2
|
|
|
|
|
1
|
|
3697
|
|
|
|
|
|
|
if(Mouse::Util::MOUSE_XS){ |
3698
|
|
|
|
|
|
|
# register meta storage for performance |
3699
|
|
|
|
|
|
|
Mouse::Util::__register_metaclass_storage(\%METAS, 0); |
3700
|
|
|
|
|
|
|
|
3701
|
|
|
|
|
|
|
# ensure thread safety |
3702
|
|
|
|
|
|
|
*CLONE = sub { Mouse::Util::__register_metaclass_storage(\%METAS, 1) }; |
3703
|
|
|
|
|
|
|
} |
3704
|
|
|
|
|
|
|
|
3705
|
12
|
|
|
12
|
0
|
15
|
sub initialize { |
3706
|
|
|
|
|
|
|
my($class, $package_name, @args) = @_; |
3707
|
12
|
50
|
33
|
|
|
71
|
|
3708
|
|
|
|
|
|
|
($package_name && !ref($package_name)) |
3709
|
|
|
|
|
|
|
|| $class->throw_error("You must pass a package name and it cannot be blessed"); |
3710
|
12
|
|
66
|
|
|
58
|
|
3711
|
|
|
|
|
|
|
return $METAS{$package_name} |
3712
|
|
|
|
|
|
|
||= $class->_construct_meta(package => $package_name, @args); |
3713
|
|
|
|
|
|
|
} |
3714
|
|
|
|
|
|
|
|
3715
|
0
|
|
|
0
|
0
|
0
|
sub reinitialize { |
3716
|
|
|
|
|
|
|
my($class, $package_name, @args) = @_; |
3717
|
0
|
0
|
|
|
|
0
|
|
3718
|
|
|
|
|
|
|
$package_name = $package_name->name if ref $package_name; |
3719
|
0
|
0
|
0
|
|
|
0
|
|
3720
|
|
|
|
|
|
|
($package_name && !ref($package_name)) |
3721
|
|
|
|
|
|
|
|| $class->throw_error("You must pass a package name and it cannot be blessed"); |
3722
|
0
|
0
|
|
|
|
0
|
|
3723
|
0
|
|
|
|
|
0
|
if(exists $METAS{$package_name}) { |
|
0
|
|
|
|
|
0
|
|
3724
|
|
|
|
|
|
|
unshift @args, %{ $METAS{$package_name} }; |
3725
|
0
|
|
|
|
|
0
|
} |
3726
|
0
|
|
|
|
|
0
|
delete $METAS{$package_name}; |
3727
|
|
|
|
|
|
|
return $class->initialize($package_name, @args); |
3728
|
|
|
|
|
|
|
} |
3729
|
|
|
|
|
|
|
|
3730
|
0
|
|
|
0
|
|
0
|
sub _class_of{ |
3731
|
0
|
0
|
|
|
|
0
|
my($class_or_instance) = @_; |
3732
|
0
|
|
0
|
|
|
0
|
return undef unless defined $class_or_instance; |
3733
|
|
|
|
|
|
|
return $METAS{ ref($class_or_instance) || $class_or_instance }; |
3734
|
|
|
|
|
|
|
} |
3735
|
|
|
|
|
|
|
|
3736
|
|
|
|
|
|
|
# Means of accessing all the metaclasses that have |
3737
|
|
|
|
|
|
|
# been initialized thus far. |
3738
|
|
|
|
|
|
|
# The public versions are aliased into Mouse::Util::*. |
3739
|
0
|
|
|
0
|
|
0
|
#sub _get_all_metaclasses { %METAS } |
3740
|
0
|
|
|
0
|
|
0
|
sub _get_all_metaclass_instances { values %METAS } |
3741
|
20
|
|
|
20
|
|
42
|
sub _get_all_metaclass_names { keys %METAS } |
3742
|
|
|
|
|
|
|
sub _get_metaclass_by_name { $METAS{$_[0]} } |
3743
|
|
|
|
|
|
|
#sub _store_metaclass_by_name { $METAS{$_[0]} = $_[1] } |
3744
|
|
|
|
|
|
|
#sub _weaken_metaclass { weaken($METAS{$_[0]}) } |
3745
|
|
|
|
|
|
|
#sub _does_metaclass_exist { defined $METAS{$_[0]} } |
3746
|
|
|
|
|
|
|
#sub _remove_metaclass_by_name { delete $METAS{$_[0]} } |
3747
|
|
|
|
|
|
|
|
3748
|
|
|
|
|
|
|
sub name; |
3749
|
|
|
|
|
|
|
|
3750
|
|
|
|
|
|
|
sub namespace; |
3751
|
|
|
|
|
|
|
|
3752
|
|
|
|
|
|
|
# add_attribute is an abstract method |
3753
|
|
|
|
|
|
|
|
3754
|
0
|
|
|
0
|
0
|
|
sub get_attribute_map { # DEPRECATED |
3755
|
0
|
|
|
|
|
|
Carp::cluck('get_attribute_map() has been deprecated. Use get_attribute_list() and get_attribute() instead'); |
3756
|
|
|
|
|
|
|
return $_[0]->{attributes}; |
3757
|
|
|
|
|
|
|
} |
3758
|
0
|
|
|
0
|
0
|
|
|
3759
|
0
|
|
|
0
|
0
|
|
sub has_attribute { exists $_[0]->{attributes}->{$_[1]} } |
3760
|
0
|
|
|
0
|
0
|
|
sub get_attribute { $_[0]->{attributes}->{$_[1]} } |
3761
|
|
|
|
|
|
|
sub remove_attribute { delete $_[0]->{attributes}->{$_[1]} } |
3762
|
0
|
|
|
0
|
0
|
|
|
|
0
|
|
|
|
|
|
|
3763
|
|
|
|
|
|
|
sub get_attribute_list{ keys %{$_[0]->{attributes}} } |
3764
|
|
|
|
|
|
|
|
3765
|
2
|
|
|
|
|
3
|
# XXX: not completely compatible with Moose |
|
14
|
|
|
|
|
20
|
|
3766
|
|
|
|
|
|
|
my %foreign = map{ $_ => undef } qw( |
3767
|
|
|
|
|
|
|
Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints |
3768
|
|
|
|
|
|
|
Carp Scalar::Util List::Util |
3769
|
|
|
|
|
|
|
); |
3770
|
0
|
|
|
0
|
|
|
sub _get_method_body { |
3771
|
0
|
|
|
|
|
|
my($self, $method_name) = @_; |
3772
|
0
|
0
|
0
|
|
|
|
my $code = Mouse::Util::get_code_ref($self->{package}, $method_name); |
3773
|
|
|
|
|
|
|
return $code && !exists $foreign{ Mouse::Util::get_code_package($code) } |
3774
|
|
|
|
|
|
|
? $code |
3775
|
|
|
|
|
|
|
: undef; |
3776
|
|
|
|
|
|
|
} |
3777
|
|
|
|
|
|
|
|
3778
|
|
|
|
|
|
|
sub add_method; |
3779
|
|
|
|
|
|
|
|
3780
|
0
|
|
|
0
|
0
|
|
sub has_method { |
3781
|
0
|
0
|
|
|
|
|
my($self, $method_name) = @_; |
3782
|
|
|
|
|
|
|
defined($method_name) |
3783
|
|
|
|
|
|
|
or $self->throw_error('You must define a method name'); |
3784
|
0
|
|
0
|
|
|
|
|
3785
|
|
|
|
|
|
|
return defined( $self->{methods}{$method_name} ) |
3786
|
|
|
|
|
|
|
|| defined( $self->_get_method_body($method_name) ); |
3787
|
|
|
|
|
|
|
} |
3788
|
|
|
|
|
|
|
|
3789
|
0
|
|
|
0
|
0
|
|
sub get_method_body { |
3790
|
0
|
0
|
|
|
|
|
my($self, $method_name) = @_; |
3791
|
|
|
|
|
|
|
defined($method_name) |
3792
|
|
|
|
|
|
|
or $self->throw_error('You must define a method name'); |
3793
|
0
|
|
0
|
|
|
|
|
3794
|
|
|
|
|
|
|
return $self->{methods}{$method_name} |
3795
|
|
|
|
|
|
|
||= $self->_get_method_body($method_name); |
3796
|
|
|
|
|
|
|
} |
3797
|
|
|
|
|
|
|
|
3798
|
0
|
|
|
0
|
0
|
|
sub get_method { |
3799
|
|
|
|
|
|
|
my($self, $method_name) = @_; |
3800
|
0
|
0
|
|
|
|
|
|
3801
|
0
|
|
|
|
|
|
if(my $code = $self->get_method_body($method_name)){ |
3802
|
|
|
|
|
|
|
return Mouse::Util::load_class($self->method_metaclass)->wrap( |
3803
|
|
|
|
|
|
|
body => $code, |
3804
|
|
|
|
|
|
|
name => $method_name, |
3805
|
|
|
|
|
|
|
package => $self->name, |
3806
|
|
|
|
|
|
|
associated_metaclass => $self, |
3807
|
|
|
|
|
|
|
); |
3808
|
|
|
|
|
|
|
} |
3809
|
0
|
|
|
|
|
|
|
3810
|
|
|
|
|
|
|
return undef; |
3811
|
|
|
|
|
|
|
} |
3812
|
|
|
|
|
|
|
|
3813
|
0
|
|
|
0
|
0
|
|
sub get_method_list { |
3814
|
|
|
|
|
|
|
my($self) = @_; |
3815
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
3816
|
|
|
|
|
|
|
return grep { $self->has_method($_) } keys %{ $self->namespace }; |
3817
|
|
|
|
|
|
|
} |
3818
|
|
|
|
|
|
|
|
3819
|
0
|
|
|
0
|
|
|
sub _collect_methods { # Mouse specific, used for method modifiers |
3820
|
|
|
|
|
|
|
my($meta, @args) = @_; |
3821
|
0
|
|
|
|
|
|
|
3822
|
0
|
|
|
|
|
|
my @methods; |
3823
|
0
|
0
|
|
|
|
|
foreach my $arg(@args){ |
3824
|
0
|
0
|
|
|
|
|
if(my $type = ref $arg){ |
|
|
0
|
|
|
|
|
|
3825
|
0
|
|
|
|
|
|
if($type eq 'Regexp'){ |
|
0
|
|
|
|
|
|
|
3826
|
|
|
|
|
|
|
push @methods, grep { $_ =~ $arg } $meta->get_all_method_names; |
3827
|
|
|
|
|
|
|
} |
3828
|
0
|
|
|
|
|
|
elsif($type eq 'ARRAY'){ |
|
0
|
|
|
|
|
|
|
3829
|
|
|
|
|
|
|
push @methods, @{$arg}; |
3830
|
|
|
|
|
|
|
} |
3831
|
0
|
|
|
|
|
|
else{ |
3832
|
0
|
|
|
|
|
|
my $subname = ( caller(1) )[3]; |
3833
|
|
|
|
|
|
|
$meta->throw_error( |
3834
|
|
|
|
|
|
|
sprintf( |
3835
|
|
|
|
|
|
|
'Methods passed to %s must be provided as a list,' |
3836
|
|
|
|
|
|
|
. ' ArrayRef or regular expression, not %s', |
3837
|
|
|
|
|
|
|
$subname, |
3838
|
|
|
|
|
|
|
$type, |
3839
|
|
|
|
|
|
|
) |
3840
|
|
|
|
|
|
|
); |
3841
|
|
|
|
|
|
|
} |
3842
|
|
|
|
|
|
|
} |
3843
|
0
|
|
|
|
|
|
else{ |
3844
|
|
|
|
|
|
|
push @methods, $arg; |
3845
|
|
|
|
|
|
|
} |
3846
|
0
|
|
|
|
|
|
} |
3847
|
|
|
|
|
|
|
return @methods; |
3848
|
|
|
|
|
|
|
} |
3849
|
2
|
|
|
|
|
4
|
|
3850
|
2
|
|
|
|
|
62
|
my $ANON_SERIAL = 0; # anonymous class/role id |
3851
|
|
|
|
|
|
|
my %IMMORTALS; # immortal anonymous classes |
3852
|
|
|
|
|
|
|
|
3853
|
0
|
|
|
0
|
0
|
|
sub create { |
3854
|
|
|
|
|
|
|
my($self, $package_name, %options) = @_; |
3855
|
0
|
|
0
|
|
|
|
|
3856
|
0
|
0
|
|
|
|
|
my $class = ref($self) || $self; |
3857
|
|
|
|
|
|
|
$self->throw_error('You must pass a package name') if @_ < 2; |
3858
|
0
|
|
|
|
|
|
|
3859
|
0
|
0
|
|
|
|
|
my $superclasses; |
3860
|
0
|
0
|
|
|
|
|
if(exists $options{superclasses}){ |
3861
|
0
|
|
|
|
|
|
if(Mouse::Util::is_a_metarole($self)){ |
3862
|
|
|
|
|
|
|
delete $options{superclasses}; |
3863
|
|
|
|
|
|
|
} |
3864
|
0
|
|
|
|
|
|
else{ |
3865
|
0
|
0
|
|
|
|
|
$superclasses = delete $options{superclasses}; |
3866
|
|
|
|
|
|
|
(ref $superclasses eq 'ARRAY') |
3867
|
|
|
|
|
|
|
|| $self->throw_error("You must pass an ARRAY ref of superclasses"); |
3868
|
|
|
|
|
|
|
} |
3869
|
|
|
|
|
|
|
} |
3870
|
0
|
|
|
|
|
|
|
3871
|
0
|
0
|
|
|
|
|
my $attributes = delete $options{attributes}; |
3872
|
0
|
0
|
0
|
|
|
|
if(defined $attributes){ |
3873
|
|
|
|
|
|
|
(ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH') |
3874
|
|
|
|
|
|
|
|| $self->throw_error("You must pass an ARRAY ref of attributes"); |
3875
|
0
|
|
|
|
|
|
} |
3876
|
0
|
0
|
|
|
|
|
my $methods = delete $options{methods}; |
3877
|
0
|
0
|
|
|
|
|
if(defined $methods){ |
3878
|
|
|
|
|
|
|
(ref $methods eq 'HASH') |
3879
|
|
|
|
|
|
|
|| $self->throw_error("You must pass a HASH ref of methods"); |
3880
|
0
|
|
|
|
|
|
} |
3881
|
0
|
0
|
|
|
|
|
my $roles = delete $options{roles}; |
3882
|
0
|
0
|
|
|
|
|
if(defined $roles){ |
3883
|
|
|
|
|
|
|
(ref $roles eq 'ARRAY') |
3884
|
|
|
|
|
|
|
|| $self->throw_error("You must pass an ARRAY ref of roles"); |
3885
|
0
|
|
|
|
|
|
} |
3886
|
|
|
|
|
|
|
my $mortal; |
3887
|
|
|
|
|
|
|
my $cache_key; |
3888
|
0
|
0
|
|
|
|
|
|
3889
|
0
|
|
|
|
|
|
if(!defined $package_name){ # anonymous |
3890
|
|
|
|
|
|
|
$mortal = !$options{cache}; |
3891
|
|
|
|
|
|
|
|
3892
|
0
|
0
|
|
|
|
|
# anonymous but immortal |
3893
|
|
|
|
|
|
|
if(!$mortal){ |
3894
|
|
|
|
|
|
|
# something like Super::Class|Super::Class::2=Role|Role::1 |
3895
|
0
|
0
|
|
|
|
|
$cache_key = join '=' => ( |
3896
|
0
|
0
|
|
|
|
|
join('|', @{$superclasses || []}), |
|
0
|
|
|
|
|
|
|
3897
|
|
|
|
|
|
|
join('|', sort @{$roles || []}), |
3898
|
0
|
0
|
|
|
|
|
); |
3899
|
|
|
|
|
|
|
return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key}; |
3900
|
0
|
|
|
|
|
|
} |
3901
|
0
|
|
|
|
|
|
$options{anon_serial_id} = ++$ANON_SERIAL; |
3902
|
|
|
|
|
|
|
$package_name = $class . '::__ANON__::' . $ANON_SERIAL; |
3903
|
|
|
|
|
|
|
} |
3904
|
|
|
|
|
|
|
|
3905
|
|
|
|
|
|
|
|
3906
|
|
|
|
|
|
|
# instantiate a module |
3907
|
2
|
|
|
2
|
|
9
|
{ |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
625
|
|
|
0
|
|
|
|
|
|
|
3908
|
0
|
0
|
|
|
|
|
no strict 'refs'; |
|
0
|
|
|
|
|
|
|
3909
|
0
|
0
|
|
|
|
|
${ $package_name . '::VERSION' } = delete $options{version} if exists $options{version}; |
|
0
|
|
|
|
|
|
|
3910
|
|
|
|
|
|
|
${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority}; |
3911
|
|
|
|
|
|
|
} |
3912
|
0
|
|
|
|
|
|
|
3913
|
|
|
|
|
|
|
my $meta = $self->initialize( $package_name, %options); |
3914
|
0
|
0
|
|
|
|
|
|
3915
|
|
|
|
|
|
|
Scalar::Util::weaken($METAS{$package_name}) |
3916
|
|
|
|
|
|
|
if $mortal; |
3917
|
|
|
|
|
|
|
|
3918
|
0
|
|
0
|
0
|
|
|
$meta->add_method(meta => sub { |
3919
|
0
|
|
|
|
|
|
$self->initialize(ref($_[0]) || $_[0]); |
3920
|
|
|
|
|
|
|
}); |
3921
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
3922
|
|
|
|
|
|
|
$meta->superclasses(@{$superclasses}) |
3923
|
|
|
|
|
|
|
if defined $superclasses; |
3924
|
|
|
|
|
|
|
|
3925
|
|
|
|
|
|
|
# NOTE: |
3926
|
|
|
|
|
|
|
# process attributes first, so that they can |
3927
|
|
|
|
|
|
|
# install accessors, but locally defined methods |
3928
|
|
|
|
|
|
|
# can then overwrite them. It is maybe a little odd, but |
3929
|
0
|
0
|
|
|
|
|
# I think this should be the order of things. |
3930
|
0
|
0
|
|
|
|
|
if (defined $attributes) { |
3931
|
|
|
|
|
|
|
if(ref($attributes) eq 'ARRAY'){ |
3932
|
0
|
|
|
|
|
|
# array of Mouse::Meta::Attribute |
|
0
|
|
|
|
|
|
|
3933
|
0
|
|
|
|
|
|
foreach my $attr (@{$attributes}) { |
3934
|
|
|
|
|
|
|
$meta->add_attribute($attr); |
3935
|
|
|
|
|
|
|
} |
3936
|
|
|
|
|
|
|
} |
3937
|
|
|
|
|
|
|
else{ |
3938
|
0
|
|
|
|
|
|
# hash map of name and attribute spec pairs |
|
0
|
|
|
|
|
|
|
3939
|
0
|
|
|
|
|
|
while(my($name, $attr) = each %{$attributes}){ |
3940
|
|
|
|
|
|
|
$meta->add_attribute($name => $attr); |
3941
|
|
|
|
|
|
|
} |
3942
|
|
|
|
|
|
|
} |
3943
|
0
|
0
|
|
|
|
|
} |
3944
|
0
|
|
|
|
|
|
if (defined $methods) { |
|
0
|
|
|
|
|
|
|
3945
|
0
|
|
|
|
|
|
while(my($method_name, $method_body) = each %{$methods}){ |
3946
|
|
|
|
|
|
|
$meta->add_method($method_name, $method_body); |
3947
|
|
|
|
|
|
|
} |
3948
|
0
|
0
|
0
|
|
|
|
} |
3949
|
0
|
|
|
|
|
|
if (defined $roles and !$options{in_application_to_instance}){ |
|
0
|
|
|
|
|
|
|
3950
|
|
|
|
|
|
|
Mouse::Util::apply_all_roles($package_name, @{$roles}); |
3951
|
|
|
|
|
|
|
} |
3952
|
0
|
0
|
|
|
|
|
|
3953
|
0
|
|
|
|
|
|
if($cache_key){ |
3954
|
|
|
|
|
|
|
$IMMORTALS{$cache_key} = $meta; |
3955
|
|
|
|
|
|
|
} |
3956
|
0
|
|
|
|
|
|
|
3957
|
|
|
|
|
|
|
return $meta; |
3958
|
|
|
|
|
|
|
} |
3959
|
|
|
|
|
|
|
|
3960
|
0
|
|
|
0
|
|
|
sub DESTROY{ |
3961
|
|
|
|
|
|
|
my($self) = @_; |
3962
|
0
|
0
|
|
|
|
|
|
3963
|
|
|
|
|
|
|
return if Mouse::Util::in_global_destruction(); |
3964
|
0
|
|
|
|
|
|
|
3965
|
0
|
0
|
|
|
|
|
my $serial_id = $self->{anon_serial_id}; |
3966
|
|
|
|
|
|
|
return if !$serial_id; |
3967
|
|
|
|
|
|
|
|
3968
|
0
|
0
|
|
|
|
|
# XXX: cleaning stash with threads causes panic/SEGV on legacy perls. |
3969
|
|
|
|
|
|
|
if(exists $INC{'threads.pm'}) { |
3970
|
|
|
|
|
|
|
# (caller)[2] indicates the caller's line number, |
3971
|
0
|
0
|
|
|
|
|
# which is zero when the current thread is joining (destroying). |
3972
|
|
|
|
|
|
|
return if( (caller)[2] == 0); |
3973
|
|
|
|
|
|
|
} |
3974
|
|
|
|
|
|
|
|
3975
|
|
|
|
|
|
|
# clean up mortal anonymous class stuff |
3976
|
|
|
|
|
|
|
|
3977
|
0
|
0
|
|
|
|
|
# @ISA is a magical variable, so we must clear it manually. |
|
0
|
|
|
|
|
|
|
3978
|
|
|
|
|
|
|
@{$self->{superclasses}} = () if exists $self->{superclasses}; |
3979
|
|
|
|
|
|
|
|
3980
|
0
|
|
|
|
|
|
# Then, clear the symbol table hash |
|
0
|
|
|
|
|
|
|
3981
|
|
|
|
|
|
|
%{$self->namespace} = (); |
3982
|
0
|
|
|
|
|
|
|
3983
|
0
|
|
|
|
|
|
my $name = $self->name; |
3984
|
|
|
|
|
|
|
delete $METAS{$name}; |
3985
|
0
|
|
|
|
|
|
|
3986
|
2
|
|
|
2
|
|
9
|
$name =~ s/ $serial_id \z//xms; |
|
2
|
|
|
|
|
1
|
|
|
2
|
|
|
|
|
101
|
|
3987
|
0
|
|
|
|
|
|
no strict 'refs'; |
|
0
|
|
|
|
|
|
|
3988
|
0
|
|
|
|
|
|
delete ${$name}{ $serial_id . '::' }; |
3989
|
|
|
|
|
|
|
return; |
3990
|
|
|
|
|
|
|
} |
3991
|
|
|
|
|
|
|
|
3992
|
|
|
|
|
|
|
|
3993
|
0
|
|
|
|
|
0
|
} |
3994
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Role.pm |
3995
|
2
|
|
|
2
|
|
6
|
package Mouse::Meta::Role; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
5
|
|
3996
|
|
|
|
|
|
|
use Mouse::Util qw(:meta); # enables strict and warnings |
3997
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
1056
|
|
3998
|
2
|
|
|
2
|
|
81
|
use Mouse::Meta::Module; |
3999
|
|
|
|
|
|
|
our @ISA = qw(Mouse::Meta::Module); |
4000
|
|
|
|
|
|
|
|
4001
|
|
|
|
|
|
|
sub method_metaclass; |
4002
|
|
|
|
|
|
|
|
4003
|
0
|
|
|
0
|
|
|
sub _construct_meta { |
4004
|
|
|
|
|
|
|
my $class = shift; |
4005
|
0
|
|
|
|
|
|
|
4006
|
|
|
|
|
|
|
my %args = @_; |
4007
|
0
|
|
|
|
|
|
|
4008
|
0
|
|
|
|
|
|
$args{methods} = {}; |
4009
|
0
|
|
|
|
|
|
$args{attributes} = {}; |
4010
|
0
|
|
|
|
|
|
$args{required_methods} = []; |
4011
|
|
|
|
|
|
|
$args{roles} = []; |
4012
|
0
|
|
0
|
|
|
|
|
4013
|
0
|
0
|
|
|
|
|
my $self = bless \%args, ref($class) || $class; |
4014
|
0
|
|
|
|
|
|
if($class ne __PACKAGE__){ |
4015
|
|
|
|
|
|
|
$self->meta->_initialize_object($self, \%args); |
4016
|
0
|
|
|
|
|
|
} |
4017
|
|
|
|
|
|
|
return $self; |
4018
|
|
|
|
|
|
|
} |
4019
|
|
|
|
|
|
|
|
4020
|
0
|
|
|
0
|
0
|
|
sub create_anon_role{ |
4021
|
0
|
|
|
|
|
|
my $self = shift; |
4022
|
|
|
|
|
|
|
return $self->create(undef, @_); |
4023
|
|
|
|
|
|
|
} |
4024
|
|
|
|
|
|
|
|
4025
|
|
|
|
|
|
|
sub is_anon_role; |
4026
|
|
|
|
|
|
|
|
4027
|
|
|
|
|
|
|
sub get_roles; |
4028
|
|
|
|
|
|
|
|
4029
|
0
|
|
|
0
|
0
|
|
sub calculate_all_roles { |
4030
|
0
|
|
|
|
|
|
my $self = shift; |
4031
|
0
|
|
|
|
|
|
my %seen; |
4032
|
0
|
|
|
|
|
|
return grep { !$seen{ $_->name }++ } |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4033
|
|
|
|
|
|
|
($self, map { $_->calculate_all_roles } @{ $self->get_roles }); |
4034
|
|
|
|
|
|
|
} |
4035
|
|
|
|
|
|
|
|
4036
|
0
|
|
|
0
|
0
|
|
sub get_required_method_list{ |
|
0
|
|
|
|
|
|
|
4037
|
|
|
|
|
|
|
return @{ $_[0]->{required_methods} }; |
4038
|
|
|
|
|
|
|
} |
4039
|
|
|
|
|
|
|
|
4040
|
0
|
|
|
0
|
0
|
|
sub add_required_methods { |
4041
|
0
|
|
|
|
|
|
my($self, @methods) = @_; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4042
|
0
|
|
0
|
|
|
|
my %required = map{ $_ => 1 } @{$self->{required_methods}}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4043
|
0
|
|
|
|
|
|
push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods; |
4044
|
|
|
|
|
|
|
return; |
4045
|
|
|
|
|
|
|
} |
4046
|
|
|
|
|
|
|
|
4047
|
0
|
|
|
0
|
0
|
|
sub requires_method { |
4048
|
0
|
|
|
|
|
|
my($self, $name) = @_; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4049
|
|
|
|
|
|
|
return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0; |
4050
|
|
|
|
|
|
|
} |
4051
|
|
|
|
|
|
|
|
4052
|
0
|
|
|
0
|
0
|
|
sub add_attribute { |
4053
|
0
|
|
|
|
|
|
my $self = shift; |
4054
|
|
|
|
|
|
|
my $name = shift; |
4055
|
0
|
0
|
|
|
|
|
|
4056
|
0
|
|
|
|
|
|
$self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ }; |
4057
|
|
|
|
|
|
|
return; |
4058
|
|
|
|
|
|
|
} |
4059
|
|
|
|
|
|
|
|
4060
|
0
|
|
|
0
|
0
|
|
sub apply { |
4061
|
0
|
|
|
|
|
|
my $self = shift; |
4062
|
|
|
|
|
|
|
my $consumer = shift; |
4063
|
0
|
|
|
|
|
|
|
4064
|
0
|
|
|
|
|
|
require 'Mouse/Meta/Role/Application.pm'; |
4065
|
|
|
|
|
|
|
return Mouse::Meta::Role::Application->new(@_)->apply($self, $consumer); |
4066
|
|
|
|
|
|
|
} |
4067
|
|
|
|
|
|
|
|
4068
|
0
|
|
|
0
|
0
|
|
sub combine { |
4069
|
|
|
|
|
|
|
my($self, @role_specs) = @_; |
4070
|
0
|
|
|
|
|
|
|
4071
|
0
|
|
|
|
|
|
require 'Mouse/Meta/Role/Composite.pm'; |
4072
|
|
|
|
|
|
|
return Mouse::Meta::Role::Composite->new(roles => \@role_specs); |
4073
|
|
|
|
|
|
|
} |
4074
|
|
|
|
|
|
|
|
4075
|
|
|
|
|
|
|
sub add_before_method_modifier; |
4076
|
|
|
|
|
|
|
sub add_around_method_modifier; |
4077
|
|
|
|
|
|
|
sub add_after_method_modifier; |
4078
|
|
|
|
|
|
|
|
4079
|
|
|
|
|
|
|
sub get_before_method_modifiers; |
4080
|
|
|
|
|
|
|
sub get_around_method_modifiers; |
4081
|
|
|
|
|
|
|
sub get_after_method_modifiers; |
4082
|
|
|
|
|
|
|
|
4083
|
0
|
|
|
0
|
0
|
|
sub add_override_method_modifier{ |
4084
|
|
|
|
|
|
|
my($self, $method_name, $method) = @_; |
4085
|
0
|
0
|
|
|
|
|
|
4086
|
|
|
|
|
|
|
if($self->has_method($method_name)){ |
4087
|
|
|
|
|
|
|
# This error happens in the override keyword or during role composition, |
4088
|
0
|
|
|
|
|
|
# so I added a message, "A local method of ...", only for compatibility (gfx) |
4089
|
|
|
|
|
|
|
$self->throw_error("Cannot add an override of method '$method_name' " |
4090
|
|
|
|
|
|
|
. "because there is a local version of '$method_name'" |
4091
|
|
|
|
|
|
|
. "(A local method of the same name as been found)"); |
4092
|
|
|
|
|
|
|
} |
4093
|
0
|
|
|
|
|
|
|
4094
|
|
|
|
|
|
|
$self->{override_method_modifiers}->{$method_name} = $method; |
4095
|
|
|
|
|
|
|
} |
4096
|
|
|
|
|
|
|
|
4097
|
0
|
|
|
0
|
0
|
|
sub get_override_method_modifier { |
4098
|
0
|
|
|
|
|
|
my ($self, $method_name) = @_; |
4099
|
|
|
|
|
|
|
return $self->{override_method_modifiers}->{$method_name}; |
4100
|
|
|
|
|
|
|
} |
4101
|
|
|
|
|
|
|
|
4102
|
0
|
|
|
0
|
0
|
|
sub does_role { |
4103
|
|
|
|
|
|
|
my ($self, $role_name) = @_; |
4104
|
0
|
0
|
|
|
|
|
|
4105
|
|
|
|
|
|
|
(defined $role_name) |
4106
|
|
|
|
|
|
|
|| $self->throw_error("You must supply a role name to look for"); |
4107
|
0
|
0
|
|
|
|
|
|
4108
|
|
|
|
|
|
|
$role_name = $role_name->name if ref $role_name; |
4109
|
|
|
|
|
|
|
|
4110
|
0
|
0
|
|
|
|
|
# if we are it,.. then return true |
4111
|
|
|
|
|
|
|
return 1 if $role_name eq $self->name; |
4112
|
0
|
|
|
|
|
|
# otherwise.. check our children |
|
0
|
|
|
|
|
|
|
4113
|
0
|
0
|
|
|
|
|
for my $role (@{ $self->get_roles }) { |
4114
|
|
|
|
|
|
|
return 1 if $role->does_role($role_name); |
4115
|
0
|
|
|
|
|
|
} |
4116
|
|
|
|
|
|
|
return 0; |
4117
|
|
|
|
|
|
|
} |
4118
|
|
|
|
|
|
|
|
4119
|
0
|
|
|
|
|
0
|
} |
4120
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Role/Application.pm |
4121
|
2
|
|
|
2
|
|
8
|
package Mouse::Meta::Role::Application; |
|
2
|
|
|
0
|
|
2
|
|
|
2
|
|
|
|
|
6
|
|
4122
|
|
|
|
|
|
|
use Mouse::Util qw(:meta); |
4123
|
|
|
|
|
|
|
|
4124
|
0
|
|
|
0
|
0
|
|
sub new { |
4125
|
0
|
|
|
|
|
|
my $class = shift; |
4126
|
|
|
|
|
|
|
my $args = $class->Mouse::Object::BUILDARGS(@_); |
4127
|
0
|
0
|
0
|
|
|
|
|
4128
|
0
|
|
|
|
|
|
if(exists $args->{exclude} or exists $args->{alias}) { |
4129
|
|
|
|
|
|
|
warnings::warnif(deprecated => |
4130
|
|
|
|
|
|
|
'The alias and excludes options for role application have been' |
4131
|
|
|
|
|
|
|
. ' renamed -alias and -exclude'); |
4132
|
0
|
0
|
0
|
|
|
|
|
4133
|
0
|
|
|
|
|
|
if($args->{alias} && !exists $args->{-alias}){ |
4134
|
|
|
|
|
|
|
$args->{-alias} = $args->{alias}; |
4135
|
0
|
0
|
0
|
|
|
|
} |
4136
|
0
|
|
|
|
|
|
if($args->{excludes} && !exists $args->{-excludes}){ |
4137
|
|
|
|
|
|
|
$args->{-excludes} = $args->{excludes}; |
4138
|
|
|
|
|
|
|
} |
4139
|
|
|
|
|
|
|
} |
4140
|
0
|
|
|
|
|
|
|
4141
|
0
|
0
|
|
|
|
|
$args->{aliased_methods} = {}; |
4142
|
0
|
|
|
|
|
|
if(my $alias = $args->{-alias}){ |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4143
|
|
|
|
|
|
|
@{$args->{aliased_methods}}{ values %{$alias} } = (); |
4144
|
|
|
|
|
|
|
} |
4145
|
0
|
0
|
|
|
|
|
|
4146
|
0
|
|
|
|
|
|
if(my $excludes = $args->{-excludes}){ |
4147
|
0
|
0
|
|
|
|
|
$args->{-excludes} = {}; # replace with a hash ref |
4148
|
0
|
|
|
|
|
|
if(ref $excludes){ |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4149
|
|
|
|
|
|
|
%{$args->{-excludes}} = (map{ $_ => undef } @{$excludes}); |
4150
|
|
|
|
|
|
|
} |
4151
|
0
|
|
|
|
|
|
else{ |
4152
|
|
|
|
|
|
|
$args->{-excludes}{$excludes} = undef; |
4153
|
|
|
|
|
|
|
} |
4154
|
0
|
|
|
|
|
|
} |
4155
|
0
|
0
|
|
|
|
|
my $self = bless $args, $class; |
4156
|
0
|
|
|
|
|
|
if($class ne __PACKAGE__){ |
4157
|
|
|
|
|
|
|
$self->meta->_initialize_object($self, $args); |
4158
|
0
|
|
|
|
|
|
} |
4159
|
|
|
|
|
|
|
return $self; |
4160
|
|
|
|
|
|
|
} |
4161
|
|
|
|
|
|
|
|
4162
|
0
|
|
|
0
|
0
|
|
sub apply { |
4163
|
0
|
|
|
|
|
|
my($self, $role, $consumer, @extra) = @_; |
4164
|
|
|
|
|
|
|
my $instance; |
4165
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
4166
|
0
|
|
|
|
|
|
if(Mouse::Util::is_a_metaclass($consumer)) { # Application::ToClass |
4167
|
|
|
|
|
|
|
$self->{_to} = 'class'; |
4168
|
|
|
|
|
|
|
} |
4169
|
0
|
|
|
|
|
|
elsif(Mouse::Util::is_a_metarole($consumer)) { # Application::ToRole |
4170
|
|
|
|
|
|
|
$self->{_to} = 'role'; |
4171
|
|
|
|
|
|
|
} |
4172
|
0
|
|
|
|
|
|
else { # Appplication::ToInstance |
4173
|
0
|
|
|
|
|
|
$self->{_to} = 'instance'; |
4174
|
|
|
|
|
|
|
$instance = $consumer; |
4175
|
0
|
|
|
|
|
|
|
4176
|
0
|
|
0
|
|
|
|
my $meta = Mouse::Util::class_of($instance); |
4177
|
|
|
|
|
|
|
$consumer = ($meta || 'Mouse::Meta::Class') |
4178
|
|
|
|
|
|
|
->create_anon_class( |
4179
|
|
|
|
|
|
|
superclasses => [ref $instance], |
4180
|
|
|
|
|
|
|
roles => [$role], |
4181
|
|
|
|
|
|
|
cache => 0, |
4182
|
|
|
|
|
|
|
|
4183
|
|
|
|
|
|
|
in_application_to_instance => 1, # suppress to apply roles |
4184
|
|
|
|
|
|
|
); |
4185
|
|
|
|
|
|
|
} |
4186
|
|
|
|
|
|
|
|
4187
|
0
|
|
|
|
|
|
#$self->check_role_exclusions($role, $consumer, @extra); |
4188
|
|
|
|
|
|
|
$self->check_required_methods($role, $consumer, @extra); |
4189
|
|
|
|
|
|
|
#$self->check_required_attributes($role, $consumer, @extra); |
4190
|
0
|
|
|
|
|
|
|
4191
|
0
|
|
|
|
|
|
$self->apply_attributes($role, $consumer, @extra); |
4192
|
|
|
|
|
|
|
$self->apply_methods($role, $consumer, @extra); |
4193
|
|
|
|
|
|
|
#$self->apply_override_method_modifiers($role, $consumer, @extra); |
4194
|
|
|
|
|
|
|
#$self->apply_before_method_modifiers($role, $consumer, @extra); |
4195
|
|
|
|
|
|
|
#$self->apply_around_method_modifiers($role, $consumer, @extra); |
4196
|
0
|
|
|
|
|
|
#$self->apply_after_method_modifiers($role, $consumer, @extra); |
4197
|
|
|
|
|
|
|
$self->apply_modifiers($role, $consumer, @extra); |
4198
|
0
|
|
|
|
|
|
|
4199
|
|
|
|
|
|
|
$self->_append_roles($role, $consumer); |
4200
|
0
|
0
|
|
|
|
|
|
4201
|
|
|
|
|
|
|
if(defined $instance){ # Application::ToInstance |
4202
|
0
|
|
|
|
|
|
# rebless instance |
4203
|
0
|
|
|
|
|
|
bless $instance, $consumer->name; |
4204
|
|
|
|
|
|
|
$consumer->_initialize_object($instance, $instance, 1); |
4205
|
|
|
|
|
|
|
} |
4206
|
0
|
|
|
|
|
|
|
4207
|
|
|
|
|
|
|
return; |
4208
|
|
|
|
|
|
|
} |
4209
|
|
|
|
|
|
|
|
4210
|
0
|
|
|
0
|
0
|
|
sub check_required_methods { |
4211
|
|
|
|
|
|
|
my($self, $role, $consumer) = @_; |
4212
|
0
|
0
|
|
|
|
|
|
4213
|
0
|
|
|
|
|
|
if($self->{_to} eq 'role'){ |
4214
|
|
|
|
|
|
|
$consumer->add_required_methods($role->get_required_method_list); |
4215
|
|
|
|
|
|
|
} |
4216
|
0
|
|
|
|
|
|
else{ # to class or instance |
4217
|
|
|
|
|
|
|
my $consumer_class_name = $consumer->name; |
4218
|
0
|
|
|
|
|
|
|
4219
|
0
|
|
|
|
|
|
my @missing; |
|
0
|
|
|
|
|
|
|
4220
|
0
|
0
|
|
|
|
|
foreach my $method_name(@{$role->{required_methods}}){ |
4221
|
0
|
0
|
|
|
|
|
next if exists $self->{aliased_methods}{$method_name}; |
4222
|
0
|
0
|
|
|
|
|
next if exists $role->{methods}{$method_name}; |
4223
|
|
|
|
|
|
|
next if $consumer_class_name->can($method_name); |
4224
|
0
|
|
|
|
|
|
|
4225
|
|
|
|
|
|
|
push @missing, $method_name; |
4226
|
0
|
0
|
|
|
|
|
} |
4227
|
0
|
0
|
|
|
|
|
if(@missing){ |
4228
|
|
|
|
|
|
|
$role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'", |
4229
|
|
|
|
|
|
|
$role->name, |
4230
|
|
|
|
|
|
|
(@missing == 1 ? '' : 's'), # method or methods |
4231
|
|
|
|
|
|
|
Mouse::Util::quoted_english_list(@missing), |
4232
|
|
|
|
|
|
|
$consumer_class_name); |
4233
|
|
|
|
|
|
|
} |
4234
|
|
|
|
|
|
|
} |
4235
|
0
|
|
|
|
|
|
|
4236
|
|
|
|
|
|
|
return; |
4237
|
|
|
|
|
|
|
} |
4238
|
|
|
|
|
|
|
|
4239
|
0
|
|
|
0
|
0
|
|
sub apply_methods { |
4240
|
|
|
|
|
|
|
my($self, $role, $consumer) = @_; |
4241
|
0
|
|
|
|
|
|
|
4242
|
0
|
|
|
|
|
|
my $alias = $self->{-alias}; |
4243
|
|
|
|
|
|
|
my $excludes = $self->{-excludes}; |
4244
|
0
|
|
|
|
|
|
|
4245
|
0
|
0
|
|
|
|
|
foreach my $method_name($role->get_method_list){ |
4246
|
|
|
|
|
|
|
next if $method_name eq 'meta'; |
4247
|
0
|
|
|
|
|
|
|
4248
|
|
|
|
|
|
|
my $code = $role->get_method_body($method_name); |
4249
|
0
|
0
|
|
|
|
|
|
4250
|
0
|
0
|
|
|
|
|
if(!exists $excludes->{$method_name}){ |
4251
|
|
|
|
|
|
|
if(!$consumer->has_method($method_name)){ |
4252
|
0
|
|
|
|
|
|
# The third argument $role is used in Role::Composite |
4253
|
|
|
|
|
|
|
$consumer->add_method($method_name => $code, $role); |
4254
|
|
|
|
|
|
|
} |
4255
|
|
|
|
|
|
|
} |
4256
|
0
|
0
|
|
|
|
|
|
4257
|
0
|
|
|
|
|
|
if(exists $alias->{$method_name}){ |
4258
|
|
|
|
|
|
|
my $dstname = $alias->{$method_name}; |
4259
|
0
|
|
|
|
|
|
|
4260
|
|
|
|
|
|
|
my $dstcode = $consumer->get_method_body($dstname); |
4261
|
0
|
0
|
0
|
|
|
|
|
4262
|
0
|
|
|
|
|
|
if(defined($dstcode) && $dstcode != $code){ |
4263
|
|
|
|
|
|
|
$role->throw_error("Cannot create a method alias if a local method of the same name exists"); |
4264
|
|
|
|
|
|
|
} |
4265
|
0
|
|
|
|
|
|
else{ |
4266
|
|
|
|
|
|
|
$consumer->add_method($dstname => $code, $role); |
4267
|
|
|
|
|
|
|
} |
4268
|
|
|
|
|
|
|
} |
4269
|
|
|
|
|
|
|
} |
4270
|
0
|
|
|
|
|
|
|
4271
|
|
|
|
|
|
|
return; |
4272
|
|
|
|
|
|
|
} |
4273
|
|
|
|
|
|
|
|
4274
|
0
|
|
|
0
|
0
|
|
sub apply_attributes { |
4275
|
|
|
|
|
|
|
my($self, $role, $consumer) = @_; |
4276
|
0
|
|
|
|
|
|
|
4277
|
0
|
0
|
|
|
|
|
for my $attr_name ($role->get_attribute_list) { |
4278
|
|
|
|
|
|
|
next if $consumer->has_attribute($attr_name); |
4279
|
0
|
|
|
|
|
|
|
4280
|
|
|
|
|
|
|
$consumer->add_attribute($attr_name |
4281
|
|
|
|
|
|
|
=> $role->get_attribute($attr_name)); |
4282
|
0
|
|
|
|
|
|
} |
4283
|
|
|
|
|
|
|
return; |
4284
|
|
|
|
|
|
|
} |
4285
|
|
|
|
|
|
|
|
4286
|
0
|
|
|
0
|
0
|
|
sub apply_modifiers { |
4287
|
|
|
|
|
|
|
my($self, $role, $consumer) = @_; |
4288
|
0
|
0
|
|
|
|
|
|
4289
|
0
|
|
|
|
|
|
if(my $modifiers = $role->{override_method_modifiers}){ |
|
0
|
|
|
|
|
|
|
4290
|
|
|
|
|
|
|
foreach my $method_name (keys %{$modifiers}){ |
4291
|
0
|
|
|
|
|
|
$consumer->add_override_method_modifier( |
4292
|
|
|
|
|
|
|
$method_name => $modifiers->{$method_name}); |
4293
|
|
|
|
|
|
|
} |
4294
|
|
|
|
|
|
|
} |
4295
|
0
|
|
|
|
|
|
|
4296
|
0
|
0
|
|
|
|
|
for my $modifier_type (qw/before around after/) { |
4297
|
|
|
|
|
|
|
my $table = $role->{"${modifier_type}_method_modifiers"} |
4298
|
|
|
|
|
|
|
or next; |
4299
|
0
|
|
|
|
|
|
|
4300
|
|
|
|
|
|
|
my $add_modifier = "add_${modifier_type}_method_modifier"; |
4301
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4302
|
0
|
|
|
|
|
|
while(my($method_name, $modifiers) = each %{$table}){ |
|
0
|
|
|
|
|
|
|
4303
|
|
|
|
|
|
|
foreach my $code(@{ $modifiers }) { |
4304
|
0
|
0
|
|
|
|
|
# skip if the modifier is already applied |
4305
|
0
|
|
|
|
|
|
next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; |
4306
|
|
|
|
|
|
|
$consumer->$add_modifier($method_name => $code); |
4307
|
|
|
|
|
|
|
} |
4308
|
|
|
|
|
|
|
} |
4309
|
0
|
|
|
|
|
|
} |
4310
|
|
|
|
|
|
|
return; |
4311
|
|
|
|
|
|
|
} |
4312
|
|
|
|
|
|
|
|
4313
|
0
|
|
|
0
|
|
|
sub _append_roles { |
4314
|
|
|
|
|
|
|
my($self, $role, $metaclass_or_role) = @_; |
4315
|
0
|
|
|
|
|
|
|
4316
|
0
|
|
|
|
|
|
my $roles = $metaclass_or_role->{roles}; |
|
0
|
|
|
|
|
|
|
4317
|
0
|
0
|
|
|
|
|
foreach my $r($role, @{$role->get_roles}){ |
4318
|
0
|
|
|
|
|
|
if(!$metaclass_or_role->does_role($r)){ |
|
0
|
|
|
|
|
|
|
4319
|
|
|
|
|
|
|
push @{$roles}, $r; |
4320
|
|
|
|
|
|
|
} |
4321
|
0
|
|
|
|
|
|
} |
4322
|
|
|
|
|
|
|
return; |
4323
|
|
|
|
|
|
|
} |
4324
|
0
|
|
|
|
|
0
|
} |
4325
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Role/Composite.pm |
4326
|
2
|
|
|
2
|
|
11
|
package Mouse::Meta::Role::Composite; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
29
|
|
4327
|
2
|
|
|
2
|
|
6
|
use Carp (); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
4
|
|
4328
|
2
|
|
|
2
|
|
7
|
use Mouse::Util; # enables strict and warnings |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
36
|
|
4329
|
2
|
|
|
2
|
|
5
|
use Mouse::Meta::Role; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
1350
|
|
4330
|
2
|
|
|
2
|
|
14
|
use Mouse::Meta::Role::Application; |
4331
|
|
|
|
|
|
|
our @ISA = qw(Mouse::Meta::Role); |
4332
|
|
|
|
|
|
|
|
4333
|
|
|
|
|
|
|
# FIXME: Mouse::Meta::Role::Composite does things in different way from Moose's |
4334
|
|
|
|
|
|
|
# Moose: creates a new class for the consumer, and applies roles to it. |
4335
|
|
|
|
|
|
|
# Mouse: creates a composite role and apply roles to the role, |
4336
|
|
|
|
|
|
|
# and then applies it to the consumer. |
4337
|
|
|
|
|
|
|
|
4338
|
0
|
|
|
0
|
0
|
|
sub new { |
4339
|
0
|
|
|
|
|
|
my $class = shift; |
4340
|
0
|
|
|
|
|
|
my $args = $class->Mouse::Object::BUILDARGS(@_); |
4341
|
0
|
|
|
|
|
|
my $roles = delete $args->{roles}; |
|
0
|
|
|
|
|
|
|
4342
|
0
|
|
|
|
|
|
my $self = $class->create_anon_role(%{$args}); |
|
0
|
|
|
|
|
|
|
4343
|
|
|
|
|
|
|
foreach my $role_spec(@{$roles}) { |
4344
|
0
|
0
|
|
|
|
|
my($role, $args) = ref($role_spec) eq 'ARRAY' |
|
0
|
|
|
|
|
|
|
4345
|
|
|
|
|
|
|
? @{$role_spec} |
4346
|
0
|
|
|
|
|
|
: ($role_spec, {}); |
|
0
|
|
|
|
|
|
|
4347
|
|
|
|
|
|
|
$role->apply($self, %{$args}); |
4348
|
0
|
|
|
|
|
|
} |
4349
|
|
|
|
|
|
|
return $self; |
4350
|
|
|
|
|
|
|
} |
4351
|
|
|
|
|
|
|
|
4352
|
0
|
|
|
0
|
0
|
|
sub get_method_list { |
4353
|
0
|
|
|
|
|
|
my($self) = @_; |
4354
|
0
|
|
|
|
|
|
return grep { ! $self->{conflicting_methods}{$_} } |
|
0
|
|
|
|
|
|
|
4355
|
|
|
|
|
|
|
keys %{ $self->{methods} }; |
4356
|
|
|
|
|
|
|
} |
4357
|
|
|
|
|
|
|
|
4358
|
0
|
|
|
0
|
0
|
|
sub add_method { |
4359
|
|
|
|
|
|
|
my($self, $method_name, $code, $role) = @_; |
4360
|
0
|
0
|
0
|
|
|
|
|
4361
|
|
|
|
|
|
|
if( ($self->{methods}{$method_name} || 0) == $code){ |
4362
|
0
|
|
|
|
|
|
# This role already has the same method. |
4363
|
|
|
|
|
|
|
return; |
4364
|
|
|
|
|
|
|
} |
4365
|
0
|
0
|
|
|
|
|
|
4366
|
0
|
|
|
|
|
|
if($method_name eq 'meta'){ |
4367
|
|
|
|
|
|
|
$self->SUPER::add_method($method_name => $code); |
4368
|
|
|
|
|
|
|
} |
4369
|
|
|
|
|
|
|
else{ |
4370
|
0
|
|
0
|
|
|
|
# no need to add a subroutine to the stash |
4371
|
0
|
|
|
|
|
|
my $roles = $self->{composed_roles_by_method}{$method_name} ||= []; |
|
0
|
|
|
|
|
|
|
4372
|
0
|
0
|
|
|
|
|
push @{$roles}, $role; |
|
0
|
|
|
|
|
|
|
4373
|
0
|
|
|
|
|
|
if(@{$roles} > 1){ |
4374
|
|
|
|
|
|
|
$self->{conflicting_methods}{$method_name}++; |
4375
|
0
|
|
|
|
|
|
} |
4376
|
|
|
|
|
|
|
$self->{methods}{$method_name} = $code; |
4377
|
0
|
|
|
|
|
|
} |
4378
|
|
|
|
|
|
|
return; |
4379
|
|
|
|
|
|
|
} |
4380
|
|
|
|
|
|
|
|
4381
|
0
|
|
|
0
|
0
|
|
sub get_method_body { |
4382
|
0
|
|
|
|
|
|
my($self, $method_name) = @_; |
4383
|
|
|
|
|
|
|
return $self->{methods}{$method_name}; |
4384
|
|
|
|
|
|
|
} |
4385
|
|
|
|
|
|
|
|
4386
|
|
|
|
|
|
|
sub has_method { |
4387
|
0
|
|
|
0
|
0
|
|
# my($self, $method_name) = @_; |
4388
|
|
|
|
|
|
|
return 0; # to fool apply_methods() in combine() |
4389
|
|
|
|
|
|
|
} |
4390
|
|
|
|
|
|
|
|
4391
|
|
|
|
|
|
|
sub has_attribute { |
4392
|
0
|
|
|
0
|
0
|
|
# my($self, $method_name) = @_; |
4393
|
|
|
|
|
|
|
return 0; # to fool appply_attributes() in combine() |
4394
|
|
|
|
|
|
|
} |
4395
|
|
|
|
|
|
|
|
4396
|
|
|
|
|
|
|
sub has_override_method_modifier { |
4397
|
0
|
|
|
0
|
0
|
|
# my($self, $method_name) = @_; |
4398
|
|
|
|
|
|
|
return 0; # to fool apply_modifiers() in combine() |
4399
|
|
|
|
|
|
|
} |
4400
|
|
|
|
|
|
|
|
4401
|
0
|
|
|
0
|
0
|
|
sub add_attribute { |
4402
|
0
|
|
|
|
|
|
my $self = shift; |
4403
|
0
|
0
|
|
|
|
|
my $attr_name = shift; |
4404
|
|
|
|
|
|
|
my $spec = (@_ == 1 ? $_[0] : {@_}); |
4405
|
0
|
|
|
|
|
|
|
4406
|
0
|
0
|
0
|
|
|
|
my $existing = $self->{attributes}{$attr_name}; |
4407
|
0
|
|
|
|
|
|
if($existing && $existing != $spec){ |
4408
|
|
|
|
|
|
|
$self->throw_error("We have encountered an attribute conflict with '$attr_name' " |
4409
|
|
|
|
|
|
|
. "during composition. This is fatal error and cannot be disambiguated."); |
4410
|
0
|
|
|
|
|
|
} |
4411
|
0
|
|
|
|
|
|
$self->SUPER::add_attribute($attr_name, $spec); |
4412
|
|
|
|
|
|
|
return; |
4413
|
|
|
|
|
|
|
} |
4414
|
|
|
|
|
|
|
|
4415
|
0
|
|
|
0
|
0
|
|
sub add_override_method_modifier { |
4416
|
|
|
|
|
|
|
my($self, $method_name, $code) = @_; |
4417
|
0
|
|
|
|
|
|
|
4418
|
0
|
0
|
0
|
|
|
|
my $existing = $self->{override_method_modifiers}{$method_name}; |
4419
|
0
|
|
|
|
|
|
if($existing && $existing != $code){ |
4420
|
|
|
|
|
|
|
$self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during " |
4421
|
|
|
|
|
|
|
. "composition (Two 'override' methods of the same name encountered). " |
4422
|
|
|
|
|
|
|
. "This is fatal error.") |
4423
|
0
|
|
|
|
|
|
} |
4424
|
0
|
|
|
|
|
|
$self->SUPER::add_override_method_modifier($method_name, $code); |
4425
|
|
|
|
|
|
|
return; |
4426
|
|
|
|
|
|
|
} |
4427
|
|
|
|
|
|
|
|
4428
|
0
|
|
|
0
|
0
|
|
sub apply { |
4429
|
0
|
|
|
|
|
|
my $self = shift; |
4430
|
|
|
|
|
|
|
my $consumer = shift; |
4431
|
0
|
|
|
|
|
|
|
4432
|
0
|
|
|
|
|
|
Mouse::Meta::Role::Application::RoleSummation->new(@_)->apply($self, $consumer); |
4433
|
|
|
|
|
|
|
return; |
4434
|
|
|
|
|
|
|
} |
4435
|
|
|
|
|
|
|
|
4436
|
2
|
|
|
|
|
59
|
package Mouse::Meta::Role::Application::RoleSummation; |
4437
|
|
|
|
|
|
|
our @ISA = qw(Mouse::Meta::Role::Application); |
4438
|
|
|
|
|
|
|
|
4439
|
0
|
|
|
0
|
|
|
sub apply_methods { |
4440
|
|
|
|
|
|
|
my($self, $role, $consumer, @extra) = @_; |
4441
|
0
|
0
|
|
|
|
|
|
4442
|
0
|
|
|
|
|
|
if(exists $role->{conflicting_methods}){ |
4443
|
|
|
|
|
|
|
my $consumer_class_name = $consumer->name; |
4444
|
0
|
|
|
|
|
|
|
4445
|
0
|
|
|
|
|
|
my @conflicting = grep{ !$consumer_class_name->can($_) } |
|
0
|
|
|
|
|
|
|
4446
|
|
|
|
|
|
|
keys %{ $role->{conflicting_methods} }; |
4447
|
0
|
0
|
|
|
|
|
|
4448
|
0
|
0
|
|
|
|
|
if(@conflicting) { |
4449
|
|
|
|
|
|
|
my $method_name_conflict = (@conflicting == 1 |
4450
|
|
|
|
|
|
|
? 'a method name conflict' |
4451
|
|
|
|
|
|
|
: 'method name conflicts'); |
4452
|
0
|
|
|
|
|
|
|
4453
|
|
|
|
|
|
|
my %seen; |
4454
|
0
|
|
|
|
|
|
my $roles = Mouse::Util::quoted_english_list( |
4455
|
0
|
|
|
|
|
|
grep{ !$seen{$_}++ } # uniq |
4456
|
0
|
|
|
|
|
|
map { $_->name } |
|
0
|
|
|
|
|
|
|
4457
|
0
|
|
|
|
|
|
map { @{$_} } |
|
0
|
|
|
|
|
|
|
4458
|
|
|
|
|
|
|
@{ $role->{composed_roles_by_method} }{@conflicting} |
4459
|
|
|
|
|
|
|
); |
4460
|
0
|
0
|
|
|
|
|
|
4461
|
|
|
|
|
|
|
$self->throw_error(sprintf |
4462
|
|
|
|
|
|
|
q{Due to %s in roles %s,} |
4463
|
|
|
|
|
|
|
. q{ the method%s %s must be implemented or excluded by '%s'}, |
4464
|
|
|
|
|
|
|
$method_name_conflict, |
4465
|
|
|
|
|
|
|
$roles, |
4466
|
|
|
|
|
|
|
(@conflicting > 1 ? 's' : ''), |
4467
|
|
|
|
|
|
|
Mouse::Util::quoted_english_list(@conflicting), |
4468
|
|
|
|
|
|
|
$consumer_class_name); |
4469
|
|
|
|
|
|
|
} |
4470
|
|
|
|
|
|
|
|
4471
|
0
|
0
|
|
|
|
|
my @changed_in_v2_0_0 = grep { |
4472
|
0
|
|
|
|
|
|
$consumer_class_name->can($_) && ! $consumer->has_method($_) |
|
0
|
|
|
|
|
|
|
4473
|
0
|
0
|
|
|
|
|
} keys %{ $role->{conflicting_methods} }; |
4474
|
0
|
0
|
|
|
|
|
if (@changed_in_v2_0_0) { |
4475
|
|
|
|
|
|
|
my $method_name_conflict = (@changed_in_v2_0_0 == 1 |
4476
|
|
|
|
|
|
|
? 'a method name conflict' |
4477
|
|
|
|
|
|
|
: 'method name conflicts'); |
4478
|
0
|
|
|
|
|
|
|
4479
|
|
|
|
|
|
|
my %seen; |
4480
|
0
|
|
|
|
|
|
my $roles = Mouse::Util::quoted_english_list( |
4481
|
0
|
|
|
|
|
|
grep{ !$seen{$_}++ } # uniq |
4482
|
0
|
|
|
|
|
|
map { $_->name } |
|
0
|
|
|
|
|
|
|
4483
|
0
|
|
|
|
|
|
map { @{$_} } |
|
0
|
|
|
|
|
|
|
4484
|
|
|
|
|
|
|
@{ $role->{composed_roles_by_method} }{@changed_in_v2_0_0} |
4485
|
|
|
|
|
|
|
); |
4486
|
0
|
0
|
|
|
|
|
|
4487
|
|
|
|
|
|
|
Carp::cluck(sprintf |
4488
|
|
|
|
|
|
|
q{Due to %s in roles %s,} |
4489
|
|
|
|
|
|
|
. q{ the behavior of method%s %s might be incompatible with Moose} |
4490
|
|
|
|
|
|
|
. q{, check out %s}, |
4491
|
|
|
|
|
|
|
$method_name_conflict, |
4492
|
|
|
|
|
|
|
$roles, |
4493
|
|
|
|
|
|
|
(@changed_in_v2_0_0 > 1 ? 's' : ''), |
4494
|
|
|
|
|
|
|
Mouse::Util::quoted_english_list(@changed_in_v2_0_0), |
4495
|
|
|
|
|
|
|
$consumer_class_name); |
4496
|
|
|
|
|
|
|
} |
4497
|
|
|
|
|
|
|
} |
4498
|
0
|
|
|
|
|
|
|
4499
|
0
|
|
|
|
|
|
$self->SUPER::apply_methods($role, $consumer, @extra); |
4500
|
|
|
|
|
|
|
return; |
4501
|
|
|
|
|
|
|
} |
4502
|
|
|
|
|
|
|
|
4503
|
|
|
|
|
|
|
package Mouse::Meta::Role::Composite; |
4504
|
0
|
|
|
|
|
0
|
} |
4505
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Meta/Role/Method.pm |
4506
|
2
|
|
|
2
|
|
9
|
package Mouse::Meta::Role::Method; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
4
|
|
4507
|
|
|
|
|
|
|
use Mouse::Util; # enables strict and warnings |
4508
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
130
|
|
4509
|
2
|
|
|
2
|
|
59
|
use Mouse::Meta::Method; |
4510
|
|
|
|
|
|
|
our @ISA = qw(Mouse::Meta::Method); |
4511
|
|
|
|
|
|
|
|
4512
|
0
|
|
|
0
|
|
|
sub _new{ |
4513
|
0
|
|
|
|
|
|
my($class, %args) = @_; |
4514
|
|
|
|
|
|
|
my $self = bless \%args, $class; |
4515
|
0
|
0
|
|
|
|
|
|
4516
|
0
|
|
|
|
|
|
if($class ne __PACKAGE__){ |
4517
|
|
|
|
|
|
|
$self->meta->_initialize_object($self, \%args); |
4518
|
0
|
|
|
|
|
|
} |
4519
|
|
|
|
|
|
|
return $self; |
4520
|
|
|
|
|
|
|
} |
4521
|
|
|
|
|
|
|
|
4522
|
0
|
|
|
|
|
0
|
} |
4523
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Object.pm |
4524
|
2
|
|
|
2
|
|
9
|
package Mouse::Object; |
|
2
|
|
|
0
|
|
1
|
|
|
2
|
|
|
|
|
5
|
|
4525
|
|
|
|
|
|
|
use Mouse::Util qw(does dump meta); # enables strict and warnings |
4526
|
|
|
|
|
|
|
# all the stuff are defined in XS or PP |
4527
|
|
|
|
|
|
|
|
4528
|
0
|
|
|
0
|
0
|
|
sub DOES { |
4529
|
0
|
|
0
|
|
|
|
my($self, $class_or_role_name) = @_; |
4530
|
|
|
|
|
|
|
return $self->isa($class_or_role_name) || $self->does($class_or_role_name); |
4531
|
|
|
|
|
|
|
} |
4532
|
|
|
|
|
|
|
|
4533
|
0
|
|
|
|
|
0
|
} |
4534
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Role.pm |
4535
|
2
|
|
|
2
|
|
7
|
package Mouse::Role; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
6
|
|
4536
|
|
|
|
|
|
|
use Mouse::Exporter; # enables strict and warnings |
4537
|
2
|
|
|
2
|
|
4
|
|
4538
|
|
|
|
|
|
|
our $VERSION = 'v2.4.9'; |
4539
|
2
|
|
|
2
|
|
7
|
|
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
18
|
|
4540
|
2
|
|
|
2
|
|
6
|
use Carp (); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
17
|
|
4541
|
|
|
|
|
|
|
use Scalar::Util (); |
4542
|
2
|
|
|
2
|
|
5
|
|
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
887
|
|
4543
|
|
|
|
|
|
|
use Mouse (); |
4544
|
2
|
|
|
|
|
16
|
|
4545
|
|
|
|
|
|
|
Mouse::Exporter->setup_import_methods( |
4546
|
|
|
|
|
|
|
as_is => [qw( |
4547
|
|
|
|
|
|
|
extends with |
4548
|
|
|
|
|
|
|
has |
4549
|
|
|
|
|
|
|
before after around |
4550
|
|
|
|
|
|
|
override super |
4551
|
|
|
|
|
|
|
augment inner |
4552
|
|
|
|
|
|
|
|
4553
|
|
|
|
|
|
|
requires excludes |
4554
|
|
|
|
|
|
|
), |
4555
|
|
|
|
|
|
|
\&Scalar::Util::blessed, |
4556
|
|
|
|
|
|
|
\&Carp::confess, |
4557
|
|
|
|
|
|
|
], |
4558
|
|
|
|
|
|
|
); |
4559
|
|
|
|
|
|
|
|
4560
|
|
|
|
|
|
|
|
4561
|
0
|
|
|
0
|
0
|
|
sub extends { |
4562
|
|
|
|
|
|
|
Carp::croak "Roles do not support 'extends'"; |
4563
|
|
|
|
|
|
|
} |
4564
|
|
|
|
|
|
|
|
4565
|
0
|
|
|
0
|
0
|
|
sub with { |
4566
|
0
|
|
|
|
|
|
Mouse::Util::apply_all_roles(scalar(caller), @_); |
4567
|
|
|
|
|
|
|
return; |
4568
|
|
|
|
|
|
|
} |
4569
|
|
|
|
|
|
|
|
4570
|
0
|
|
|
0
|
0
|
|
sub has { |
4571
|
0
|
|
|
|
|
|
my $meta = Mouse::Meta::Role->initialize(scalar caller); |
4572
|
|
|
|
|
|
|
my $name = shift; |
4573
|
0
|
0
|
|
|
|
|
|
4574
|
|
|
|
|
|
|
$meta->throw_error(q{Usage: has 'name' => ( key => value, ... )}) |
4575
|
|
|
|
|
|
|
if @_ % 2; # odd number of arguments |
4576
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4577
|
0
|
|
|
|
|
|
for my $n(ref($name) ? @{$name} : $name){ |
4578
|
|
|
|
|
|
|
$meta->add_attribute($n => @_); |
4579
|
0
|
|
|
|
|
|
} |
4580
|
|
|
|
|
|
|
return; |
4581
|
|
|
|
|
|
|
} |
4582
|
|
|
|
|
|
|
|
4583
|
0
|
|
|
0
|
0
|
|
sub before { |
4584
|
0
|
|
|
|
|
|
my $meta = Mouse::Meta::Role->initialize(scalar caller); |
4585
|
0
|
|
|
|
|
|
my $code = pop; |
4586
|
0
|
|
|
|
|
|
for my $name($meta->_collect_methods(@_)) { |
4587
|
|
|
|
|
|
|
$meta->add_before_method_modifier($name => $code); |
4588
|
0
|
|
|
|
|
|
} |
4589
|
|
|
|
|
|
|
return; |
4590
|
|
|
|
|
|
|
} |
4591
|
|
|
|
|
|
|
|
4592
|
0
|
|
|
0
|
0
|
|
sub after { |
4593
|
0
|
|
|
|
|
|
my $meta = Mouse::Meta::Role->initialize(scalar caller); |
4594
|
0
|
|
|
|
|
|
my $code = pop; |
4595
|
0
|
|
|
|
|
|
for my $name($meta->_collect_methods(@_)) { |
4596
|
|
|
|
|
|
|
$meta->add_after_method_modifier($name => $code); |
4597
|
0
|
|
|
|
|
|
} |
4598
|
|
|
|
|
|
|
return; |
4599
|
|
|
|
|
|
|
} |
4600
|
|
|
|
|
|
|
|
4601
|
0
|
|
|
0
|
0
|
|
sub around { |
4602
|
0
|
|
|
|
|
|
my $meta = Mouse::Meta::Role->initialize(scalar caller); |
4603
|
0
|
|
|
|
|
|
my $code = pop; |
4604
|
0
|
|
|
|
|
|
for my $name($meta->_collect_methods(@_)) { |
4605
|
|
|
|
|
|
|
$meta->add_around_method_modifier($name => $code); |
4606
|
0
|
|
|
|
|
|
} |
4607
|
|
|
|
|
|
|
return; |
4608
|
|
|
|
|
|
|
} |
4609
|
|
|
|
|
|
|
|
4610
|
|
|
|
|
|
|
|
4611
|
0
|
0
|
|
0
|
0
|
|
sub super { |
4612
|
0
|
|
|
|
|
|
return if !defined $Mouse::SUPER_BODY; |
4613
|
|
|
|
|
|
|
$Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS); |
4614
|
|
|
|
|
|
|
} |
4615
|
|
|
|
|
|
|
|
4616
|
|
|
|
|
|
|
sub override { |
4617
|
0
|
|
|
0
|
0
|
|
# my($name, $code) = @_; |
4618
|
0
|
|
|
|
|
|
Mouse::Meta::Role->initialize(scalar caller)->add_override_method_modifier(@_); |
4619
|
|
|
|
|
|
|
return; |
4620
|
|
|
|
|
|
|
} |
4621
|
|
|
|
|
|
|
|
4622
|
|
|
|
|
|
|
# We keep the same errors messages as Moose::Role emits, here. |
4623
|
0
|
|
|
0
|
0
|
|
sub inner { |
4624
|
|
|
|
|
|
|
Carp::croak "Roles cannot support 'inner'"; |
4625
|
|
|
|
|
|
|
} |
4626
|
|
|
|
|
|
|
|
4627
|
0
|
|
|
0
|
0
|
|
sub augment { |
4628
|
|
|
|
|
|
|
Carp::croak "Roles cannot support 'augment'"; |
4629
|
|
|
|
|
|
|
} |
4630
|
|
|
|
|
|
|
|
4631
|
0
|
|
|
0
|
1
|
|
sub requires { |
4632
|
0
|
0
|
|
|
|
|
my $meta = Mouse::Meta::Role->initialize(scalar caller); |
4633
|
0
|
|
|
|
|
|
$meta->throw_error("Must specify at least one method") unless @_; |
4634
|
0
|
|
|
|
|
|
$meta->add_required_methods(@_); |
4635
|
|
|
|
|
|
|
return; |
4636
|
|
|
|
|
|
|
} |
4637
|
|
|
|
|
|
|
|
4638
|
0
|
|
|
0
|
1
|
|
sub excludes { |
4639
|
|
|
|
|
|
|
Mouse::Util::not_supported(); |
4640
|
|
|
|
|
|
|
} |
4641
|
|
|
|
|
|
|
|
4642
|
0
|
|
|
0
|
0
|
|
sub init_meta{ |
4643
|
0
|
|
|
|
|
|
shift; |
4644
|
|
|
|
|
|
|
my %args = @_; |
4645
|
|
|
|
|
|
|
|
4646
|
0
|
0
|
|
|
|
|
my $class = $args{for_class} |
4647
|
|
|
|
|
|
|
or Carp::confess("Cannot call init_meta without specifying a for_class"); |
4648
|
0
|
|
0
|
|
|
|
|
4649
|
|
|
|
|
|
|
my $metaclass = $args{metaclass} || 'Mouse::Meta::Role'; |
4650
|
0
|
|
|
|
|
|
|
4651
|
|
|
|
|
|
|
my $meta = $metaclass->initialize($class); |
4652
|
|
|
|
|
|
|
|
4653
|
0
|
|
0
|
0
|
|
|
$meta->add_method(meta => sub{ |
4654
|
0
|
|
|
|
|
|
$metaclass->initialize(ref($_[0]) || $_[0]); |
4655
|
|
|
|
|
|
|
}); |
4656
|
|
|
|
|
|
|
|
4657
|
0
|
0
|
|
|
|
|
# make a role type for each Mouse role |
4658
|
|
|
|
|
|
|
Mouse::Util::TypeConstraints::role_type($class) |
4659
|
|
|
|
|
|
|
unless Mouse::Util::TypeConstraints::find_type_constraint($class); |
4660
|
0
|
|
|
|
|
|
|
4661
|
|
|
|
|
|
|
return $meta; |
4662
|
|
|
|
|
|
|
} |
4663
|
|
|
|
|
|
|
|
4664
|
0
|
|
|
|
|
0
|
} |
4665
|
|
|
|
|
|
|
BEGIN{ # lib/Mouse/Util/MetaRole.pm |
4666
|
2
|
|
|
2
|
|
15
|
package Mouse::Util::MetaRole; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4
|
|
4667
|
2
|
|
|
2
|
|
6
|
use Mouse::Util; # enables strict and warnings |
|
2
|
|
|
0
|
|
3
|
|
|
2
|
|
|
|
|
1129
|
|
4668
|
|
|
|
|
|
|
use Scalar::Util (); |
4669
|
|
|
|
|
|
|
|
4670
|
0
|
|
|
0
|
0
|
|
sub apply_metaclass_roles { |
4671
|
0
|
|
|
|
|
|
my %args = @_; |
4672
|
|
|
|
|
|
|
_fixup_old_style_args(\%args); |
4673
|
0
|
|
|
|
|
|
|
4674
|
|
|
|
|
|
|
return apply_metaroles(%args); |
4675
|
|
|
|
|
|
|
} |
4676
|
|
|
|
|
|
|
|
4677
|
0
|
|
|
0
|
1
|
|
sub apply_metaroles { |
4678
|
|
|
|
|
|
|
my %args = @_; |
4679
|
|
|
|
|
|
|
|
4680
|
|
|
|
|
|
|
my $for = Scalar::Util::blessed($args{for}) |
4681
|
0
|
0
|
|
|
|
|
? $args{for} |
4682
|
|
|
|
|
|
|
: Mouse::Util::get_metaclass_by_name( $args{for} ); |
4683
|
0
|
0
|
|
|
|
|
|
4684
|
0
|
|
|
|
|
|
if(!$for){ |
4685
|
|
|
|
|
|
|
Carp::confess("You must pass an initialized class, but '$args{for}' has no metaclass"); |
4686
|
|
|
|
|
|
|
} |
4687
|
0
|
0
|
|
|
|
|
|
4688
|
0
|
|
|
|
|
|
if ( Mouse::Util::is_a_metarole($for) ) { |
4689
|
|
|
|
|
|
|
return _make_new_metaclass( $for, $args{role_metaroles}, 'role' ); |
4690
|
|
|
|
|
|
|
} |
4691
|
0
|
|
|
|
|
|
else { |
4692
|
|
|
|
|
|
|
return _make_new_metaclass( $for, $args{class_metaroles}, 'class' ); |
4693
|
|
|
|
|
|
|
} |
4694
|
|
|
|
|
|
|
} |
4695
|
|
|
|
|
|
|
|
4696
|
0
|
|
|
0
|
|
|
sub _make_new_metaclass { |
4697
|
|
|
|
|
|
|
my($for, $roles, $primary) = @_; |
4698
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4699
|
|
|
|
|
|
|
return $for unless keys %{$roles}; |
4700
|
|
|
|
|
|
|
|
4701
|
0
|
0
|
|
|
|
|
my $new_metaclass = exists($roles->{$primary}) |
4702
|
|
|
|
|
|
|
? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits |
4703
|
|
|
|
|
|
|
: ref $for; |
4704
|
0
|
|
|
|
|
|
|
4705
|
|
|
|
|
|
|
my %classes; |
4706
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4707
|
0
|
|
|
|
|
|
for my $key ( grep { $_ ne $primary } keys %{$roles} ) { |
4708
|
0
|
|
0
|
|
|
|
my $metaclass; |
4709
|
|
|
|
|
|
|
my $attr = $for->can($metaclass = ($key . '_metaclass')) |
4710
|
|
|
|
|
|
|
|| $for->can($metaclass = ($key . '_class')) |
4711
|
|
|
|
|
|
|
|| $for->throw_error("Unknown metaclass '$key'"); |
4712
|
|
|
|
|
|
|
|
4713
|
0
|
|
|
|
|
|
$classes{ $metaclass } |
4714
|
|
|
|
|
|
|
= _make_new_class( $for->$attr(), $roles->{$key} ); |
4715
|
|
|
|
|
|
|
} |
4716
|
0
|
|
|
|
|
|
|
4717
|
|
|
|
|
|
|
return $new_metaclass->reinitialize( $for, %classes ); |
4718
|
|
|
|
|
|
|
} |
4719
|
|
|
|
|
|
|
|
4720
|
|
|
|
|
|
|
|
4721
|
0
|
|
|
0
|
|
|
sub _fixup_old_style_args { |
4722
|
|
|
|
|
|
|
my $args = shift; |
4723
|
0
|
0
|
0
|
|
|
|
|
4724
|
|
|
|
|
|
|
return if $args->{class_metaroles} || $args->{roles_metaroles}; |
4725
|
|
|
|
|
|
|
|
4726
|
0
|
0
|
|
|
|
|
$args->{for} = delete $args->{for_class} |
4727
|
|
|
|
|
|
|
if exists $args->{for_class}; |
4728
|
0
|
|
|
|
|
|
|
4729
|
|
|
|
|
|
|
my @old_keys = qw( |
4730
|
|
|
|
|
|
|
attribute_metaclass_roles |
4731
|
|
|
|
|
|
|
method_metaclass_roles |
4732
|
|
|
|
|
|
|
wrapped_method_metaclass_roles |
4733
|
|
|
|
|
|
|
instance_metaclass_roles |
4734
|
|
|
|
|
|
|
constructor_class_roles |
4735
|
|
|
|
|
|
|
destructor_class_roles |
4736
|
|
|
|
|
|
|
error_class_roles |
4737
|
|
|
|
|
|
|
|
4738
|
|
|
|
|
|
|
application_to_class_class_roles |
4739
|
|
|
|
|
|
|
application_to_role_class_roles |
4740
|
|
|
|
|
|
|
application_to_instance_class_roles |
4741
|
|
|
|
|
|
|
application_role_summation_class_roles |
4742
|
|
|
|
|
|
|
); |
4743
|
|
|
|
|
|
|
|
4744
|
|
|
|
|
|
|
my $for = Scalar::Util::blessed($args->{for}) |
4745
|
0
|
0
|
|
|
|
|
? $args->{for} |
4746
|
|
|
|
|
|
|
: Mouse::Util::get_metaclass_by_name( $args->{for} ); |
4747
|
0
|
|
|
|
|
|
|
4748
|
0
|
0
|
|
|
|
|
my $top_key; |
4749
|
0
|
|
|
|
|
|
if( Mouse::Util::is_a_metaclass($for) ){ |
4750
|
|
|
|
|
|
|
$top_key = 'class_metaroles'; |
4751
|
|
|
|
|
|
|
|
4752
|
0
|
0
|
|
|
|
|
$args->{class_metaroles}{class} = delete $args->{metaclass_roles} |
4753
|
|
|
|
|
|
|
if exists $args->{metaclass_roles}; |
4754
|
|
|
|
|
|
|
} |
4755
|
0
|
|
|
|
|
|
else { |
4756
|
|
|
|
|
|
|
$top_key = 'role_metaroles'; |
4757
|
|
|
|
|
|
|
|
4758
|
0
|
0
|
|
|
|
|
$args->{role_metaroles}{role} = delete $args->{metaclass_roles} |
4759
|
|
|
|
|
|
|
if exists $args->{metaclass_roles}; |
4760
|
|
|
|
|
|
|
} |
4761
|
0
|
|
|
|
|
|
|
4762
|
0
|
|
|
|
|
|
for my $old_key (@old_keys) { |
4763
|
|
|
|
|
|
|
my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/; |
4764
|
|
|
|
|
|
|
|
4765
|
0
|
0
|
|
|
|
|
$args->{$top_key}{$new_key} = delete $args->{$old_key} |
4766
|
|
|
|
|
|
|
if exists $args->{$old_key}; |
4767
|
|
|
|
|
|
|
} |
4768
|
0
|
|
|
|
|
|
|
4769
|
|
|
|
|
|
|
return; |
4770
|
|
|
|
|
|
|
} |
4771
|
|
|
|
|
|
|
|
4772
|
|
|
|
|
|
|
|
4773
|
0
|
|
|
0
|
1
|
|
sub apply_base_class_roles { |
4774
|
|
|
|
|
|
|
my %options = @_; |
4775
|
0
|
|
|
|
|
|
|
4776
|
|
|
|
|
|
|
my $for = $options{for_class}; |
4777
|
0
|
|
|
|
|
|
|
4778
|
|
|
|
|
|
|
my $meta = Mouse::Util::class_of($for); |
4779
|
|
|
|
|
|
|
|
4780
|
|
|
|
|
|
|
my $new_base = _make_new_class( |
4781
|
|
|
|
|
|
|
$for, |
4782
|
0
|
|
|
|
|
|
$options{roles}, |
4783
|
|
|
|
|
|
|
[ $meta->superclasses() ], |
4784
|
|
|
|
|
|
|
); |
4785
|
0
|
0
|
|
|
|
|
|
4786
|
|
|
|
|
|
|
$meta->superclasses($new_base) |
4787
|
0
|
|
|
|
|
|
if $new_base ne $meta->name(); |
4788
|
|
|
|
|
|
|
return; |
4789
|
|
|
|
|
|
|
} |
4790
|
|
|
|
|
|
|
|
4791
|
0
|
|
|
0
|
|
|
sub _make_new_class { |
4792
|
|
|
|
|
|
|
my($existing_class, $roles, $superclasses) = @_; |
4793
|
0
|
0
|
|
|
|
|
|
4794
|
0
|
0
|
|
|
|
|
if(!$superclasses){ |
4795
|
|
|
|
|
|
|
return $existing_class if !$roles; |
4796
|
0
|
|
|
|
|
|
|
4797
|
|
|
|
|
|
|
my $meta = Mouse::Meta::Class->initialize($existing_class); |
4798
|
|
|
|
|
|
|
|
4799
|
0
|
0
|
0
|
|
|
|
return $existing_class |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
4800
|
|
|
|
|
|
|
if !grep { !ref($_) && !$meta->does_role($_) } @{$roles}; |
4801
|
|
|
|
|
|
|
} |
4802
|
0
|
0
|
|
|
|
|
|
4803
|
|
|
|
|
|
|
return Mouse::Meta::Class->create_anon_class( |
4804
|
|
|
|
|
|
|
superclasses => $superclasses ? $superclasses : [$existing_class], |
4805
|
|
|
|
|
|
|
roles => $roles, |
4806
|
|
|
|
|
|
|
cache => 1, |
4807
|
|
|
|
|
|
|
)->name(); |
4808
|
|
|
|
|
|
|
} |
4809
|
|
|
|
|
|
|
|
4810
|
|
|
|
|
|
|
} |
4811
|
|
|
|
|
|
|
END_OF_TINY |
4812
|
|
|
|
|
|
|
die $@ if $@; |
4813
|
|
|
|
|
|
|
} # unless Mouse.pm is loaded |
4814
|
|
|
|
|
|
|
package Mouse::Tiny; |
4815
|
|
|
|
|
|
|
|
4816
|
|
|
|
|
|
|
our $VERSION = 'v2.4.9'; |
4817
|
|
|
|
|
|
|
|
4818
|
|
|
|
|
|
|
Mouse::Exporter->setup_import_methods(also => 'Mouse'); |
4819
|
|
|
|
|
|
|
|
4820
|
|
|
|
|
|
|
1; |