line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Dios; |
2
|
|
|
|
|
|
|
our $VERSION = '0.002011'; |
3
|
|
|
|
|
|
|
|
4
|
55
|
|
|
55
|
|
2231249
|
use 5.014; use warnings; |
|
55
|
|
|
55
|
|
198
|
|
|
55
|
|
|
|
|
291
|
|
|
55
|
|
|
|
|
97
|
|
|
55
|
|
|
|
|
1554
|
|
5
|
55
|
|
|
55
|
|
26067
|
use Dios::Types; |
|
55
|
|
|
|
|
407
|
|
|
55
|
|
|
|
|
371
|
|
6
|
55
|
|
|
55
|
|
3793
|
use Keyword::Declare; |
|
55
|
|
|
|
|
102
|
|
|
55
|
|
|
|
|
351
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
my $PARAMETER_SYNTAX = qr{ |
9
|
|
|
|
|
|
|
(?&WS)?+ |
10
|
|
|
|
|
|
|
(? |
11
|
|
|
|
|
|
|
(? |
12
|
|
|
|
|
|
|
(? (?&PerlNumber) ) |
13
|
|
|
|
|
|
|
| |
14
|
|
|
|
|
|
|
(? (?&PerlQuotelikeQ) ) |
15
|
|
|
|
|
|
|
| |
16
|
|
|
|
|
|
|
(? (?&PerlMatch) ) |
17
|
|
|
|
|
|
|
) |
18
|
|
|
|
|
|
|
| |
19
|
|
|
|
|
|
|
# TYPE... |
20
|
|
|
|
|
|
|
(? (?&TYPE_SPEC) )?+ |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
# NAME... |
23
|
|
|
|
|
|
|
(?&WS)?+ |
24
|
|
|
|
|
|
|
(? |
25
|
|
|
|
|
|
|
: (? (?&IDENT) ) \( (?&WS)?+ |
26
|
|
|
|
|
|
|
(? (? [\$\@%]) (?&IDENT) ) (?&WS)?+ |
27
|
|
|
|
|
|
|
\) |
28
|
|
|
|
|
|
|
| |
29
|
|
|
|
|
|
|
: (? (? [\$\@%]) (? (?&IDENT) ) ) |
30
|
|
|
|
|
|
|
| |
31
|
|
|
|
|
|
|
\* (?) |
32
|
|
|
|
|
|
|
(?: |
33
|
|
|
|
|
|
|
(? (? [\@%]) (?&IDENT) ) |
34
|
|
|
|
|
|
|
| |
35
|
|
|
|
|
|
|
: (? (?&IDENT) ) \( (?&WS)? |
36
|
|
|
|
|
|
|
(? (? \@) (?&IDENT) ) (?&WS)? |
37
|
|
|
|
|
|
|
\) |
38
|
|
|
|
|
|
|
| |
39
|
|
|
|
|
|
|
: (? (? \@) (? (?&IDENT) ) ) |
40
|
|
|
|
|
|
|
| |
41
|
|
|
|
|
|
|
(? (? [\@%]) ) |
42
|
|
|
|
|
|
|
) |
43
|
|
|
|
|
|
|
| |
44
|
|
|
|
|
|
|
(? (? [\$\@%]) (?&IDENT) ) |
45
|
|
|
|
|
|
|
| |
46
|
|
|
|
|
|
|
(? (? [\$\@%]?+) ) |
47
|
|
|
|
|
|
|
) |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# OPTIONAL OR REQUIRED... |
50
|
|
|
|
|
|
|
(?: (? \? ) (? ) |
51
|
|
|
|
|
|
|
| (? \! ) |
52
|
|
|
|
|
|
|
)?+ |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# CONSTRAINT... |
55
|
|
|
|
|
|
|
(?&WS)?+ |
56
|
|
|
|
|
|
|
(?: where (?&WS)?+ (? (?&PerlBlock) ) )?+ |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# READONLY OR ALIAS... |
59
|
|
|
|
|
|
|
(?: (?&WS)?+ is (?&WS)?+ (? ro | alias ) )?+ |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# DEFAULT VALUE... |
62
|
|
|
|
|
|
|
(?: (?&WS)?+ (? (?> // | \|\| )?+ = ) |
63
|
|
|
|
|
|
|
(?&WS)?+ (? (?&PerlConditionalExpression) ))?+ |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
(?&WS)?+ |
66
|
|
|
|
|
|
|
) |
67
|
|
|
|
|
|
|
(? , | : | (?= --> ) | \z ) |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
(?(DEFINE) |
70
|
|
|
|
|
|
|
(? (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ ) |
71
|
|
|
|
|
|
|
(? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ ) |
72
|
|
|
|
|
|
|
(? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] ) |
73
|
|
|
|
|
|
|
(? (?&IDENT) (?: :: (?&IDENT) )*+ ) |
74
|
|
|
|
|
|
|
(? [^\W\d] \w*+ ) |
75
|
|
|
|
|
|
|
(? (\s++ | \# [^\n]*+ \n )++ ) |
76
|
|
|
|
|
|
|
$PPR::GRAMMAR |
77
|
|
|
|
|
|
|
) |
78
|
|
|
|
|
|
|
}xms; |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
my $EMPTY_PARAM_LIST = qr{ |
81
|
|
|
|
|
|
|
\A |
82
|
|
|
|
|
|
|
(?&OWS) |
83
|
|
|
|
|
|
|
(?: |
84
|
|
|
|
|
|
|
\( (?&OWS) (\*\@_)?+ (?&OWS) \) |
85
|
|
|
|
|
|
|
)?+ |
86
|
|
|
|
|
|
|
(?&OWS) |
87
|
|
|
|
|
|
|
\z |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
(?(DEFINE) |
90
|
|
|
|
|
|
|
(? \s*+ (?: \# .* \n \s*+ )*+ ) |
91
|
|
|
|
|
|
|
) |
92
|
|
|
|
|
|
|
}xm; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub _translate_parameters { |
95
|
226
|
|
|
226
|
|
683
|
my $params = shift; |
96
|
226
|
|
|
|
|
483
|
my $kind = shift; |
97
|
226
|
|
|
|
|
426
|
my $sub_name = shift; |
98
|
226
|
|
|
|
|
438
|
my $sub_name_tidy = $sub_name; |
99
|
226
|
|
|
|
|
1012
|
$sub_name_tidy =~ s{\A \s*+ (?: \# .*+ \n \s*+ )*+ }{}x; |
100
|
|
|
|
|
|
|
|
101
|
226
|
100
|
|
|
|
1005
|
my $sub_desc = $sub_name ? "$kind $sub_name_tidy" : "anonymous $kind"; |
102
|
226
|
|
50
|
|
|
1126
|
my $invocant_name = $^H{'Dios invocant_name'} // '$self'; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# Empty and "standard" parameter lists are easy... |
105
|
226
|
100
|
66
|
|
|
3684
|
if (!defined $params || $params =~ $EMPTY_PARAM_LIST) { |
106
|
50
|
|
|
|
|
162
|
my $std_slurpy = defined $1; |
107
|
50
|
100
|
|
|
|
475
|
my $code |
|
|
100
|
|
|
|
|
|
108
|
|
|
|
|
|
|
= ($kind eq 'method' |
109
|
|
|
|
|
|
|
? _generate_invocant("method $sub_name_tidy", {var=>$invocant_name, sigil=>'$'}) |
110
|
|
|
|
|
|
|
: q{} |
111
|
|
|
|
|
|
|
) |
112
|
|
|
|
|
|
|
. ($std_slurpy ? q{} : qq{Dios::_error(ucfirst(q{$sub_desc takes no arguments})) if \@_;}); |
113
|
|
|
|
|
|
|
|
114
|
50
|
100
|
|
|
|
291
|
my $spec = ( $kind eq 'method' ? q{ {type=>'Any', where=[]}, } : q{} ) |
|
|
100
|
|
|
|
|
|
115
|
|
|
|
|
|
|
. ( $std_slurpy ? q{ {optional => 1, type=>'Slurpy', where=>[]} } : q{} ); |
116
|
|
|
|
|
|
|
|
117
|
50
|
|
|
|
|
275
|
return { code => $code, spec => $spec }; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
176
|
|
|
|
|
1002
|
$params =~ s{\A \s*+ \(}{}x; |
121
|
176
|
|
|
|
|
860
|
$params =~ s{\) \s*+ \z}{}x; |
122
|
|
|
|
|
|
|
|
123
|
176
|
|
|
|
|
412
|
my $return_type = undef; |
124
|
176
|
|
|
|
|
339
|
my $return_constraint = undef; |
125
|
176
|
100
|
|
|
|
611
|
my $invocant = $kind eq 'method' ? $invocant_name : undef; |
126
|
176
|
|
|
|
|
357
|
my $first_param = 1; |
127
|
176
|
|
|
|
|
326
|
my @params; |
128
|
|
|
|
|
|
|
|
129
|
176
|
|
66
|
|
|
5147225
|
while (length($params) && $params =~ s{\A \s*+ $PARAMETER_SYNTAX }{}x) { |
130
|
284
|
|
|
|
|
75454
|
my %param = %+; |
131
|
284
|
100
|
|
|
|
3700
|
last if $param{raw_param} !~ /\S/; |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# Special case of literal numeric constant as parameter (e.g. multi func fib(0) { 0 } )... |
134
|
251
|
100
|
|
|
|
2083
|
if (defined $param{is_num_constant}) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
135
|
3
|
|
|
|
|
10
|
$param{type} = 'Num'; |
136
|
3
|
|
|
|
|
14
|
$param{constraint} = "{ \$_ == $param{is_num_constant} }"; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# Special case of literal string constant as parameter (e.g. multi func handle_event('add') {...} )... |
140
|
|
|
|
|
|
|
elsif (defined $param{is_str_constant}) { |
141
|
7
|
|
|
|
|
20
|
$param{type} = 'Str'; |
142
|
7
|
|
|
|
|
28
|
$param{constraint} = "{ \$_ eq $param{is_str_constant} }"; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# Special case of literal regex match as parameter (e.g. multi func # handle_event(/a|b/) {...} )... |
146
|
|
|
|
|
|
|
elsif (defined $param{is_regex_constant}) { |
147
|
2
|
|
|
|
|
7
|
$param{type} = 'Str'; |
148
|
2
|
|
|
|
|
9
|
$param{constraint} = "{ \$_ =~ $param{is_regex_constant} }"; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
251
|
|
|
|
|
3147293
|
push @params, \%param; |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# Make an implicit invocant explicit... |
156
|
176
|
100
|
100
|
|
|
1137
|
if (!@params && $kind eq 'method') { |
157
|
1
|
|
|
|
|
28242
|
"$invocant:" =~ m{\A \s*+ $PARAMETER_SYNTAX }x; |
158
|
1
|
|
|
|
|
176
|
push @params, {%+}; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# Extract trailing return type specification... |
162
|
176
|
100
|
|
|
|
1211
|
if ($params =~ s{ (?&WS) --> (?&WS) (.*+) (?(DEFINE) (? \s*+ (\# [^\n]*+ \n \s*+ )*+)) }{}xms ) { |
163
|
33
|
|
|
|
|
248
|
($return_type, $return_constraint) = split /\bwhere\b/, $1, 2; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# Anything else in the parameter list is a mistake... |
167
|
176
|
50
|
|
|
|
683
|
_error( qq{Invalid parameter specification: $params\n in $kind declaration} ) |
168
|
|
|
|
|
|
|
if $params =~ /\S/; |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# Convert the parameters into checking code... |
171
|
176
|
|
|
|
|
462
|
my $code = q{}; |
172
|
176
|
|
|
|
|
369
|
my $spec = q{}; |
173
|
176
|
|
|
|
|
326
|
my $nameless_pos = 0; |
174
|
176
|
|
|
|
|
442
|
my (%param_named, @positional, @named, $slurpy); |
175
|
|
|
|
|
|
|
|
176
|
176
|
|
|
|
|
629
|
for my $param (@params) { |
177
|
252
|
|
|
|
|
424
|
$nameless_pos++; |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# Constraints imply an Any type... |
180
|
252
|
100
|
66
|
|
|
924
|
if (defined $param->{constraint} && (!defined $param->{type} || $param->{type} !~ /\S/)) { |
|
|
|
100
|
|
|
|
|
181
|
1
|
|
|
|
|
2
|
$param->{type} = 'Any'; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
# Rectify nameless params... |
185
|
252
|
100
|
|
|
|
669
|
if (exists $param->{nameless}) { |
186
|
19
|
|
100
|
|
|
76
|
$param->{sigil} ||= '$'; |
187
|
19
|
100
|
|
|
|
119
|
my $nth = $nameless_pos |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
188
|
|
|
|
|
|
|
. ( $nameless_pos =~ /(?
|
189
|
|
|
|
|
|
|
: $nameless_pos =~ /(?
|
190
|
|
|
|
|
|
|
: $nameless_pos =~ /(?
|
191
|
|
|
|
|
|
|
: 'th' |
192
|
|
|
|
|
|
|
); |
193
|
19
|
|
|
|
|
86
|
$param->{var} = $param->{sigil} . '__nameless_'.$nth.'_parameter__'; |
194
|
19
|
|
|
|
|
50
|
$param->{namedvar} = $param->{sigil} . ' (unnamed $nth parameter)'; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# "There ken be onla one!" (...parameter of any given name)... |
198
|
|
|
|
|
|
|
_error( qq{Can't declare two parameters named $param->{var}\n in specification of $sub_desc}) |
199
|
252
|
50
|
|
|
|
741
|
if exists $param_named{ $param->{var} }; |
200
|
252
|
|
|
|
|
804
|
$param_named{ $param->{var} }++; |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# Parameters are lexical, so can't be named @_ or $_ or %_... |
203
|
|
|
|
|
|
|
_error( |
204
|
|
|
|
|
|
|
qq{Can't declare a }, |
205
|
|
|
|
|
|
|
(exists $param->{name} ? 'named' : exists $param->{slurpy} ? 'slurpy' : 'positional'), |
206
|
|
|
|
|
|
|
qq{ parameter named $param->{var}\nin specification of $sub_desc}, |
207
|
252
|
0
|
66
|
|
|
1105
|
) if substr($param->{var},1) eq '_' && $param->{namedvar} ne '*@_'; |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
# Handle implicit invocant specially... |
210
|
252
|
100
|
100
|
|
|
1495
|
if ($first_param && $kind eq 'method' && $param->{terminator} ne ':') { |
|
|
|
100
|
|
|
|
|
211
|
89
|
|
|
|
|
690
|
$code .= _generate_invocant( "$sub_desc", {var=>$invocant_name, sigil=>'$'} ); |
212
|
89
|
|
|
|
|
318
|
$first_param = 0; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# Handle explicit invocant... |
216
|
252
|
100
|
100
|
|
|
1321
|
if ($first_param && $param->{terminator} && $param->{terminator} eq ':') { |
|
|
100
|
100
|
|
|
|
|
217
|
18
|
50
|
|
|
|
55
|
_error( qq{Can't specify invocant ($param->{raw_param}:) for $sub_desc} ) if $kind ne 'method'; |
218
|
18
|
|
|
|
|
96
|
$code .= _generate_invocant( "$sub_desc", $param ); |
219
|
18
|
|
50
|
|
|
123
|
my $type = $param->{type} // 'Any'; |
220
|
18
|
50
|
|
|
|
70
|
my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{}; |
221
|
18
|
|
|
|
|
65
|
$spec .= qq{{type => '$type', $constraint },}; |
222
|
18
|
|
|
|
|
47
|
$first_param = 0; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
# Save a scalar (named or positional) paramater... |
226
|
|
|
|
|
|
|
elsif (!exists $param->{slurpy}) { |
227
|
214
|
100
|
|
|
|
507
|
if (exists $param->{name}) { push @named, $param } |
|
58
|
|
|
|
|
138
|
|
228
|
156
|
|
|
|
|
368
|
else { push @positional, $param } |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# Save the final slurpy array or hash... |
232
|
|
|
|
|
|
|
else { |
233
|
20
|
50
|
|
|
|
59
|
_error( qq{Can't specify more than one slurpy parameter }, |
234
|
|
|
|
|
|
|
qq{($slurpy->{namedvar}, $param->{namedvar})\n}, |
235
|
|
|
|
|
|
|
qq{ in specification of $sub_desc} |
236
|
|
|
|
|
|
|
) if defined $slurpy; |
237
|
|
|
|
|
|
|
|
238
|
20
|
100
|
|
|
|
54
|
if (exists $param->{name}) { |
239
|
|
|
|
|
|
|
_error( qq{Can't specify non-array named slurpy parameter ($param->{namedvar})\n}, |
240
|
|
|
|
|
|
|
qq{ in specification of $sub_desc} |
241
|
2
|
50
|
33
|
|
|
13
|
) if exists $param->{name} && $param->{sigil} ne '@'; |
242
|
|
|
|
|
|
|
|
243
|
2
|
|
|
|
|
6
|
push @named, $param; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
else { |
246
|
18
|
|
|
|
|
59
|
$slurpy = $param; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
176
|
100
|
|
|
|
499
|
if (@positional) { |
252
|
104
|
|
|
|
|
478
|
$code .= _generate_positionals( "$sub_desc", @positional ); |
253
|
104
|
|
|
|
|
292
|
for my $param (@positional) { |
254
|
156
|
|
100
|
|
|
549
|
my $type = $param->{type} // 'Any'; |
255
|
|
|
|
|
|
|
|
256
|
156
|
100
|
|
|
|
621
|
if ($param->{sigil} eq '@') { $type = "Array[$type]"; } |
|
6
|
100
|
|
|
|
19
|
|
257
|
2
|
|
|
|
|
5
|
elsif ($param->{sigil} eq '%') { $type = "Hash[$type]"; } |
258
|
|
|
|
|
|
|
|
259
|
156
|
100
|
|
|
|
395
|
my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{}; |
260
|
|
|
|
|
|
|
|
261
|
156
|
100
|
|
|
|
359
|
my $is_optional = exists $param->{default_type} ? 1 : 0; |
262
|
|
|
|
|
|
|
|
263
|
156
|
|
|
|
|
627
|
$spec .= qq{{optional => $is_optional, type => '$type', $constraint},}; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
} |
266
|
176
|
100
|
|
|
|
511
|
if (@named) { |
267
|
40
|
|
|
|
|
193
|
$code .= _generate_nameds( "$sub_desc", @named ); |
268
|
40
|
|
|
|
|
113
|
for my $param (@named) { |
269
|
60
|
|
100
|
|
|
196
|
my $type = $param->{type} // 'Any'; |
270
|
|
|
|
|
|
|
|
271
|
60
|
100
|
|
|
|
225
|
if ($param->{sigil} eq '@') { $type = "Array[$type]"; } |
|
5
|
100
|
|
|
|
14
|
|
272
|
1
|
|
|
|
|
3
|
elsif ($param->{sigil} eq '%') { $type = "Hash[$type]"; } |
273
|
|
|
|
|
|
|
|
274
|
60
|
100
|
|
|
|
159
|
my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{}; |
275
|
|
|
|
|
|
|
|
276
|
60
|
100
|
|
|
|
142
|
my $is_optional = exists $param->{default_type} ? 1 : 0; |
277
|
|
|
|
|
|
|
|
278
|
60
|
|
|
|
|
266
|
$spec .= qq{{named => '$param->{name}', optional => $is_optional, type => '$type', $constraint},}; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
|
282
|
176
|
100
|
|
|
|
502
|
if (defined $slurpy) { |
283
|
18
|
100
|
|
|
|
63
|
if ($slurpy->{var} ne '@_') { |
284
|
17
|
50
|
|
|
|
59
|
my $constraint = $slurpy->{constraint} ? "where => sub $slurpy->{constraint}" : q{}; |
285
|
17
|
|
|
|
|
76
|
$code .= _generate_slurpies( "$sub_desc", $slurpy ); |
286
|
17
|
|
|
|
|
56
|
$spec .= qq{ {optional => 1, type=>'Slurpy', $constraint} }; |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
else { |
290
|
158
|
|
|
|
|
727
|
$code .= qq[Dios::_error q{Unexpected extra argument}.(\@_==1?q{}:q{s}).' ('.join(', ', map { Dios::_perl \$_ } \@_).q{) in call to $sub_desc} if \@_;]; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
176
|
100
|
|
|
|
553
|
$return_type = defined $return_type ? qq{q{$return_type}} : ""; |
294
|
176
|
50
|
|
|
|
479
|
if (defined $return_constraint) { |
295
|
0
|
|
|
|
|
0
|
$return_type .= qq{, sub $return_constraint }; |
296
|
|
|
|
|
|
|
} |
297
|
176
|
|
|
|
|
2185
|
return { code => $code, return_type => $return_type, spec => $spec }; |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
sub _verify_required_named { |
301
|
40
|
|
|
40
|
|
111
|
my ($context, @params) = @_; |
302
|
40
|
|
|
|
|
90
|
my $code = q{}; |
303
|
40
|
|
|
|
|
87
|
for my $param (@params) { |
304
|
60
|
100
|
|
|
|
172
|
next if !$param->{required}; |
305
|
1
|
|
|
|
|
3
|
my $vardesc = quotemeta $param->{namedvar}; |
306
|
1
|
|
50
|
|
|
7
|
my $argdesc = qq{'$param->{name}' => <} . lc($param->{type}//'value'). q{>}; |
307
|
1
|
|
|
|
|
6
|
$code .= qq[Dios::_error(qq{No argument ($argdesc) found for required named parameter $vardesc\\n] |
308
|
|
|
|
|
|
|
. qq[in call to $context}) if !\$seen{$param->{name}}; ]; |
309
|
|
|
|
|
|
|
} |
310
|
40
|
|
|
|
|
98
|
return $code; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
sub _generate_invocant { |
314
|
153
|
|
|
153
|
|
483
|
my ($context, $param) = @_; |
315
|
153
|
|
|
|
|
264
|
my $code; |
316
|
153
|
|
|
|
|
547
|
my $vardesc = qq{invocant $param->{var}}; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# Create and unpack corresponding argument... |
319
|
153
|
|
|
|
|
555
|
$code .= qq{my $param->{var}; }; |
320
|
153
|
|
|
|
|
391
|
$code .= _unpack_code( @{$param}{'sigil','var','name','default','special'}, $vardesc, $context ); |
|
153
|
|
|
|
|
1120
|
|
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# Install a type check, if necessary... |
323
|
153
|
50
|
|
|
|
1084
|
if (exists $param->{type}) { |
324
|
0
|
|
|
|
|
0
|
$code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context); |
|
0
|
|
|
|
|
0
|
|
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
153
|
|
|
|
|
557
|
return $code; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
sub _generate_positionals { |
331
|
104
|
|
|
104
|
|
347
|
my ($context, @positionals) = @_; |
332
|
104
|
|
|
|
|
203
|
my $code; |
333
|
|
|
|
|
|
|
|
334
|
104
|
|
|
|
|
249
|
for my $param (@positionals) { |
335
|
|
|
|
|
|
|
# Create and unpack corresponding argument... |
336
|
156
|
|
|
|
|
340
|
my $var = $param->{var}; |
337
|
156
|
100
|
|
|
|
589
|
my $vardesc = $var =~ /^(.)__nameless_(\d++[^\W_]++)_parameter__$/ |
338
|
|
|
|
|
|
|
? "unnamed $2 positional parameter" |
339
|
|
|
|
|
|
|
: "positional parameter $var"; |
340
|
156
|
|
|
|
|
481
|
$code .= qq{my $var; }; |
341
|
|
|
|
|
|
|
$code .= _unpack_code( |
342
|
156
|
|
|
|
|
314
|
@{$param}{'sigil','var','name','default','special'}, |
|
156
|
|
|
|
|
775
|
|
343
|
|
|
|
|
|
|
$vardesc, |
344
|
|
|
|
|
|
|
$context |
345
|
|
|
|
|
|
|
); |
346
|
156
|
100
|
66
|
|
|
785
|
if (exists $param->{name} && exists $param->{default_type}) { |
347
|
36
|
100
|
100
|
|
|
195
|
if ($param->{default_type} eq '//=' && $param->{sigil} eq '$') { |
|
|
100
|
|
|
|
|
|
348
|
9
|
|
|
|
|
16
|
my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{}); |
|
9
|
|
|
|
|
24
|
|
349
|
9
|
|
|
|
|
40
|
$code .= qq{ do {$assign_code} if !defined $var; }; |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
elsif ($param->{default_type} eq '||=') { |
352
|
10
|
|
|
|
|
15
|
my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{}); |
|
10
|
|
|
|
|
25
|
|
353
|
10
|
|
|
|
|
34
|
$code .= qq{ do {$assign_code} if !$var; }; |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# Install a type check, if necessary... |
358
|
156
|
100
|
|
|
|
505
|
next if !exists $param->{type}; |
359
|
55
|
|
|
|
|
106
|
$code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context); |
|
55
|
|
|
|
|
201
|
|
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
104
|
|
|
|
|
422
|
return $code; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
sub _generate_nameds { |
366
|
40
|
|
|
40
|
|
128
|
my ($context, @nameds) = @_; |
367
|
40
|
|
|
|
|
72
|
my $code; |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
# Declare all named args... |
370
|
40
|
|
|
|
|
113
|
$code .= 'my (' . join(',', map { $_->{var} } @nameds) . '); '; |
|
60
|
|
|
|
|
293
|
|
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
# Walk the arg list, unpacking them... |
373
|
40
|
|
|
|
|
113
|
$code .= qq[{ my %seen; while (\@_) { my \$next_key = shift;]; |
374
|
|
|
|
|
|
|
|
375
|
40
|
|
|
|
|
85
|
my $defaults = q{}; |
376
|
40
|
|
|
|
|
113
|
for my $param (@nameds) { |
377
|
60
|
|
|
|
|
171
|
$code .= qq[ if (\$next_key eq q{$param->{name}}) {]; |
378
|
|
|
|
|
|
|
my $unpack_code = |
379
|
|
|
|
|
|
|
exists $param->{slurpy} ? _unpack_named_slurpy_code( |
380
|
2
|
|
|
|
|
14
|
@{$param}{qw< var sigil name special >}, |
381
|
|
|
|
|
|
|
"slurpy named parameter $param->{namedvar}", $context |
382
|
|
|
|
|
|
|
) |
383
|
|
|
|
|
|
|
: _unpack_code( |
384
|
58
|
|
|
|
|
334
|
@{$param}{'sigil','var','name'}, undef, $param->{special}, |
385
|
60
|
100
|
|
|
|
178
|
"named parameter $param->{namedvar}", $context |
386
|
|
|
|
|
|
|
); |
387
|
60
|
|
|
|
|
217
|
$code .= qq[$unpack_code next}]; |
388
|
|
|
|
|
|
|
|
389
|
60
|
100
|
66
|
|
|
291
|
if (exists $param->{name} && exists $param->{default}) { |
390
|
2
|
|
|
|
|
5
|
my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{}); |
|
2
|
|
|
|
|
7
|
|
391
|
|
|
|
|
|
|
$defaults .= qq{ do {$assign_code} if } |
392
|
|
|
|
|
|
|
. ( $param->{default_type} eq '//=' ? qq{!defined $param->{var}; } |
393
|
2
|
50
|
|
|
|
19
|
: $param->{default_type} eq '||=' ? qq{!$param->{var}; } |
|
|
100
|
|
|
|
|
|
394
|
|
|
|
|
|
|
: qq{!\$seen{$param->{'name'}}; } |
395
|
|
|
|
|
|
|
); |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
|
399
|
40
|
|
|
|
|
157
|
my $requireds = _verify_required_named($context, @nameds); |
400
|
|
|
|
|
|
|
|
401
|
40
|
|
|
|
|
140
|
$code .= qq[unshift \@_, \$next_key; last} $defaults $requireds}]; |
402
|
|
|
|
|
|
|
|
403
|
40
|
|
|
|
|
86
|
for my $param (@nameds) { |
404
|
60
|
100
|
|
|
|
153
|
next if !exists $param->{type}; |
405
|
|
|
|
|
|
|
|
406
|
40
|
100
|
|
|
|
95
|
my $slurpy = exists $param->{slurpy} ? q{slurpy } : q{}; |
407
|
|
|
|
|
|
|
$code .= _typecheck_code( |
408
|
40
|
|
|
|
|
84
|
@{$param}{'sigil','var','type','constraint'}, "${slurpy}named parameter $param->{namedvar}", $context |
|
40
|
|
|
|
|
214
|
|
409
|
|
|
|
|
|
|
); |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
|
412
|
40
|
|
|
|
|
147
|
return $code; |
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
my $REFALIASING = q{use experimental 'refaliasing'}; |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub _generate_slurpies { |
418
|
17
|
|
|
17
|
|
48
|
my ($context, $param) = @_; |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
# No slurpy by default... |
421
|
17
|
50
|
|
|
|
56
|
return q{} if !defined $param; |
422
|
17
|
|
|
|
|
53
|
my $special = $param->{special}; |
423
|
17
|
|
|
|
|
41
|
my $code = q{}; |
424
|
|
|
|
|
|
|
|
425
|
17
|
100
|
|
|
|
101
|
my $vardesc = $param->{var} =~ /^(.)__nameless_.*_parameter__$/ |
426
|
|
|
|
|
|
|
? "nameless slurpy parameter (*$1)" |
427
|
|
|
|
|
|
|
: "slurpy parameter *$param->{var}"; |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
# Check named slurpies... |
430
|
17
|
100
|
|
|
|
75
|
if ($param->{sigil} eq '%') { |
431
|
2
|
|
|
|
|
9
|
$code .= qq{Dios::_error('Final key ('.Dios::dump(\$_[-1]).qq{) for $vardesc is missing its value\\nin call to $context}) if \@_ % 2;} |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
# Create and unpack corresponding argument... |
435
|
17
|
50
|
33
|
|
|
91
|
$code .= !$special ? qq{ my $param->{var} = } |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
436
|
|
|
|
|
|
|
: $special eq 'ro' ? qq{ Const::Fast::const my $param->{var} => } |
437
|
|
|
|
|
|
|
: $special eq 'alias' && $] < 5.022 ? qq{ Data::Alias::alias my $param->{var} = } |
438
|
|
|
|
|
|
|
: $special eq 'alias' ? qq{ $REFALIASING; \\my $param->{var} =\\ } |
439
|
|
|
|
|
|
|
: die "Internal error: unknown special trait: is $special"; |
440
|
|
|
|
|
|
|
|
441
|
17
|
100
|
|
|
|
65
|
$code .= exists $param->{default} ? qq{ (\@_ ? \@_ : $param->{default}); } |
442
|
|
|
|
|
|
|
: qq{ \@_; }; |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# Install a type check, if necessary... |
445
|
17
|
100
|
|
|
|
57
|
if (exists $param->{type}) { |
446
|
1
|
|
|
|
|
2
|
$code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context, 'slurpy'); |
|
1
|
|
|
|
|
4
|
|
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
# Install existence check, if necessary... |
450
|
17
|
100
|
|
|
|
60
|
if (exists $param->{required}) { |
451
|
1
|
|
|
|
|
3
|
my $vardesc = quotemeta $vardesc; |
452
|
1
|
|
|
|
|
5
|
$code .= qq[Dios::_error qq{Missing argument for required $vardesc\\nin $context} if !\@_;]; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
17
|
|
|
|
|
58
|
return $code; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
sub _assign_value_code { |
459
|
388
|
|
|
388
|
|
917
|
my ($sigil, $var, $special, $value_source, $check_type) = @_; |
460
|
388
|
|
100
|
|
|
1611
|
$special //= q{}; |
461
|
|
|
|
|
|
|
|
462
|
388
|
100
|
|
|
|
910
|
if ($sigil eq '$') { |
463
|
375
|
100
|
66
|
|
|
3021
|
return $special eq 'ro' ? qq[ Const::Fast::const($var => $value_source); ] |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
464
|
|
|
|
|
|
|
: $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var = $value_source ; ] |
465
|
|
|
|
|
|
|
: $special eq 'alias' ? qq[ $REFALIASING; \\$var = \\($value_source); ] |
466
|
|
|
|
|
|
|
: qq[ $var = $value_source ; ] |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
# Arrays and hashes, need more type-checking... |
470
|
13
|
100
|
|
|
|
38
|
if ($sigil eq '@') { |
471
|
10
|
50
|
33
|
|
|
113
|
return qq[ { my \$next_value = $value_source; ] |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
472
|
|
|
|
|
|
|
. $check_type |
473
|
|
|
|
|
|
|
. ( $special eq 'ro' ? qq[ Const::Fast::const($var => \@{\$next_value}); ] |
474
|
|
|
|
|
|
|
: $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var = \@{\$next_value} ; ] |
475
|
|
|
|
|
|
|
: $special eq 'alias' ? qq[ $REFALIASING; \\$var = \@{\$next_value} ; ] |
476
|
|
|
|
|
|
|
: qq[ $var = \@{\$next_value} ; ] |
477
|
|
|
|
|
|
|
) |
478
|
|
|
|
|
|
|
. qq[} ]; |
479
|
|
|
|
|
|
|
} |
480
|
3
|
50
|
|
|
|
21
|
if ($sigil eq '%') { |
481
|
3
|
50
|
33
|
|
|
53
|
return qq[ { my \$next_value = $value_source; ] |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
482
|
|
|
|
|
|
|
. $check_type |
483
|
|
|
|
|
|
|
. ( $special eq 'ro' ? qq[ Const::Fast::const($var => \%{\$next_value}); ] |
484
|
|
|
|
|
|
|
: $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var = \%{\$next_value} ; ] |
485
|
|
|
|
|
|
|
: $special eq 'alias' ? qq[ $REFALIASING; \\$var = \%{\$next_value} ; ] |
486
|
|
|
|
|
|
|
: qq[ $var = \%{\$next_value} ; ] |
487
|
|
|
|
|
|
|
) |
488
|
|
|
|
|
|
|
. qq[} ]; |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
sub _unpack_code { |
493
|
367
|
|
|
367
|
|
1171
|
my ($sigil, $var, $name, $default, $special, $vardesc, $context) = @_; |
494
|
367
|
|
|
|
|
881
|
state $type_of = { '$' => q{}, '@' => 'ARRAY', '%' => 'HASH' }; |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# Set up for readonly or aliasing, if specified... |
497
|
367
|
100
|
|
|
|
907
|
if ($special) { |
498
|
4
|
100
|
33
|
|
|
82
|
if ($special eq 'ro') { |
|
|
50
|
|
|
|
|
|
499
|
|
|
|
|
|
|
_error(q{'is ro' requires the Const::Fast module (which could not be loaded)}) |
500
|
2
|
50
|
|
|
|
6
|
if !eval { require Const::Fast; 1 }; |
|
2
|
|
|
|
|
575
|
|
|
2
|
|
|
|
|
1109
|
|
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
elsif ($special eq 'alias' && $] < 5.022) { |
503
|
|
|
|
|
|
|
_error(q{'is alias' requires the Data::Alias module (which could not be loaded)}) |
504
|
0
|
0
|
|
|
|
0
|
if !eval { require Data::Alias; 1 }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# Set up for default handling, if specified... |
509
|
367
|
|
|
|
|
980
|
my $value_source = qq{ ( !\@_ ? Dios::_error(q{No argument found for $vardesc in call to $context}) : shift) }; |
510
|
367
|
|
|
|
|
1829
|
my $type_check = qq[ Dios::_error q{Argument for $vardesc is not \L$type_of->{$sigil}\E ref in call to $context} ] |
511
|
|
|
|
|
|
|
. qq[ if ref(\$next_value) ne '$type_of->{$sigil}';]; |
512
|
|
|
|
|
|
|
|
513
|
367
|
100
|
|
|
|
1000
|
if (defined($default)) { |
514
|
36
|
50
|
66
|
|
|
128
|
$default ||= $sigil eq '$' ? 'undef' |
|
|
100
|
|
|
|
|
|
515
|
|
|
|
|
|
|
: $sigil eq '@' ? '[]' |
516
|
|
|
|
|
|
|
: '{}'; |
517
|
36
|
100
|
|
|
|
96
|
my $and_type_test = $sigil eq '$' ? '' : "&& ref(\$_[0]) eq '$type_of->{$sigil}'"; |
518
|
36
|
|
|
|
|
105
|
$value_source = qq{ \@_ $and_type_test ? shift() : $default }; |
519
|
36
|
|
|
|
|
63
|
$type_check = q{}; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
# Named params have to be tracked, if they have defaults... |
523
|
367
|
100
|
|
|
|
1135
|
my $note_seen |
524
|
|
|
|
|
|
|
= $name ? qq{ Dios::_error(q{Unexpected second value (}.Dios::_perl($var).q{) for named '$name' parameter in call to $context}) if \$seen{$name}; \$seen{$name} = 1; } |
525
|
|
|
|
|
|
|
: q{}; |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# Return the code... |
528
|
367
|
|
|
|
|
968
|
return _assign_value_code($sigil, $var, $special, $value_source, $type_check) |
529
|
|
|
|
|
|
|
. $note_seen; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
sub _unpack_named_slurpy_code { |
533
|
2
|
|
|
2
|
|
5
|
my ($var, $sigil, $name, $special, $vardesc, $context) = @_; |
534
|
2
|
|
50
|
|
|
11
|
$special //= q{}; |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
# Must be able to use the module, if it's required |
537
|
2
|
50
|
33
|
|
|
9
|
if ($special eq 'alias' && $] < 5.022) { |
538
|
|
|
|
|
|
|
_error(q{'is alias' requires the Data::Alias module (which could not be loaded)}) |
539
|
0
|
0
|
|
|
|
0
|
if !eval { require Data::Alias; 1 }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
# Work out how at unpack the arg |
543
|
2
|
50
|
33
|
|
|
13
|
my $unpack_code |
|
|
50
|
|
|
|
|
|
544
|
|
|
|
|
|
|
= $special eq 'alias' && $] >= 5.022 ? qq{use experimental 'refaliasing';\\\$${name}[\@$name]=\\shift;} |
545
|
|
|
|
|
|
|
: $special eq 'alias' ? qq{ Data::Alias::alias( \$${name}[\@$name] = shift); } |
546
|
|
|
|
|
|
|
: qq{ push $var, shift; }; |
547
|
|
|
|
|
|
|
|
548
|
2
|
|
|
|
|
9
|
return qq{ Dios::_error q{No argument found for $vardesc in call to $context} if !\@_; } |
549
|
|
|
|
|
|
|
. $unpack_code; |
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
sub _typecheck_code { |
553
|
96
|
|
|
96
|
|
287
|
my ($sigil, $var, $type, $constraint, $vardesc, $context, $is_slurpy) = @_; |
554
|
96
|
100
|
|
|
|
216
|
$constraint = $constraint ? "sub $constraint" : q{}; |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
# Provide a human-readble description for any error message... |
557
|
96
|
|
|
|
|
221
|
$vardesc = qq{q{Value (%s) for $vardesc}}; |
558
|
|
|
|
|
|
|
|
559
|
96
|
100
|
|
|
|
226
|
if ($sigil eq '$') { |
560
|
94
|
|
|
|
|
471
|
return qq[{package Dios::Types; validate(q{$type}, $var,$vardesc,$constraint)}]; |
561
|
|
|
|
|
|
|
} |
562
|
2
|
50
|
|
|
|
9
|
if ($sigil eq '@') { |
563
|
2
|
100
|
|
|
|
8
|
return qq[{package Dios::Types; validate(q{List[$type]}, \\$var,$vardesc,$constraint)}] if $is_slurpy; |
564
|
1
|
|
|
|
|
7
|
return qq[{package Dios::Types; validate(q{Array[$type]},\\$var,$vardesc,$constraint)}]; |
565
|
|
|
|
|
|
|
} |
566
|
0
|
0
|
|
|
|
0
|
if ($sigil eq '%') { |
567
|
0
|
|
|
|
|
0
|
return qq[{package Dios::Types; validate(q{Hash[$type]}, \\$var,$vardesc,$constraint)}]; |
568
|
|
|
|
|
|
|
} |
569
|
0
|
|
|
|
|
0
|
die 'Internal error: unable to generate type checking code'; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
sub _perl { |
573
|
55
|
|
|
55
|
|
186356
|
use Data::Dump 'dump'; |
|
55
|
|
|
|
|
111
|
|
|
55
|
|
|
|
|
4796
|
|
574
|
7
|
|
|
7
|
|
5969
|
return dump(@_); |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
our @CARP_NOT = 'Keyword::Declare'; |
578
|
|
|
|
|
|
|
sub _error { |
579
|
55
|
|
|
55
|
|
342
|
use Carp; |
|
55
|
|
|
|
|
94
|
|
|
55
|
|
|
|
|
3904
|
|
580
|
20
|
|
|
20
|
|
15855
|
croak @_; |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
55
|
|
|
55
|
|
321
|
use re 'eval'; |
|
55
|
|
|
|
|
99
|
|
|
55
|
|
|
|
|
107896
|
|
584
|
|
|
|
|
|
|
my $FIELD_DEFN = qr{ |
585
|
|
|
|
|
|
|
(? |
586
|
|
|
|
|
|
|
(?&TYPE_SPEC) |
587
|
|
|
|
|
|
|
)? \s*+ |
588
|
|
|
|
|
|
|
(? |
589
|
|
|
|
|
|
|
[\$\@%] |
590
|
|
|
|
|
|
|
) |
591
|
|
|
|
|
|
|
(? |
592
|
|
|
|
|
|
|
[.!]? |
593
|
|
|
|
|
|
|
) |
594
|
|
|
|
|
|
|
(? |
595
|
|
|
|
|
|
|
[^\W\d] \w* # Simple identifier |
596
|
|
|
|
|
|
|
) |
597
|
|
|
|
|
|
|
(? |
598
|
|
|
|
|
|
|
\s+ is \s+ req(?:uired)? |
599
|
|
|
|
|
|
|
)? |
600
|
|
|
|
|
|
|
(?: |
601
|
|
|
|
|
|
|
\s+ is \s+ |
602
|
|
|
|
|
|
|
(? r[wo] ) |
603
|
|
|
|
|
|
|
)? |
604
|
|
|
|
|
|
|
(? # repeat to allow 'is' options in either order |
605
|
|
|
|
|
|
|
\s+ is \s+ req(?:uired)? |
606
|
|
|
|
|
|
|
)? |
607
|
|
|
|
|
|
|
(? |
608
|
|
|
|
|
|
|
\s*+ : \s*+ (?&ATTR) |
609
|
|
|
|
|
|
|
(?: |
610
|
|
|
|
|
|
|
(?: \s*+ : \s*+ | \s++) (?&ATTR) |
611
|
|
|
|
|
|
|
)*+ |
612
|
|
|
|
|
|
|
)? |
613
|
|
|
|
|
|
|
(? |
614
|
|
|
|
|
|
|
.*+ |
615
|
|
|
|
|
|
|
) |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
(?(DEFINE) |
618
|
|
|
|
|
|
|
(? (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ ) |
619
|
|
|
|
|
|
|
(? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ ) |
620
|
|
|
|
|
|
|
(? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] ) |
621
|
|
|
|
|
|
|
(? (?&IDENT) (?: :: (?&IDENT) )*+ ) |
622
|
|
|
|
|
|
|
(? [^\W\d] \w*+ ) |
623
|
|
|
|
|
|
|
(? [^\W\d]\w*+ (?! [(] ) ) |
624
|
|
|
|
|
|
|
) |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
}xms; |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
my $SHARED_DEFN = qr{ |
629
|
|
|
|
|
|
|
(? |
630
|
|
|
|
|
|
|
(?&TYPE_SPEC) |
631
|
|
|
|
|
|
|
)? |
632
|
|
|
|
|
|
|
\s*+ |
633
|
|
|
|
|
|
|
(? |
634
|
|
|
|
|
|
|
\$ | \@ | \% |
635
|
|
|
|
|
|
|
) |
636
|
|
|
|
|
|
|
(? |
637
|
|
|
|
|
|
|
[.!]? |
638
|
|
|
|
|
|
|
) |
639
|
|
|
|
|
|
|
(? |
640
|
|
|
|
|
|
|
[^\W\d] \w* # Simple identifier |
641
|
|
|
|
|
|
|
) |
642
|
|
|
|
|
|
|
(?: |
643
|
|
|
|
|
|
|
\s+ is \s+ |
644
|
|
|
|
|
|
|
(? r[wo] ) |
645
|
|
|
|
|
|
|
)? |
646
|
|
|
|
|
|
|
(? |
647
|
|
|
|
|
|
|
.* |
648
|
|
|
|
|
|
|
) |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
(?(DEFINE) |
651
|
|
|
|
|
|
|
(? (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ ) |
652
|
|
|
|
|
|
|
(? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ ) |
653
|
|
|
|
|
|
|
(? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] ) |
654
|
|
|
|
|
|
|
(? (?&IDENT) (?: :: (?&IDENT) )*+ ) |
655
|
|
|
|
|
|
|
(? [^\W\d] \w*+ ) |
656
|
|
|
|
|
|
|
) |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
}xms; |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
my $LEXICAL_DEFN = qr{ |
661
|
|
|
|
|
|
|
(? |
662
|
|
|
|
|
|
|
(?&TYPE_SPEC) |
663
|
|
|
|
|
|
|
)? |
664
|
|
|
|
|
|
|
\s*+ |
665
|
|
|
|
|
|
|
(? |
666
|
|
|
|
|
|
|
\$ | \@ | \% |
667
|
|
|
|
|
|
|
) |
668
|
|
|
|
|
|
|
(? |
669
|
|
|
|
|
|
|
[^\W\d] \w* # Simple identifier |
670
|
|
|
|
|
|
|
) |
671
|
|
|
|
|
|
|
(? |
672
|
|
|
|
|
|
|
.* |
673
|
|
|
|
|
|
|
) |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
(?(DEFINE) |
676
|
|
|
|
|
|
|
(? (?&TYPE_NAME) (?: (?: [&|] | => ) (?&TYPE_NAME) )*+ ) |
677
|
|
|
|
|
|
|
(? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ ) |
678
|
|
|
|
|
|
|
(? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] ) |
679
|
|
|
|
|
|
|
(? (?&IDENT) (?: :: (?&IDENT) )*+ ) |
680
|
|
|
|
|
|
|
(? [^\W\d] \w*+ ) |
681
|
|
|
|
|
|
|
) |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
}xms; |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
# These options can be passed in when importing, to change how accessors are generated... |
687
|
|
|
|
|
|
|
my %OIO_accessor_keyword = ( |
688
|
|
|
|
|
|
|
'standard' => { rw => 'Std', ro => 'StdRO' }, |
689
|
|
|
|
|
|
|
'unified' => { rw => 'Acc', ro => 'Get' }, |
690
|
|
|
|
|
|
|
'lvalue' => { rw => 'Lvalue', ro => 'Get' }, |
691
|
|
|
|
|
|
|
); |
692
|
|
|
|
|
|
|
@OIO_accessor_keyword{qw< std uni lval >} |
693
|
|
|
|
|
|
|
= @OIO_accessor_keyword{qw< standard unified lvalue >}; |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
my %OIO_accessor_generate = ( |
696
|
|
|
|
|
|
|
'standard' => { |
697
|
|
|
|
|
|
|
rw => sub { my ($name, $sigil) = @_; |
698
|
|
|
|
|
|
|
my $var = $sigil.$name; |
699
|
|
|
|
|
|
|
my $unpack = $sigil eq '$' ? 'shift' : '@_'; |
700
|
|
|
|
|
|
|
return qq{ sub get_$name { shift; $var } |
701
|
|
|
|
|
|
|
sub set_$name { local \$Carp::CarpLevel = 1; |
702
|
|
|
|
|
|
|
shift; |
703
|
|
|
|
|
|
|
$var = $unpack; |
704
|
|
|
|
|
|
|
}; |
705
|
|
|
|
|
|
|
}; |
706
|
|
|
|
|
|
|
}, |
707
|
|
|
|
|
|
|
ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name; |
708
|
|
|
|
|
|
|
return qq{ sub get_$name { shift; $var } }; |
709
|
|
|
|
|
|
|
}, |
710
|
|
|
|
|
|
|
}, |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
'unified' => { |
713
|
|
|
|
|
|
|
rw => sub { my ($name, $sigil) = @_; |
714
|
|
|
|
|
|
|
my $var = $sigil.$name; |
715
|
|
|
|
|
|
|
my $unpack = $sigil eq '$' ? 'shift' : '@_'; |
716
|
|
|
|
|
|
|
return qq{ sub $name { local \$Carp::CarpLevel = 1; |
717
|
|
|
|
|
|
|
shift; |
718
|
|
|
|
|
|
|
if (\@_) { |
719
|
|
|
|
|
|
|
$var = $unpack; |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
$var |
722
|
|
|
|
|
|
|
}; }; |
723
|
|
|
|
|
|
|
}, |
724
|
|
|
|
|
|
|
ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name; |
725
|
|
|
|
|
|
|
return qq{ sub $name { shift; $var } }; |
726
|
|
|
|
|
|
|
}, |
727
|
|
|
|
|
|
|
}, |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
'lvalue' => { |
730
|
|
|
|
|
|
|
rw => sub { my ($name, $sigil) = @_; |
731
|
|
|
|
|
|
|
my $var = $sigil.$name; |
732
|
|
|
|
|
|
|
return qq{ sub $name :lvalue { |
733
|
|
|
|
|
|
|
local \$Carp::CarpLevel = 1; |
734
|
|
|
|
|
|
|
$var |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
}; |
737
|
|
|
|
|
|
|
}, |
738
|
|
|
|
|
|
|
ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name; |
739
|
|
|
|
|
|
|
return qq{ sub $name { $var } }; |
740
|
|
|
|
|
|
|
}, |
741
|
|
|
|
|
|
|
}, |
742
|
|
|
|
|
|
|
); |
743
|
|
|
|
|
|
|
@OIO_accessor_generate{qw< std uni lval >} |
744
|
|
|
|
|
|
|
= @OIO_accessor_generate{qw< standard unified lvalue >}; |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
# Convert a 'has' to an OIO variable declaration with attributes... |
747
|
|
|
|
|
|
|
sub _compose_field { |
748
|
30
|
|
|
30
|
|
119
|
my ($type, $var, $traits, $handles, $initializer, $constraint) = @_; |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
# Normalize constraint... |
751
|
30
|
100
|
|
|
|
130
|
$constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{}; |
752
|
30
|
50
|
66
|
|
|
175
|
if ($constraint && !defined $type) { |
753
|
0
|
|
|
|
|
0
|
$type = 'Any'; |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
# Read-only or readwrite??? |
757
|
30
|
100
|
|
|
|
178
|
my $rw = $traits =~ /\brw\b/ ? 'rw' : 'ro'; |
758
|
30
|
|
|
|
|
132
|
my $required = $traits =~ /\breq(?:uired)?\b/; |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
# Did the user specify a particular kind of accessor generation??? |
761
|
30
|
|
|
|
|
104
|
my $accessor_type = $^H{'Dios accessor_type'}; |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
# Unpack the parsed components of the field declaration... |
764
|
30
|
|
|
|
|
182
|
my ($sigil, $twigil, $name) = $var =~ m{\A ([\$\@%]) ([.!]?+) (\S*+) }xms; |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
# Adapt type to sigil... |
767
|
30
|
100
|
50
|
|
|
220
|
my $container_type = ($sigil eq '@') ? "Array[".($type//'Any')."]" |
|
|
100
|
50
|
|
|
|
|
768
|
|
|
|
|
|
|
: ($sigil eq '%') ? "Hash[".($type//'Any')."]" |
769
|
|
|
|
|
|
|
: $type; |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
# Is it type-checked??? |
772
|
30
|
|
|
|
|
74
|
my $TYPE_SETUP = q{}; |
773
|
30
|
|
|
|
|
61
|
my $TYPE_VALIDATOR = q{}; |
774
|
30
|
100
|
|
|
|
102
|
if ($type) { |
775
|
28
|
|
|
|
|
73
|
state $validator_num = 0; $validator_num++; |
|
28
|
|
|
|
|
71
|
|
776
|
28
|
|
|
|
|
154
|
$TYPE_VALIDATOR = qq[ { no warnings; \$Dios::_internal::attr_validator_$validator_num = Dios::Types::validator_for(q{$container_type}, 'Value (%s) for $sigil$name attribute', $constraint ); } ]; |
777
|
28
|
|
|
|
|
84
|
$TYPE_SETUP = qq[ :Type( sub{ \$Dios::_internal::attr_validator_$validator_num->(shift) }) ]; |
778
|
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
# Define accessors... |
781
|
30
|
100
|
|
|
|
215
|
my $access = $twigil ne '.' ? q{} : $OIO_accessor_keyword{$accessor_type}{$rw}."(Name=>q{$name}) $TYPE_SETUP"; |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
# Is it a delegated handler??? |
784
|
30
|
|
|
|
|
66
|
my $delegators = ''; |
785
|
30
|
|
|
|
|
144
|
for my $delegation (split /(?&WS) handles (?&WS) (?(DEFINE) (? \s*+ (?: \# [^\n]*+ \n \s*+ )*+ ))/x, $handles) { |
786
|
0
|
0
|
|
|
|
0
|
next unless $delegation; |
787
|
0
|
0
|
|
|
|
0
|
if ($delegation =~ m{^:(.*)<(.*)>$}xms) { |
788
|
0
|
|
|
|
|
0
|
$delegators .= " :Handles($1-->$2)"; |
789
|
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
else { |
791
|
0
|
|
|
|
|
0
|
$delegators .= " :Handles($delegation)"; |
792
|
|
|
|
|
|
|
} |
793
|
|
|
|
|
|
|
} |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
# Is it initialized??? |
796
|
30
|
100
|
|
|
|
139
|
my $init = qq{:Arg(Name=>q{$name} } . ($required ? q{, Mandatory=>1)} : q{)} ); |
797
|
30
|
|
|
|
|
63
|
my $INIT_FUNC = q{}; |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
# Ensure array and hash attrs are initialized... |
800
|
30
|
50
|
33
|
|
|
196
|
if ($sigil =~ /[\@%]/ && (!$initializer || $initializer =~ m{\A \s*+ \z}xms)) { |
|
|
|
66
|
|
|
|
|
801
|
15
|
|
|
|
|
59
|
$initializer = '//=()'; |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
# Install the initialization code... |
805
|
30
|
100
|
|
|
|
138
|
if ($initializer =~ m{\A \s*+ (? // \s*+ )? = (? .*+ ) }xms) { |
806
|
16
|
|
|
|
|
228
|
my %init_field = %+; |
807
|
16
|
|
|
|
|
100
|
my $init_val = $init_field{INIT_VAL}; |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
# Adapt initializer value to sigil... |
810
|
16
|
100
|
|
|
|
84
|
if ($sigil eq '@') { $init_val = "[$init_val]"; } |
|
7
|
100
|
|
|
|
28
|
|
811
|
8
|
|
|
|
|
26
|
elsif ($sigil eq '%') { $init_val = "+{$init_val}"; } |
812
|
|
|
|
|
|
|
|
813
|
16
|
100
|
|
|
|
96
|
$init = qq{:DEFAULT(___i_n_i_t__${name}___(\$self)) } . ($init_field{DEFAULT_INIT} ? $init : q{}); |
814
|
16
|
|
|
|
|
76
|
$INIT_FUNC = qq{sub ___i_n_i_t__${name}___ { my (\$self) = \@_; $init_val }}; |
815
|
|
|
|
|
|
|
} |
816
|
|
|
|
|
|
|
else { |
817
|
14
|
|
|
|
|
42
|
$init .= $initializer; |
818
|
|
|
|
|
|
|
} |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
# Update the attribute setting code... |
821
|
30
|
100
|
|
|
|
91
|
if ($sigil eq '$') { |
822
|
15
|
50
|
|
|
|
177
|
$^H{'Dios attrs'} .= $] < 5.022 ? qq{alias my \$$name = \$_Dios__attr_${name}[\${\$_[0]}];} |
823
|
|
|
|
|
|
|
: qq{ \\ my \$$name = \\ \$_Dios__attr_${name}[\${\$_[0]}];}; |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
else { |
826
|
15
|
50
|
|
|
|
184
|
$^H{'Dios attrs'} |
827
|
|
|
|
|
|
|
.= $] < 5.022 ? qq{alias my $sigil$name = $sigil}.qq{{\$_Dios__attr_${name}[\${\$_[0]}]};} |
828
|
|
|
|
|
|
|
: qq{ \\ my $sigil$name = \$_Dios__attr_${name}[\${\$_[0]}]; }; |
829
|
|
|
|
|
|
|
} |
830
|
|
|
|
|
|
|
# Add type-checking code to alias... |
831
|
30
|
100
|
|
|
|
99
|
if ($type) { |
832
|
28
|
|
|
|
|
176
|
$^H{'Dios attrs'} .= qq{ Dios::Types::_set_var_type(q{$type}, \\$sigil$name, 'Value (%s) for $sigil$name attribute', $constraint ); }; |
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
# Return the converted syntax... |
836
|
30
|
|
|
|
|
279
|
return qq{ $TYPE_VALIDATOR my \@_Dios__attr_$name : Field $access $delegators $init $TYPE_SETUP; $INIT_FUNC; }; |
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
# Convert a typed lexical variable... |
840
|
|
|
|
|
|
|
sub _compose_lexical { |
841
|
3
|
|
|
3
|
|
15
|
my ($type, $variable, $constraint) = @_; |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
# Normalize constraint... |
844
|
3
|
100
|
|
|
|
21
|
$constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{}; |
845
|
3
|
50
|
66
|
|
|
28
|
if ($constraint && !defined $type) { |
846
|
0
|
|
|
|
|
0
|
$type = 'Any'; |
847
|
|
|
|
|
|
|
} |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
# Is it type-checked??? |
850
|
3
|
|
|
|
|
8
|
my $TYPE_SETUP = q{}; |
851
|
3
|
50
|
|
|
|
14
|
if (defined $type) { |
852
|
3
|
|
|
|
|
19
|
$TYPE_SETUP = qq[ Dios::Types::_set_var_type(q{$type}, \\$variable, 'Value (%s) assigned to $variable', $constraint ); ]; |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
# Return the converted syntax... |
856
|
3
|
|
|
|
|
16
|
return qq{my $variable; $TYPE_SETUP; $variable = $variable}; |
857
|
|
|
|
|
|
|
} |
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
# Convert a 'shared' to a class attribute... |
861
|
|
|
|
|
|
|
sub _compose_shared { |
862
|
5
|
|
|
5
|
|
41
|
my ($type, $var, $traits, $initializer, $constraint) = @_; |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
# Normalize constraint... |
865
|
5
|
100
|
|
|
|
19
|
$constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{}; |
866
|
5
|
50
|
66
|
|
|
26
|
if ($constraint && !defined $type) { |
867
|
0
|
|
|
|
|
0
|
$type = 'Any'; |
868
|
|
|
|
|
|
|
} |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
# Did the user specify a particular kind of accessor generation??? |
871
|
5
|
|
|
|
|
19
|
my $accessor_type = $^H{'Dios accessor_type'}; |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
# Unpack the parsed components of the shared declaration... |
874
|
5
|
|
|
|
|
32
|
my ($sigil, $twigil, $name) = $var =~ m{\A ([\$\@%]) ([.!]?+) (\S*+) }xms; |
875
|
5
|
100
|
|
|
|
21
|
my $rw = $traits =~ /\brw\b/ ? 'rw' : 'ro'; |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
# Generate accessor subs... |
878
|
|
|
|
|
|
|
my $accessors = $twigil ne '.' ? q{} |
879
|
5
|
50
|
|
|
|
39
|
: $OIO_accessor_generate{$accessor_type}{$rw}->($name, $sigil); |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
# Build type checking sub... |
882
|
5
|
|
|
|
|
10
|
my $type_func = q{}; |
883
|
5
|
100
|
|
|
|
14
|
if ($type) { |
884
|
1
|
|
|
|
|
7
|
$type_func = qq[ sub ___t_y_p_e__${name}___ { state \$check = Dios::Types::validator_for(q{$type}, 'Value (%s) for \$$name attribute' ); \$check->($_[0]) } ___t_y_p_e__${name}___($sigil$name); ]; |
885
|
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
else { |
887
|
4
|
|
|
|
|
8
|
$type_func = q{}; |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
# Is it type-checked??? |
890
|
5
|
|
|
|
|
9
|
my $TYPE_SETUP = q{}; |
891
|
5
|
100
|
|
|
|
15
|
if ($type) { |
892
|
1
|
|
|
|
|
5
|
$TYPE_SETUP = qq[ Dios::Types::_set_var_type(q{$type}, \\$sigil$name, 'Value (%s) for shared $sigil$name attribute', '$sigil', $constraint ); ]; |
893
|
|
|
|
|
|
|
} |
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
# Return the converted syntax... |
896
|
5
|
|
|
|
|
25
|
return qq{my $sigil$name $initializer; $TYPE_SETUP; $accessors}; |
897
|
|
|
|
|
|
|
} |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
sub _multi_dispatch { |
902
|
55
|
|
|
55
|
|
435
|
use Data::Dump 'dump'; |
|
55
|
|
|
|
|
108
|
|
|
55
|
|
|
|
|
28444
|
|
903
|
|
|
|
|
|
|
|
904
|
58
|
|
|
58
|
|
51299
|
my $subname = shift; |
905
|
58
|
|
|
|
|
82
|
my $kind = shift; |
906
|
58
|
|
|
|
|
112
|
my @arg_list = @_; |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
# Find all possible variants for this call... |
909
|
58
|
|
|
|
|
64
|
our %multis; |
910
|
58
|
|
50
|
|
|
69
|
my @variants = @{ $Dios::multis{$subname} //= [] }; |
|
58
|
|
|
|
|
205
|
|
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
# But only those in the right hierarchy, if it's a method call |
913
|
58
|
100
|
|
|
|
122
|
if ($kind eq 'method') { |
914
|
28
|
|
|
|
|
41
|
@variants = grep { $arg_list[0]->isa($_->{class}) } @variants; |
|
196
|
|
|
|
|
1638
|
|
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
# And only those in the right namespace, if it's a function call... |
918
|
|
|
|
|
|
|
else { |
919
|
30
|
|
|
|
|
71
|
my $caller = caller; |
920
|
30
|
|
|
|
|
537
|
@variants = grep { $_->{class} eq $caller } @variants; |
|
122
|
|
|
|
|
265
|
|
921
|
|
|
|
|
|
|
} |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
# Eliminate variants that doen't match the argument list... |
924
|
58
|
|
|
|
|
311
|
for my $variant (@variants) { |
925
|
290
|
|
|
|
|
354
|
my $match = eval{ $variant->{validator}(@arg_list) }; |
|
290
|
|
|
|
|
727
|
|
926
|
290
|
100
|
|
|
|
50010
|
if (defined $match) { |
927
|
103
|
|
|
|
|
116
|
@{$variant}{ keys %{$match} } = values %{$match}; |
|
103
|
|
|
|
|
414
|
|
|
103
|
|
|
|
|
153
|
|
|
103
|
|
|
|
|
209
|
|
928
|
|
|
|
|
|
|
} |
929
|
|
|
|
|
|
|
else { |
930
|
187
|
|
|
|
|
355
|
$variant = undef; |
931
|
|
|
|
|
|
|
} |
932
|
|
|
|
|
|
|
} |
933
|
58
|
|
|
|
|
91
|
@variants = grep { defined } @variants; |
|
290
|
|
|
|
|
423
|
|
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
# If there's only one left, we're done... |
936
|
58
|
100
|
|
|
|
158
|
return $variants[0] if @variants == 1; |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
# If there isn't one left, we're also done (but not in a good way)... |
939
|
|
|
|
|
|
|
return { |
940
|
6
|
|
|
6
|
|
58
|
impl => sub { my $args = dump(@arg_list); |
941
|
6
|
50
|
|
|
|
1342
|
croak "No suitable '$subname' variant found for call to multi $subname", |
942
|
|
|
|
|
|
|
(($args =~ m{\A \( .* \) \Z}xms) ? $args : qq{($args)}); |
943
|
|
|
|
|
|
|
}, |
944
|
33
|
100
|
|
|
|
100
|
} if @variants == 0; |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
# There were 2+ left, so pick the one with the most specific signature... |
947
|
27
|
|
|
|
|
87
|
@variants = Dios::Types::_resolve_signatures($kind, @variants); |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
# If there isn't one left, we're also done (but in an even worse way than before)... |
950
|
|
|
|
|
|
|
return { |
951
|
0
|
|
|
0
|
|
0
|
impl => sub { my $args = dump(@arg_list); |
952
|
0
|
0
|
|
|
|
0
|
croak "Dios: Internal error in dispatch resolution of multi $subname", |
953
|
|
|
|
|
|
|
(($args =~ m{\A \( .* \) \Z}xms) ? $args : qq{($args)}); |
954
|
|
|
|
|
|
|
}, |
955
|
27
|
50
|
|
|
|
58
|
} if @variants == 0; |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
# Otherwise, return the most specific/earliest... |
958
|
27
|
|
|
|
|
70
|
return $variants[0]; |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
#====[ NOTE: I still prefer an ambiguity warning, but Perl 6 no longer does that :-( ]===== |
961
|
|
|
|
|
|
|
# |
962
|
|
|
|
|
|
|
# # Otherwise, the call is ambiguous, so report that... |
963
|
|
|
|
|
|
|
# return { |
964
|
|
|
|
|
|
|
# impl => sub { |
965
|
|
|
|
|
|
|
# croak "Ambiguous call to multi '$subname'. Could invoke any of:\n", |
966
|
|
|
|
|
|
|
# map({ my $sig = $_->{sig}; "\t$subname(". join(',',map({$_->{type}} @$sig)) .")\n" } @variants), |
967
|
|
|
|
|
|
|
# "to handle:\n\t$subname(", dump(@arg_list)=~s/^\(|\)$//gr, ")\ncalled"; |
968
|
|
|
|
|
|
|
# }, |
969
|
|
|
|
|
|
|
# }; |
970
|
|
|
|
|
|
|
} |
971
|
|
|
|
|
|
|
|
972
|
55
|
|
|
55
|
|
1803259
|
keytype ParamList is m{ |
973
|
|
|
|
|
|
|
\( |
974
|
|
|
|
|
|
|
(?: |
975
|
|
|
|
|
|
|
(?&Parameter) |
976
|
|
|
|
|
|
|
(?: |
977
|
|
|
|
|
|
|
(?: (?&PerlOWS) [:,] |
978
|
|
|
|
|
|
|
(?: (?&Parameter) (?&PerlOWS) , )*+ |
979
|
|
|
|
|
|
|
(?&Parameter)?+ |
980
|
|
|
|
|
|
|
)?+ |
981
|
|
|
|
|
|
|
)?+ |
982
|
|
|
|
|
|
|
)?+ |
983
|
|
|
|
|
|
|
(?: (?&PerlOWS) --> [^)]*+ )?+ |
984
|
|
|
|
|
|
|
(?&PerlOWS) |
985
|
|
|
|
|
|
|
\) |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
(?(DEFINE) |
988
|
|
|
|
|
|
|
(? |
989
|
|
|
|
|
|
|
(?&PerlOWS) |
990
|
|
|
|
|
|
|
(?: |
991
|
|
|
|
|
|
|
# Nameless literal constraint |
992
|
|
|
|
|
|
|
(?&PerlNumber) | (?&PerlQuotelikeQ) | (?&PerlMatch) |
993
|
|
|
|
|
|
|
| |
994
|
|
|
|
|
|
|
(?! , | --> | \) ) # Every component is optional, but there must be at least one |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
# TYPE... |
997
|
|
|
|
|
|
|
(?: (?&TYPE_SPEC) (?&PerlOWS) )?+ |
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
# NAME... |
1000
|
|
|
|
|
|
|
(?> |
1001
|
|
|
|
|
|
|
: (?&IDENT) \( (?&PerlOWS) [\$\@%] (?&IDENT) (?&PerlOWS) \) |
1002
|
|
|
|
|
|
|
| |
1003
|
|
|
|
|
|
|
: [\$\@%] (?&IDENT) |
1004
|
|
|
|
|
|
|
| |
1005
|
|
|
|
|
|
|
\* |
1006
|
|
|
|
|
|
|
(?: |
1007
|
|
|
|
|
|
|
[\@%] (?&IDENT)?+ |
1008
|
|
|
|
|
|
|
| |
1009
|
|
|
|
|
|
|
: (?&IDENT) \( (?&PerlOWS) \@ (?&IDENT) (?&PerlOWS) \) |
1010
|
|
|
|
|
|
|
| |
1011
|
|
|
|
|
|
|
: \@ (?&IDENT) |
1012
|
|
|
|
|
|
|
) |
1013
|
|
|
|
|
|
|
| |
1014
|
|
|
|
|
|
|
[\$\@%] (?&IDENT)?+ |
1015
|
|
|
|
|
|
|
)?+ |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
# OPTIONAL OR REQUIRED... |
1018
|
|
|
|
|
|
|
[?!]?+ |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
# CONSTRAINT... |
1021
|
|
|
|
|
|
|
(?: (?&PerlOWS) where (?&PerlOWS) (?&PerlBlock) )?+ |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
# READONLY OR ALIAS... |
1024
|
|
|
|
|
|
|
(?: (?&PerlOWS) is (?&PerlOWS) (?: ro | alias ) )?+ |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
# DEFAULT VALUE... |
1027
|
|
|
|
|
|
|
(?: (?&PerlOWS) (?://|\|\|)? = (?&PerlOWS) (?&PerlConditionalExpression) )?+ |
1028
|
|
|
|
|
|
|
) |
1029
|
|
|
|
|
|
|
) |
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
(? (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ ) |
1032
|
|
|
|
|
|
|
(? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ ) |
1033
|
|
|
|
|
|
|
(? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] ) |
1034
|
|
|
|
|
|
|
(? (?&IDENT) (?: :: (?&IDENT) )*+ ) |
1035
|
|
|
|
|
|
|
(? [^\W\d] \w*+ ) |
1036
|
|
|
|
|
|
|
) |
1037
|
|
|
|
|
|
|
}xms; |
1038
|
|
|
|
|
|
|
|
1039
|
0
|
|
|
|
|
|
sub import { |
1040
|
65
|
|
|
65
|
|
7182
|
my (undef, $opt) = @_; |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
# What kind of accessors were requested in this scope??? |
1043
|
|
|
|
|
|
|
$^H{'Dios accessor_type'} |
1044
|
65
|
|
66
|
|
|
1439
|
= $opt->{accessor} // $opt->{accessors} // $opt->{acc} // q{standard}; |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
# How should the invocants be named in this scope??? |
1047
|
65
|
|
100
|
|
|
553
|
my $invocant_name = $opt->{invocant} // $opt->{inv} // q{$self}; |
|
|
|
100
|
|
|
|
|
1048
|
65
|
50
|
|
|
|
982
|
if ($invocant_name =~ m{\A (\$?+) ([^\W\d]\w*+) \Z}xms) { |
1049
|
65
|
|
100
|
|
|
898
|
$^H{'Dios invocant_name'} = ($1||'$').$2; |
1050
|
|
|
|
|
|
|
} |
1051
|
|
|
|
|
|
|
else { |
1052
|
0
|
|
|
|
|
0
|
_error "Invalid invocant specification: '$invocant_name'\nin 'use Dios' statement"; |
1053
|
|
|
|
|
|
|
} |
1054
|
|
|
|
|
|
|
|
1055
|
65
|
|
|
|
|
139
|
# Class definitions are translated to encapsulated packages using OIO... |
1056
|
55
|
|
|
55
|
|
1665044
|
keytype Bases is /is (?&PerlNWS) (?&PerlQualifiedIdentifier)/x; |
|
65
|
|
|
|
|
115
|
|
1057
|
65
|
50
|
50
|
|
|
419
|
keyword class ( |
1058
|
65
|
|
|
|
|
2696
|
QualIdent $class_name, |
1059
|
|
|
|
|
|
|
Bases* @bases, |
1060
|
|
|
|
|
|
|
Block $block |
1061
|
|
|
|
|
|
|
) |
1062
|
65
|
100
|
|
48
|
|
921
|
{{{ { package <{$class_name}>; use Object::InsideOut <{ s{^ is (?&WS) (?(DEFINE) (? \s*+ (?: \# .*+ \n \s*+ )*+ ))}{}x for @bases; (@bases ? qq{qw{@bases}} : q{}) }>; do <{ $block }> } }}} |
|
48
|
100
|
|
|
|
3861371
|
|
|
48
|
|
|
|
|
169
|
|
|
48
|
|
|
|
|
1355435
|
|
|
21
|
|
|
|
|
106
|
|
|
21
|
|
|
|
|
96
|
|
|
1010
|
|
|
|
|
1846
|
|
|
48
|
|
|
|
|
8410
|
|
|
48
|
|
|
|
|
154
|
|
|
48
|
|
|
|
|
109
|
|
|
48
|
|
|
|
|
184
|
|
|
48
|
|
|
|
|
318
|
|
|
48
|
|
|
|
|
312
|
|
|
48
|
|
|
|
|
729
|
|
1063
|
|
|
|
|
|
|
|
1064
|
55
|
|
|
55
|
|
1751586
|
# Function definitions are translated to subroutines with extra argument-unpacking code... |
|
65
|
|
|
|
|
4615
|
|
1065
|
65
|
50
|
50
|
|
|
223
|
keyword func ( |
1066
|
65
|
|
|
|
|
1916
|
QualIdent $sub_name = '', |
1067
|
|
|
|
|
|
|
ParamList $parameter_list = '', |
1068
|
55
|
0
|
|
|
|
430
|
Attributes $attrs = '', |
|
0
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1069
|
|
|
|
|
|
|
Block $block |
1070
|
53
|
|
|
53
|
|
3672913
|
) |
|
53
|
|
|
|
|
179
|
|
|
53
|
|
|
|
|
149
|
|
|
53
|
|
|
|
|
103
|
|
|
53
|
|
|
|
|
109
|
|
|
53
|
|
|
|
|
106
|
|
1071
|
|
|
|
|
|
|
{ |
1072
|
53
|
|
|
|
|
284
|
# Generate code that unpacks and tests arguments... |
1073
|
|
|
|
|
|
|
$parameter_list = _translate_parameters($parameter_list, func => "$sub_name"); |
1074
|
|
|
|
|
|
|
|
1075
|
53
|
100
|
|
|
|
237
|
# Assemble and return the sub definition... |
1076
|
30
|
|
|
|
|
351
|
if (my $return_type = $parameter_list->{return_type}) { |
1077
|
|
|
|
|
|
|
qq{sub $sub_name $attrs { $parameter_list->{code} Dios::Types::_validate_return_type [q{$sub_name}, $return_type], \@_, sub $block } }; |
1078
|
|
|
|
|
|
|
} |
1079
|
23
|
100
|
|
|
|
371
|
else { |
1080
|
|
|
|
|
|
|
($sub_name ? "sub $sub_name;" : q{} ) |
1081
|
|
|
|
|
|
|
. qq{sub $sub_name $attrs { $parameter_list->{code} do $block } }; |
1082
|
65
|
|
|
|
|
492
|
} |
1083
|
|
|
|
|
|
|
} |
1084
|
55
|
|
|
55
|
|
2050019
|
|
1085
|
65
|
|
|
|
|
2720
|
# Multi definitions are translated to subroutines with extra argument-unpacking code... |
1086
|
65
|
50
|
50
|
|
|
210
|
keyword multi ( |
1087
|
65
|
|
|
|
|
1457
|
/method|func/ $type = 'func', |
1088
|
0
|
|
|
|
|
0
|
QualIdent $sub_name = '', |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1089
|
|
|
|
|
|
|
ParamList $parameter_list = '', |
1090
|
0
|
|
|
|
|
0
|
Attributes $attrs = '', |
1091
|
34
|
|
|
34
|
|
2413761
|
Block $block |
|
34
|
|
|
|
|
100
|
|
|
34
|
|
|
|
|
64
|
|
|
34
|
|
|
|
|
64
|
|
|
34
|
|
|
|
|
64
|
|
|
34
|
|
|
|
|
69
|
|
|
34
|
|
|
|
|
52
|
|
1092
|
|
|
|
|
|
|
) |
1093
|
0
|
0
|
|
|
|
0
|
{ |
|
34
|
|
|
|
|
151
|
|
1094
|
0
|
|
|
|
|
0
|
# Generate code that unpacks and tests arguments... |
|
34
|
|
|
|
|
94
|
|
1095
|
|
|
|
|
|
|
$parameter_list = _translate_parameters($parameter_list, $type => "$sub_name"); |
1096
|
|
|
|
|
|
|
my $parameter_types = $parameter_list->{spec}; |
1097
|
0
|
0
|
|
|
|
0
|
|
|
34
|
|
|
|
|
133
|
|
1098
|
|
|
|
|
|
|
# Assemble and return the method definition... |
1099
|
34
|
|
|
|
|
221
|
my $code = qq{ BEGIN { *$sub_name = sub { my \$best_variant = Dios::_multi_dispatch('$sub_name', '$type', \@_); \@_ = \@{\$best_variant->{args}//[]}; goto &{\$best_variant->{impl}}; } if ! *${sub_name}{CODE}; } }; |
1100
|
55
|
|
|
|
|
432
|
|
1101
|
|
|
|
|
|
|
my $multiname = sprintf 'DIOS_multi_%010d', ++$Dios::multinum; |
1102
|
34
|
50
|
|
|
|
105
|
|
1103
|
0
|
|
|
|
|
0
|
# Assemble and return the sub definition... |
1104
|
|
|
|
|
|
|
if (my $return_type = $parameter_list->{return_type}) { |
1105
|
|
|
|
|
|
|
$code .= qq{sub $multiname; sub $multiname $attrs { local *$multiname = '$sub_name'; $parameter_list->{code}; return { args => \\\@_, impl => sub { local *__ANON__ = '$sub_name'; Dios::Types::_validate_return_type [q{$sub_name}, $return_type], \@_, sub $block } } } }; |
1106
|
34
|
|
|
|
|
118
|
} |
1107
|
34
|
|
|
|
|
281
|
else { |
1108
|
|
|
|
|
|
|
$block = substr($block,1,-1); |
1109
|
34
|
|
|
|
|
194
|
$code .= qq{sub $multiname; sub $multiname $attrs { local *$multiname = '$sub_name'; $parameter_list->{code}; return { args => \\\@_, impl => sub { local *__ANON__ = '$sub_name'; $block } } } }; |
1110
|
|
|
|
|
|
|
} |
1111
|
34
|
|
|
|
|
592
|
$code .= qq{BEGIN{ push \@{ \$Dios::multis{q{$sub_name}} }, { sig => [$parameter_types], class => __PACKAGE__, validator => \\&$multiname }; }}; |
1112
|
65
|
|
|
|
|
506
|
|
1113
|
|
|
|
|
|
|
return $code; |
1114
|
55
|
|
|
55
|
|
2281803
|
} |
1115
|
|
|
|
|
|
|
|
1116
|
65
|
|
|
|
|
2840
|
# Method definitions are translated to subroutines with extra invocant-and-argument-unpacking code... |
1117
|
65
|
50
|
50
|
|
|
218
|
keyword method ( |
1118
|
0
|
|
|
|
|
0
|
QualIdent $sub_name = '', |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
65
|
|
|
|
|
1426
|
|
1119
|
|
|
|
|
|
|
ParamList $parameter_list = '', |
1120
|
0
|
|
|
|
|
0
|
Attributes $attrs = '', |
1121
|
0
|
|
|
|
|
0
|
Block $block |
1122
|
131
|
|
|
131
|
|
9756643
|
) |
|
131
|
|
|
|
|
465
|
|
|
131
|
|
|
|
|
302
|
|
|
131
|
|
|
|
|
281
|
|
|
131
|
|
|
|
|
301
|
|
|
131
|
|
|
|
|
280
|
|
1123
|
|
|
|
|
|
|
{ |
1124
|
0
|
50
|
|
|
|
0
|
# Which kind of aliasing do we need (to create local vars bound to the object's fields)??? |
|
131
|
|
|
|
|
680
|
|
1125
|
131
|
100
|
|
|
|
660
|
my $use_aliasing = $] < 5.022 ? q{use Data::Alias} : q{use experimental 'refaliasing'}; |
1126
|
0
|
|
|
|
|
0
|
my $attr_binding = $^H{'Dios attrs'} ? "$use_aliasing; $^H{'Dios attrs'}" : q{}; |
1127
|
|
|
|
|
|
|
|
1128
|
131
|
|
|
|
|
770
|
# Generate code that unpacks and tests arguments... |
1129
|
0
|
0
|
|
|
|
0
|
$parameter_list = _translate_parameters($parameter_list, method => "$sub_name"); |
1130
|
0
|
|
|
|
|
0
|
|
1131
|
131
|
100
|
|
|
|
1899
|
# Assemble and return the method definition... |
1132
|
|
|
|
|
|
|
($sub_name ? "sub $sub_name;" : q{} ) |
1133
|
0
|
|
|
|
|
0
|
. qq{sub $sub_name $attrs { $attr_binding { $parameter_list->{code}; do $block } } }; |
|
65
|
|
|
|
|
425
|
|
1134
|
0
|
|
|
|
|
0
|
} |
1135
|
55
|
|
|
55
|
|
2186692
|
|
1136
|
0
|
|
|
|
|
0
|
# Submethod definitions are translated like methods, but with special re-routing... |
|
65
|
|
|
|
|
2540
|
|
1137
|
65
|
50
|
50
|
|
|
209
|
keyword submethod ( |
1138
|
0
|
|
|
|
|
0
|
QualIdent $sub_name = '', |
|
65
|
|
|
|
|
1483
|
|
1139
|
55
|
|
|
|
|
475
|
ParamList $parameter_list = '', |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1140
|
|
|
|
|
|
|
Attributes $attrs = '', |
1141
|
0
|
0
|
|
|
|
0
|
Block $block |
1142
|
0
|
0
|
|
8
|
|
0
|
) |
|
8
|
|
|
|
|
585021
|
|
|
8
|
|
|
|
|
26
|
|
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
18
|
|
|
8
|
|
|
|
|
24
|
|
|
8
|
|
|
|
|
18
|
|
1143
|
|
|
|
|
|
|
{ |
1144
|
8
|
50
|
|
|
|
41
|
# Which kind of aliasing do we need (to create local vars bound to the object's fields)??? |
1145
|
0
|
100
|
|
|
|
0
|
my $use_aliasing = $] < 5.022 ? q{use Data::Alias} : q{use experimental 'refaliasing'}; |
|
8
|
|
|
|
|
49
|
|
1146
|
|
|
|
|
|
|
my $attr_binding = $^H{'Dios attrs'} ? "$use_aliasing; $^H{'Dios attrs'}" : q{}; |
1147
|
|
|
|
|
|
|
|
1148
|
0
|
0
|
|
|
|
0
|
# Handle any special submethod names... |
|
8
|
|
|
|
|
25
|
|
1149
|
8
|
100
|
|
|
|
36
|
my $init_args = q{}; |
|
|
100
|
|
|
|
|
|
1150
|
55
|
|
|
|
|
404
|
if ($sub_name eq 'BUILD') { |
1151
|
4
|
|
|
|
|
29
|
# Extract named args for :InitArgs hash (TODO: this should pull out type/required info too)... |
1152
|
|
|
|
|
|
|
my @param_names = $parameter_list =~ m{ : [\$\@%]?+ (\w++) }gxms; |
1153
|
|
|
|
|
|
|
|
1154
|
4
|
|
|
|
|
29
|
# Tell OIO about this constructor args... |
1155
|
|
|
|
|
|
|
$init_args = qq{ BEGIN{ my %$sub_name :InitArgs = map { \$_ => {} } qw{@param_names}; } }; |
1156
|
|
|
|
|
|
|
|
1157
|
4
|
|
|
|
|
11
|
# Mark the sub as an initializer |
1158
|
|
|
|
|
|
|
$attrs .= ' :Private :Init'; |
1159
|
|
|
|
|
|
|
|
1160
|
4
|
|
|
|
|
15
|
# Repack the arguments from ($self, {attr=>val, et=>cetera}) to ($self, attr=>val, et=>cetera)... |
1161
|
|
|
|
|
|
|
$attr_binding = q{@_ = ($_[0], %{$_[1]});} . $attr_binding; |
1162
|
|
|
|
|
|
|
} |
1163
|
|
|
|
|
|
|
elsif ($sub_name eq 'DESTROY') { |
1164
|
3
|
50
|
66
|
|
|
27
|
# Parameter list will never be satisfied (which breaks cleanup), so don't allow it at all... |
1165
|
|
|
|
|
|
|
return q{die 'submethod DESTROY cannot have a parameter list';} |
1166
|
|
|
|
|
|
|
if $parameter_list && $parameter_list !~ /^\(\s*+\)$/; |
1167
|
|
|
|
|
|
|
|
1168
|
3
|
|
|
|
|
9
|
# Mark it as a destructor... |
1169
|
|
|
|
|
|
|
$attrs .= ' :Private :Destroy'; |
1170
|
|
|
|
|
|
|
|
1171
|
3
|
|
|
|
|
7
|
# Rename it so as not to clash with OIO's DESTROY... |
1172
|
|
|
|
|
|
|
$sub_name = '___DESTROY___'; |
1173
|
|
|
|
|
|
|
} |
1174
|
1
|
|
|
|
|
6
|
else { |
1175
|
|
|
|
|
|
|
$attr_binding = qq{ if ((ref(\$_[0])||\$_[0]) ne __PACKAGE__) { return \$_[0]->SUPER::$sub_name(\@_[1..\$#_]); } } . $attr_binding; |
1176
|
|
|
|
|
|
|
} |
1177
|
|
|
|
|
|
|
|
1178
|
8
|
|
|
|
|
46
|
# Generate the code to unpack and test arguments... |
1179
|
|
|
|
|
|
|
$parameter_list = _translate_parameters($parameter_list, method => "$sub_name"); |
1180
|
|
|
|
|
|
|
|
1181
|
8
|
50
|
|
|
|
102
|
# Assemble and return the method definition... |
1182
|
|
|
|
|
|
|
($sub_name ? "sub $sub_name;" : q{} ) |
1183
|
65
|
|
|
|
|
489
|
. qq{$init_args sub $sub_name $attrs { $attr_binding { $parameter_list->{code}; do $block } } }; |
1184
|
|
|
|
|
|
|
} |
1185
|
55
|
|
|
55
|
|
2511488
|
|
1186
|
65
|
|
|
|
|
2770
|
# Components of variable declaration... |
1187
|
55
|
|
|
55
|
|
1675909
|
keytype TypeSpec is m{ (?&TypeSpec) |
1188
|
|
|
|
|
|
|
(?(DEFINE) |
1189
|
0
|
|
|
|
|
0
|
(? |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1190
|
|
|
|
|
|
|
(?&TypeName) (?: (?: [&|] | => ) (?&TypeName) )*+ |
1191
|
0
|
0
|
|
|
|
0
|
) |
1192
|
0
|
0
|
|
|
|
0
|
(? |
1193
|
|
|
|
|
|
|
\s* (?&TypeName) (?: \s* (?: [&|] | => ) \s* (?&TypeName) )*+ \s* |
1194
|
|
|
|
|
|
|
) |
1195
|
0
|
|
|
|
|
0
|
(? |
1196
|
0
|
0
|
|
|
|
0
|
Match \[ [^]]*+ \] |
|
|
0
|
|
|
|
|
|
1197
|
|
|
|
|
|
|
| |
1198
|
0
|
|
|
|
|
0
|
(?&PerlIdentifier) \[ (?&TypeSpecSpacey) \] |
1199
|
|
|
|
|
|
|
| |
1200
|
|
|
|
|
|
|
(?&PerlQualifiedIdentifier) |
1201
|
0
|
|
|
|
|
0
|
) |
1202
|
|
|
|
|
|
|
) |
1203
|
65
|
|
|
|
|
119
|
}x; |
1204
|
0
|
|
|
55
|
|
0
|
keytype Var is / [\$\@%] [.!]?+ (?&PerlIdentifier) /x; |
|
55
|
|
|
|
|
1641883
|
|
|
65
|
|
|
|
|
109
|
|
1205
|
55
|
|
|
55
|
|
1666155
|
keytype Traits is / (?: (?&PerlOWS) is (?&PerlOWS) (?: ro | rw | req(?:uired)? ) )++ /x; |
|
65
|
|
|
|
|
111
|
|
1206
|
55
|
|
|
55
|
|
1667021
|
keytype Handles is / (?: (?&PerlOWS) handles (?&PerlOWS) |
1207
|
0
|
|
|
|
|
0
|
(?: (?&PerlIdentifier) | :(?&PerlIdentifier)<(?&PerlIdentifier)> ) |
1208
|
65
|
|
|
|
|
106
|
)++ /x; |
1209
|
55
|
|
|
55
|
|
1672581
|
keytype Init is m{ (?: // )?+ = (?&PerlOWS) (?&PerlExpression) }x; |
|
65
|
|
|
|
|
103
|
|
1210
|
55
|
|
|
55
|
|
1658679
|
keytype Constraint is m{ where (?&PerlOWS) (?&PerlBlock) }x; |
1211
|
0
|
0
|
0
|
|
|
0
|
|
1212
|
65
|
|
|
|
|
108
|
# An attribute definition is translated into an array with a :Field attribute... |
1213
|
65
|
50
|
50
|
|
|
208
|
keyword has ( |
1214
|
65
|
|
|
|
|
1485
|
TypeSpec $type = '', |
1215
|
0
|
|
|
|
|
0
|
Var $variable, |
1216
|
|
|
|
|
|
|
Constraint $constraint = '', |
1217
|
|
|
|
|
|
|
Traits $traits = '', |
1218
|
0
|
|
|
30
|
|
0
|
Handles $handles = '', |
|
30
|
|
|
|
|
2200250
|
|
|
30
|
|
|
|
|
103
|
|
|
30
|
|
|
|
|
63
|
|
|
30
|
|
|
|
|
66
|
|
|
30
|
|
|
|
|
78
|
|
|
30
|
|
|
|
|
67
|
|
|
30
|
|
|
|
|
79
|
|
|
30
|
|
|
|
|
80
|
|
1219
|
30
|
|
|
|
|
173
|
Init $init = '', |
1220
|
65
|
|
|
|
|
420
|
) { |
1221
|
0
|
|
|
|
|
0
|
_compose_field($type, $variable, $traits, $handles, $init, $constraint) |
1222
|
55
|
|
|
55
|
|
2199855
|
} |
1223
|
65
|
|
|
|
|
2181
|
|
1224
|
55
|
|
|
55
|
|
1659219
|
keytype ReadTraits is / (?&PerlOWS) is (?&PerlOWS) (?: ro | rw ) /x; |
1225
|
0
|
|
|
|
|
0
|
|
1226
|
0
|
|
|
|
|
0
|
# An attribute definition is translated into an my var with extra code for accessors... |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
65
|
|
|
|
|
110
|
|
1227
|
0
|
50
|
50
|
|
|
0
|
keyword shared ( |
|
65
|
|
|
|
|
210
|
|
1228
|
0
|
0
|
|
|
|
0
|
TypeSpec $type = '', |
|
55
|
|
|
|
|
443
|
|
|
65
|
|
|
|
|
1420
|
|
1229
|
|
|
|
|
|
|
Var $variable, |
1230
|
55
|
|
|
|
|
460
|
Constraint $constraint = '', |
1231
|
|
|
|
|
|
|
ReadTraits $traits = '', |
1232
|
5
|
|
|
5
|
|
418856
|
Init $init = '', |
|
5
|
|
|
|
|
16
|
|
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
16
|
|
|
5
|
|
|
|
|
12
|
|
1233
|
5
|
|
|
|
|
24
|
) { |
1234
|
65
|
|
|
|
|
422
|
_compose_shared($type, $variable, $traits, $init, $constraint) |
1235
|
|
|
|
|
|
|
} |
1236
|
55
|
|
|
55
|
|
2205411
|
|
1237
|
65
|
|
|
|
|
2188
|
# An lexical variable definition is translated into a typed lexical... |
1238
|
65
|
50
|
50
|
|
|
213
|
keyword lex (TypeSpec? $type, Var $variable, Constraint? $constraint) { |
1239
|
65
|
|
|
|
|
1533
|
_compose_lexical($type, $variable, $constraint) |
1240
|
0
|
|
|
|
|
0
|
} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1241
|
0
|
|
|
|
|
0
|
|
1242
|
55
|
|
|
|
|
421
|
|
1243
|
3
|
|
|
3
|
|
268036
|
# Subtypes are handled by Dios::Types... |
|
3
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
7
|
|
|
65
|
|
|
|
|
2913
|
|
1244
|
3
|
50
|
50
|
|
|
20
|
keyword subtype {{{ use Dios::Types; subtype }}} |
|
65
|
|
|
|
|
239
|
|
1245
|
65
|
|
|
|
|
1394
|
|
|
65
|
|
|
|
|
1534
|
|
1246
|
65
|
|
|
|
|
2175
|
# Tail recursion is handled as in Perl 6... |
1247
|
55
|
50
|
50
|
55
|
|
2197608
|
keyword callwith () {{{ goto &{+do{no strict 'refs'; \&{(caller 0)[3]} }} for 1, @_ = grep 1, }}} |
|
65
|
|
|
|
|
209
|
|
|
65
|
|
|
|
|
2012
|
|
1248
|
65
|
50
|
50
|
|
|
1399
|
keyword callsame () {{{ goto &{+do{no strict 'refs'; \&{(caller 0)[3]} }} }}} |
|
65
|
|
|
|
|
190
|
|
1249
|
65
|
|
|
2
|
|
366
|
|
|
2
|
|
|
|
|
179094
|
|
|
2
|
|
|
|
|
17
|
|
|
65
|
|
|
|
|
1373
|
|
1250
|
|
|
|
|
|
|
} |
1251
|
0
|
|
|
55
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
55
|
|
|
|
|
2032083
|
|
1252
|
0
|
|
|
1
|
|
0
|
1; # Magic true value required at end of module |
|
65
|
|
|
|
|
550
|
|
|
1
|
|
|
|
|
66084
|
|
|
1
|
|
|
|
|
9
|
|
1253
|
55
|
|
|
1
|
|
395
|
|
|
65
|
|
|
|
|
355
|
|
|
1
|
|
|
|
|
64717
|
|
|
1
|
|
|
|
|
8
|
|
1254
|
55
|
|
|
55
|
|
1989532
|
__END__ |