line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Mouse::PurePerl; |
2
|
|
|
|
|
|
|
# The pure Perl backend for Mouse |
3
|
|
|
|
|
|
|
package Mouse::Util; |
4
|
1
|
|
|
1
|
|
13155
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
23
|
|
5
|
1
|
|
|
1
|
|
3
|
use warnings; |
|
1
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
24
|
|
6
|
1
|
|
|
1
|
|
3
|
use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl twice |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
31
|
|
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
3
|
use Scalar::Util (); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
14
|
|
9
|
1
|
|
|
1
|
|
2
|
use B (); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
363
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
require Mouse::Util; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# taken from Class/MOP.pm |
14
|
|
|
|
|
|
|
sub is_valid_class_name { |
15
|
1
|
|
|
1
|
0
|
1
|
my $class = shift; |
16
|
|
|
|
|
|
|
|
17
|
1
|
50
|
|
|
|
3
|
return 0 if ref($class); |
18
|
1
|
50
|
|
|
|
5
|
return 0 unless defined($class); |
19
|
|
|
|
|
|
|
|
20
|
1
|
50
|
|
|
|
21
|
return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms; |
21
|
|
|
|
|
|
|
|
22
|
0
|
|
|
|
|
0
|
return 0; |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
sub is_class_loaded { |
26
|
1
|
|
|
1
|
1
|
2
|
my $class = shift; |
27
|
|
|
|
|
|
|
|
28
|
1
|
50
|
33
|
|
|
11
|
return 0 if ref($class) || !defined($class) || !length($class); |
|
|
|
33
|
|
|
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# walk the symbol table tree to avoid autovififying |
31
|
|
|
|
|
|
|
# \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar:: |
32
|
|
|
|
|
|
|
|
33
|
1
|
|
|
|
|
3
|
my $pack = \%::; |
34
|
1
|
|
|
|
|
5
|
foreach my $part (split('::', $class)) { |
35
|
2
|
|
|
|
|
3
|
$part .= '::'; |
36
|
2
|
50
|
|
|
|
7
|
return 0 if !exists $pack->{$part}; |
37
|
|
|
|
|
|
|
|
38
|
2
|
|
|
|
|
3
|
my $entry = \$pack->{$part}; |
39
|
2
|
50
|
|
|
|
7
|
return 0 if ref($entry) ne 'GLOB'; |
40
|
2
|
|
|
|
|
2
|
$pack = *{$entry}{HASH}; |
|
2
|
|
|
|
|
8
|
|
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
1
|
50
|
|
|
|
2
|
return 0 if !%{$pack}; |
|
1
|
|
|
|
|
7
|
|
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# check for $VERSION or @ISA |
46
|
|
|
|
|
|
|
return 1 if exists $pack->{VERSION} |
47
|
1
|
0
|
33
|
|
|
9
|
&& defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} }; |
|
0
|
|
33
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
48
|
|
|
|
|
|
|
return 1 if exists $pack->{ISA} |
49
|
1
|
0
|
33
|
|
|
4
|
&& defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0; |
|
0
|
|
33
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# check for any method |
52
|
1
|
|
|
|
|
2
|
foreach my $name( keys %{$pack} ) { |
|
1
|
|
|
|
|
5
|
|
53
|
1
|
|
|
|
|
2
|
my $entry = \$pack->{$name}; |
54
|
1
|
50
|
33
|
|
|
6
|
return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE}; |
|
1
|
|
|
|
|
10
|
|
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# fail |
58
|
0
|
|
|
|
|
0
|
return 0; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# taken from Sub::Identify |
63
|
|
|
|
|
|
|
sub get_code_info { |
64
|
2
|
|
|
2
|
1
|
2
|
my ($coderef) = @_; |
65
|
2
|
50
|
|
|
|
6
|
ref($coderef) or return; |
66
|
|
|
|
|
|
|
|
67
|
2
|
|
|
|
|
7
|
my $cv = B::svref_2object($coderef); |
68
|
2
|
50
|
|
|
|
26
|
$cv->isa('B::CV') or return; |
69
|
|
|
|
|
|
|
|
70
|
2
|
|
|
|
|
8
|
my $gv = $cv->GV; |
71
|
2
|
50
|
|
|
|
11
|
$gv->isa('B::GV') or return; |
72
|
|
|
|
|
|
|
|
73
|
2
|
|
|
|
|
23
|
return ($gv->STASH->NAME, $gv->NAME); |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub get_code_package{ |
77
|
0
|
|
|
0
|
1
|
0
|
my($coderef) = @_; |
78
|
|
|
|
|
|
|
|
79
|
0
|
|
|
|
|
0
|
my $cv = B::svref_2object($coderef); |
80
|
0
|
0
|
|
|
|
0
|
$cv->isa('B::CV') or return ''; |
81
|
|
|
|
|
|
|
|
82
|
0
|
|
|
|
|
0
|
my $gv = $cv->GV; |
83
|
0
|
0
|
|
|
|
0
|
$gv->isa('B::GV') or return ''; |
84
|
|
|
|
|
|
|
|
85
|
0
|
|
|
|
|
0
|
return $gv->STASH->NAME; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
sub get_code_ref{ |
89
|
0
|
|
|
0
|
1
|
0
|
my($package, $name) = @_; |
90
|
1
|
|
|
1
|
|
3
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
24
|
|
91
|
1
|
|
|
1
|
|
2
|
no warnings 'once'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
23
|
|
92
|
1
|
|
|
1
|
|
3
|
use warnings FATAL => 'uninitialized'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
780
|
|
93
|
0
|
|
|
|
|
0
|
return *{$package . '::' . $name}{CODE}; |
|
0
|
|
|
|
|
0
|
|
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub generate_isa_predicate_for { |
97
|
1
|
|
|
1
|
0
|
2
|
my($for_class, $name) = @_; |
98
|
|
|
|
|
|
|
|
99
|
1
|
0
|
|
0
|
|
5
|
my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) }; |
|
0
|
|
|
|
|
0
|
|
100
|
|
|
|
|
|
|
|
101
|
1
|
50
|
|
|
|
3
|
if(defined $name){ |
102
|
0
|
|
|
|
|
0
|
Mouse::Util::install_subroutines(scalar caller, $name => $predicate); |
103
|
0
|
|
|
|
|
0
|
return; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
1
|
|
|
|
|
3
|
return $predicate; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub generate_can_predicate_for { |
110
|
3
|
|
|
3
|
0
|
3
|
my($methods_ref, $name) = @_; |
111
|
|
|
|
|
|
|
|
112
|
3
|
|
|
|
|
2
|
my @methods = @{$methods_ref}; |
|
3
|
|
|
|
|
4
|
|
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
my $predicate = sub{ |
115
|
2
|
|
|
2
|
|
3
|
my($instance) = @_; |
116
|
2
|
50
|
|
|
|
13
|
if(Scalar::Util::blessed($instance)){ |
117
|
0
|
|
|
|
|
0
|
foreach my $method(@methods){ |
118
|
0
|
0
|
|
|
|
0
|
if(!$instance->can($method)){ |
119
|
0
|
|
|
|
|
0
|
return 0; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
} |
122
|
0
|
|
|
|
|
0
|
return 1; |
123
|
|
|
|
|
|
|
} |
124
|
2
|
|
|
|
|
14
|
return 0; |
125
|
3
|
|
|
|
|
8
|
}; |
126
|
|
|
|
|
|
|
|
127
|
3
|
50
|
|
|
|
5
|
if(defined $name){ |
128
|
3
|
|
|
|
|
6
|
Mouse::Util::install_subroutines(scalar caller, $name => $predicate); |
129
|
3
|
|
|
|
|
5
|
return; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
0
|
|
|
|
|
0
|
return $predicate; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
package Mouse::Util::TypeConstraints; |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
|
138
|
0
|
|
|
0
|
0
|
0
|
sub Any { 1 } |
139
|
0
|
|
|
0
|
0
|
0
|
sub Item { 1 } |
140
|
|
|
|
|
|
|
|
141
|
0
|
0
|
|
0
|
0
|
0
|
sub Bool { !$_[0] || $_[0] eq '1' } |
142
|
0
|
|
|
0
|
0
|
0
|
sub Undef { !defined($_[0]) } |
143
|
0
|
|
|
0
|
0
|
0
|
sub Defined { defined($_[0]) } |
144
|
0
|
0
|
|
0
|
0
|
0
|
sub Value { defined($_[0]) && !ref($_[0]) } |
145
|
0
|
|
|
0
|
0
|
0
|
sub Num { Scalar::Util::looks_like_number($_[0]) } |
146
|
|
|
|
|
|
|
sub Str { |
147
|
|
|
|
|
|
|
# We need to use a copy here to flatten MAGICs, for instance as in |
148
|
|
|
|
|
|
|
# Str( substr($_, 0, 42) ). |
149
|
0
|
|
|
0
|
0
|
0
|
my($value) = @_; |
150
|
0
|
|
0
|
|
|
0
|
return defined($value) && ref(\$value) eq 'SCALAR'; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
sub Int { |
153
|
|
|
|
|
|
|
# We need to use a copy here to save the original internal SV flags. |
154
|
0
|
|
|
0
|
0
|
0
|
my($value) = @_; |
155
|
0
|
|
0
|
|
|
0
|
return defined($value) && $value =~ /\A -? [0-9]+ \z/xms; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
0
|
|
|
0
|
0
|
0
|
sub Ref { ref($_[0]) } |
159
|
|
|
|
|
|
|
sub ScalarRef { |
160
|
0
|
|
|
0
|
0
|
0
|
my($value) = @_; |
161
|
0
|
|
0
|
|
|
0
|
return ref($value) eq 'SCALAR' || ref($value) eq 'REF'; |
162
|
|
|
|
|
|
|
} |
163
|
0
|
|
|
0
|
0
|
0
|
sub ArrayRef { ref($_[0]) eq 'ARRAY' } |
164
|
0
|
|
|
0
|
0
|
0
|
sub HashRef { ref($_[0]) eq 'HASH' } |
165
|
0
|
|
|
0
|
0
|
0
|
sub CodeRef { ref($_[0]) eq 'CODE' } |
166
|
0
|
|
|
0
|
0
|
0
|
sub RegexpRef { ref($_[0]) eq 'Regexp' } |
167
|
0
|
|
|
0
|
0
|
0
|
sub GlobRef { ref($_[0]) eq 'GLOB' } |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
sub FileHandle { |
170
|
0
|
|
|
0
|
0
|
0
|
my($value) = @_; |
171
|
0
|
|
0
|
|
|
0
|
return Scalar::Util::openhandle($value) |
172
|
|
|
|
|
|
|
|| (Scalar::Util::blessed($value) && $value->isa("IO::Handle")) |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
0
|
0
|
|
0
|
0
|
0
|
sub Object { Scalar::Util::blessed($_[0]) && ref($_[0]) ne 'Regexp' } |
176
|
|
|
|
|
|
|
|
177
|
0
|
|
|
0
|
0
|
0
|
sub ClassName { Mouse::Util::is_class_loaded($_[0]) } |
178
|
0
|
|
0
|
0
|
0
|
0
|
sub RoleName { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') } |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub _parameterize_ArrayRef_for { |
181
|
0
|
|
|
0
|
|
0
|
my($type_parameter) = @_; |
182
|
0
|
|
|
|
|
0
|
my $check = $type_parameter->_compiled_type_constraint; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
return sub { |
185
|
0
|
|
|
0
|
|
0
|
foreach my $value (@{$_}) { |
|
0
|
|
|
|
|
0
|
|
186
|
0
|
0
|
|
|
|
0
|
return undef unless $check->($value); |
187
|
|
|
|
|
|
|
} |
188
|
0
|
|
|
|
|
0
|
return 1; |
189
|
|
|
|
|
|
|
} |
190
|
0
|
|
|
|
|
0
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub _parameterize_HashRef_for { |
193
|
0
|
|
|
0
|
|
0
|
my($type_parameter) = @_; |
194
|
0
|
|
|
|
|
0
|
my $check = $type_parameter->_compiled_type_constraint; |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
return sub { |
197
|
0
|
|
|
0
|
|
0
|
foreach my $value(values %{$_}){ |
|
0
|
|
|
|
|
0
|
|
198
|
0
|
0
|
|
|
|
0
|
return undef unless $check->($value); |
199
|
|
|
|
|
|
|
} |
200
|
0
|
|
|
|
|
0
|
return 1; |
201
|
0
|
|
|
|
|
0
|
}; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
# 'Maybe' type accepts 'Any', so it requires parameters |
205
|
|
|
|
|
|
|
sub _parameterize_Maybe_for { |
206
|
0
|
|
|
0
|
|
0
|
my($type_parameter) = @_; |
207
|
0
|
|
|
|
|
0
|
my $check = $type_parameter->_compiled_type_constraint; |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
return sub{ |
210
|
0
|
|
0
|
0
|
|
0
|
return !defined($_) || $check->($_); |
211
|
0
|
|
|
|
|
0
|
}; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
package Mouse::Meta::Module; |
215
|
|
|
|
|
|
|
|
216
|
1
|
|
|
1
|
0
|
5
|
sub name { $_[0]->{package} } |
217
|
|
|
|
|
|
|
|
218
|
0
|
|
|
0
|
|
0
|
sub _method_map { $_[0]->{methods} } |
219
|
0
|
|
|
0
|
|
0
|
sub _attribute_map{ $_[0]->{attributes} } |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
sub namespace{ |
222
|
0
|
|
|
0
|
0
|
0
|
my $name = $_[0]->{package}; |
223
|
1
|
|
|
1
|
|
4
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
203
|
|
224
|
0
|
|
|
|
|
0
|
return \%{ $name . '::' }; |
|
0
|
|
|
|
|
0
|
|
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
sub add_method { |
228
|
1
|
|
|
1
|
0
|
2
|
my($self, $name, $code) = @_; |
229
|
|
|
|
|
|
|
|
230
|
1
|
50
|
|
|
|
5
|
if(!defined $name){ |
231
|
0
|
|
|
|
|
0
|
$self->throw_error('You must pass a defined name'); |
232
|
|
|
|
|
|
|
} |
233
|
1
|
50
|
|
|
|
4
|
if(!defined $code){ |
234
|
0
|
|
|
|
|
0
|
$self->throw_error('You must pass a defined code'); |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
1
|
50
|
|
|
|
5
|
if(ref($code) ne 'CODE'){ |
238
|
0
|
|
|
|
|
0
|
$code = \&{$code}; # coerce |
|
0
|
|
|
|
|
0
|
|
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
1
|
|
|
|
|
3
|
$self->{methods}->{$name} = $code; # Moose stores meta object here. |
242
|
|
|
|
|
|
|
|
243
|
1
|
|
|
|
|
6
|
Mouse::Util::install_subroutines($self->name, |
244
|
|
|
|
|
|
|
$name => $code, |
245
|
|
|
|
|
|
|
); |
246
|
1
|
|
|
|
|
11
|
return; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
my $generate_class_accessor = sub { |
250
|
|
|
|
|
|
|
my($name) = @_; |
251
|
|
|
|
|
|
|
return sub { |
252
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
253
|
0
|
0
|
|
|
|
0
|
if(@_) { |
254
|
0
|
|
|
|
|
0
|
return $self->{$name} = shift; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
|
257
|
0
|
|
|
|
|
0
|
foreach my $class($self->linearized_isa) { |
258
|
0
|
0
|
|
|
|
0
|
my $meta = Mouse::Util::get_metaclass_by_name($class) |
259
|
|
|
|
|
|
|
or next; |
260
|
|
|
|
|
|
|
|
261
|
0
|
0
|
|
|
|
0
|
if(exists $meta->{$name}) { |
262
|
0
|
|
|
|
|
0
|
return $meta->{$name}; |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
} |
265
|
0
|
|
|
|
|
0
|
return undef; |
266
|
|
|
|
|
|
|
}; |
267
|
|
|
|
|
|
|
}; |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
package Mouse::Meta::Class; |
271
|
|
|
|
|
|
|
|
272
|
1
|
|
|
1
|
|
370
|
use Mouse::Meta::Method::Constructor; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
20
|
|
273
|
1
|
|
|
1
|
|
328
|
use Mouse::Meta::Method::Destructor; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
1690
|
|
274
|
|
|
|
|
|
|
|
275
|
0
|
0
|
|
0
|
0
|
0
|
sub method_metaclass { $_[0]->{method_metaclass} || 'Mouse::Meta::Method' } |
276
|
0
|
0
|
|
0
|
0
|
0
|
sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' } |
277
|
|
|
|
|
|
|
|
278
|
0
|
0
|
|
0
|
0
|
0
|
sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' } |
279
|
0
|
0
|
|
0
|
0
|
0
|
sub destructor_class { $_[0]->{destructor_class} || 'Mouse::Meta::Method::Destructor' } |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
sub is_anon_class{ |
282
|
0
|
|
|
0
|
0
|
0
|
return exists $_[0]->{anon_serial_id}; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
0
|
|
|
0
|
0
|
0
|
sub roles { $_[0]->{roles} } |
286
|
|
|
|
|
|
|
|
287
|
0
|
|
|
0
|
1
|
0
|
sub linearized_isa { @{ Mouse::Util::get_linear_isa($_[0]->{package}) } } |
|
0
|
|
|
|
|
0
|
|
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
sub new_object { |
290
|
0
|
|
|
0
|
1
|
0
|
my $meta = shift; |
291
|
0
|
0
|
|
|
|
0
|
my %args = (@_ == 1 ? %{$_[0]} : @_); |
|
0
|
|
|
|
|
0
|
|
292
|
|
|
|
|
|
|
|
293
|
0
|
|
|
|
|
0
|
my $object = bless {}, $meta->name; |
294
|
|
|
|
|
|
|
|
295
|
0
|
|
|
|
|
0
|
$meta->_initialize_object($object, \%args, 0); |
296
|
|
|
|
|
|
|
# BUILDALL |
297
|
0
|
0
|
|
|
|
0
|
if( $object->can('BUILD') ) { |
298
|
0
|
|
|
|
|
0
|
for my $class (reverse $meta->linearized_isa) { |
299
|
0
|
|
0
|
|
|
0
|
my $build = Mouse::Util::get_code_ref($class, 'BUILD') |
300
|
|
|
|
|
|
|
|| next; |
301
|
|
|
|
|
|
|
|
302
|
0
|
|
|
|
|
0
|
$object->$build(\%args); |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
} |
305
|
0
|
|
|
|
|
0
|
return $object; |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub clone_object { |
309
|
0
|
|
|
0
|
1
|
0
|
my $class = shift; |
310
|
0
|
|
|
|
|
0
|
my $object = shift; |
311
|
0
|
|
|
|
|
0
|
my $args = $object->Mouse::Object::BUILDARGS(@_); |
312
|
|
|
|
|
|
|
|
313
|
0
|
0
|
0
|
|
|
0
|
(Scalar::Util::blessed($object) && $object->isa($class->name)) |
314
|
|
|
|
|
|
|
|| $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)"); |
315
|
|
|
|
|
|
|
|
316
|
0
|
|
|
|
|
0
|
my $cloned = bless { %$object }, ref $object; |
317
|
0
|
|
|
|
|
0
|
$class->_initialize_object($cloned, $args, 1); |
318
|
0
|
|
|
|
|
0
|
return $cloned; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
sub _initialize_object{ |
322
|
0
|
|
|
0
|
|
0
|
my($self, $object, $args, $is_cloning) = @_; |
323
|
|
|
|
|
|
|
# The initializer, which is used everywhere, must be clear |
324
|
|
|
|
|
|
|
# when an attribute is added. See Mouse::Meta::Class::add_attribute. |
325
|
|
|
|
|
|
|
my $initializer = $self->{_mouse_cache}{_initialize_object} ||= |
326
|
0
|
|
0
|
|
|
0
|
Mouse::Util::load_class($self->constructor_class) |
327
|
|
|
|
|
|
|
->_generate_initialize_object($self); |
328
|
0
|
|
|
|
|
0
|
goto &{$initializer}; |
|
0
|
|
|
|
|
0
|
|
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
sub get_all_attributes { |
332
|
0
|
|
|
0
|
1
|
0
|
my($self) = @_; |
333
|
0
|
|
|
|
|
0
|
return @{ $self->{_mouse_cache}{all_attributes} |
334
|
0
|
|
0
|
|
|
0
|
||= $self->_calculate_all_attributes }; |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
|
337
|
0
|
|
|
0
|
0
|
0
|
sub is_immutable { $_[0]->{is_immutable} } |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub strict_constructor; |
340
|
|
|
|
|
|
|
*strict_constructor = $generate_class_accessor->('strict_constructor'); |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
sub _invalidate_metaclass_cache { |
343
|
0
|
|
|
0
|
|
0
|
my($self) = @_; |
344
|
0
|
|
|
|
|
0
|
delete $self->{_mouse_cache}; |
345
|
0
|
|
|
|
|
0
|
return; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
sub _report_unknown_args { |
349
|
0
|
|
|
0
|
|
0
|
my($metaclass, $attrs, $args) = @_; |
350
|
|
|
|
|
|
|
|
351
|
0
|
|
|
|
|
0
|
my @unknowns; |
352
|
|
|
|
|
|
|
my %init_args; |
353
|
0
|
|
|
|
|
0
|
foreach my $attr(@{$attrs}){ |
|
0
|
|
|
|
|
0
|
|
354
|
0
|
|
|
|
|
0
|
my $init_arg = $attr->init_arg; |
355
|
0
|
0
|
|
|
|
0
|
if(defined $init_arg){ |
356
|
0
|
|
|
|
|
0
|
$init_args{$init_arg}++; |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
|
360
|
0
|
|
|
|
|
0
|
while(my $key = each %{$args}){ |
|
0
|
|
|
|
|
0
|
|
361
|
0
|
0
|
|
|
|
0
|
if(!exists $init_args{$key}){ |
362
|
0
|
|
|
|
|
0
|
push @unknowns, $key; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
0
|
|
|
|
|
0
|
$metaclass->throw_error( sprintf |
367
|
|
|
|
|
|
|
"Unknown attribute passed to the constructor of %s: %s", |
368
|
|
|
|
|
|
|
$metaclass->name, Mouse::Util::english_list(@unknowns), |
369
|
|
|
|
|
|
|
); |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
package Mouse::Meta::Role; |
373
|
|
|
|
|
|
|
|
374
|
0
|
0
|
|
0
|
0
|
0
|
sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' } |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
sub is_anon_role{ |
377
|
0
|
|
|
0
|
0
|
0
|
return exists $_[0]->{anon_serial_id}; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
0
|
|
|
0
|
0
|
0
|
sub get_roles { $_[0]->{roles} } |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
sub add_before_method_modifier { |
383
|
0
|
|
|
0
|
0
|
0
|
my ($self, $method_name, $method) = @_; |
384
|
|
|
|
|
|
|
|
385
|
0
|
|
0
|
|
|
0
|
push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method; |
|
0
|
|
|
|
|
0
|
|
386
|
0
|
|
|
|
|
0
|
return; |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
sub add_around_method_modifier { |
389
|
0
|
|
|
0
|
0
|
0
|
my ($self, $method_name, $method) = @_; |
390
|
|
|
|
|
|
|
|
391
|
0
|
|
0
|
|
|
0
|
push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method; |
|
0
|
|
|
|
|
0
|
|
392
|
0
|
|
|
|
|
0
|
return; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
sub add_after_method_modifier { |
395
|
0
|
|
|
0
|
0
|
0
|
my ($self, $method_name, $method) = @_; |
396
|
|
|
|
|
|
|
|
397
|
0
|
|
0
|
|
|
0
|
push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method; |
|
0
|
|
|
|
|
0
|
|
398
|
0
|
|
|
|
|
0
|
return; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
sub get_before_method_modifiers { |
402
|
0
|
|
|
0
|
0
|
0
|
my ($self, $method_name) = @_; |
403
|
0
|
|
0
|
|
|
0
|
return @{ $self->{before_method_modifiers}{$method_name} ||= [] } |
|
0
|
|
|
|
|
0
|
|
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
sub get_around_method_modifiers { |
406
|
0
|
|
|
0
|
0
|
0
|
my ($self, $method_name) = @_; |
407
|
0
|
|
0
|
|
|
0
|
return @{ $self->{around_method_modifiers}{$method_name} ||= [] } |
|
0
|
|
|
|
|
0
|
|
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
sub get_after_method_modifiers { |
410
|
0
|
|
|
0
|
0
|
0
|
my ($self, $method_name) = @_; |
411
|
0
|
|
0
|
|
|
0
|
return @{ $self->{after_method_modifiers}{$method_name} ||= [] } |
|
0
|
|
|
|
|
0
|
|
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
sub add_metaclass_accessor { # for meta roles (a.k.a. traits) |
415
|
0
|
|
|
0
|
0
|
0
|
my($meta, $name) = @_; |
416
|
0
|
|
|
|
|
0
|
$meta->add_method($name => $generate_class_accessor->($name)); |
417
|
0
|
|
|
|
|
0
|
return; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
package Mouse::Meta::Attribute; |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
require Mouse::Meta::Method::Accessor; |
423
|
|
|
|
|
|
|
|
424
|
0
|
0
|
|
0
|
0
|
0
|
sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' } |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
# readers |
427
|
|
|
|
|
|
|
|
428
|
0
|
|
|
0
|
0
|
0
|
sub name { $_[0]->{name} } |
429
|
0
|
|
|
0
|
0
|
0
|
sub associated_class { $_[0]->{associated_class} } |
430
|
|
|
|
|
|
|
|
431
|
0
|
|
|
0
|
0
|
0
|
sub accessor { $_[0]->{accessor} } |
432
|
0
|
|
|
0
|
0
|
0
|
sub reader { $_[0]->{reader} } |
433
|
0
|
|
|
0
|
0
|
0
|
sub writer { $_[0]->{writer} } |
434
|
0
|
|
|
0
|
0
|
0
|
sub predicate { $_[0]->{predicate} } |
435
|
0
|
|
|
0
|
0
|
0
|
sub clearer { $_[0]->{clearer} } |
436
|
0
|
|
|
0
|
0
|
0
|
sub handles { $_[0]->{handles} } |
437
|
|
|
|
|
|
|
|
438
|
0
|
|
|
0
|
|
0
|
sub _is_metadata { $_[0]->{is} } |
439
|
0
|
|
|
0
|
0
|
0
|
sub is_required { $_[0]->{required} } |
440
|
|
|
|
|
|
|
sub default { |
441
|
0
|
|
|
0
|
0
|
0
|
my($self, $instance) = @_; |
442
|
0
|
|
|
|
|
0
|
my $value = $self->{default}; |
443
|
0
|
0
|
0
|
|
|
0
|
$value = $value->($instance) if defined($instance) and ref($value) eq "CODE"; |
444
|
0
|
|
|
|
|
0
|
return $value; |
445
|
|
|
|
|
|
|
} |
446
|
0
|
|
|
0
|
0
|
0
|
sub is_lazy { $_[0]->{lazy} } |
447
|
0
|
|
|
0
|
0
|
0
|
sub is_lazy_build { $_[0]->{lazy_build} } |
448
|
0
|
|
|
0
|
0
|
0
|
sub is_weak_ref { $_[0]->{weak_ref} } |
449
|
0
|
|
|
0
|
0
|
0
|
sub init_arg { $_[0]->{init_arg} } |
450
|
0
|
|
|
0
|
0
|
0
|
sub type_constraint { $_[0]->{type_constraint} } |
451
|
|
|
|
|
|
|
|
452
|
0
|
|
|
0
|
1
|
0
|
sub trigger { $_[0]->{trigger} } |
453
|
0
|
|
|
0
|
0
|
0
|
sub builder { $_[0]->{builder} } |
454
|
0
|
|
|
0
|
0
|
0
|
sub should_auto_deref { $_[0]->{auto_deref} } |
455
|
0
|
|
|
0
|
0
|
0
|
sub should_coerce { $_[0]->{coerce} } |
456
|
|
|
|
|
|
|
|
457
|
0
|
|
|
0
|
0
|
0
|
sub documentation { $_[0]->{documentation} } |
458
|
0
|
|
|
0
|
0
|
0
|
sub insertion_order { $_[0]->{insertion_order} } |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
# predicates |
461
|
|
|
|
|
|
|
|
462
|
0
|
|
|
0
|
0
|
0
|
sub has_accessor { exists $_[0]->{accessor} } |
463
|
0
|
|
|
0
|
0
|
0
|
sub has_reader { exists $_[0]->{reader} } |
464
|
0
|
|
|
0
|
0
|
0
|
sub has_writer { exists $_[0]->{writer} } |
465
|
0
|
|
|
0
|
0
|
0
|
sub has_predicate { exists $_[0]->{predicate} } |
466
|
0
|
|
|
0
|
0
|
0
|
sub has_clearer { exists $_[0]->{clearer} } |
467
|
0
|
|
|
0
|
0
|
0
|
sub has_handles { exists $_[0]->{handles} } |
468
|
|
|
|
|
|
|
|
469
|
0
|
|
|
0
|
0
|
0
|
sub has_default { exists $_[0]->{default} } |
470
|
0
|
|
|
0
|
0
|
0
|
sub has_type_constraint { exists $_[0]->{type_constraint} } |
471
|
0
|
|
|
0
|
0
|
0
|
sub has_trigger { exists $_[0]->{trigger} } |
472
|
0
|
|
|
0
|
0
|
0
|
sub has_builder { exists $_[0]->{builder} } |
473
|
|
|
|
|
|
|
|
474
|
0
|
|
|
0
|
0
|
0
|
sub has_documentation { exists $_[0]->{documentation} } |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
sub _process_options{ |
477
|
0
|
|
|
0
|
|
0
|
my($class, $name, $args) = @_; |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
# taken from Class::MOP::Attribute::new |
480
|
|
|
|
|
|
|
|
481
|
0
|
0
|
|
|
|
0
|
defined($name) |
482
|
|
|
|
|
|
|
or $class->throw_error('You must provide a name for the attribute'); |
483
|
|
|
|
|
|
|
|
484
|
0
|
0
|
|
|
|
0
|
if(!exists $args->{init_arg}){ |
485
|
0
|
|
|
|
|
0
|
$args->{init_arg} = $name; |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# 'required' requires either 'init_arg', 'builder', or 'default' |
489
|
0
|
|
|
|
|
0
|
my $can_be_required = defined( $args->{init_arg} ); |
490
|
|
|
|
|
|
|
|
491
|
0
|
0
|
|
|
|
0
|
if(exists $args->{builder}){ |
|
|
0
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# XXX: |
493
|
|
|
|
|
|
|
# Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility |
494
|
|
|
|
|
|
|
# This feature will be changed in a future. (gfx) |
495
|
|
|
|
|
|
|
$class->throw_error('builder must be a defined scalar value which is a method name') |
496
|
|
|
|
|
|
|
#if ref $args->{builder} || !defined $args->{builder}; |
497
|
0
|
0
|
|
|
|
0
|
if !defined $args->{builder}; |
498
|
|
|
|
|
|
|
|
499
|
0
|
|
|
|
|
0
|
$can_be_required++; |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
elsif(exists $args->{default}){ |
502
|
0
|
0
|
0
|
|
|
0
|
if(ref $args->{default} && ref($args->{default}) ne 'CODE'){ |
503
|
0
|
|
|
|
|
0
|
$class->throw_error("References are not allowed as default values, you must " |
504
|
|
|
|
|
|
|
. "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"); |
505
|
|
|
|
|
|
|
} |
506
|
0
|
|
|
|
|
0
|
$can_be_required++; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
0
|
0
|
0
|
|
|
0
|
if( $args->{required} && !$can_be_required ) { |
510
|
0
|
|
|
|
|
0
|
$class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg"); |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
# taken from Mouse::Meta::Attribute->new and ->_process_args |
514
|
|
|
|
|
|
|
|
515
|
0
|
0
|
|
|
|
0
|
if(exists $args->{is}){ |
516
|
0
|
|
|
|
|
0
|
my $is = $args->{is}; |
517
|
|
|
|
|
|
|
|
518
|
0
|
0
|
|
|
|
0
|
if($is eq 'ro'){ |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
519
|
0
|
|
0
|
|
|
0
|
$args->{reader} ||= $name; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
elsif($is eq 'rw'){ |
522
|
0
|
0
|
|
|
|
0
|
if(exists $args->{writer}){ |
523
|
0
|
|
0
|
|
|
0
|
$args->{reader} ||= $name; |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
else{ |
526
|
0
|
|
0
|
|
|
0
|
$args->{accessor} ||= $name; |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
elsif($is eq 'bare'){ |
530
|
|
|
|
|
|
|
# do nothing, but don't complain (later) about missing methods |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
else{ |
533
|
0
|
0
|
|
|
|
0
|
$is = 'undef' if !defined $is; |
534
|
0
|
|
|
|
|
0
|
$class->throw_error("I do not understand this option (is => $is) on attribute ($name)"); |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
0
|
|
|
|
|
0
|
my $tc; |
539
|
0
|
0
|
|
|
|
0
|
if(exists $args->{isa}){ |
540
|
0
|
|
|
|
|
0
|
$tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa}); |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
|
543
|
0
|
0
|
|
|
|
0
|
if(exists $args->{does}){ |
544
|
0
|
0
|
|
|
|
0
|
if(defined $tc){ # both isa and does supplied |
545
|
0
|
|
|
|
|
0
|
my $does_ok = do{ |
546
|
0
|
|
|
|
|
0
|
local $@; |
547
|
0
|
|
|
|
|
0
|
eval{ "$tc"->does($args->{does}) }; |
|
0
|
|
|
|
|
0
|
|
548
|
|
|
|
|
|
|
}; |
549
|
0
|
0
|
|
|
|
0
|
if(!$does_ok){ |
550
|
0
|
|
|
|
|
0
|
$class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)"); |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
else { |
554
|
0
|
|
|
|
|
0
|
$tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does}); |
555
|
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
|
558
|
0
|
0
|
|
|
|
0
|
if($args->{coerce}){ |
559
|
0
|
0
|
|
|
|
0
|
defined($tc) |
560
|
|
|
|
|
|
|
|| $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)"); |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
$args->{weak_ref} |
563
|
0
|
0
|
|
|
|
0
|
&& $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)"); |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
|
566
|
0
|
0
|
|
|
|
0
|
if ($args->{lazy_build}) { |
567
|
|
|
|
|
|
|
exists($args->{default}) |
568
|
0
|
0
|
|
|
|
0
|
&& $class->throw_error("You can not use lazy_build and default for the same attribute ($name)"); |
569
|
|
|
|
|
|
|
|
570
|
0
|
|
|
|
|
0
|
$args->{lazy} = 1; |
571
|
0
|
|
0
|
|
|
0
|
$args->{builder} ||= "_build_${name}"; |
572
|
0
|
0
|
|
|
|
0
|
if ($name =~ /^_/) { |
573
|
0
|
|
0
|
|
|
0
|
$args->{clearer} ||= "_clear${name}"; |
574
|
0
|
|
0
|
|
|
0
|
$args->{predicate} ||= "_has${name}"; |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
else { |
577
|
0
|
|
0
|
|
|
0
|
$args->{clearer} ||= "clear_${name}"; |
578
|
0
|
|
0
|
|
|
0
|
$args->{predicate} ||= "has_${name}"; |
579
|
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
|
582
|
0
|
0
|
|
|
|
0
|
if ($args->{auto_deref}) { |
583
|
0
|
0
|
|
|
|
0
|
defined($tc) |
584
|
|
|
|
|
|
|
|| $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)"); |
585
|
|
|
|
|
|
|
|
586
|
0
|
0
|
0
|
|
|
0
|
( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') ) |
587
|
|
|
|
|
|
|
|| $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)"); |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
|
590
|
0
|
0
|
|
|
|
0
|
if (exists $args->{trigger}) { |
591
|
|
|
|
|
|
|
('CODE' eq ref $args->{trigger}) |
592
|
0
|
0
|
|
|
|
0
|
|| $class->throw_error("Trigger must be a CODE ref on attribute ($name)"); |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
|
595
|
0
|
0
|
|
|
|
0
|
if ($args->{lazy}) { |
596
|
|
|
|
|
|
|
(exists $args->{default} || defined $args->{builder}) |
597
|
0
|
0
|
0
|
|
|
0
|
|| $class->throw_error("You cannot have a lazy attribute ($name) without specifying a default value for it"); |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
|
600
|
0
|
|
|
|
|
0
|
return; |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
package Mouse::Meta::TypeConstraint; |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
use overload |
607
|
1
|
|
|
|
|
5
|
'""' => '_as_string', |
608
|
|
|
|
|
|
|
'0+' => '_identity', |
609
|
|
|
|
|
|
|
'|' => '_unite', |
610
|
|
|
|
|
|
|
|
611
|
1
|
|
|
1
|
|
943
|
fallback => 1; |
|
1
|
|
|
|
|
708
|
|
612
|
|
|
|
|
|
|
|
613
|
0
|
|
|
0
|
1
|
0
|
sub name { $_[0]->{name} } |
614
|
0
|
|
|
0
|
1
|
0
|
sub parent { $_[0]->{parent} } |
615
|
0
|
|
|
0
|
1
|
0
|
sub message { $_[0]->{message} } |
616
|
|
|
|
|
|
|
|
617
|
0
|
|
|
0
|
|
0
|
sub _identity { Scalar::Util::refaddr($_[0]) } # overload 0+ |
618
|
|
|
|
|
|
|
|
619
|
0
|
|
|
0
|
0
|
0
|
sub type_parameter { $_[0]->{type_parameter} } |
620
|
0
|
|
|
0
|
|
0
|
sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} } |
621
|
|
|
|
|
|
|
|
622
|
0
|
|
|
0
|
|
0
|
sub __is_parameterized { exists $_[0]->{type_parameter} } |
623
|
0
|
|
|
0
|
1
|
0
|
sub has_coercion { exists $_[0]->{_compiled_type_coercion} } |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
sub compile_type_constraint{ |
627
|
3
|
|
|
3
|
0
|
3
|
my($self) = @_; |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# add parents first |
630
|
3
|
|
|
|
|
3
|
my @checks; |
631
|
3
|
|
|
|
|
26
|
for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){ |
632
|
3
|
50
|
|
|
|
9
|
if($parent->{hand_optimized_type_constraint}){ |
|
|
50
|
|
|
|
|
|
633
|
0
|
|
|
|
|
0
|
unshift @checks, $parent->{hand_optimized_type_constraint}; |
634
|
0
|
|
|
|
|
0
|
last; # a hand optimized constraint must include all the parents |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
elsif($parent->{constraint}){ |
637
|
0
|
|
|
|
|
0
|
unshift @checks, $parent->{constraint}; |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
# then add child |
642
|
3
|
50
|
|
|
|
5
|
if($self->{constraint}){ |
643
|
0
|
|
|
|
|
0
|
push @checks, $self->{constraint}; |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
|
646
|
3
|
50
|
|
|
|
6
|
if($self->{type_constraints}){ # Union |
647
|
0
|
|
|
|
|
0
|
my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
648
|
|
|
|
|
|
|
push @checks, sub{ |
649
|
0
|
|
|
0
|
|
0
|
foreach my $c(@types){ |
650
|
0
|
0
|
|
|
|
0
|
return 1 if $c->($_[0]); |
651
|
|
|
|
|
|
|
} |
652
|
0
|
|
|
|
|
0
|
return 0; |
653
|
0
|
|
|
|
|
0
|
}; |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
|
656
|
3
|
50
|
|
|
|
4
|
if(@checks == 0){ |
657
|
3
|
|
|
|
|
4
|
$self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any; |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
else{ |
660
|
|
|
|
|
|
|
$self->{compiled_type_constraint} = sub{ |
661
|
0
|
|
|
0
|
|
0
|
my(@args) = @_; |
662
|
0
|
|
|
|
|
0
|
for ($args[0]) { # local $_ will cancel tie-ness due to perl's bug |
663
|
0
|
|
|
|
|
0
|
foreach my $c(@checks){ |
664
|
0
|
0
|
|
|
|
0
|
return undef if !$c->(@args); |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
} |
667
|
0
|
|
|
|
|
0
|
return 1; |
668
|
0
|
|
|
|
|
0
|
}; |
669
|
|
|
|
|
|
|
} |
670
|
3
|
|
|
|
|
6
|
return; |
671
|
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
sub check { |
674
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
675
|
0
|
|
|
|
|
|
return $self->_compiled_type_constraint->(@_); |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
package Mouse::Object; |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
sub BUILDARGS { |
682
|
0
|
|
|
0
|
1
|
|
my $class = shift; |
683
|
|
|
|
|
|
|
|
684
|
0
|
0
|
|
|
|
|
if (scalar @_ == 1) { |
685
|
0
|
0
|
|
|
|
|
(ref($_[0]) eq 'HASH') |
686
|
|
|
|
|
|
|
|| $class->meta->throw_error("Single parameters to new() must be a HASH ref"); |
687
|
|
|
|
|
|
|
|
688
|
0
|
|
|
|
|
|
return {%{$_[0]}}; |
|
0
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
else { |
691
|
0
|
|
|
|
|
|
return {@_}; |
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
} |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
sub new { |
696
|
0
|
|
|
0
|
1
|
|
my $class = shift; |
697
|
0
|
|
|
|
|
|
my $args = $class->BUILDARGS(@_); |
698
|
0
|
|
|
|
|
|
return $class->meta->new_object($args); |
699
|
|
|
|
|
|
|
} |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
sub DESTROY { |
702
|
0
|
|
|
0
|
|
|
my $self = shift; |
703
|
|
|
|
|
|
|
|
704
|
0
|
0
|
|
|
|
|
return unless $self->can('DEMOLISH'); # short circuit |
705
|
|
|
|
|
|
|
|
706
|
0
|
|
|
|
|
|
my $e = do{ |
707
|
0
|
|
|
|
|
|
local $?; |
708
|
0
|
|
|
|
|
|
local $@; |
709
|
0
|
|
|
|
|
|
eval{ |
710
|
|
|
|
|
|
|
# DEMOLISHALL |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
# We cannot count on being able to retrieve a previously made |
713
|
|
|
|
|
|
|
# metaclass, _or_ being able to make a new one during global |
714
|
|
|
|
|
|
|
# destruction. However, we should still be able to use mro at |
715
|
|
|
|
|
|
|
# that time (at least tests suggest so ;) |
716
|
|
|
|
|
|
|
|
717
|
0
|
|
|
|
|
|
foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) { |
|
0
|
|
|
|
|
|
|
718
|
0
|
|
0
|
|
|
|
my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH') |
719
|
|
|
|
|
|
|
|| next; |
720
|
|
|
|
|
|
|
|
721
|
0
|
|
|
|
|
|
$self->$demolish(Mouse::Util::in_global_destruction()); |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
}; |
724
|
0
|
|
|
|
|
|
$@; |
725
|
|
|
|
|
|
|
}; |
726
|
|
|
|
|
|
|
|
727
|
1
|
|
|
1
|
|
545
|
no warnings 'misc'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
138
|
|
728
|
0
|
0
|
|
|
|
|
die $e if $e; # rethrow |
729
|
|
|
|
|
|
|
} |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
sub BUILDALL { |
732
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
# short circuit |
735
|
0
|
0
|
|
|
|
|
return unless $self->can('BUILD'); |
736
|
|
|
|
|
|
|
|
737
|
0
|
|
|
|
|
|
for my $class (reverse $self->meta->linearized_isa) { |
738
|
0
|
|
0
|
|
|
|
my $build = Mouse::Util::get_code_ref($class, 'BUILD') |
739
|
|
|
|
|
|
|
|| next; |
740
|
|
|
|
|
|
|
|
741
|
0
|
|
|
|
|
|
$self->$build(@_); |
742
|
|
|
|
|
|
|
} |
743
|
0
|
|
|
|
|
|
return; |
744
|
|
|
|
|
|
|
} |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
sub DEMOLISHALL; |
747
|
|
|
|
|
|
|
*DEMOLISHALL = \&DESTROY; |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
1; |
750
|
|
|
|
|
|
|
__END__ |