line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Dios::Types; |
2
|
|
|
|
|
|
|
our $VERSION = '0.000001'; |
3
|
|
|
|
|
|
|
|
4
|
59
|
|
|
59
|
|
233442
|
use 5.014; use warnings; |
|
59
|
|
|
59
|
|
193
|
|
|
59
|
|
|
|
|
298
|
|
|
59
|
|
|
|
|
111
|
|
|
59
|
|
|
|
|
1474
|
|
5
|
59
|
|
|
59
|
|
294
|
use Carp; |
|
59
|
|
|
|
|
110
|
|
|
59
|
|
|
|
|
3549
|
|
6
|
59
|
|
|
59
|
|
329
|
use Scalar::Util qw< reftype blessed looks_like_number openhandle >; |
|
59
|
|
|
|
|
93
|
|
|
59
|
|
|
|
|
5625
|
|
7
|
59
|
|
|
59
|
|
50578
|
use overload; |
|
59
|
|
|
|
|
47640
|
|
|
59
|
|
|
|
|
309
|
|
8
|
59
|
|
|
59
|
|
17984
|
use Sub::Uplevel; |
|
59
|
|
|
|
|
51440
|
|
|
59
|
|
|
|
|
352
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
$Carp::CarpInternal{'Dios::Types'}=1; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
### IF KEYWORDS { |
13
|
59
|
|
|
59
|
|
36648
|
use Keyword::Declare; |
|
59
|
|
|
|
|
5938230
|
|
|
59
|
|
|
|
|
807
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
### IF KEYWORDS } |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
my %exportable = ( validate => 1, validator_for => 1 ); |
18
|
0
|
|
|
|
|
0
|
sub import { |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# Throw away the package name... |
21
|
62
|
|
|
62
|
|
487
|
shift @_; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# Cycle through each SUB => AS pair... |
24
|
62
|
|
|
|
|
403
|
while (my ($exported, $export_as) = splice(@_, 0, 2)) { |
25
|
|
|
|
|
|
|
# If it's not a rename, don't change the name... |
26
|
4
|
50
|
66
|
|
|
23
|
if ($export_as && $exportable{$export_as}) { |
27
|
0
|
|
|
|
|
0
|
unshift @_, $export_as; |
28
|
0
|
|
|
|
|
0
|
undef $export_as; |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# If it's not exported, don't export it... |
32
|
4
|
50
|
|
|
|
16
|
croak "Can't export $exported" if !$exportable{$exported}; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
# Unrenamed exports are exported under their own names... |
35
|
4
|
|
66
|
|
|
17
|
$export_as //= $exported; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# Do the export... |
38
|
59
|
|
|
59
|
|
18406
|
no strict 'refs'; |
|
59
|
|
|
|
|
109
|
|
|
59
|
|
|
|
|
11311
|
|
39
|
4
|
|
|
|
|
4
|
*{caller.'::'.$export_as} = \&{$exported}; |
|
4
|
|
|
|
|
12
|
|
|
4
|
|
|
|
|
11
|
|
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
### IF KEYWORDS { |
43
|
62
|
|
|
|
|
209
|
|
44
|
59
|
|
|
59
|
|
1831618
|
keytype TypeSpec is / |
45
|
|
|
|
|
|
|
(?&PerlIdentifier) (?: \[ (?>(?&PPR_balanced_squares)) \])?+ |
46
|
|
|
|
|
|
|
(?: |
47
|
|
|
|
|
|
|
(?&PerlOWS) [&|] (?&PerlOWS) |
48
|
|
|
|
|
|
|
(?&PerlIdentifier) (?: \[ (?>(?&PPR_balanced_squares)) \])?+ |
49
|
|
|
|
|
|
|
)*+ |
50
|
|
|
|
|
|
|
/x; |
51
|
62
|
|
|
|
|
89
|
|
52
|
59
|
|
|
59
|
|
1808409
|
keytype TypeParams is / \[ (?>(?&PPR_balanced_squares)) \] /x; |
53
|
|
|
|
|
|
|
|
54
|
62
|
|
|
|
|
93
|
# Create a new subtype of a known type, adding a constraint... |
55
|
62
|
50
|
50
|
|
|
238
|
keyword subtype ( |
56
|
62
|
|
|
|
|
2342
|
Ident $new_type, |
57
|
|
|
|
|
|
|
TypeParams $new_type_params = q{}, |
58
|
|
|
|
|
|
|
'of', |
59
|
|
|
|
|
|
|
TypeSpec $known_type, |
60
|
5
|
|
|
5
|
|
515405
|
'where', |
|
5
|
|
|
|
|
19
|
|
|
5
|
|
|
|
|
18
|
|
|
5
|
|
|
|
|
12
|
|
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
8
|
|
61
|
5
|
|
|
|
|
30
|
Block $constraint |
62
|
|
|
|
|
|
|
) { |
63
|
5
|
|
|
|
|
26
|
my $subtype_defn |
64
|
62
|
|
|
|
|
515
|
= qq{Dios::Types::_define_subtype('$new_type', '$new_type_params', 'Is', '[$known_type]', sub $constraint) }; |
65
|
|
|
|
|
|
|
qq{if (((caller 0)[3]//q{}) =~ /\\b(?:un)?import\\Z/) { $subtype_defn }; BEGIN{ $subtype_defn }}; |
66
|
59
|
|
|
59
|
|
1974852
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
|
69
|
62
|
|
|
|
|
3484
|
# Alias a new subtype to a known type... |
70
|
0
|
50
|
50
|
|
|
0
|
keyword subtype ( |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
62
|
|
|
|
|
205
|
|
71
|
0
|
|
|
|
|
0
|
Ident $new_type, |
|
62
|
|
|
|
|
1476
|
|
72
|
|
|
|
|
|
|
TypeParams $new_type_params = q{}, |
73
|
0
|
|
|
|
|
0
|
'of', |
74
|
59
|
|
|
|
|
481
|
TypeSpec $known_type, |
75
|
4
|
|
|
4
|
|
392801
|
) { |
|
4
|
|
|
|
|
37
|
|
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
8
|
|
76
|
4
|
|
|
|
|
19
|
my $subtype_defn |
77
|
|
|
|
|
|
|
= qq{Dios::Types::_define_subtype('$new_type', '$new_type_params', 'Is', '[$known_type]') }; |
78
|
4
|
|
|
|
|
43
|
qq{if (((caller 0)[3]//q{}) =~ /\\b(?:un)?import\\Z/) { $subtype_defn }; BEGIN{ $subtype_defn }}; |
79
|
62
|
|
|
|
|
375
|
} |
80
|
|
|
|
|
|
|
|
81
|
59
|
|
|
59
|
|
1986553
|
### IF KEYWORDS } |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
0
|
|
|
|
|
0
|
my @user_defined_type; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
86
|
0
|
|
|
|
|
0
|
|
87
|
|
|
|
|
|
|
### IF KEYWORDS { |
88
|
0
|
|
|
|
|
0
|
|
89
|
59
|
|
|
|
|
423
|
sub _define_subtype { |
90
|
11
|
|
|
11
|
|
2449
|
my ($new_typename, $new_type_params, $old_typename, $old_type_params, $constraint) = @_; |
91
|
11
|
|
100
|
10
|
|
73
|
$constraint //= sub{1}; |
|
10
|
|
|
|
|
21
|
|
92
|
|
|
|
|
|
|
|
93
|
11
|
|
50
|
|
|
51
|
local $Dios::Types::lexical_hints = (caller 0)[10] // {}; |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# Reassemble the complete base type... |
96
|
11
|
|
|
|
|
314
|
$old_typename .= $old_type_params; |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
# We are building a sub that builds type handlers... |
99
|
11
|
|
|
|
|
19
|
my $new_type_handler_generator; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# The simple case (where the new type is not parameterized)... |
102
|
11
|
100
|
|
|
|
33
|
if (!length($new_type_params)) { |
103
|
9
|
|
|
|
|
30
|
my $old_type_handler = _build_handler_for($old_typename); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
$new_type_handler_generator = sub { |
106
|
|
|
|
|
|
|
return sub { |
107
|
21
|
|
|
|
|
48
|
my $okay = $old_type_handler->($_[0]); |
108
|
21
|
100
|
|
|
|
39
|
return _error_near($_[0], $new_typename, $okay) if !$okay; |
109
|
17
|
100
|
|
|
|
40
|
return _error_near($_[0], $new_typename ) if !$constraint->(local $_ = $_[0]); |
110
|
13
|
|
|
|
|
114
|
return 1; |
111
|
|
|
|
|
|
|
} |
112
|
9
|
|
|
21
|
|
42
|
}; |
|
21
|
|
|
|
|
82
|
|
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# The more complex case, where the new type has parameters... |
116
|
|
|
|
|
|
|
else { |
117
|
|
|
|
|
|
|
# Extract the new parameter names... |
118
|
2
|
|
|
|
|
19
|
my @new_type_param_names = split /\s*,\s*/, $new_type_params =~ s{\A\[\s*+|\s*+\]\Z}{}grx; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
$new_type_handler_generator = sub { |
121
|
10
|
|
|
10
|
|
17
|
my ($typename) = @_; |
122
|
10
|
|
|
|
|
70
|
my @params = split /\s*,\s*/, $typename =~ s{\A \w++ \[ \s*+ | \s*+ \] \Z}{}grx; |
123
|
10
|
|
|
|
|
20
|
my $substituted_typename = $old_typename; |
124
|
10
|
|
|
|
|
23
|
for my $n (0..$#params) { |
125
|
12
|
|
|
|
|
95
|
$substituted_typename =~ s{$new_type_param_names[$n]}{$params[$n]}gxms; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
10
|
|
|
|
|
30
|
my $old_type_handler |
129
|
|
|
|
|
|
|
= _build_handler_for($substituted_typename, |
130
|
|
|
|
|
|
|
"generated by parameterized subtype: $typename\n"); |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
return sub { |
133
|
9
|
|
|
|
|
20
|
my $okay = $old_type_handler->($_[0]); |
134
|
9
|
100
|
|
|
|
17
|
return _error_near($_[0], $typename, $okay) if !$okay; |
135
|
7
|
100
|
|
|
|
9
|
if (! eval{ local $SIG{__WARN__} = sub{}; $constraint->(local $_ = $_[0]) }) { |
|
7
|
|
|
|
|
33
|
|
|
7
|
|
|
|
|
22
|
|
136
|
3
|
|
|
|
|
26
|
my $constraint_desc = _describe_constraint($_[0], undef, $constraint, $@); |
137
|
3
|
|
|
|
|
14
|
return _error_near( |
138
|
|
|
|
|
|
|
$_[0], qq{Value ($_[0]) did not satisfy the constraint: $constraint_desc\n } |
139
|
|
|
|
|
|
|
); |
140
|
|
|
|
|
|
|
} |
141
|
4
|
|
|
|
|
79
|
return 1; |
142
|
|
|
|
|
|
|
} |
143
|
2
|
|
|
|
|
14
|
}; |
|
9
|
|
|
|
|
42
|
|
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
11
|
|
|
|
|
69
|
$^H{"Dios::Types subtype=$new_typename"} = @user_defined_type; |
147
|
11
|
|
|
|
|
786
|
push @user_defined_type, $new_type_handler_generator; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
### IF KEYWORDS } |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub _error_near ($$;$) { |
153
|
98
|
|
|
98
|
|
311
|
my ($where, $what, $previous_errors) = @_; |
154
|
|
|
|
|
|
|
|
155
|
0
|
|
|
|
|
0
|
{ package Dios::Types::Error; |
156
|
59
|
|
|
59
|
|
41219
|
use overload 'bool' => sub{0}, fallback => 1; |
|
59
|
|
|
209
|
|
129
|
|
|
59
|
|
|
|
|
571
|
|
|
209
|
|
|
|
|
541
|
|
157
|
|
|
|
|
|
|
sub msg { |
158
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
159
|
0
|
0
|
|
|
|
0
|
return $self->[0] ne $self->[-1] ? "$self->[-1]\n(because $self->[0])" : $self->[0]; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
98
|
100
|
100
|
|
|
136
|
$previous_errors = bless [], 'Dios::Types::Error' if (reftype($previous_errors)//q{}) ne 'ARRAY'; |
|
98
|
|
|
|
|
436
|
|
164
|
98
|
|
|
|
|
135
|
push @{$previous_errors}, _perl($where) . " isn't of type $what"; |
|
98
|
|
|
|
|
418
|
|
165
|
|
|
|
|
|
|
|
166
|
98
|
|
|
|
|
16545
|
return $previous_errors; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# Standard type checking... |
170
|
|
|
|
|
|
|
my %handler_for = ( |
171
|
|
|
|
|
|
|
# Any Perl value or ref... |
172
|
|
|
|
|
|
|
Slurpy => sub { 1 }, |
173
|
|
|
|
|
|
|
Any => sub { 1 }, |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# Anything that is true or false (and that's everything in Perl!) |
176
|
|
|
|
|
|
|
Bool => sub { 1 }, |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# Anything defined, or not... |
179
|
|
|
|
|
|
|
Def => sub { defined $_[0] }, |
180
|
|
|
|
|
|
|
Undef => sub { !defined $_[0] }, |
181
|
|
|
|
|
|
|
Void => sub { !defined $_[0] || ref $_[0] eq 'ARRAY' && !@{$_[0]} }, |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# Values, references, and filehandles... |
184
|
|
|
|
|
|
|
Value => sub { defined($_[0]) && !ref($_[0]) }, |
185
|
|
|
|
|
|
|
Ref => sub { ref $_[0] }, |
186
|
|
|
|
|
|
|
IO => \&openhandle, |
187
|
|
|
|
|
|
|
Glob => sub { ref($_[0]) eq 'GLOB' }, |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# An integer... |
190
|
|
|
|
|
|
|
Int => sub { |
191
|
|
|
|
|
|
|
# If it's an object, must have a warning-less numeric overloading... |
192
|
|
|
|
|
|
|
if (ref($_[0])) { |
193
|
|
|
|
|
|
|
# Normal references aren't integers... |
194
|
|
|
|
|
|
|
return 0 if !blessed($_[0]); |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# Is there an overloading??? |
197
|
|
|
|
|
|
|
my $converter = overload::Method($_[0],'0+') |
198
|
|
|
|
|
|
|
or return 0; |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# Does this object convert to a number without complaint??? |
201
|
|
|
|
|
|
|
my $warned; |
202
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { $warned = 1 }; |
203
|
|
|
|
|
|
|
my $value = eval{ $converter->($_[0]) } |
204
|
|
|
|
|
|
|
// return 0; |
205
|
|
|
|
|
|
|
return 0 if $warned; |
206
|
|
|
|
|
|
|
return $value =~ m{\A \s*+ [+-]?+ (?: \d++ (\.0*+)?+ | inf(?:inity)?+ ) \s*+ \Z}ixms; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
# Value must be defined, non-reference, looks like an integer... |
210
|
|
|
|
|
|
|
return defined($_[0]) |
211
|
|
|
|
|
|
|
&& $_[0] =~ m{\A \s*+ [+-]?+ (?: \d++ (\.0*+)?+ | inf(?:inity)?+ ) \s*+ \Z}ixms; |
212
|
|
|
|
|
|
|
}, |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# A number |
215
|
|
|
|
|
|
|
Num => sub { |
216
|
|
|
|
|
|
|
return 0 if !defined $_[0] || lc($_[0]) eq 'nan'; |
217
|
|
|
|
|
|
|
&looks_like_number |
218
|
|
|
|
|
|
|
}, |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
# A string, or stringifiable object, or array ref, or hash ref, that is empty... |
221
|
|
|
|
|
|
|
Empty => sub { |
222
|
|
|
|
|
|
|
my $value = shift; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# Must be defined... |
225
|
|
|
|
|
|
|
return 0 if !defined($value); |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# May be an empty array or hash... |
228
|
|
|
|
|
|
|
my $reftype = ref($value); |
229
|
|
|
|
|
|
|
return 1 if $reftype eq 'ARRAY' && !@{$value}; |
230
|
|
|
|
|
|
|
return 1 if $reftype eq 'HASH' && !keys %{$value}; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# May be an object that overloads stringification... |
233
|
|
|
|
|
|
|
return 1 if $reftype && overload::Method($value, q{""}) && "$value" eq q{}; |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# Otherwise, has to be an empty string... |
236
|
|
|
|
|
|
|
return $value eq q{}; |
237
|
|
|
|
|
|
|
}, |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
# A string, or stringifiable object... |
240
|
|
|
|
|
|
|
Str => sub { defined($_[0]) && (ref($_[0]) ? overload::Method(shift,q{""}) : 1) }, |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# A blessed object... |
243
|
|
|
|
|
|
|
Obj => \&blessed, |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# Any loaded class (must have @ISA or $VERSION or at least one method defined)... |
246
|
|
|
|
|
|
|
Class => sub { |
247
|
|
|
|
|
|
|
return 0 if ref $_[0] || not $_[0]; |
248
|
|
|
|
|
|
|
my $stash = \%main::; |
249
|
|
|
|
|
|
|
for my $partial_name (split /::/, $_[0]) { |
250
|
|
|
|
|
|
|
return 0 if !exists $stash->{$partial_name.'::'}; |
251
|
|
|
|
|
|
|
$stash = $stash->{$partial_name.'::'}; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
return 1 if exists $stash->{'ISA'}; |
254
|
|
|
|
|
|
|
return 1 if exists $stash->{'VERSION'}; |
255
|
|
|
|
|
|
|
for my $globref (values %$stash) { |
256
|
|
|
|
|
|
|
return 1 if *{$globref}{CODE}; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
return 0; |
259
|
|
|
|
|
|
|
}, |
260
|
|
|
|
|
|
|
); |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
# Built-in type checking... |
263
|
|
|
|
|
|
|
for my $type (qw< SCALAR ARRAY HASH CODE GLOB >) { |
264
|
|
|
|
|
|
|
$handler_for{ ucfirst(lc($type)) } = sub { (reftype($_[0]) // q{}) eq $type }; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
$handler_for{ Regex } = sub { (reftype($_[0]) // q{}) eq 'REGEXP' }; |
267
|
|
|
|
|
|
|
$handler_for{ List } = $handler_for{ Array }; |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# Standard type hierrachy... |
270
|
|
|
|
|
|
|
my %BASIC_NARROWER = ( |
271
|
|
|
|
|
|
|
Slurpy => { }, |
272
|
|
|
|
|
|
|
Any => { map {$_=>1} qw< Slurpy >}, |
273
|
|
|
|
|
|
|
Bool => { map {$_=>1} qw< Slurpy Any >}, |
274
|
|
|
|
|
|
|
Undef => { map {$_=>1} qw< Slurpy Any Bool >}, |
275
|
|
|
|
|
|
|
Def => { map {$_=>1} qw< Slurpy Any Bool >}, |
276
|
|
|
|
|
|
|
Value => { map {$_=>1} qw< Slurpy Any Bool Def >}, |
277
|
|
|
|
|
|
|
Num => { map {$_=>1} qw< Slurpy Any Bool Def Value Str >}, |
278
|
|
|
|
|
|
|
Int => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Num >}, |
279
|
|
|
|
|
|
|
Str => { map {$_=>1} qw< Slurpy Any Bool Def Value >}, |
280
|
|
|
|
|
|
|
Class => { map {$_=>1} qw< Slurpy Any Bool Def Value Str >}, |
281
|
|
|
|
|
|
|
Empty => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array List Hash >}, |
282
|
|
|
|
|
|
|
Ref => { map {$_=>1} qw< Slurpy Any Bool Def >}, |
283
|
|
|
|
|
|
|
Scalar => { map {$_=>1} qw< Slurpy Any Bool Def Ref >}, |
284
|
|
|
|
|
|
|
Regex => { map {$_=>1} qw< Slurpy Any Bool Def Ref >}, |
285
|
|
|
|
|
|
|
Code => { map {$_=>1} qw< Slurpy Any Bool Def Ref >}, |
286
|
|
|
|
|
|
|
Glob => { map {$_=>1} qw< Slurpy Any Bool Def Ref >}, |
287
|
|
|
|
|
|
|
IO => { map {$_=>1} qw< Slurpy Any Bool Def Ref >}, |
288
|
|
|
|
|
|
|
Obj => { map {$_=>1} qw< Slurpy Any Bool Def Ref >}, |
289
|
|
|
|
|
|
|
Array => { map {$_=>1} qw< Slurpy Any Bool Def Ref >}, |
290
|
|
|
|
|
|
|
List => { map {$_=>1} qw< Slurpy Any Bool Def Ref Array >}, |
291
|
|
|
|
|
|
|
Empty => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array Hash List >}, |
292
|
|
|
|
|
|
|
Hash => { map {$_=>1} qw< Slurpy Any Bool Def Ref >}, |
293
|
|
|
|
|
|
|
Empty => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array Hash List >}, |
294
|
|
|
|
|
|
|
); |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
# This is the full typename syntax... |
297
|
|
|
|
|
|
|
my $BASIC_TYPES = join('|', keys %handler_for); |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
my $TYPED_OR_PURE_ETC = qr{ \s*+ ,? \s*+ \.\.\.}xms; |
300
|
|
|
|
|
|
|
my $TYPED_ETC = qr{ \s*+ \.\.\.}xms; |
301
|
|
|
|
|
|
|
my $PURE_ETC = qr{ \s*+ , \s*+ \.\.\.}xms; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
my $KEYED_TYPENAME = q{ |
304
|
|
|
|
|
|
|
\\s* |
305
|
|
|
|
|
|
|
(?: ' (? [^'\\\\]*+ (?: \\\\. [^'\\\\]*+ )*+ ) ' |
306
|
|
|
|
|
|
|
| (? (?&IDENT) ) |
307
|
|
|
|
|
|
|
) |
308
|
|
|
|
|
|
|
(? \\s* [?] )? |
309
|
|
|
|
|
|
|
(?: \\s* => \\s* (? (?&CONJ_TYPENAME) ) )? |
310
|
|
|
|
|
|
|
}; |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
my $TYPENAME_GRAMMAR = qr{ |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
(? |
315
|
|
|
|
|
|
|
(? (?&QUAL_IDENT) ) |
316
|
|
|
|
|
|
|
| Is \[ (? \s*+ (?&DISJ_TYPENAME_BAR) \s*+ ) \] |
317
|
|
|
|
|
|
|
| Is \[ (? \s*+ (?&CONJ_TYPENAME) \s*+ ) \] |
318
|
|
|
|
|
|
|
| Not \[ (? \s*+ (?&DISJ_TYPENAME) \s*+ ) \] |
319
|
|
|
|
|
|
|
| List \[ (? \s*+ (?&DISJ_TYPENAME) \s*+ ) \] |
320
|
|
|
|
|
|
|
| Array \[ (? \s*+ (?&DISJ_TYPENAME) \s*+ ) \] |
321
|
|
|
|
|
|
|
| Tuple \[ (? \s*+ (?&TUPLE_FORMAT) \s*+ ) \] |
322
|
|
|
|
|
|
|
| Hash \[ (? \s*+ (?&DISJ_TYPENAME) (?: \s*+ => \s*+ (?&DISJ_TYPENAME) )?+ \s*+ ) \] |
323
|
|
|
|
|
|
|
| Dict \[ (? \s*+ (?&DICT_FORMAT) \s*+ ) \] |
324
|
|
|
|
|
|
|
| Ref \[ (?[ \s*+ (?&DISJ_TYPENAME) \s*+ ) \] ] |
325
|
|
|
|
|
|
|
| Eq \[ (? \s*+ (?&STR_SPEC) \s*+ ) \] |
326
|
|
|
|
|
|
|
| Match \[ (? \s*+ (?®EX_SPEC) \s*+ ) \] |
327
|
|
|
|
|
|
|
| Can \[ (? \s*+ (?&OPT_QUAL_IDENT) \s*+ (?: , \s*+ (?&OPT_QUAL_IDENT) \s*+ )*+ ) \] |
328
|
|
|
|
|
|
|
| Overloads \[ (? [^]]++ ) \] |
329
|
|
|
|
|
|
|
| (? (?&BASIC) ) |
330
|
|
|
|
|
|
|
| (? (?!(?&BASIC)) (?&IDENT) (?: \s*+ \[ \s*+ (?&TYPE_LIST) \s*+ \] )?+ ) |
331
|
|
|
|
|
|
|
) |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
(?(DEFINE) |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
(? (?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )++ ) |
336
|
|
|
|
|
|
|
(? (?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )*+ ) |
337
|
|
|
|
|
|
|
(? (?&ATOM_TYPENAME) (?: \s* [&] \s* (?&ATOM_TYPENAME) )*+ ) |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
(? |
340
|
|
|
|
|
|
|
(?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )++ |
341
|
|
|
|
|
|
|
| (?&ATOM_TYPENAME) (?: \s* [&] \s* (?&ATOM_TYPENAME) )++ |
342
|
|
|
|
|
|
|
) |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
(? |
345
|
|
|
|
|
|
|
(?&TYPE_LIST) (?: \s*+ ,? \s*+ \.\.\. )? |
346
|
|
|
|
|
|
|
) |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
(? |
349
|
|
|
|
|
|
|
(?&CONJ_TYPENAME) (?: \s*,\s* (?&CONJ_TYPENAME) )*+ |
350
|
|
|
|
|
|
|
) |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
(? |
353
|
|
|
|
|
|
|
(?&KEYED_TYPENAME) (?: \s*,\s* (?&KEYED_TYPENAME) )*+ $PURE_ETC? |
354
|
|
|
|
|
|
|
) |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
(? |
357
|
|
|
|
|
|
|
$KEYED_TYPENAME |
358
|
|
|
|
|
|
|
) |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
(? (?: [^][\\]++ | \\[][\\] )*+ ) |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
(? (?: [^][\\]++ | \\\S | \[ \^? \]? [^]]*+ \] )*+ ) |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
(? \b (?: $BASIC_TYPES ) \b ) |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
(? (?&IDENT) (?: :: (?&IDENT) )++ ) |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
(? (?&IDENT) (?: :: (?&IDENT) )*+ ) |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
(? [^\W\d] \w*+ ) |
371
|
|
|
|
|
|
|
) |
372
|
|
|
|
|
|
|
}xms; |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
my $FROM_TYPENAME_GRAMMAR = qr{ (?(DEFINE) $TYPENAME_GRAMMAR ) }xms; |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
my $IS_REF_TYPE |
377
|
|
|
|
|
|
|
= qr/\A (?: List | Array | Hash | Code | Scalar | Regex | Tuple | Dict | Glob | IO | Obj ) \b/x; |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# Complex types are built on the fly... |
380
|
|
|
|
|
|
|
sub _build_handler_for { |
381
|
250
|
|
|
250
|
|
496
|
my ($type, $context, $level) = @_; |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
# Reformat conjunctions and disjunctions to avoid left recursion... |
384
|
250
|
100
|
|
|
|
18967
|
if ($type =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z $FROM_TYPENAME_GRAMMAR }xms) { |
385
|
18
|
|
|
|
|
89
|
$type = "Is[$1]"; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# Parse the type specification... |
389
|
250
|
50
|
|
|
|
9694
|
$type =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms |
|
|
100
|
|
|
|
|
|
390
|
|
|
|
|
|
|
or croak "Incomprehensible type name: $type\n", |
391
|
|
|
|
|
|
|
(defined $context ? $context : q{}); |
392
|
|
|
|
|
|
|
|
393
|
249
|
|
|
|
|
3229
|
my %type_is = %+; |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
# Conjunction handlers test each component type and fail if any fails... |
396
|
249
|
100
|
|
|
|
871
|
if ( exists $type_is{conj} ) { my @types = grep {defined} $type_is{conj} =~ m{ ((?&ATOM_TYPENAME)) |
|
22
|
|
|
|
|
2293
|
|
|
972
|
|
|
|
|
1172
|
|
397
|
|
|
|
|
|
|
$FROM_TYPENAME_GRAMMAR |
398
|
|
|
|
|
|
|
}gxms; |
399
|
22
|
|
|
|
|
93
|
my @handlers = map {_build_handler_for($_)} @types; |
|
27
|
|
|
|
|
93
|
|
400
|
|
|
|
|
|
|
return sub { |
401
|
34
|
|
|
34
|
|
56
|
for (@handlers) { |
402
|
39
|
|
|
|
|
71
|
my $okay = $_->($_[0]); |
403
|
39
|
100
|
|
|
|
99
|
return _error_near($_[0], join(' or ', @types), $okay) |
404
|
|
|
|
|
|
|
if !$okay; |
405
|
|
|
|
|
|
|
} |
406
|
27
|
|
|
|
|
39
|
return 1; |
407
|
|
|
|
|
|
|
} |
408
|
22
|
|
|
|
|
129
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# Disjunction handlers test each component type and fail if all of them fail... |
411
|
227
|
100
|
|
|
|
459
|
if ( exists $type_is{disj} ) { my @types = grep {defined} $type_is{disj} =~ m{ ((?&CONJ_TYPENAME)) |
|
14
|
|
|
|
|
4348
|
|
|
1044
|
|
|
|
|
1266
|
|
412
|
|
|
|
|
|
|
$FROM_TYPENAME_GRAMMAR |
413
|
|
|
|
|
|
|
}gxms; |
414
|
14
|
|
|
|
|
113
|
my @handlers = map {_build_handler_for($_)} @types; |
|
29
|
|
|
|
|
95
|
|
415
|
|
|
|
|
|
|
return sub { |
416
|
25
|
|
|
25
|
|
55
|
for (@handlers) { |
417
|
43
|
100
|
|
|
|
108
|
return 1 if $_->($_[0]); |
418
|
|
|
|
|
|
|
} |
419
|
3
|
|
|
|
|
15
|
return _error_near($_[0], join(' or ', @types)); |
420
|
|
|
|
|
|
|
} |
421
|
14
|
|
|
|
|
122
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
# Basic types, just use the built-in handler... |
424
|
213
|
100
|
|
|
|
382
|
if ( exists $type_is{basic} ) { return $handler_for{$type_is{basic}}; } |
|
102
|
|
|
|
|
442
|
|
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
# User defined types match an object of that type... |
427
|
111
|
100
|
|
|
|
216
|
if ( exists $type_is{user} ) { my $typename = $type_is{user}; |
|
13
|
|
|
|
|
24
|
|
428
|
13
|
|
|
|
|
41
|
my $root_name = $typename =~ s{\[.*}{}rxms; |
429
|
13
|
|
|
|
|
38
|
my $idx = $Dios::Types::lexical_hints->{"Dios::Types subtype=$root_name"}; |
430
|
|
|
|
|
|
|
return sub { |
431
|
|
|
|
|
|
|
# Is it user-defined??? |
432
|
33
|
100
|
|
33
|
|
63
|
if (defined $idx) { |
433
|
31
|
|
|
|
|
53
|
for ($_[0]) { |
434
|
31
|
|
66
|
|
|
73
|
return $user_defined_type[$idx]($typename)($_) |
435
|
|
|
|
|
|
|
|| _error_near($_[0], $typename); |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
2
|
|
33
|
|
|
18
|
return blessed($_[0]) && $_[0]->isa($typename) |
440
|
|
|
|
|
|
|
|| _error_near($_[0], $typename); |
441
|
|
|
|
|
|
|
} |
442
|
13
|
|
|
|
|
134
|
} |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# Array[T] types require an array ref, whose every element is of type T... |
445
|
98
|
100
|
|
|
|
198
|
if ( exists $type_is{array} ) { my $value_handler = _build_handler_for($type_is{array}); |
|
31
|
|
|
|
|
213
|
|
446
|
|
|
|
|
|
|
return sub { |
447
|
80
|
100
|
100
|
80
|
|
369
|
return _error_near($_[0], "Array[$type_is{array}]") |
448
|
|
|
|
|
|
|
if (reftype($_[0]) // q{}) ne 'ARRAY'; |
449
|
|
|
|
|
|
|
|
450
|
78
|
|
|
|
|
105
|
for (@{$_[0]}) { |
|
78
|
|
|
|
|
178
|
|
451
|
167
|
100
|
|
|
|
303
|
next if my $okay = $value_handler->($_); |
452
|
21
|
|
|
|
|
81
|
return _error_near($_, $type_is{array}, $okay); |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
57
|
|
|
|
|
231
|
return 1; |
456
|
|
|
|
|
|
|
} |
457
|
31
|
|
|
|
|
242
|
} |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
# List[T] types require an array ref, whose every element is of type T... |
460
|
67
|
100
|
|
|
|
152
|
if ( exists $type_is{list} ) { my $value_handler = _build_handler_for($type_is{list}); |
|
3
|
|
|
|
|
14
|
|
461
|
|
|
|
|
|
|
return sub { |
462
|
4
|
100
|
100
|
4
|
|
53
|
return _error_near($_[0], "List[$type_is{list}]") |
463
|
|
|
|
|
|
|
if (reftype($_[0]) // q{}) ne 'ARRAY'; |
464
|
|
|
|
|
|
|
|
465
|
3
|
|
|
|
|
7
|
for (@{$_[0]}) { |
|
3
|
|
|
|
|
9
|
|
466
|
7
|
50
|
|
|
|
18
|
next if my $okay = $value_handler->($_); |
467
|
0
|
|
|
|
|
0
|
return _error_near($_, $type_is{list}, $okay); |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
3
|
|
|
|
|
10
|
return 1; |
471
|
|
|
|
|
|
|
} |
472
|
3
|
|
|
|
|
24
|
} |
473
|
|
|
|
|
|
|
|
474
|
64
|
100
|
|
|
|
132
|
if ( exists $type_is{tuple} ) { my @types |
475
|
72
|
|
|
|
|
85
|
= grep {defined} |
476
|
1
|
|
|
|
|
327
|
$type_is{tuple} =~ m{ ((?&CONJ_TYPENAME) | $TYPED_OR_PURE_ETC ) |
477
|
|
|
|
|
|
|
$FROM_TYPENAME_GRAMMAR |
478
|
|
|
|
|
|
|
}gxms; |
479
|
|
|
|
|
|
|
# Build type handlers for sequence... |
480
|
1
|
|
|
|
|
11
|
my ($final_any, $final_handler); |
481
|
1
|
50
|
33
|
|
|
40
|
if (@types > 1 && $types[-1] =~ /^$TYPED_ETC$/) { |
|
|
50
|
33
|
|
|
|
|
482
|
0
|
|
|
|
|
0
|
pop @types; |
483
|
0
|
|
|
|
|
0
|
$final_handler = _build_handler_for(pop @types); |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
elsif (@types > 0 && $types[-1] =~ /^$PURE_ETC$/) { |
486
|
0
|
|
|
|
|
0
|
pop @types; |
487
|
0
|
|
|
|
|
0
|
$final_any = 1; |
488
|
0
|
|
|
|
|
0
|
$final_handler = _build_handler_for('Any'); |
489
|
|
|
|
|
|
|
} |
490
|
1
|
|
|
|
|
5
|
my @value_handlers = map {_build_handler_for($_)} @types; |
|
2
|
|
|
|
|
5
|
|
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
return sub { |
493
|
2
|
|
|
2
|
|
3
|
my $array_ref = shift; |
494
|
|
|
|
|
|
|
# Tuples must be array refs the same length as their specifications... |
495
|
|
|
|
|
|
|
return _error_near($array_ref, "Dict[$type_is{tuple}]") |
496
|
|
|
|
|
|
|
if (reftype($array_ref) // q{}) ne 'ARRAY' |
497
|
2
|
100
|
50
|
|
|
19
|
|| !$final_handler && @{$array_ref} != @types; |
|
1
|
|
33
|
|
|
5
|
|
|
|
|
66
|
|
|
|
|
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
# The first N values must match the N types specified... |
500
|
1
|
|
|
|
|
4
|
for my $n (0..$#types) { |
501
|
2
|
|
|
|
|
6
|
my $okay = $value_handlers[$n]($array_ref->[$n]); |
502
|
2
|
50
|
|
|
|
10
|
return _error_near($array_ref, "Dict[$type_is{tuple}]", $okay) |
503
|
|
|
|
|
|
|
if !$okay; |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
# Succeed at once if no etcetera to test, or it etcetera guaranteed... |
507
|
1
|
50
|
33
|
|
|
7
|
return 1 if $final_any || @{$array_ref} == @types; |
|
1
|
|
|
|
|
5
|
|
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
# Any extra values must match the "et cetera" handler specified... |
510
|
0
|
|
|
|
|
0
|
for my $n ($#types+1..$#{$array_ref}) { |
|
0
|
|
|
|
|
0
|
|
511
|
0
|
|
|
|
|
0
|
my $okay = $final_handler->($array_ref->[$n]); |
512
|
0
|
0
|
|
|
|
0
|
return _error_near($array_ref, "Dict[$type_is{tuple}]", $okay) |
513
|
|
|
|
|
|
|
if !$okay; |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
|
516
|
0
|
|
|
|
|
0
|
return 1; |
517
|
|
|
|
|
|
|
} |
518
|
1
|
|
|
|
|
9
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
# Hash[T] and Hash[T=>T] types require a hash ref, whose every value is of type T... |
521
|
63
|
|
|
|
|
212
|
my $HASH_KV_SPEC = qr{ |
522
|
|
|
|
|
|
|
\A |
523
|
|
|
|
|
|
|
((?&BalancedSquareBrackets)) |
524
|
|
|
|
|
|
|
(?: (=>) (.*) )?+ |
525
|
|
|
|
|
|
|
\Z |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
(?(DEFINE) |
528
|
|
|
|
|
|
|
(? |
529
|
|
|
|
|
|
|
(?: [^][] | \[ (?&BalancedSquareBrackets) \] )*? |
530
|
|
|
|
|
|
|
) |
531
|
|
|
|
|
|
|
) |
532
|
|
|
|
|
|
|
}xms; |
533
|
63
|
100
|
|
|
|
139
|
if ( exists $type_is{hash} ) { my ($type_k, $arrow, $type_v) = $type_is{hash} =~ $HASH_KV_SPEC; |
|
21
|
|
|
|
|
258
|
|
534
|
|
|
|
|
|
|
# Only value type specified... |
535
|
21
|
100
|
|
|
|
73
|
if (!$arrow) { |
536
|
12
|
|
|
|
|
53
|
$type_k =~ s/\A\s+|\s+\Z//g; |
537
|
12
|
|
|
|
|
74
|
my $value_handler = _build_handler_for($type_k); |
538
|
|
|
|
|
|
|
return sub { |
539
|
39
|
100
|
100
|
39
|
|
201
|
return _error_near($_[0], "Hash[$type_is{hash}]") |
540
|
|
|
|
|
|
|
if (reftype($_[0]) // q{}) ne 'HASH'; |
541
|
|
|
|
|
|
|
|
542
|
35
|
|
|
|
|
54
|
for (values %{$_[0]}) { |
|
35
|
|
|
|
|
107
|
|
543
|
41
|
|
|
|
|
97
|
my $okay = $value_handler->($_); |
544
|
41
|
100
|
|
|
|
116
|
return _error_near($_, $type_is{hash}, $okay) |
545
|
|
|
|
|
|
|
if !$okay; |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
|
548
|
31
|
|
|
|
|
154
|
return 1; |
549
|
|
|
|
|
|
|
} |
550
|
12
|
|
|
|
|
115
|
} |
551
|
|
|
|
|
|
|
# Both key and value type specified... |
552
|
|
|
|
|
|
|
else { |
553
|
9
|
|
|
|
|
38
|
$type_k =~ s/\A\s+|\s+\Z//g; |
554
|
9
|
|
|
|
|
31
|
$type_v =~ s/\A\s+|\s+\Z//g; |
555
|
9
|
|
|
|
|
22
|
my $key_handler = _build_handler_for($type_k); |
556
|
9
|
|
|
|
|
20
|
my $value_handler = _build_handler_for($type_v); |
557
|
|
|
|
|
|
|
return sub { |
558
|
18
|
50
|
50
|
18
|
|
73
|
return _error_near($_[0], "Hash[$type_is{hash}]") |
559
|
|
|
|
|
|
|
if (reftype($_[0]) // q{}) ne 'HASH'; |
560
|
|
|
|
|
|
|
|
561
|
18
|
|
|
|
|
21
|
for (keys %{$_[0]}) { |
|
18
|
|
|
|
|
49
|
|
562
|
39
|
|
|
|
|
57
|
my $okay = $key_handler->($_); |
563
|
39
|
100
|
|
|
|
90
|
return _error_near($_, $type_is{hash}, $okay) |
564
|
|
|
|
|
|
|
if !$okay; |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
11
|
|
|
|
|
16
|
for (values %{$_[0]}) { |
|
11
|
|
|
|
|
22
|
|
568
|
23
|
|
|
|
|
40
|
my $okay = $value_handler->($_); |
569
|
23
|
100
|
|
|
|
50
|
return _error_near($_, $type_is{hash}, $okay) |
570
|
|
|
|
|
|
|
if !$okay; |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
|
573
|
9
|
|
|
|
|
19
|
return 1; |
574
|
|
|
|
|
|
|
} |
575
|
9
|
|
|
|
|
87
|
} |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
# Dict[ k => T, k => T, ... ] requires a hash key, with the specified keys type-matched too... |
579
|
42
|
100
|
|
|
|
81
|
if ( exists $type_is{dict} ) { my (%handler_for, @required_keys, $extra_keys_allowed); |
|
2
|
|
|
|
|
4
|
|
580
|
2
|
|
|
|
|
341
|
while ($type_is{dict} =~ m{ (? $KEYED_TYPENAME)|(? $PURE_ETC) |
581
|
|
|
|
|
|
|
$FROM_TYPENAME_GRAMMAR}gxms |
582
|
|
|
|
|
|
|
) { |
583
|
|
|
|
|
|
|
# Create a type checker for each specified key (once!)... |
584
|
6
|
100
|
|
|
|
41
|
if (exists $+{keyed}) { |
585
|
4
|
|
|
|
|
27
|
my ($key, $valtype, $optional) = @+{qw< key valtype optional >}; |
586
|
|
|
|
|
|
|
croak qq{Two type specifications for key '$key' }, |
587
|
|
|
|
|
|
|
qq{in Dict[$type_is{dict}]} |
588
|
4
|
50
|
|
|
|
14
|
if exists $handler_for{$key}; |
589
|
4
|
|
50
|
|
|
36
|
$handler_for{$key} |
590
|
|
|
|
|
|
|
= _build_handler_for($valtype // 'Any'); |
591
|
4
|
50
|
|
|
|
54
|
push @required_keys, $key if !$optional; |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
# And remember whether other keys are allowed... |
594
|
|
|
|
|
|
|
else { |
595
|
2
|
|
|
|
|
13
|
$extra_keys_allowed = 1; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
# Build type handlers for sequence... |
600
|
|
|
|
|
|
|
return sub { |
601
|
4
|
|
|
4
|
|
6
|
my $hash_ref = shift; |
602
|
|
|
|
|
|
|
# It has to be a hash reference... |
603
|
4
|
100
|
50
|
|
|
18
|
return _error_near($hash_ref, "Dict[$type_is{dict}]") |
604
|
|
|
|
|
|
|
if (reftype($hash_ref) // q{}) ne 'HASH'; |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
# With all the required keys... |
607
|
3
|
|
|
|
|
5
|
for my $key (@required_keys) { |
608
|
|
|
|
|
|
|
return _error_near($_, "Dict[$type_is{dict}]") |
609
|
5
|
100
|
|
|
|
14
|
if !exists $hash_ref->{$key}; |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# Each entry has to have a permitted key and the right type of value... |
613
|
2
|
|
|
|
|
3
|
while (my ($key, $value) = each %{$hash_ref}) { |
|
10
|
|
|
|
|
23
|
|
614
|
8
|
100
|
|
|
|
11
|
if (exists $handler_for{$key}) { |
615
|
4
|
|
|
|
|
10
|
my $okay = $handler_for{$key}($value); |
616
|
4
|
50
|
|
|
|
7
|
return _error_near($_, "Dict[$type_is{dict}]", $okay) |
617
|
|
|
|
|
|
|
if !$okay; |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
else { |
620
|
4
|
50
|
|
|
|
9
|
return _error_near($_, "Dict[$type_is{dict}]") |
621
|
|
|
|
|
|
|
if !$extra_keys_allowed; |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
|
|
625
|
2
|
|
|
|
|
3
|
return 1; |
626
|
|
|
|
|
|
|
} |
627
|
2
|
|
|
|
|
21
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# Ref[T] types require a reference, whose dereferenced value is of type T... |
630
|
|
|
|
|
|
|
# but with special magic if T is already itself a reference type |
631
|
40
|
100
|
|
|
|
68
|
if ( exists $type_is{ref} ) { my $value_handler = _build_handler_for($type_is{ref}); |
|
14
|
|
|
|
|
44
|
|
632
|
14
|
100
|
|
|
|
79
|
return $value_handler if $type_is{ref} =~ $IS_REF_TYPE; |
633
|
|
|
|
|
|
|
return sub { |
634
|
26
|
|
|
26
|
|
84
|
my $reftype = reftype($_[0]); |
635
|
26
|
50
|
66
|
|
|
147
|
return _error_near($_[0], "Ref[$type_is{ref}]") |
|
|
|
33
|
|
|
|
|
636
|
|
|
|
|
|
|
if !$reftype || $reftype ne 'REF' && $reftype ne 'SCALAR'; |
637
|
26
|
|
|
|
|
46
|
my $okay = $value_handler->(${$_[0]}); |
|
26
|
|
|
|
|
65
|
|
638
|
26
|
100
|
|
|
|
96
|
return $okay ? 1 : _error_near($_[0], "Ref[$type_is{ref}]", $okay) |
639
|
|
|
|
|
|
|
} |
640
|
10
|
|
|
|
|
86
|
} |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
# Not[T] negates the usual test... |
643
|
26
|
100
|
|
|
|
48
|
if ( exists $type_is{not} ) { my $negated_handler = _build_handler_for($type_is{not}); |
|
2
|
|
|
|
|
6
|
|
644
|
|
|
|
|
|
|
return sub { |
645
|
11
|
|
|
11
|
|
24
|
my $not_okay = $negated_handler->($_[0]); |
646
|
11
|
100
|
|
|
|
24
|
return _error_near($_[0], "Not[$type_is{not}]", $not_okay) |
647
|
|
|
|
|
|
|
if $not_okay; |
648
|
9
|
|
|
|
|
13
|
return 1; |
649
|
|
|
|
|
|
|
} |
650
|
2
|
|
|
|
|
34
|
} |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
# Eq[S] types require a stringifiable, that matches 'S'... |
653
|
24
|
50
|
|
|
|
61
|
if ( exists $type_is{eq} ) { my $str = eval "q[$type_is{eq}]"; |
|
0
|
|
|
|
|
0
|
|
654
|
|
|
|
|
|
|
return sub { |
655
|
|
|
|
|
|
|
return 1 if defined $_[0] |
656
|
|
|
|
|
|
|
&& (!blessed($_[0]) || overload::Method($_[0],q{""})) |
657
|
0
|
0
|
0
|
0
|
|
0
|
&& eval{ "$_[0]" eq $str }; |
|
0
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
|
|
658
|
0
|
|
|
|
|
0
|
return _error_near($_[0], "Eq[$type_is{eq}]"); |
659
|
|
|
|
|
|
|
} |
660
|
0
|
|
|
|
|
0
|
} |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
# Match[R] types require a stringifiable, that matches /R/x... |
663
|
24
|
100
|
|
|
|
47
|
if ( exists $type_is{match} ) { |
664
|
6
|
|
|
|
|
11
|
my $regex = eval { qr{$type_is{match}}x }; |
|
6
|
|
|
|
|
99
|
|
665
|
6
|
50
|
|
|
|
19
|
croak "Invalid regex syntax in Match[$type_is{match}]:\n $@" if $@; |
666
|
|
|
|
|
|
|
return sub { |
667
|
|
|
|
|
|
|
return 1 if defined $_[0] |
668
|
|
|
|
|
|
|
&& (!blessed($_[0]) || overload::Method($_[0],q{""})) |
669
|
26
|
100
|
33
|
26
|
|
109
|
&& eval{ "$_[0]" =~ $regex }; |
|
26
|
|
33
|
|
|
132
|
|
|
|
|
66
|
|
|
|
|
670
|
4
|
|
|
|
|
23
|
return _error_near($_[0], "Match[$type_is{match}]"); |
671
|
|
|
|
|
|
|
} |
672
|
6
|
|
|
|
|
43
|
} |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
# Can[M] types require a class or object with the specified methods... |
675
|
18
|
100
|
|
|
|
55
|
if ( exists $type_is{can} ) { my @method_names = split q{,}, $type_is{can}; |
|
8
|
|
|
|
|
27
|
|
676
|
8
|
|
|
|
|
75
|
s{\s*}{}g for @method_names; |
677
|
|
|
|
|
|
|
return sub { |
678
|
8
|
50
|
33
|
8
|
|
36
|
return 0 if !blessed($_[0]) && !$handler_for{Class}($_[0]); |
679
|
8
|
|
|
|
|
14
|
for my $method_name (@method_names) { |
680
|
|
|
|
|
|
|
return _error_near($_[0], "Can[$type_is{can}]") |
681
|
12
|
100
|
|
|
|
14
|
if !eval{ $_[0]->can($method_name) }; |
|
12
|
|
|
|
|
73
|
|
682
|
|
|
|
|
|
|
} |
683
|
6
|
|
|
|
|
13
|
return 1 |
684
|
|
|
|
|
|
|
} |
685
|
8
|
|
|
|
|
65
|
} |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
# Overloads[O] types require a class or object with the specified overloads... |
688
|
10
|
50
|
|
|
|
19
|
if ( exists $type_is{overloads} ) { my @ops = split q{,}, $type_is{overloads}; |
|
10
|
|
|
|
|
29
|
|
689
|
10
|
|
|
|
|
87
|
s{\s*}{}g for @ops; |
690
|
|
|
|
|
|
|
return sub { |
691
|
59
|
|
|
59
|
|
210485
|
use overload; |
|
59
|
|
|
|
|
136
|
|
|
59
|
|
|
|
|
237
|
|
692
|
10
|
50
|
33
|
10
|
|
44
|
return 0 if !blessed($_[0]) && !$handler_for{Class}($_[0]); |
693
|
10
|
|
|
|
|
19
|
for my $op (@ops) { |
694
|
24
|
100
|
|
|
|
380
|
return _error_near($_[0], "Can[$type_is{overloads}]") |
695
|
|
|
|
|
|
|
if !overload::Method($_[0], $op); |
696
|
|
|
|
|
|
|
} |
697
|
6
|
|
|
|
|
200
|
return 1 |
698
|
|
|
|
|
|
|
} |
699
|
10
|
|
|
|
|
80
|
} |
700
|
|
|
|
|
|
|
|
701
|
0
|
|
|
|
|
0
|
die "Internal error: could not generate a type from '$type'. Please report this as a bug." |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
sub _complete_desc { |
705
|
558
|
|
|
558
|
|
937
|
my ($desc, $value) = @_; |
706
|
558
|
|
100
|
|
|
956
|
$desc //= q{Value (%s)}; |
707
|
558
|
|
|
|
|
922
|
my $value_perl = _perl($value); |
708
|
558
|
|
|
|
|
57035
|
return $desc =~ s{(?
|
709
|
|
|
|
|
|
|
} |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
sub validate { |
712
|
757
|
|
|
757
|
1
|
169878
|
my ($typename, $value) = splice(@_,0,2); |
713
|
757
|
|
|
|
|
1087
|
my ($value_desc, @constraints); |
714
|
757
|
|
|
|
|
1208
|
for my $arg (@_) { |
715
|
|
|
|
|
|
|
# Subs are undescribed constraints... |
716
|
682
|
100
|
|
|
|
1554
|
if (ref($arg) eq 'CODE') { |
|
|
50
|
|
|
|
|
|
717
|
60
|
|
|
|
|
101
|
push @constraints, $arg; |
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
# Anything else is part of the value description... |
721
|
|
|
|
|
|
|
elsif (defined $arg) { |
722
|
622
|
|
|
|
|
1068
|
$value_desc .= $arg; |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
# What's happening in the caller's lexical scope??? |
727
|
757
|
|
50
|
|
|
1638
|
local $Dios::Types::lexical_hints = (caller 0)[10] // {}; |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
# All but the basic handlers are built late, as needed... |
730
|
757
|
100
|
|
|
|
14187
|
if (!exists $handler_for{$typename}) { |
731
|
44
|
50
|
|
|
|
145
|
$handler_for{$typename} = _build_handler_for($typename) |
732
|
|
|
|
|
|
|
or die 'Internal error: unable to build type checker. Please report this as a bug.'; |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
# Either the type matches or we die... |
736
|
757
|
100
|
|
|
|
1617
|
if (!$handler_for{$typename}($value)) { |
737
|
314
|
|
|
|
|
631
|
$value_desc = _complete_desc($value_desc, $value); |
738
|
314
|
50
|
|
|
|
3513
|
croak qq{\u$value_desc} |
739
|
|
|
|
|
|
|
. ($value_desc =~ /\s$/ ? q{} : q{ }) |
740
|
|
|
|
|
|
|
. qq{is not of type $typename}; |
741
|
|
|
|
|
|
|
} |
742
|
442
|
100
|
|
|
|
1675
|
return 1 if !@constraints; |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
# Either every constraint matches or we die... |
745
|
58
|
|
|
|
|
76
|
for my $test (@constraints) { |
746
|
58
|
|
|
|
|
69
|
local $@; |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
# If it fails to match... |
749
|
58
|
100
|
|
0
|
|
82
|
if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $value) }) { |
|
58
|
|
|
|
|
256
|
|
|
58
|
|
|
|
|
159
|
|
750
|
33
|
|
|
|
|
227
|
$value_desc = _complete_desc($value_desc, $value); |
751
|
33
|
|
|
|
|
78
|
my $constraint_desc = _describe_constraint($value, $value_desc, $test, $@); |
752
|
33
|
50
|
|
|
|
439
|
croak qq{\u$value_desc} |
753
|
|
|
|
|
|
|
. ($value_desc =~ /\s$/ ? q{} : q{ }) |
754
|
|
|
|
|
|
|
. qq{did not satisfy the constraint: $constraint_desc\n } |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
|
758
|
25
|
|
|
|
|
221
|
return 1; |
759
|
|
|
|
|
|
|
} |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
sub _up_validate { |
762
|
118
|
|
|
118
|
|
3013
|
my ($uplevels, $typename, $value) = splice(@_,0,3); |
763
|
118
|
|
|
|
|
163
|
my ($value_desc, @constraints); |
764
|
118
|
|
|
|
|
191
|
for my $arg (@_) { |
765
|
|
|
|
|
|
|
# Subs are undescribed constraints... |
766
|
166
|
100
|
|
|
|
378
|
if (ref($arg) eq 'CODE') { |
|
|
50
|
|
|
|
|
|
767
|
50
|
|
|
|
|
87
|
push @constraints, $arg; |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
# Anything else is part of the value description... |
771
|
|
|
|
|
|
|
elsif (defined $arg) { |
772
|
116
|
|
|
|
|
214
|
$value_desc .= $arg; |
773
|
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
|
} |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
# What's happening in the caller's lexical scope??? |
777
|
118
|
|
100
|
|
|
243
|
local $Dios::Types::lexical_hints = (caller $uplevels)[10] // {}; |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# All but the basic handlers are built late, as needed... |
780
|
118
|
100
|
|
|
|
2105
|
if (!exists $handler_for{$typename}) { |
781
|
2
|
50
|
|
|
|
6
|
$handler_for{$typename} = _build_handler_for($typename) |
782
|
|
|
|
|
|
|
or die 'Internal error: unable to build type checker. Please report this as a bug.'; |
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
# Either the type matches or we die... |
786
|
118
|
100
|
|
|
|
265
|
if (!$handler_for{$typename}($value)) { |
787
|
13
|
|
|
|
|
34
|
$value_desc = _complete_desc($value_desc, $value); |
788
|
13
|
100
|
|
|
|
177
|
croak qq{\u$value_desc} |
789
|
|
|
|
|
|
|
. ($value_desc =~ /\s$/ ? q{} : q{ }) |
790
|
|
|
|
|
|
|
. qq{is not of type $typename}; |
791
|
|
|
|
|
|
|
} |
792
|
105
|
100
|
|
|
|
409
|
return 1 if !@constraints; |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
# Either every constraint matches or we die... |
795
|
42
|
|
|
|
|
60
|
for my $test (@constraints) { |
796
|
42
|
|
|
|
|
54
|
local $@; |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
# If it fails to match... |
799
|
42
|
100
|
|
0
|
|
55
|
if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $value) }) { |
|
42
|
|
|
|
|
204
|
|
|
42
|
|
|
|
|
147
|
|
800
|
4
|
|
|
|
|
33
|
$value_desc = _complete_desc($value_desc, $value); |
801
|
4
|
|
|
|
|
49
|
my $constraint_desc = _describe_constraint($value, $value_desc, $test, $@); |
802
|
4
|
50
|
|
|
|
90
|
croak qq{\u$value_desc} |
803
|
|
|
|
|
|
|
. ($value_desc =~ /\s$/ ? q{} : q{ }) |
804
|
|
|
|
|
|
|
. qq{did not satisfy the constraint: $constraint_desc\n } |
805
|
|
|
|
|
|
|
} |
806
|
|
|
|
|
|
|
} |
807
|
|
|
|
|
|
|
|
808
|
38
|
|
|
|
|
183
|
return 1; |
809
|
|
|
|
|
|
|
} |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
sub validator_for { |
812
|
281
|
|
|
281
|
1
|
108408
|
my $typename = shift; |
813
|
281
|
|
|
|
|
430
|
my ($value_desc, @constraints); |
814
|
281
|
|
|
|
|
473
|
for my $arg (@_) { |
815
|
|
|
|
|
|
|
# Subs are undescribed constraints... |
816
|
168
|
100
|
|
|
|
496
|
if (ref($arg) eq 'CODE') { |
|
|
50
|
|
|
|
|
|
817
|
1
|
|
|
|
|
3
|
push @constraints, $arg; |
818
|
|
|
|
|
|
|
} |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
# Anything else is part of the value description... |
821
|
|
|
|
|
|
|
elsif (defined $arg) { |
822
|
167
|
|
|
|
|
385
|
$value_desc .= $arg; |
823
|
|
|
|
|
|
|
} |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
# What's happening in the caller's lexical scope??? |
827
|
281
|
|
50
|
|
|
727
|
local $Dios::Types::lexical_hints = (caller 0)[10] // {}; |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
# All but the basic handlers are built late, as needed... |
830
|
281
|
100
|
|
|
|
5508
|
if (!exists $handler_for{$typename}) { |
831
|
43
|
50
|
|
|
|
110
|
$handler_for{$typename} = _build_handler_for($typename) |
832
|
|
|
|
|
|
|
or die 'Internal error: unable to build type checker. Please report this as a bug.'; |
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
# Return the smallest sub that validates the type... |
836
|
281
|
|
|
|
|
481
|
my $handler = $handler_for{$typename}; |
837
|
|
|
|
|
|
|
|
838
|
281
|
50
|
66
|
|
|
938
|
return $handler if !$value_desc && !@constraints; |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
return sub { |
841
|
198
|
100
|
|
198
|
|
65958
|
return 1 if $handler->($_[0]); |
842
|
|
|
|
|
|
|
|
843
|
152
|
|
|
|
|
379
|
my $desc = _complete_desc($value_desc, $_[0]); |
844
|
152
|
50
|
|
|
|
1772
|
croak qq{\u$desc} |
845
|
|
|
|
|
|
|
. ($desc =~ /\s$/ ? q{} : q{ }) |
846
|
|
|
|
|
|
|
. qq{is not of type $typename}; |
847
|
167
|
100
|
|
|
|
1008
|
} if !@constraints; |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
return sub { |
850
|
|
|
|
|
|
|
# Either the type matches or we die... |
851
|
10
|
100
|
|
10
|
|
31564
|
if (!$handler_for{$typename}($_[0])) { |
852
|
2
|
|
|
|
|
6
|
my $desc = _complete_desc($value_desc, $_[0]); |
853
|
2
|
50
|
|
|
|
34
|
croak qq{\u$desc} |
854
|
|
|
|
|
|
|
. ($desc =~ /\s$/ ? q{} : q{ }) |
855
|
|
|
|
|
|
|
. qq{is not of type $typename}; |
856
|
|
|
|
|
|
|
} |
857
|
8
|
50
|
|
|
|
30
|
return 1 if !@constraints; |
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
# Either every constraint matches or we die... |
860
|
8
|
|
|
|
|
17
|
for my $test (@constraints) { |
861
|
8
|
|
|
|
|
12
|
local $@; |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
# If it fails to match... |
864
|
8
|
50
|
|
|
|
13
|
if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $_[0]) }) { |
|
8
|
|
|
|
|
48
|
|
|
8
|
|
|
|
|
27
|
|
865
|
0
|
|
|
|
|
0
|
my $desc = _complete_desc($value_desc, $_[0]); |
866
|
0
|
|
|
|
|
0
|
my $constraint_desc = _describe_constraint($_[0], $desc, $test, $@); |
867
|
0
|
0
|
|
|
|
0
|
croak qq{\u$desc} |
868
|
|
|
|
|
|
|
. ($desc =~ /\s$/ ? q{} : q{ }) |
869
|
|
|
|
|
|
|
. qq{did not satisfy the constraint: $constraint_desc\n } |
870
|
|
|
|
|
|
|
} |
871
|
|
|
|
|
|
|
} |
872
|
|
|
|
|
|
|
|
873
|
8
|
|
|
|
|
84
|
return 1; |
874
|
|
|
|
|
|
|
} |
875
|
1
|
|
|
|
|
8
|
} |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
package Dios::Types::TypedArray { |
878
|
|
|
|
|
|
|
our @CARP_NOT = ('Dios::Types'); |
879
|
8
|
|
|
8
|
|
40
|
sub TIEARRAY { bless [$_[1]], $_[0] } |
880
|
64
|
|
|
64
|
|
17008
|
sub FETCHSIZE { @{$_[0]} - 1 } |
|
64
|
|
|
|
|
128
|
|
881
|
0
|
|
|
0
|
|
0
|
sub STORESIZE { $#{$_[0]} = $_[1] + 1 } |
|
0
|
|
|
|
|
0
|
|
882
|
38
|
|
|
38
|
|
1639
|
sub STORE { my ($type, $desc, @constraint) = @{$_[0][0]}; |
|
38
|
|
|
|
|
85
|
|
883
|
38
|
|
|
|
|
101
|
Dios::Types::_up_validate(1, $type, $_[2], $desc, @constraint); |
884
|
34
|
|
|
|
|
129
|
$_[0]->[$_[1]+1] = $_[2]; |
885
|
|
|
|
|
|
|
} |
886
|
53
|
|
|
53
|
|
484
|
sub FETCH { $_[0]->[$_[1]+1] } |
887
|
12
|
|
|
12
|
|
4097
|
sub CLEAR { @{$_[0]} = $_[0][0] } |
|
12
|
|
|
|
|
68
|
|
888
|
0
|
0
|
|
0
|
|
0
|
sub POP { @{$_[0]} > 1 ? pop(@{$_[0]}) : undef } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
889
|
0
|
|
|
0
|
|
0
|
sub PUSH { my $o = shift; push(@{$o}, @_) } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
890
|
0
|
|
|
0
|
|
0
|
sub SHIFT { splice(@{$_[0]},1,1) } |
|
0
|
|
|
|
|
0
|
|
891
|
0
|
|
|
0
|
|
0
|
sub UNSHIFT { my $o = shift; splice(@$o,1,0,@_) } |
|
0
|
|
|
|
|
0
|
|
892
|
0
|
|
|
0
|
|
0
|
sub EXISTS { exists $_[0]->[$_[1]+1] } |
893
|
0
|
|
|
0
|
|
0
|
sub DELETE { delete $_[0]->[$_[1]+1] } |
894
|
|
|
|
12
|
|
|
sub EXTEND { } |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
sub SPLICE |
897
|
|
|
|
|
|
|
{ |
898
|
0
|
|
|
0
|
|
0
|
my $ob = shift; |
899
|
0
|
|
|
|
|
0
|
my $sz = @{$ob} - 1; |
|
0
|
|
|
|
|
0
|
|
900
|
0
|
0
|
|
|
|
0
|
my $off = @_ ? shift : 0; |
901
|
0
|
0
|
|
|
|
0
|
$off += $sz if $off < 0; |
902
|
0
|
0
|
|
|
|
0
|
my $len = @_ ? shift : $sz-$off; |
903
|
0
|
|
|
|
|
0
|
return splice(@$ob,$off+1,$len,@_); |
904
|
|
|
|
|
|
|
} |
905
|
|
|
|
|
|
|
} |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
package Dios::Types::TypedHash { |
908
|
|
|
|
|
|
|
our @CARP_NOT = ('Dios::Types'); |
909
|
8
|
|
|
8
|
|
38
|
sub TIEHASH { bless [$_[1], {}], $_[0] } |
910
|
24
|
|
|
24
|
|
523
|
sub STORE { my ($type, $desc, @constraint) = @{$_[0][0]}; |
|
24
|
|
|
|
|
60
|
|
911
|
24
|
|
|
|
|
71
|
Dios::Types::_up_validate(1, $type, $_[2], $desc, @constraint); |
912
|
22
|
|
|
|
|
88
|
$_[0][1]{$_[1]} = $_[2] |
913
|
|
|
|
|
|
|
} |
914
|
35
|
|
|
35
|
|
406
|
sub FETCH { $_[0][1]{$_[1]} } |
915
|
16
|
|
|
16
|
|
6741
|
sub FIRSTKEY { my $a = scalar keys %{$_[0][1]}; each %{$_[0][1]} } |
|
16
|
|
|
|
|
50
|
|
|
16
|
|
|
|
|
32
|
|
|
16
|
|
|
|
|
67
|
|
916
|
32
|
|
|
32
|
|
46
|
sub NEXTKEY { each %{$_[0][1]} } |
|
32
|
|
|
|
|
85
|
|
917
|
34
|
|
|
34
|
|
396
|
sub EXISTS { exists $_[0][1]{$_[1]} } |
918
|
0
|
|
|
0
|
|
0
|
sub DELETE { delete $_[0][1]{$_[1]} } |
919
|
12
|
|
|
12
|
|
7006
|
sub CLEAR { %{$_[0][1]} = () } |
|
12
|
|
|
|
|
80
|
|
920
|
0
|
|
|
0
|
|
0
|
sub SCALAR { scalar %{$_[0][1]} } |
|
0
|
|
|
|
|
0
|
|
921
|
|
|
|
|
|
|
} |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
sub _set_var_type { |
924
|
51
|
|
|
51
|
|
38274
|
my ($type, $varref, $value_desc, @constraint) = @_; |
925
|
51
|
|
|
|
|
133
|
my $vartype = ref $varref; |
926
|
|
|
|
|
|
|
|
927
|
51
|
100
|
100
|
|
|
301
|
if ($vartype ne 'ARRAY' && $vartype ne 'HASH') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
928
|
|
|
|
|
|
|
croak 'Typed attributes require the Variable::Magic module, which could not be loaded' |
929
|
21
|
50
|
|
|
|
39
|
if !eval{ require Variable::Magic }; |
|
21
|
|
|
|
|
163
|
|
930
|
|
|
|
|
|
|
|
931
|
21
|
|
|
|
|
180
|
Variable::Magic::cast( ${$varref}, Variable::Magic::wizard( set => sub { |
932
|
|
|
|
|
|
|
# Code around awkward Object::Insideout behaviour... |
933
|
42
|
100
|
100
|
42
|
|
32208
|
return if ((caller 3)[3]//"") eq 'Object::InsideOut::DESTROY'; |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
# Code around more awkward Object::Insideout behaviour... |
936
|
59
|
|
|
59
|
|
122794
|
no warnings 'redefine'; |
|
59
|
|
|
|
|
130
|
|
|
59
|
|
|
|
|
98599
|
|
937
|
23
|
|
|
|
|
408
|
local *croak = *confess{CODE}; |
938
|
23
|
100
|
|
|
|
43
|
return if eval { _up_validate(+2, $type, ${$_[0]}, $value_desc, @constraint) }; |
|
23
|
|
|
|
|
39
|
|
|
23
|
|
|
|
|
83
|
|
939
|
4
|
|
|
|
|
2189
|
die $@ =~ s{\s+at .*}{}r |
940
|
|
|
|
|
|
|
=~ s{[\h\S]*Dios.*}{}gr |
941
|
|
|
|
|
|
|
=~ s{.*\(eval .*}{}gr |
942
|
|
|
|
|
|
|
=~ s{\s*[\h\S]*called at}{ at}r |
943
|
|
|
|
|
|
|
=~ s{.*called at.*}{}gr; |
944
|
21
|
|
|
|
|
60
|
})); |
945
|
|
|
|
|
|
|
} |
946
|
|
|
|
|
|
|
elsif ($vartype eq 'ARRAY') { |
947
|
15
|
100
|
|
|
|
25
|
return if tied @{$varref}; |
|
15
|
|
|
|
|
84
|
|
948
|
8
|
|
|
|
|
16
|
tie @{$varref}, 'Dios::Types::TypedArray', [$type, $value_desc, @constraint]; |
|
8
|
|
|
|
|
78
|
|
949
|
|
|
|
|
|
|
} |
950
|
|
|
|
|
|
|
elsif ($vartype eq 'HASH') { |
951
|
15
|
100
|
|
|
|
25
|
return if tied %{$varref}; |
|
15
|
|
|
|
|
65
|
|
952
|
8
|
|
|
|
|
18
|
tie %{$varref}, 'Dios::Types::TypedHash', [$type, $value_desc, @constraint]; |
|
8
|
|
|
|
|
63
|
|
953
|
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
else { |
955
|
0
|
|
|
|
|
0
|
die 'Internal error: argument to _set_var_type() must be scalar, array ref, or hash ref'; |
956
|
|
|
|
|
|
|
} |
957
|
|
|
|
|
|
|
} |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
# Implement return-type checking... |
960
|
|
|
|
|
|
|
sub _validate_return_type { |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
# Type info is first arg (an arrayref), subroutine body is final arg (a sub ref)... |
963
|
33
|
|
|
33
|
|
14932
|
my ($name, $type, $where) = @{shift()}; |
|
33
|
|
|
|
|
70
|
|
964
|
33
|
|
50
|
26
|
|
171
|
$where //= sub{1}; |
|
26
|
|
|
|
|
103
|
|
965
|
33
|
|
|
|
|
41
|
my $function = pop; |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
# List return context... |
968
|
33
|
100
|
|
|
|
69
|
if (wantarray) { |
|
|
100
|
|
|
|
|
|
969
|
|
|
|
|
|
|
# Tidy up type... |
970
|
1
|
|
|
|
|
7
|
$type =~ s{\A Void \| | \| Void \Z}{}xmsg; |
971
|
1
|
|
|
|
|
5
|
my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1); |
972
|
1
|
50
|
33
|
|
|
24
|
warn sprintf "Call to $name() not in void context at %s line %d\n", (caller 1)[1,2] |
973
|
|
|
|
|
|
|
if $void_warning && $type eq 'Void'; |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
# Execute the subroutine body in (apparently) the right context... |
976
|
1
|
|
|
|
|
4
|
my @retvals = uplevel 2, $function, @_; |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
# Adapt the constraint to produce a more appropriate error message... |
979
|
|
|
|
|
|
|
my $listwhere = sub { |
980
|
1
|
|
|
1
|
|
2
|
for (@{shift()}) { |
|
1
|
|
|
|
|
4
|
|
981
|
3
|
50
|
|
|
|
4
|
die _describe_constraint($_,undef,$where) if !$where->($_) |
982
|
|
|
|
|
|
|
} |
983
|
1
|
|
|
|
|
6
|
return 1; |
984
|
1
|
|
|
|
|
300
|
}; |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
# Validate the return values... |
987
|
|
|
|
|
|
|
eval { |
988
|
1
|
50
|
|
|
|
4
|
if (@retvals == 1) { |
989
|
0
|
|
|
|
|
0
|
_up_validate(+1, |
990
|
|
|
|
|
|
|
$type, $retvals[0], $where, |
991
|
|
|
|
|
|
|
"Return value (" . (_perl(@retvals)=~s/^\(|\)$//gr) . ") of call to $name()\n" |
992
|
|
|
|
|
|
|
); |
993
|
|
|
|
|
|
|
} |
994
|
|
|
|
|
|
|
else { |
995
|
1
|
|
|
|
|
4
|
undef; |
996
|
|
|
|
|
|
|
} |
997
|
|
|
|
|
|
|
} |
998
|
|
|
|
|
|
|
// |
999
|
1
|
|
33
|
|
|
3
|
eval { |
|
|
|
50
|
|
|
|
|
1000
|
1
|
|
|
|
|
5
|
_up_validate(+1, |
1001
|
|
|
|
|
|
|
$type, \@retvals, $listwhere, |
1002
|
|
|
|
|
|
|
"List of return values (" . (_perl(@retvals)=~s/^\(|\)$//gr) . ") of call to $name()\n" |
1003
|
|
|
|
|
|
|
) |
1004
|
|
|
|
|
|
|
} |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
# ..or convert the error message to report from the correct line number... |
1007
|
0
|
|
|
|
|
0
|
// die $@ =~ s{\s*+at \S+ line \d++.*+}{sprintf "\nat %s line %d\n", (caller 1)[1,2]}ser; |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
# If the return values are valid, return them... |
1010
|
1
|
|
|
|
|
9
|
return @retvals; |
1011
|
|
|
|
|
|
|
} |
1012
|
|
|
|
|
|
|
|
1013
|
|
|
|
|
|
|
# Scalar context... |
1014
|
|
|
|
|
|
|
elsif (defined wantarray) { |
1015
|
|
|
|
|
|
|
# Tidy up type... |
1016
|
30
|
|
|
|
|
62
|
$type =~ s{\A Void \| | \| Void \Z}{}xmsg; |
1017
|
30
|
|
|
|
|
67
|
my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1); |
1018
|
30
|
50
|
33
|
|
|
644
|
warn sprintf "Call to $name() not in void context at %s line %d\n", (caller 1)[1,2] |
1019
|
|
|
|
|
|
|
if $void_warning && $type eq 'Void'; |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
# Execute the subroutine body in (apparently) the right context... |
1022
|
30
|
|
|
|
|
65
|
my $retval = uplevel 2, $function, @_; |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
# Validate the return value... |
1025
|
30
|
|
100
|
|
|
757
|
eval { |
1026
|
30
|
|
|
|
|
56
|
_up_validate(+1, |
1027
|
|
|
|
|
|
|
$type, $retval, $where, |
1028
|
|
|
|
|
|
|
"Scalar return value (" . _perl($retval) . ") of call to $name()\n" |
1029
|
|
|
|
|
|
|
) |
1030
|
|
|
|
|
|
|
} |
1031
|
|
|
|
|
|
|
# ...or convert the error message to report from the correct line number... |
1032
|
7
|
|
|
|
|
1729
|
// die $@ =~ s{\s*at \S+ line \d+.*}{sprintf "\nat %s line %d\n", (caller 1)[1,2]}er; |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
# If the return value is valid, return it... |
1035
|
23
|
|
|
|
|
79
|
return $retval; |
1036
|
|
|
|
|
|
|
} |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
# Void context... |
1039
|
|
|
|
|
|
|
else { |
1040
|
|
|
|
|
|
|
# Execute the subroutine body in (apparently) the right context... |
1041
|
2
|
|
|
|
|
8
|
uplevel 2, $function, @_; |
1042
|
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
|
# Warn about explicit return types in void context, unless return type implies void is okay... |
1044
|
2
|
|
|
|
|
337
|
my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1); |
1045
|
|
|
|
|
|
|
warn sprintf |
1046
|
|
|
|
|
|
|
"Useless call to $name() with explicit return type $type\nin void context at %s line %d\n", |
1047
|
|
|
|
|
|
|
(caller 1)[1,2] |
1048
|
2
|
50
|
33
|
|
|
46
|
if $void_warning && !eval{ _up_validate(+1, $type, undef) }; |
|
2
|
|
|
|
|
5
|
|
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
} |
1051
|
|
|
|
|
|
|
} |
1052
|
|
|
|
|
|
|
|
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
# Compare two types... |
1057
|
|
|
|
|
|
|
sub _is_narrower { |
1058
|
136
|
|
|
136
|
|
221
|
my ($type_a, $type_b, $unnormalized) = @_; |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
# Short-circuit on identity... |
1061
|
136
|
100
|
|
|
|
277
|
return 0 if $type_a eq $type_b; |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
# Otherwise, normalize and decompose... |
1064
|
110
|
100
|
100
|
|
|
3530
|
if (!$unnormalized && $type_a =~ m{\A (?: Ref ) \Z }xms) { |
|
|
50
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1065
|
24
|
|
|
|
|
36
|
$type_a = "Ref[Any]"; |
1066
|
|
|
|
|
|
|
} |
1067
|
|
|
|
|
|
|
elsif (!$unnormalized && $type_a =~ m{\A (?: Array | List ) \Z }xms) { |
1068
|
0
|
|
|
|
|
0
|
$type_a = "Ref[Array[Any]]"; |
1069
|
|
|
|
|
|
|
} |
1070
|
|
|
|
|
|
|
elsif (!$unnormalized && $type_a eq 'Hash') { |
1071
|
4
|
|
|
|
|
7
|
$type_a = "Ref[Hash[Any]]"; |
1072
|
|
|
|
|
|
|
} |
1073
|
|
|
|
|
|
|
elsif ($type_a =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z $FROM_TYPENAME_GRAMMAR }xms) { |
1074
|
0
|
|
|
|
|
0
|
$type_a = "Is[$1]"; |
1075
|
|
|
|
|
|
|
} |
1076
|
110
|
|
|
|
|
2018
|
$type_a =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms; my %type_a_is = %+; |
|
110
|
|
|
|
|
1149
|
|
1077
|
|
|
|
|
|
|
|
1078
|
110
|
50
|
66
|
|
|
3737
|
if (!$unnormalized && $type_b =~ m{\A (?: Ref ) \Z }xms) { |
|
|
50
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1079
|
0
|
|
|
|
|
0
|
$type_b = "Ref[Any]"; |
1080
|
|
|
|
|
|
|
} |
1081
|
|
|
|
|
|
|
elsif (!$unnormalized && $type_b =~ m{\A (?: Array | List ) \Z }xms) { |
1082
|
0
|
|
|
|
|
0
|
$type_b = "Ref[Array[Any]]"; |
1083
|
|
|
|
|
|
|
} |
1084
|
|
|
|
|
|
|
elsif (!$unnormalized && $type_b eq 'Hash') { |
1085
|
20
|
|
|
|
|
34
|
$type_b = "Ref[Hash[Any]]"; |
1086
|
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
|
elsif ($type_b =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z $FROM_TYPENAME_GRAMMAR }xms) { |
1088
|
0
|
|
|
|
|
0
|
$type_b = "Is[$1]"; |
1089
|
|
|
|
|
|
|
} |
1090
|
110
|
|
|
|
|
1983
|
$type_b =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms; my %type_b_is = %+; |
|
110
|
|
|
|
|
945
|
|
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
# If both are basic types, use the standard comparisons... |
1093
|
110
|
100
|
100
|
|
|
412
|
if (exists $type_a_is{basic} && exists $type_b_is{basic}) { |
1094
|
62
|
100
|
|
|
|
254
|
return +1 if $BASIC_NARROWER{$type_b}->{$type_a}; |
1095
|
30
|
50
|
|
|
|
186
|
return -1 if $BASIC_NARROWER{$type_a}->{$type_b}; |
1096
|
|
|
|
|
|
|
} |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
# If both are array or hash or reference types, use the standard comparisons on their element-types... |
1099
|
48
|
|
|
|
|
116
|
for my $elem_type (qw< array hash ref >) { |
1100
|
144
|
100
|
100
|
|
|
301
|
if (exists $type_a_is{$elem_type} && exists $type_b_is{$elem_type}) { |
1101
|
16
|
|
|
|
|
42
|
return _is_narrower($type_a_is{$elem_type}, $type_b_is{$elem_type}, 'unnormalized'); |
1102
|
|
|
|
|
|
|
} |
1103
|
|
|
|
|
|
|
} |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
# If either type is parameterized, try the generic unparameterized version... |
1106
|
32
|
50
|
66
|
|
|
193
|
if ($type_a =~ s{\A(?:List|Array|Hash|Ref|Match|Eq)\K\[.*}{}xms |
1107
|
|
|
|
|
|
|
|| $type_b =~ s{\A(?:List|Array|Hash|Ref|Match|Eq)\K\[.*}{}xms) { |
1108
|
32
|
0
|
33
|
|
|
88
|
return -1 if $type_a =~ m{\A(?:Match|Eq)\Z} && $BASIC_NARROWER{Class}->{$type_b}; |
1109
|
32
|
0
|
33
|
|
|
71
|
return +1 if $type_b =~ m{\A(?:Match|Eq)\Z} && $BASIC_NARROWER{Class}->{$type_a}; |
1110
|
32
|
|
|
|
|
74
|
return _is_narrower($type_a, $type_b, 'unnormalized'); |
1111
|
|
|
|
|
|
|
} |
1112
|
|
|
|
|
|
|
|
1113
|
|
|
|
|
|
|
# If both are user-defined types, try the standard inheritance hierarchy rules... |
1114
|
0
|
0
|
0
|
|
|
0
|
if (exists $type_a_is{user} && exists $type_b_is{user}) { |
1115
|
0
|
0
|
|
|
|
0
|
return +1 if $type_b->isa($type_a); |
1116
|
0
|
0
|
|
|
|
0
|
return -1 if $type_a->isa($type_b); |
1117
|
|
|
|
|
|
|
} |
1118
|
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
# Otherwise, unable to compare... |
1120
|
0
|
|
|
|
|
0
|
return 0; |
1121
|
|
|
|
|
|
|
} |
1122
|
|
|
|
|
|
|
|
1123
|
|
|
|
|
|
|
# Compare two type signatures (of equal length)... |
1124
|
|
|
|
|
|
|
sub _cmp_signatures { |
1125
|
46
|
|
|
46
|
|
80
|
my ($sig_a, $sig_b) = @_; |
1126
|
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
|
# Extract named parameters of B... |
1128
|
46
|
|
|
|
|
50
|
state %named_B_for; |
1129
|
|
|
|
|
|
|
my $named_B = |
1130
|
46
|
100
|
100
|
|
|
109
|
$named_B_for{$sig_b} //= { map { $_->{named} ? ($_->{named} => $_) : () } @{$sig_b} }; |
|
34
|
|
|
|
|
113
|
|
|
18
|
|
|
|
|
33
|
|
1131
|
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
|
# Track relative ordering parameter-by-parameter... |
1133
|
46
|
|
|
|
|
59
|
my $partial_ordering = 0; |
1134
|
46
|
|
|
|
|
176
|
for my $n (0 .. max($#$sig_a, $#$sig_b)) { |
1135
|
|
|
|
|
|
|
# Unpack the next parameter types... |
1136
|
88
|
|
50
|
|
|
181
|
my $sig_a_n = $sig_a->[$n] // {}; |
1137
|
88
|
|
|
|
|
122
|
my $sig_a_name = $sig_a_n->{named}; |
1138
|
88
|
100
|
50
|
|
|
175
|
my $sig_b_n = ($sig_a_name ? $named_B->{$sig_a_name} : $sig_b->[$n]) // {}; |
1139
|
88
|
|
50
|
|
|
233
|
my ($type_a, $type_b) = ($sig_a_n->{type} // 'Any', $sig_b_n->{type} // 'Any'); |
|
|
|
50
|
|
|
|
|
1140
|
|
|
|
|
|
|
|
1141
|
|
|
|
|
|
|
# Find the ordering of the next parameter pair from the two signatures... |
1142
|
88
|
|
|
|
|
155
|
my $is_narrower = _is_narrower($type_a, $type_b); |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
# Tie-break in favour of the type with more constraints... |
1145
|
88
|
100
|
66
|
|
|
202
|
if (!$is_narrower && $type_a eq $type_b) { |
1146
|
26
|
|
50
|
|
|
67
|
my $where_a = $sig_a_n->{where} // 0; |
1147
|
26
|
|
50
|
|
|
59
|
my $where_b = $sig_b_n->{where} // 0; |
1148
|
26
|
50
|
|
|
|
55
|
$is_narrower = $where_a > $where_b ? -1 |
|
|
50
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
: $where_a < $where_b ? +1 |
1150
|
|
|
|
|
|
|
: 0; |
1151
|
|
|
|
|
|
|
} |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
# If this pair's ordering contradicts the ordering so far, there is no ordering... |
1154
|
88
|
100
|
100
|
|
|
262
|
return 0 if $is_narrower && $is_narrower == -$partial_ordering; |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
# Otherwise if there's an ordering, it becomes the "ordering so far"... |
1157
|
72
|
|
100
|
|
|
194
|
$partial_ordering ||= $is_narrower; |
1158
|
|
|
|
|
|
|
} |
1159
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
# If we make it through the entire list, return the resulting ordering... |
1161
|
30
|
|
|
|
|
72
|
return $partial_ordering; |
1162
|
|
|
|
|
|
|
} |
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
# Resolve ambiguous argument lists using Perl6-ish multiple dispatch rules... |
1165
|
59
|
|
|
59
|
|
497
|
use List::Util qw< max first >; |
|
59
|
|
|
|
|
118
|
|
|
59
|
|
|
|
|
37913
|
|
1166
|
|
|
|
|
|
|
sub _resolve_signatures { |
1167
|
27
|
|
|
27
|
|
33
|
state %narrowness_for; |
1168
|
27
|
|
|
|
|
53
|
my ($kind, @sigs) = @_; |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
# Track narrownesses... |
1171
|
27
|
|
|
|
|
55
|
my %narrower = map { $_ => [] } 0..$#sigs; |
|
78
|
|
|
|
|
173
|
|
1172
|
|
|
|
|
|
|
|
1173
|
|
|
|
|
|
|
# Compare all signatures, recording definitive differences in narrowness... |
1174
|
27
|
|
|
|
|
81
|
for my $index_1 (0 .. $#sigs) { |
1175
|
78
|
|
|
|
|
163
|
for my $index_2 ($index_1+1 .. $#sigs) { |
1176
|
91
|
|
|
|
|
146
|
my $sig1 = $sigs[$index_1]{sig}; |
1177
|
91
|
|
|
|
|
115
|
my $sig2 = $sigs[$index_2]{sig}; |
1178
|
|
|
|
|
|
|
my $narrowness = |
1179
|
91
|
|
100
|
|
|
326
|
$narrowness_for{$sig1,$sig2} //= _cmp_signatures($sig1, $sig2); |
1180
|
|
|
|
|
|
|
|
1181
|
91
|
100
|
|
|
|
195
|
if ($narrowness < 0) { push @{$narrower{$index_1}}, $index_2; } |
|
35
|
100
|
|
|
|
39
|
|
|
35
|
|
|
|
|
98
|
|
1182
|
24
|
|
|
|
|
32
|
elsif ($narrowness > 0) { push @{$narrower{$index_2}}, $index_1; } |
|
24
|
|
|
|
|
64
|
|
1183
|
|
|
|
|
|
|
} |
1184
|
|
|
|
|
|
|
} |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
# Find the narrowest signature(s)... |
1187
|
27
|
|
|
|
|
57
|
my $max_narrower = max map { scalar @{$_} } values %narrower; |
|
78
|
|
|
|
|
78
|
|
|
78
|
|
|
|
|
145
|
|
1188
|
|
|
|
|
|
|
|
1189
|
|
|
|
|
|
|
# If they're not sufficiently narrow, weed out the non-contenders... |
1190
|
27
|
100
|
|
|
|
55
|
if ($max_narrower < @sigs-1) { |
1191
|
6
|
|
|
|
|
15
|
@sigs = @sigs[ sort grep { @{$narrower{$_}} } keys %narrower ]; |
|
22
|
|
|
|
|
20
|
|
|
22
|
|
|
|
|
52
|
|
1192
|
|
|
|
|
|
|
} |
1193
|
|
|
|
|
|
|
# Otherwise, locate the narrowest... |
1194
|
|
|
|
|
|
|
else { |
1195
|
21
|
|
|
43
|
|
111
|
@sigs = @sigs[ first { @{$narrower{$_}} >= $max_narrower } keys %narrower ]; |
|
43
|
|
|
|
|
49
|
|
|
43
|
|
|
|
|
92
|
|
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
# Tie-break methods on the class of the variants... |
1199
|
27
|
100
|
100
|
|
|
132
|
if ($kind eq 'method' && @sigs > 1) { |
1200
|
4
|
|
|
|
|
24
|
@sigs = sort { $a->{class} eq $b->{class} ? 0 |
1201
|
|
|
|
|
|
|
: $a->{class}->isa($b->{class}) ? -1 |
1202
|
4
|
50
|
|
|
|
22
|
: $b->{class}->isa($a->{class}) ? +1 |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1203
|
|
|
|
|
|
|
: 0 |
1204
|
|
|
|
|
|
|
} @sigs; |
1205
|
4
|
|
|
|
|
58
|
@sigs = grep { $_->{class} eq $sigs[0]{class} } @sigs; |
|
8
|
|
|
|
|
20
|
|
1206
|
|
|
|
|
|
|
} |
1207
|
|
|
|
|
|
|
|
1208
|
27
|
|
|
|
|
97
|
return @sigs; |
1209
|
|
|
|
|
|
|
} |
1210
|
|
|
|
|
|
|
|
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
sub _describe_constraint { |
1213
|
40
|
|
|
40
|
|
89
|
my ($value, $value_desc, $constraint, $constraint_desc) = @_; |
1214
|
|
|
|
|
|
|
|
1215
|
|
|
|
|
|
|
# Did the exception provide a constraint description??? |
1216
|
40
|
50
|
|
|
|
84
|
if ($constraint_desc) { |
1217
|
0
|
|
|
|
|
0
|
$constraint_desc =~ s{\b at .* line .*+ \s*+}{}gx; |
1218
|
|
|
|
|
|
|
} |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
# Describe the value that failed... |
1221
|
40
|
|
|
|
|
68
|
$value_desc = _complete_desc($value_desc, $value); |
1222
|
|
|
|
|
|
|
|
1223
|
|
|
|
|
|
|
# Try to describe the constraint by name, if it was a named sub... |
1224
|
40
|
50
|
50
|
|
|
146
|
if (!length($constraint_desc//q{}) && eval{ require B }) { |
|
40
|
|
33
|
|
|
264
|
|
1225
|
40
|
|
|
|
|
275
|
my $sub_name = B::svref_2object($constraint)->GV->NAME; |
1226
|
40
|
50
|
33
|
|
|
184
|
if ($sub_name && $sub_name ne '__ANON__') { |
1227
|
0
|
|
|
|
|
0
|
$sub_name =~ s/[:_]++/ /g; |
1228
|
0
|
|
|
|
|
0
|
$constraint_desc = $sub_name; |
1229
|
|
|
|
|
|
|
} |
1230
|
|
|
|
|
|
|
} |
1231
|
|
|
|
|
|
|
|
1232
|
|
|
|
|
|
|
# Deparse the constraint sub (if necessary and possible)... |
1233
|
40
|
50
|
50
|
|
|
112
|
if (!length($constraint_desc//q{}) && eval{ require B::Deparse }) { |
|
40
|
|
33
|
|
|
173
|
|
1234
|
40
|
|
|
|
|
271
|
state $deparser = B::Deparse->new; |
1235
|
40
|
|
|
|
|
96
|
my ($hint_bits, $warning_bits) = (caller 0)[8,9]; |
1236
|
40
|
|
|
|
|
1153
|
$deparser->ambient_pragmas( |
1237
|
|
|
|
|
|
|
hint_bits => $hint_bits, warning_bits => $warning_bits, '$[' => 0 + $[ |
1238
|
59
|
|
|
59
|
|
24071
|
); |
|
59
|
|
|
|
|
15585
|
|
|
59
|
|
|
|
|
12718
|
|
1239
|
40
|
|
|
|
|
31795
|
$constraint_desc = $deparser->coderef2text($constraint); |
1240
|
40
|
|
|
|
|
1220
|
$constraint_desc =~ s{\s*+ BEGIN \s*+ \{ (?&CODE) \} |
1241
|
|
|
|
|
|
|
(?(DEFINE) (? [^{}]*+ (\{ (?&CODE) \} [^{}]*+ )*+ ))}{}gxms; |
1242
|
40
|
|
|
|
|
413
|
$constraint_desc =~ s{(?: (?:use|no) \s*+ (?: feature | warnings | strict ) | die \s*+ sprintf ) [^;]* ;}{}gxms; |
1243
|
40
|
|
|
|
|
152
|
$constraint_desc =~ s{package \s*+ \S+ \s*+ ;}{}gxms; |
1244
|
40
|
|
|
|
|
185
|
$constraint_desc =~ s{\s++}{ }g; |
1245
|
|
|
|
|
|
|
} |
1246
|
40
|
|
33
|
|
|
154
|
return $constraint_desc // "$constraint"; |
1247
|
|
|
|
|
|
|
} |
1248
|
|
|
|
|
|
|
|
1249
|
|
|
|
|
|
|
sub _perl { |
1250
|
59
|
|
|
59
|
|
16947
|
use Data::Dump 'dump'; |
|
59
|
|
|
|
|
238382
|
|
|
59
|
|
|
|
|
11856
|
|
1251
|
|
|
|
|
|
|
dump( map { |
1252
|
1471
|
50
|
|
1471
|
|
275950
|
if (my $tiedclass = tied $_) { $tiedclass =~ s/=.*//; "<$tiedclass tie>" } |
|
1473
|
100
|
|
|
|
4689
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1253
|
2
|
|
|
|
|
14
|
elsif (my $classname = blessed $_) { "<$classname object>" } |
1254
|
1471
|
|
|
|
|
4928
|
else { $_ } |
1255
|
|
|
|
|
|
|
} @_ ) |
1256
|
|
|
|
|
|
|
=~ s{" (< \S++ \s (?:object|tie) >) "}{$1}xgmsr; |
1257
|
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
|
} |
1259
|
|
|
|
|
|
|
|
1260
|
|
|
|
|
|
|
|
1261
|
|
|
|
|
|
|
|
1262
|
|
|
|
|
|
|
1; # Magic true value required at end of module |
1263
|
|
|
|
|
|
|
__END__ |