line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
use 5.010; |
3
|
24
|
|
|
24
|
|
13498
|
use strict; |
|
24
|
|
|
|
|
81
|
|
4
|
24
|
|
|
24
|
|
107
|
use warnings; |
|
24
|
|
|
|
|
39
|
|
|
24
|
|
|
|
|
465
|
|
5
|
24
|
|
|
24
|
|
99
|
|
|
24
|
|
|
|
|
34
|
|
|
24
|
|
|
|
|
627
|
|
6
|
|
|
|
|
|
|
#use Carp; |
7
|
|
|
|
|
|
|
use Mo qw(default); |
8
|
24
|
|
|
24
|
|
101
|
use Role::Tiny::With; |
|
24
|
|
|
|
|
37
|
|
|
24
|
|
|
|
|
100
|
|
9
|
24
|
|
|
24
|
|
11121
|
use Log::ger; |
|
24
|
|
|
|
|
87032
|
|
|
24
|
|
|
|
|
1106
|
|
10
|
24
|
|
|
24
|
|
3024
|
use Scalar::Util qw(blessed); |
|
24
|
|
|
|
|
127
|
|
|
24
|
|
|
|
|
125
|
|
11
|
24
|
|
|
24
|
|
4289
|
|
|
24
|
|
|
|
|
47
|
|
|
24
|
|
|
|
|
24056
|
|
12
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY |
13
|
|
|
|
|
|
|
our $DATE = '2022-08-20'; # DATE |
14
|
|
|
|
|
|
|
our $DIST = 'Data-Sah'; # DIST |
15
|
|
|
|
|
|
|
our $VERSION = '0.912'; # VERSION |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our %coercer_cache; # key=type, value=coercer coderef |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
with 'Data::Sah::Compiler::TextResultRole'; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
has main => (is => 'rw'); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# BEGIN COPIED FROM String::LineNumber |
24
|
|
|
|
|
|
|
my ($str, $opts) = @_; |
25
|
|
|
|
|
|
|
$opts //= {}; |
26
|
0
|
|
|
0
|
|
0
|
$opts->{width} //= 4; |
27
|
0
|
|
0
|
|
|
0
|
$opts->{zeropad} //= 0; |
28
|
0
|
|
0
|
|
|
0
|
$opts->{skip_empty} //= 1; |
29
|
0
|
|
0
|
|
|
0
|
|
30
|
0
|
|
0
|
|
|
0
|
my $i = 0; |
31
|
|
|
|
|
|
|
$str =~ s/^(([\t ]*\S)?.*)/ |
32
|
0
|
|
|
|
|
0
|
sprintf(join("", |
33
|
0
|
|
|
|
|
0
|
"%", |
34
|
|
|
|
|
|
|
($opts->{zeropad} && !($opts->{skip_empty} |
35
|
|
|
|
|
|
|
&& !defined($2)) ? "0" : ""), |
36
|
|
|
|
|
|
|
$opts->{width}, "s", |
37
|
|
|
|
|
|
|
"|%s"), |
38
|
|
|
|
|
|
|
++$i && $opts->{skip_empty} && !defined($2) ? "" : $i, |
39
|
|
|
|
|
|
|
$1)/meg; |
40
|
0
|
0
|
0
|
|
|
0
|
|
|
|
0
|
0
|
|
|
|
|
41
|
|
|
|
|
|
|
$str; |
42
|
|
|
|
|
|
|
} |
43
|
0
|
|
|
|
|
0
|
# END COPIED FROM String::LineNumber |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
die "BUG: Please override name()"; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
0
|
|
|
0
|
0
|
0
|
# literal representation in target language |
49
|
|
|
|
|
|
|
die "BUG: Please override literal()"; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# compile expression to target language |
53
|
0
|
|
|
0
|
0
|
0
|
die "BUG: Please override expr()"; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
my ($self, $cd, $msg) = @_; |
57
|
|
|
|
|
|
|
die join( |
58
|
0
|
|
|
0
|
0
|
0
|
"", |
59
|
|
|
|
|
|
|
"Sah ". $self->name . " compiler: ", |
60
|
|
|
|
|
|
|
"at schema:/", join("/", @{$cd->{spath} // []}), ": ", |
61
|
|
|
|
|
|
|
# XXX show (snippet of) current schema |
62
|
35
|
|
|
35
|
|
85
|
$msg, |
63
|
|
|
|
|
|
|
); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
35
|
|
50
|
|
|
118
|
# form dependency list from which clauses are mentioned in expressions NEED TO |
|
35
|
|
|
|
|
2142
|
|
67
|
|
|
|
|
|
|
# BE UPDATED: NEED TO CHECK EXPR IN ALL ATTRS FOR THE WHOLE SCHEMA/SUBSCHEMAS |
68
|
|
|
|
|
|
|
# (NOT IN THE CURRENT CLSET ONLY), THERE IS NO LONGER A ctbl, THE WAY EXPR IS |
69
|
|
|
|
|
|
|
# STORED IS NOW DIFFERENT. PLAN: NORMALIZE ALL SUBSCHEMAS, GATHER ALL EXPR VARS |
70
|
|
|
|
|
|
|
# AND STORE IN $cd->{all_expr_vars} (SKIP DOING THIS IS |
71
|
|
|
|
|
|
|
# $cd->{outer_cd}{all_expr_vars} is already defined). |
72
|
|
|
|
|
|
|
#require Data::Graph::Util; |
73
|
|
|
|
|
|
|
require Language::Expr::Interpreter::var_enumer; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
my ($self, $cd, $ctbl) = @_; |
76
|
|
|
|
|
|
|
my $main = $self->main; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
my %depends; |
79
|
|
|
|
|
|
|
for my $crec (values %$ctbl) { |
80
|
0
|
|
|
0
|
|
0
|
my $cn = $crec->{name}; |
81
|
|
|
|
|
|
|
my $expr = defined($crec->{expr}) ? $crec->{value} : |
82
|
0
|
|
|
|
|
0
|
$crec->{attrs}{expr}; |
83
|
0
|
|
|
|
|
0
|
if (defined $expr) { |
84
|
|
|
|
|
|
|
my $vars = $main->_var_enumer->eval($expr); |
85
|
0
|
|
|
|
|
0
|
for (@$vars) { |
86
|
0
|
|
|
|
|
0
|
/^\w+$/ or $self->_die($cd, |
87
|
0
|
|
|
|
|
0
|
"Invalid variable syntax '$_', ". |
88
|
|
|
|
|
|
|
"currently only the form \$abc is supported"); |
89
|
0
|
0
|
|
|
|
0
|
$ctbl->{$_} or $self->_die($cd, |
90
|
0
|
0
|
|
|
|
0
|
"Unhandled clause specified in variable '$_'"); |
91
|
0
|
|
|
|
|
0
|
} |
92
|
0
|
|
|
|
|
0
|
$depends{$cn} = $vars; |
93
|
0
|
0
|
|
|
|
0
|
for (@$vars) { |
94
|
|
|
|
|
|
|
push @{ $ctbl->{$_}{depended_by} }, $cn; |
95
|
|
|
|
|
|
|
} |
96
|
0
|
0
|
|
|
|
0
|
} else { |
97
|
|
|
|
|
|
|
$depends{$cn} = []; |
98
|
|
|
|
|
|
|
} |
99
|
0
|
|
|
|
|
0
|
} |
100
|
0
|
|
|
|
|
0
|
#$log->tracef("deps: %s", \%depends); |
101
|
0
|
|
|
|
|
0
|
#my @sorted = Data::Graph::Util::toposort(\%depends); # dies when cyclic |
|
0
|
|
|
|
|
0
|
|
102
|
|
|
|
|
|
|
#$log->tracef("sorted: %s", \@sorted); |
103
|
|
|
|
|
|
|
my %rsched = #map |
104
|
0
|
|
|
|
|
0
|
#{@{ $depends{$sched->[$_]} } ? ($sched->[$_] => $_) : ()} |
105
|
|
|
|
|
|
|
# 0..@$sched-1; |
106
|
|
|
|
|
|
|
(); # TMP |
107
|
|
|
|
|
|
|
#$log->tracef("deps: %s", \%rsched); |
108
|
|
|
|
|
|
|
\%rsched; |
109
|
|
|
|
|
|
|
} |
110
|
0
|
|
|
|
|
0
|
|
111
|
|
|
|
|
|
|
# generate a list of clauses in clsets, in order of evaluation. clauses are |
112
|
|
|
|
|
|
|
# sorted based on expression dependencies and priority. result is array of |
113
|
|
|
|
|
|
|
# [CLSET_NUM, CLAUSE, CLAUSEMETA] triplets, e.g. ([0, 'default', {...}], [1, |
114
|
|
|
|
|
|
|
# 'default', {...}], [0, 'min', {...}], [0, 'max', {...}]). |
115
|
0
|
|
|
|
|
0
|
my ($self, $cd, $clsets) = @_; |
116
|
|
|
|
|
|
|
my $tn = $cd->{type}; |
117
|
|
|
|
|
|
|
my $th = $cd->{th}; |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
my $deps; |
120
|
|
|
|
|
|
|
## temporarily disabled, expr needs to be sorted globally |
121
|
|
|
|
|
|
|
#if ($self->_clset_has_expr($clset)) { |
122
|
|
|
|
|
|
|
# $deps = $self->_form_deps($ctbl); |
123
|
10514
|
|
|
10514
|
|
19119
|
#} else { |
124
|
10514
|
|
|
|
|
16001
|
# $deps = {}; |
125
|
10514
|
|
|
|
|
12651
|
#} |
126
|
|
|
|
|
|
|
#$deps = {}; |
127
|
10514
|
|
|
|
|
12332
|
|
128
|
|
|
|
|
|
|
my $sorter = sub { |
129
|
|
|
|
|
|
|
my ($ia, $ca, $metaa) = @$a; |
130
|
|
|
|
|
|
|
my ($ib, $cb, $metab) = @$b; |
131
|
|
|
|
|
|
|
my $res; |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# dependency |
134
|
|
|
|
|
|
|
#$res = ($deps->{"$ca.$ia"} // -1) <=> ($deps->{"$cb.$ib"} // -1); |
135
|
|
|
|
|
|
|
#return $res if $res; |
136
|
|
|
|
|
|
|
|
137
|
1116
|
|
|
1116
|
|
2428
|
{ |
138
|
1116
|
|
|
|
|
1911
|
$res = $metaa->{prio} <=> $metab->{prio}; |
139
|
1116
|
|
|
|
|
1445
|
#$log->errorf("TMP: sort1"); |
140
|
|
|
|
|
|
|
last if $res; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
# prio from schema |
143
|
|
|
|
|
|
|
my $sprioa = $clsets->[$ia]{"$ca.prio"} // 50; |
144
|
|
|
|
|
|
|
my $spriob = $clsets->[$ib]{"$cb.prio"} // 50; |
145
|
|
|
|
|
|
|
$res = $sprioa <=> $spriob; |
146
|
1116
|
|
|
|
|
1366
|
#$log->errorf("TMP: sort2"); |
|
1116
|
|
|
|
|
2065
|
|
147
|
|
|
|
|
|
|
last if $res; |
148
|
1116
|
100
|
|
|
|
2381
|
|
149
|
|
|
|
|
|
|
# alphabetical order of clause name |
150
|
|
|
|
|
|
|
$res = $ca cmp $cb; |
151
|
108
|
|
50
|
|
|
641
|
#$log->errorf("TMP: sort3"); |
152
|
108
|
|
50
|
|
|
553
|
last if $res; |
153
|
108
|
|
|
|
|
181
|
|
154
|
|
|
|
|
|
|
# clause set order |
155
|
108
|
50
|
|
|
|
314
|
$res = $ia <=> $ib; |
156
|
|
|
|
|
|
|
#$log->errorf("TMP: sort4"); |
157
|
|
|
|
|
|
|
last if $res; |
158
|
108
|
|
|
|
|
226
|
|
159
|
|
|
|
|
|
|
$res = 0; |
160
|
108
|
50
|
|
|
|
294
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
#$log->errorf("TMP: sort [%s,%s] vs [%s,%s] = %s", $ia, $ca, $ib, $cb, $res); |
163
|
0
|
|
|
|
|
0
|
$res; |
164
|
|
|
|
|
|
|
}; |
165
|
0
|
0
|
|
|
|
0
|
|
166
|
|
|
|
|
|
|
my @clauses; |
167
|
0
|
|
|
|
|
0
|
for my $i (0..@$clsets-1) { |
168
|
|
|
|
|
|
|
for my $k (grep {!/\A_/ && !/\./} keys %{$clsets->[$i]}) { |
169
|
|
|
|
|
|
|
my $meta; |
170
|
|
|
|
|
|
|
eval { |
171
|
1116
|
|
|
|
|
3210
|
$meta = "Data::Sah::Type::$tn"->${\("clausemeta_$k")}; |
172
|
10514
|
|
|
|
|
47014
|
}; |
173
|
|
|
|
|
|
|
if ($@) { |
174
|
10514
|
|
|
|
|
15308
|
for ($cd->{args}{on_unhandled_clause}) { |
175
|
10514
|
|
|
|
|
25783
|
my $msg = "Unhandled clause for type $tn: $k ($@)"; |
176
|
9616
|
|
100
|
|
|
12888
|
next if $_ eq 'ignore'; |
|
15183
|
|
|
|
|
61765
|
|
|
9616
|
|
|
|
|
19935
|
|
177
|
10496
|
|
|
|
|
14738
|
next if $_ eq 'warn'; # don't produce multiple warnings |
178
|
10496
|
|
|
|
|
14043
|
$self->_die($cd, $msg); |
179
|
10496
|
|
|
|
|
17970
|
} |
|
10496
|
|
|
|
|
59719
|
|
180
|
|
|
|
|
|
|
} |
181
|
10496
|
100
|
|
|
|
22378
|
$meta //= {prio=>50}; |
182
|
31
|
|
|
|
|
86
|
push @clauses, [$i, $k, $meta]; |
183
|
31
|
|
|
|
|
90
|
} |
184
|
31
|
100
|
|
|
|
4291
|
} |
185
|
15
|
100
|
|
|
|
50
|
|
186
|
14
|
|
|
|
|
52
|
my $res = [sort $sorter @clauses]; |
187
|
|
|
|
|
|
|
#$log->errorf("TMP: sorted clauses: %s", $res); |
188
|
|
|
|
|
|
|
$res; |
189
|
10482
|
|
100
|
|
|
18757
|
} |
190
|
10482
|
|
|
|
|
29372
|
|
191
|
|
|
|
|
|
|
my ($self, %args) = @_; |
192
|
|
|
|
|
|
|
my $cd = $args{cd}; |
193
|
|
|
|
|
|
|
my $name = $args{name}; |
194
|
10500
|
|
|
|
|
26323
|
|
195
|
|
|
|
|
|
|
my $th_map = $cd->{th_map}; |
196
|
10500
|
|
|
|
|
62942
|
return $th_map->{$name} if $th_map->{$name}; |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
if ($args{load} // 1) { |
199
|
|
|
|
|
|
|
no warnings; |
200
|
15186
|
|
|
15186
|
1
|
40212
|
$self->_die($cd, "Invalid syntax for type name '$name', please use ". |
201
|
15186
|
|
|
|
|
24818
|
"letters/numbers/underscores only") |
202
|
15186
|
|
|
|
|
20094
|
unless $name =~ $Data::Sah::type_re; |
203
|
|
|
|
|
|
|
my $main = $self->main; |
204
|
15186
|
|
|
|
|
20659
|
my $module = ref($self) . "::TH::$name"; |
205
|
15186
|
100
|
|
|
|
30215
|
if (!eval "require $module; 1") { ## no critic: BuiltinFunctions::ProhibitStringyEval |
206
|
|
|
|
|
|
|
$self->_die($cd, "Can't load type handler $module". |
207
|
15160
|
50
|
50
|
|
|
50105
|
($@ ? ": $@" : "")); |
208
|
24
|
|
|
24
|
|
178
|
} |
|
24
|
|
|
|
|
50
|
|
|
24
|
|
|
|
|
5283
|
|
209
|
15160
|
50
|
|
|
|
111580
|
$self->add_compile_module($cd, $module, {category=>'type_handler'}); |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
my $obj = $module->new(compiler=>$self); |
212
|
15160
|
|
|
|
|
43182
|
$th_map->{$name} = $obj; |
213
|
15160
|
|
|
|
|
78520
|
} |
214
|
15160
|
50
|
|
|
|
880277
|
return $th_map->{$name}; |
215
|
0
|
0
|
|
|
|
0
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
my ($self, %args) = @_; |
218
|
15160
|
|
|
|
|
85993
|
my $cd = $args{cd}; |
219
|
|
|
|
|
|
|
my $name = $args{name}; |
220
|
15160
|
|
|
|
|
83365
|
|
221
|
15160
|
|
|
|
|
770177
|
my $fsh_table = $cd->{fsh_table}; |
222
|
|
|
|
|
|
|
return $fsh_table->{$name} if $fsh_table->{$name}; |
223
|
15160
|
|
|
|
|
54907
|
|
224
|
|
|
|
|
|
|
if ($args{load} // 1) { |
225
|
|
|
|
|
|
|
no warnings; |
226
|
|
|
|
|
|
|
$self->_die($cd, "Invalid syntax for func set name '$name', ". |
227
|
0
|
|
|
0
|
1
|
0
|
"please use letters/numbers/underscores") |
228
|
0
|
|
|
|
|
0
|
unless $name =~ $Data::Sah::funcset_re; |
229
|
0
|
|
|
|
|
0
|
my $module = ref($self) . "::FSH::$name"; |
230
|
|
|
|
|
|
|
if (!eval "require $module; 1") { ## no critic: BuiltinFunctions::ProhibitStringyEval |
231
|
0
|
|
|
|
|
0
|
$self->_die($cd, "Can't load func set handler $module". |
232
|
0
|
0
|
|
|
|
0
|
($@ ? ": $@" : "")); |
233
|
|
|
|
|
|
|
} |
234
|
0
|
0
|
0
|
|
|
0
|
|
235
|
24
|
|
|
24
|
|
168
|
my $obj = $module->new(); |
|
24
|
|
|
|
|
60
|
|
|
24
|
|
|
|
|
72965
|
|
236
|
0
|
0
|
|
|
|
0
|
$fsh_table->{$name} = $obj; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
return $fsh_table->{$name}; |
239
|
0
|
|
|
|
|
0
|
} |
240
|
0
|
0
|
|
|
|
0
|
|
241
|
0
|
0
|
|
|
|
0
|
require Time::HiRes; |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
my ($self, %args) = @_; |
244
|
|
|
|
|
|
|
|
245
|
0
|
|
|
|
|
0
|
my $cd = {}; |
246
|
0
|
|
|
|
|
0
|
$cd->{v} = 2; |
247
|
|
|
|
|
|
|
$cd->{args} = \%args; |
248
|
0
|
|
|
|
|
0
|
$cd->{compiler} = $self; |
249
|
|
|
|
|
|
|
$cd->{compiler_name} = $self->name; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
if (my $ocd = $args{outer_cd}) { |
252
|
10130
|
|
|
10130
|
0
|
47700
|
# for checking later, because outer_cd might be autovivified to hash |
253
|
|
|
|
|
|
|
# later |
254
|
10130
|
|
|
|
|
97660
|
$cd->{is_inner} = 1; |
255
|
|
|
|
|
|
|
|
256
|
10130
|
|
|
|
|
18988
|
$cd->{outer_cd} = $ocd; |
257
|
10130
|
|
|
|
|
19043
|
$cd->{indent_level} = $ocd->{indent_level}; |
258
|
10130
|
|
|
|
|
19509
|
$cd->{th_map} = { %{ $ocd->{th_map} } }; |
259
|
10130
|
|
|
|
|
14941
|
$cd->{fsh_map} = { %{ $ocd->{fsh_map} } }; |
260
|
10130
|
|
|
|
|
24501
|
$cd->{default_lang} = $ocd->{default_lang}; |
261
|
|
|
|
|
|
|
$cd->{spath} = [@{ $ocd->{spath} }]; |
262
|
10130
|
100
|
|
|
|
23425
|
} else { |
263
|
|
|
|
|
|
|
$cd->{indent_level} = $cd->{args}{indent_level} // 0; |
264
|
|
|
|
|
|
|
$cd->{th_map} = {}; |
265
|
655
|
|
|
|
|
1255
|
$cd->{fsh_map} = {}; |
266
|
|
|
|
|
|
|
# we use || here because in some env, LANG/LANGUAGE is set to '' |
267
|
655
|
|
|
|
|
1008
|
$cd->{default_lang} = $ENV{LANG} || "en_US"; |
268
|
655
|
|
|
|
|
999
|
$cd->{default_lang} =~ s/\..+//; # en_US.UTF-8 -> en_US |
269
|
655
|
|
|
|
|
772
|
$cd->{spath} = []; |
|
655
|
|
|
|
|
2207
|
|
270
|
655
|
|
|
|
|
1109
|
} |
|
655
|
|
|
|
|
1135
|
|
271
|
655
|
|
|
|
|
1139
|
$cd->{_id} = Time::HiRes::gettimeofday(); # compilation id |
272
|
655
|
|
|
|
|
843
|
$cd->{ccls} = []; |
|
655
|
|
|
|
|
1509
|
|
273
|
|
|
|
|
|
|
|
274
|
9475
|
|
100
|
|
|
21382
|
$cd; |
275
|
9475
|
|
|
|
|
18645
|
} |
276
|
9475
|
|
|
|
|
15601
|
|
277
|
|
|
|
|
|
|
my ($self, $args) = @_; |
278
|
9475
|
|
50
|
|
|
37386
|
|
279
|
9475
|
|
|
|
|
20783
|
return if $args->{_args_checked}++; |
280
|
9475
|
|
|
|
|
18400
|
|
281
|
|
|
|
|
|
|
$args->{data_name} //= 'data'; |
282
|
10130
|
|
|
|
|
32149
|
$args->{data_name} =~ /\A[A-Za-z_]\w*\z/ or $self->_die( |
283
|
10130
|
|
|
|
|
18866
|
{}, "Invalid syntax in data_name '$args->{data_name}', ". |
284
|
|
|
|
|
|
|
"please use letters/nums only"); |
285
|
10130
|
|
|
|
|
21973
|
$args->{allow_expr} //= 1; |
286
|
|
|
|
|
|
|
$args->{on_unhandled_attr} //= 'die'; |
287
|
|
|
|
|
|
|
$args->{on_unhandled_clause} //= 'die'; |
288
|
|
|
|
|
|
|
$args->{skip_clause} //= []; |
289
|
9800
|
|
|
9800
|
0
|
17624
|
$args->{mark_missing_translation} //= 1; |
290
|
|
|
|
|
|
|
for ($args->{lang}) { |
291
|
9800
|
100
|
|
|
|
28681
|
$_ //= $ENV{LANG} || $ENV{LANGUAGE} || "en_US"; |
292
|
|
|
|
|
|
|
s/\W.*//; # LANG=en_US.UTF-8, LANGUAGE=en_US:en |
293
|
4746
|
|
50
|
|
|
21427
|
} |
294
|
4746
|
50
|
|
|
|
21973
|
# locale, no default |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
|
297
|
4746
|
|
50
|
|
|
18023
|
my ($self, $cd, $clset_num, $clause) = @_; |
298
|
4746
|
|
100
|
|
|
17197
|
|
299
|
4746
|
|
100
|
|
|
17383
|
my $th = $cd->{th}; |
300
|
4746
|
|
100
|
|
|
19325
|
my $tn = $cd->{type}; |
301
|
4746
|
|
50
|
|
|
17221
|
my $clsets = $cd->{clsets}; |
302
|
4746
|
|
|
|
|
10612
|
|
303
|
4746
|
|
50
|
|
|
33411
|
my $clset = $clsets->[$clset_num]; |
|
|
|
66
|
|
|
|
|
304
|
4746
|
|
|
|
|
14153
|
local $cd->{spath} = [@{$cd->{spath}}, $clause]; |
305
|
|
|
|
|
|
|
local $cd->{clset} = $clset; |
306
|
|
|
|
|
|
|
local $cd->{clset_num} = $clset_num; |
307
|
|
|
|
|
|
|
local $cd->{uclset} = $cd->{uclsets}[$clset_num]; |
308
|
|
|
|
|
|
|
local $cd->{clset_dlang} = $cd->{_clset_dlangs}[$clset_num]; |
309
|
|
|
|
|
|
|
#$log->tracef("Processing clause %s", $clause); |
310
|
10641
|
|
|
10641
|
|
18044
|
|
311
|
|
|
|
|
|
|
delete $cd->{uclset}{$clause}; |
312
|
10641
|
|
|
|
|
18905
|
delete $cd->{uclset}{"$clause.prio"}; |
313
|
10641
|
|
|
|
|
16428
|
|
314
|
10641
|
|
|
|
|
16091
|
if (grep { $_ eq $clause } @{ $cd->{args}{skip_clause} }) { |
315
|
|
|
|
|
|
|
delete $cd->{uclset}{$_} |
316
|
10641
|
|
|
|
|
15207
|
for grep {/^\Q$clause\E(\.|\z)/} keys(%{$cd->{uclset}}); |
317
|
10641
|
|
|
|
|
13439
|
return; |
|
10641
|
|
|
|
|
27440
|
|
318
|
10641
|
|
|
|
|
22827
|
} |
319
|
10641
|
|
|
|
|
19166
|
|
320
|
10641
|
|
|
|
|
19068
|
my $meth = "clause_$clause"; |
321
|
10641
|
|
|
|
|
21312
|
my $mmeth = "clausemeta_$clause"; |
322
|
|
|
|
|
|
|
unless ($th->can($meth)) { |
323
|
|
|
|
|
|
|
for ($cd->{args}{on_unhandled_clause}) { |
324
|
10641
|
|
|
|
|
18502
|
next if $_ eq 'ignore'; |
325
|
10641
|
|
|
|
|
20369
|
do { warn "Can't handle clause $clause"; next } |
326
|
|
|
|
|
|
|
if $_ eq 'warn'; |
327
|
10641
|
100
|
|
|
|
13559
|
$self->_die($cd, "Can't handle clause $clause"); |
|
4
|
|
|
|
|
10
|
|
|
10641
|
|
|
|
|
29771
|
|
328
|
|
|
|
|
|
|
} |
329
|
2
|
|
|
|
|
3
|
} |
|
2
|
|
|
|
|
21
|
|
|
2
|
|
|
|
|
5
|
|
330
|
2
|
|
|
|
|
9
|
|
331
|
|
|
|
|
|
|
# put information about the clause to $cd |
332
|
|
|
|
|
|
|
|
333
|
10639
|
|
|
|
|
18321
|
my $meta; |
334
|
10639
|
|
|
|
|
16300
|
if ($th->can($mmeth)) { |
335
|
10639
|
100
|
|
|
|
33163
|
$meta = $th->$mmeth; |
336
|
35
|
|
|
|
|
96
|
} else { |
337
|
35
|
100
|
|
|
|
97
|
$meta = {}; |
338
|
10
|
100
|
|
|
|
36
|
} |
|
1
|
|
|
|
|
11
|
|
|
1
|
|
|
|
|
63
|
|
339
|
|
|
|
|
|
|
local $cd->{cl_meta} = $meta; |
340
|
9
|
|
|
|
|
44
|
$self->_die($cd, "Clause $clause doesn't allow expression") |
341
|
|
|
|
|
|
|
if $clset->{"$clause.is_expr"} && !$meta->{allow_expr}; |
342
|
|
|
|
|
|
|
for my $a (keys %{ $meta->{attrs} }) { |
343
|
|
|
|
|
|
|
my $av = $meta->{attrs}{$a}; |
344
|
|
|
|
|
|
|
$self->_die($cd, "Attribute $clause.$a doesn't allow ". |
345
|
|
|
|
|
|
|
"expression") |
346
|
10630
|
|
|
|
|
18995
|
if $clset->{"$clause.$a.is_expr"} && !$av->{allow_expr}; |
347
|
10630
|
100
|
|
|
|
31379
|
} |
348
|
10604
|
|
|
|
|
36231
|
local $cd->{clause} = $clause; |
349
|
|
|
|
|
|
|
my $cv = $clset->{$clause}; |
350
|
26
|
|
|
|
|
42
|
my $ie = $clset->{"$clause.is_expr"}; |
351
|
|
|
|
|
|
|
my $op = $clset->{"$clause.op"}; |
352
|
10630
|
|
|
|
|
23558
|
|
353
|
|
|
|
|
|
|
# store original value before being coerced/normalized |
354
|
10630
|
50
|
66
|
|
|
31603
|
local $cd->{cl_raw_value} = $cv; |
355
|
10630
|
|
|
|
|
13483
|
|
|
10630
|
|
|
|
|
24743
|
|
356
|
458
|
|
|
|
|
777
|
# coerce clause value (with default coerce rules & x.perl.coerce_to). XXX it |
357
|
|
|
|
|
|
|
# should be validate + coerce but for now we do coerce to reduce compilation |
358
|
|
|
|
|
|
|
# overhead. |
359
|
458
|
50
|
33
|
|
|
1332
|
{ |
360
|
|
|
|
|
|
|
last if $ie; |
361
|
10630
|
|
|
|
|
20440
|
my $coerce_type = $meta->{schema}[0] or last; |
362
|
10630
|
|
|
|
|
15833
|
my $value_is_array; |
363
|
10630
|
|
|
|
|
16456
|
if ($coerce_type eq '_same') { |
364
|
10630
|
|
|
|
|
17445
|
$coerce_type = $cd->{type}; |
365
|
|
|
|
|
|
|
} elsif ($coerce_type eq '_same_elem') { |
366
|
|
|
|
|
|
|
$coerce_type = $cd->{nschema}[1]{of} // |
367
|
10630
|
|
|
|
|
21386
|
$cd->{nschema}[1]{each_elem} // 'any'; |
368
|
|
|
|
|
|
|
} elsif ($clause eq 'between' || $clause eq 'xbetween') { # XXX special cased for now |
369
|
|
|
|
|
|
|
$coerce_type = $cd->{type}; |
370
|
|
|
|
|
|
|
$value_is_array = 1; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
my $coercer = $coercer_cache{$coerce_type}; |
373
|
10630
|
100
|
|
|
|
13140
|
if (!$coercer) { |
|
10630
|
|
|
|
|
20220
|
|
374
|
10622
|
100
|
|
|
|
24327
|
require Data::Sah::Coerce; |
375
|
10596
|
|
|
|
|
15062
|
$coercer = Data::Sah::Coerce::gen_coercer( |
376
|
10596
|
100
|
100
|
|
|
42164
|
type => $coerce_type, |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
377
|
2719
|
|
|
|
|
5113
|
return_type=>'status+err+val', |
378
|
|
|
|
|
|
|
(coerce_to => $cd->{coerce_to}) x !!$cd->{coerce_to}, |
379
|
|
|
|
|
|
|
); |
380
|
122
|
|
66
|
|
|
632
|
$coercer_cache{$coerce_type} = $coercer; |
|
|
|
50
|
|
|
|
|
381
|
|
|
|
|
|
|
} |
382
|
1386
|
|
|
|
|
2905
|
my ($cstatus, $cerr); |
383
|
1386
|
|
|
|
|
2816
|
if ($op && ($op eq 'or' || $op eq 'and')) { |
384
|
|
|
|
|
|
|
for my $cv2 (@$cv) { |
385
|
10596
|
|
|
|
|
20412
|
if ($value_is_array) { |
386
|
10596
|
100
|
|
|
|
27560
|
$cv2 = [@$cv2]; # shallow copy |
387
|
52
|
|
|
|
|
9423
|
for (@$cv2) { |
388
|
|
|
|
|
|
|
($cstatus, $cerr, $_) = @{ $coercer->($_) }; |
389
|
|
|
|
|
|
|
if ($cerr) { |
390
|
|
|
|
|
|
|
$self->_die($cd, "Can't coerce clause value $_: $cerr"); |
391
|
|
|
|
|
|
|
} |
392
|
52
|
|
|
|
|
43182
|
} |
393
|
52
|
|
|
|
|
10734
|
} else { |
394
|
|
|
|
|
|
|
($cstatus, $cerr, $cv) = @{ $coercer->($cv) }; |
395
|
10596
|
|
|
|
|
15764
|
if ($cerr) { |
396
|
10596
|
100
|
100
|
|
|
42795
|
$self->_die($cd, "Can't coerce clause value $cv: $cerr"); |
|
|
|
100
|
|
|
|
|
397
|
2966
|
|
|
|
|
6358
|
} |
398
|
4770
|
100
|
|
|
|
7795
|
} |
399
|
1152
|
|
|
|
|
3020
|
} |
400
|
1152
|
|
|
|
|
2129
|
} else { |
401
|
2304
|
|
|
|
|
2709
|
if ($value_is_array) { |
|
2304
|
|
|
|
|
36706
|
|
402
|
2304
|
50
|
|
|
|
17407
|
$cv = [@$cv]; # shallow copy |
403
|
0
|
|
|
|
|
0
|
for (@$cv) { |
404
|
|
|
|
|
|
|
my $cf; |
405
|
|
|
|
|
|
|
($cstatus, $cerr, $_) = @{ $coercer->($_) }; |
406
|
|
|
|
|
|
|
if ($cerr) { |
407
|
3618
|
|
|
|
|
3877
|
$self->_die($cd, "Can't coerce clause value $_: $cerr"); |
|
3618
|
|
|
|
|
63233
|
|
408
|
3618
|
50
|
|
|
|
22347
|
} |
409
|
0
|
|
|
|
|
0
|
} |
410
|
|
|
|
|
|
|
} else { |
411
|
|
|
|
|
|
|
($cstatus, $cerr, $cv) = @{ $coercer->($cv) }; |
412
|
|
|
|
|
|
|
if ($cerr) { |
413
|
|
|
|
|
|
|
$self->_die($cd, "Can't coerce clause value $cv: $cerr"); |
414
|
7630
|
100
|
|
|
|
13312
|
} |
415
|
660
|
|
|
|
|
1862
|
} |
416
|
660
|
|
|
|
|
1675
|
} |
417
|
1248
|
|
|
|
|
1537
|
#$log->tracef("Coerced clause value %s to %s (type=%s)", |
418
|
1248
|
|
|
|
|
1650
|
# $cd->{cl_raw_value}, $cv, $coerce_type); |
|
1248
|
|
|
|
|
23232
|
|
419
|
1248
|
50
|
|
|
|
10536
|
} |
420
|
0
|
|
|
|
|
0
|
|
421
|
|
|
|
|
|
|
local $cd->{cl_value} = $cv; |
422
|
|
|
|
|
|
|
local $cd->{cl_term} = $ie ? $self->expr($cd, $cv) : $self->literal($cv); |
423
|
|
|
|
|
|
|
local $cd->{cl_is_expr} = $ie; |
424
|
6970
|
|
|
|
|
9993
|
local $cd->{cl_op} = $op; |
|
6970
|
|
|
|
|
149568
|
|
425
|
6970
|
50
|
|
|
|
54213
|
delete $cd->{uclset}{"$clause.is_expr"}; |
426
|
0
|
|
|
|
|
0
|
delete $cd->{uclset}{"$clause.op"}; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
if ($self->can("before_clause")) { |
429
|
|
|
|
|
|
|
$self->before_clause($cd); |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
if ($th->can("before_clause")) { |
432
|
|
|
|
|
|
|
$th->before_clause($cd); |
433
|
|
|
|
|
|
|
} |
434
|
10630
|
|
|
|
|
34294
|
my $tmpnam = "before_clause_$clause"; |
435
|
10630
|
100
|
|
|
|
33004
|
if ($th->can($tmpnam)) { |
436
|
10630
|
|
|
|
|
752907
|
$th->$tmpnam($cd); |
437
|
10630
|
|
|
|
|
19020
|
} |
438
|
10630
|
|
|
|
|
23436
|
|
439
|
10630
|
|
|
|
|
18848
|
my $is_multi; |
440
|
|
|
|
|
|
|
if (defined($op) && !$ie) { |
441
|
10630
|
50
|
|
|
|
38405
|
if ($op =~ /\A(and|or|none)\z/) { |
442
|
10630
|
|
|
|
|
27655
|
$is_multi = 1; |
443
|
|
|
|
|
|
|
} elsif ($op eq 'not') { |
444
|
10630
|
100
|
|
|
|
37500
|
$is_multi = 0; |
445
|
3051
|
|
|
|
|
9328
|
} else { |
446
|
|
|
|
|
|
|
$self->_die($cd, "Invalid value for $clause.op, ". |
447
|
10630
|
|
|
|
|
20090
|
"must be one of and/or/not/none"); |
448
|
10630
|
100
|
|
|
|
42221
|
} |
449
|
1025
|
|
|
|
|
4679
|
} |
450
|
|
|
|
|
|
|
$self->_die($cd, "'$clause.op' attribute set to $op, ". |
451
|
|
|
|
|
|
|
"but value of '$clause' clause not an array") |
452
|
10630
|
|
|
|
|
13317
|
if $is_multi && ref($cv) ne 'ARRAY'; |
453
|
10630
|
100
|
66
|
|
|
28023
|
if (!$th->can($meth)) { |
454
|
4349
|
100
|
|
|
|
18237
|
# skip |
|
|
50
|
|
|
|
|
|
455
|
3686
|
|
|
|
|
5757
|
} elsif ($cd->{CLAUSE_DO_MULTI} || !$is_multi) { |
456
|
|
|
|
|
|
|
local $cd->{cl_is_multi} = 1 if $is_multi; |
457
|
663
|
|
|
|
|
1128
|
$th->$meth($cd); |
458
|
|
|
|
|
|
|
} else { |
459
|
0
|
|
|
|
|
0
|
my $i = 0; |
460
|
|
|
|
|
|
|
for my $cv2 (@$cv) { |
461
|
|
|
|
|
|
|
local $cd->{spath} = [@{ $cd->{spath} }, $i]; |
462
|
|
|
|
|
|
|
local $cd->{cl_value} = $cv2; |
463
|
10630
|
50
|
66
|
|
|
30697
|
local $cd->{cl_term} = $self->literal($cv2); |
464
|
|
|
|
|
|
|
local $cd->{_debug_ccl_note} = "" if $i; |
465
|
|
|
|
|
|
|
$i++; |
466
|
10630
|
100
|
100
|
|
|
52373
|
$th->$meth($cd); |
|
|
100
|
|
|
|
|
|
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
} |
469
|
8305
|
100
|
|
|
|
17364
|
|
470
|
8305
|
|
|
|
|
28523
|
$tmpnam = "after_clause_$clause"; |
471
|
|
|
|
|
|
|
if ($th->can($tmpnam)) { |
472
|
2299
|
|
|
|
|
4150
|
$th->$tmpnam($cd); |
473
|
2299
|
|
|
|
|
5346
|
} |
474
|
3686
|
|
|
|
|
5078
|
if ($th->can("after_clause")) { |
|
3686
|
|
|
|
|
10096
|
|
475
|
3686
|
|
|
|
|
6832
|
$th->after_clause($cd); |
476
|
3686
|
|
|
|
|
8117
|
} |
477
|
3686
|
100
|
|
|
|
184095
|
if ($self->can("after_clause")) { |
478
|
3686
|
|
|
|
|
5010
|
$self->after_clause($cd); |
479
|
3686
|
|
|
|
|
10995
|
} |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
delete $cd->{uclset}{"$clause.err_msg"}; |
482
|
|
|
|
|
|
|
delete $cd->{uclset}{"$clause.err_level"}; |
483
|
10597
|
|
|
|
|
24810
|
delete $cd->{uclset}{$_} for |
484
|
10597
|
100
|
|
|
|
45816
|
grep {/\A\Q$clause\E\.human(\..+)?\z/} keys(%{$cd->{uclset}}); |
485
|
56
|
|
|
|
|
165
|
} |
486
|
|
|
|
|
|
|
|
487
|
10597
|
50
|
|
|
|
29600
|
my ($self, $cd, $which) = @_; |
488
|
0
|
|
|
|
|
0
|
|
489
|
|
|
|
|
|
|
# $which can be left undef/false if called from compile(), or set to 'from |
490
|
10597
|
50
|
|
|
|
28108
|
# clause_clset' if called from within clause_clset(), in which case |
491
|
10597
|
|
|
|
|
23211
|
# before_handle_type, handle_type, before_all_clauses, and after_all_clauses |
492
|
|
|
|
|
|
|
# won't be called. |
493
|
|
|
|
|
|
|
|
494
|
10597
|
|
|
|
|
22381
|
my $th = $cd->{th}; |
495
|
10597
|
|
|
|
|
18936
|
my $tn = $cd->{type}; |
496
|
10597
|
|
|
|
|
13393
|
my $clsets = $cd->{clsets}; |
497
|
1222
|
|
|
|
|
22244
|
|
|
10597
|
|
|
|
|
77387
|
|
498
|
|
|
|
|
|
|
my $cname = $self->name; |
499
|
|
|
|
|
|
|
local $cd->{uclsets} = []; |
500
|
|
|
|
|
|
|
$cd->{_clset_dlangs} = []; # default lang for each clset |
501
|
10514
|
|
|
10514
|
|
21321
|
for my $clset (@$clsets) { |
502
|
|
|
|
|
|
|
for (keys %$clset) { |
503
|
|
|
|
|
|
|
if (!$cd->{args}{allow_expr} && /\.is_expr\z/ && $clset->{$_}) { |
504
|
|
|
|
|
|
|
$self->_die($cd, "Expression not allowed: $_"); |
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
$cd->{coerce_to} //= $clset->{'x.perl.coerce_to'} if $clset->{'x.perl.coerce_to'}; |
508
|
10514
|
|
|
|
|
14978
|
push @{ $cd->{uclsets} }, { |
509
|
10514
|
|
|
|
|
16807
|
map {$_=>$clset->{$_}} |
510
|
10514
|
|
|
|
|
13110
|
grep { |
511
|
|
|
|
|
|
|
!/\A_|\._|\Ax\./ && (!/\Ac\./ || /\Ac\.\Q$cname\E\./) |
512
|
10514
|
|
|
|
|
24934
|
} keys %$clset |
513
|
10514
|
|
|
|
|
28943
|
}; |
514
|
10514
|
|
|
|
|
18097
|
my $dl = $clset->{default_lang} // |
515
|
10514
|
|
|
|
|
18350
|
($cd->{outer_cd} ? $cd->{outer_cd}{clset_dlang} : undef) // |
516
|
9616
|
|
|
|
|
19398
|
"en_US"; |
517
|
15183
|
0
|
33
|
|
|
36511
|
push @{ $cd->{_clset_dlangs} }, $dl; |
|
|
|
33
|
|
|
|
|
518
|
0
|
|
|
|
|
0
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
my $clauses = $self->_get_clauses_from_clsets($cd, $clsets); |
521
|
9616
|
100
|
33
|
|
|
21792
|
$cd->{has_constraint_clause} = 0; |
522
|
9616
|
|
|
|
|
20873
|
$cd->{has_subschema} = 0; |
523
|
15015
|
|
|
|
|
44029
|
#$cd->{inspect_elem} = 0; # currently not needed |
524
|
|
|
|
|
|
|
for my $cl (@$clauses) { |
525
|
9616
|
100
|
66
|
|
|
11881
|
# 0=clset_num, 1=cl name, 2=cl meta |
|
15183
|
|
|
|
|
100430
|
|
526
|
|
|
|
|
|
|
next if $cl->[1] =~ /\A(req|forbidden)\z/; |
527
|
|
|
|
|
|
|
$cd->{has_subschema} = 1 if $cl->[2]{subschema}; |
528
|
|
|
|
|
|
|
#$cd->{inspect_elem} = 1 if $cl->[2]{inspect_elem}; |
529
|
9616
|
100
|
100
|
|
|
52452
|
if ($cl->[2]{tags} && grep {$_ eq 'constraint'} @{ $cl->[2]{tags} }) { |
|
|
|
100
|
|
|
|
|
530
|
|
|
|
|
|
|
$cd->{has_constraint_clause} = 1; |
531
|
9616
|
|
|
|
|
18076
|
} |
|
9616
|
|
|
|
|
22719
|
|
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
|
534
|
10514
|
|
|
|
|
25921
|
if ($which) { |
535
|
10500
|
|
|
|
|
18313
|
# {before,after}_clause_sets is currently internal/undocumented, created |
536
|
10500
|
|
|
|
|
15657
|
# only for clause_clset |
537
|
|
|
|
|
|
|
if ($self->can("before_clause_sets")) { |
538
|
10500
|
|
|
|
|
16592
|
$self->before_clause_sets($cd); |
539
|
|
|
|
|
|
|
} |
540
|
10482
|
100
|
|
|
|
30639
|
if ($th->can("before_clause_sets")) { |
541
|
9390
|
100
|
|
|
|
18478
|
$th->before_clause_sets($cd); |
542
|
|
|
|
|
|
|
} |
543
|
9390
|
100
|
100
|
|
|
22625
|
} else { |
|
9751
|
|
|
|
|
33060
|
|
|
9373
|
|
|
|
|
18258
|
|
544
|
8803
|
|
|
|
|
18326
|
if ($self->can("before_handle_type")) { |
545
|
|
|
|
|
|
|
$self->before_handle_type($cd); |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
|
548
|
10500
|
100
|
|
|
|
18355
|
$th->handle_type($cd); |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
if ($self->can("before_all_clauses")) { |
551
|
371
|
50
|
|
|
|
1281
|
$self->before_all_clauses($cd); |
552
|
0
|
|
|
|
|
0
|
} |
553
|
|
|
|
|
|
|
if ($th->can("before_all_clauses")) { |
554
|
371
|
50
|
|
|
|
1279
|
$th->before_all_clauses($cd); |
555
|
0
|
|
|
|
|
0
|
} |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
|
558
|
10129
|
50
|
|
|
|
34047
|
for my $clause0 (@$clauses) { |
559
|
10129
|
|
|
|
|
27235
|
my ($clset_num, $clause) = @$clause0; |
560
|
|
|
|
|
|
|
$self->_process_clause($cd, $clset_num, $clause); |
561
|
|
|
|
|
|
|
} # for clause |
562
|
10126
|
|
|
|
|
45534
|
|
563
|
|
|
|
|
|
|
for my $uclset (@{ $cd->{uclsets} }) { |
564
|
10126
|
100
|
|
|
|
44890
|
if (keys %$uclset) { |
565
|
5056
|
|
|
|
|
13498
|
for ($cd->{args}{on_unhandled_attr}) { |
566
|
|
|
|
|
|
|
my $msg = "Unhandled attribute(s) for type $tn: ". |
567
|
10126
|
100
|
|
|
|
48393
|
join(", ", keys %$uclset); |
568
|
521
|
|
|
|
|
1682
|
next if $_ eq 'ignore'; |
569
|
|
|
|
|
|
|
do { warn $msg; next } if $_ eq 'warn'; |
570
|
|
|
|
|
|
|
$self->_die($cd, $msg); |
571
|
|
|
|
|
|
|
} |
572
|
10497
|
|
|
|
|
19388
|
} |
573
|
10479
|
|
|
|
|
21707
|
} |
574
|
10479
|
|
|
|
|
26499
|
|
575
|
|
|
|
|
|
|
if ($which) { |
576
|
|
|
|
|
|
|
# {before,after}_clause_sets is currently internal/undocumented, created |
577
|
10464
|
|
|
|
|
16140
|
# only for clause_clset |
|
10464
|
|
|
|
|
19365
|
|
578
|
9566
|
100
|
|
|
|
22394
|
if ($th->can("after_clause_sets")) { |
579
|
26
|
|
|
|
|
70
|
$th->after_clause_sets($cd); |
580
|
26
|
|
|
|
|
95
|
} |
581
|
|
|
|
|
|
|
if ($self->can("after_clause_sets")) { |
582
|
26
|
100
|
|
|
|
85
|
$self->after_clause_sets($cd); |
583
|
7
|
100
|
|
|
|
21
|
} |
|
1
|
|
|
|
|
10
|
|
|
1
|
|
|
|
|
47
|
|
584
|
6
|
|
|
|
|
22
|
} else { |
585
|
|
|
|
|
|
|
if ($th->can("after_all_clauses")) { |
586
|
|
|
|
|
|
|
$th->after_all_clauses($cd); |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
if ($self->can("after_all_clauses")) { |
589
|
10458
|
100
|
|
|
|
20625
|
$self->after_all_clauses($cd); |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
} |
592
|
366
|
50
|
|
|
|
1317
|
} |
593
|
0
|
|
|
|
|
0
|
|
594
|
|
|
|
|
|
|
my ($self, %args) = @_; |
595
|
366
|
100
|
|
|
|
1659
|
|
596
|
174
|
|
|
|
|
468
|
# XXX schema |
597
|
|
|
|
|
|
|
$self->check_compile_args(\%args); |
598
|
|
|
|
|
|
|
|
599
|
10092
|
100
|
|
|
|
36921
|
my $main = $self->main; |
600
|
517
|
|
|
|
|
1623
|
my $cd = $self->init_cd(%args); |
601
|
|
|
|
|
|
|
|
602
|
10092
|
50
|
|
|
|
31090
|
if ($self->can("before_compile")) { |
603
|
10092
|
|
|
|
|
29255
|
$self->before_compile($cd); |
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
# normalize schema |
607
|
|
|
|
|
|
|
my $schema0 = $args{schema} or $self->_die($cd, "No schema"); |
608
|
|
|
|
|
|
|
my $nschema; |
609
|
10130
|
|
|
10130
|
1
|
74424
|
if ($args{schema_is_normalized}) { |
610
|
|
|
|
|
|
|
$nschema = $schema0; |
611
|
|
|
|
|
|
|
#$log->tracef("schema already normalized, skipped normalization"); |
612
|
10130
|
|
|
|
|
36514
|
} else { |
613
|
|
|
|
|
|
|
$nschema = $main->normalize_schema($schema0); |
614
|
10130
|
|
|
|
|
28252
|
#$log->tracef("normalized schema=%s", $nschema); |
615
|
10130
|
|
|
|
|
79891
|
} |
616
|
|
|
|
|
|
|
$cd->{nschema} = $nschema; |
617
|
10130
|
50
|
|
|
|
47506
|
local $cd->{schema} = $nschema; |
618
|
10130
|
|
|
|
|
24187
|
|
619
|
|
|
|
|
|
|
if ($self->can("before_resolve")) { |
620
|
|
|
|
|
|
|
my $res = $self->before_resolve($cd); |
621
|
|
|
|
|
|
|
return $cd if ($res//0) == 99; |
622
|
10130
|
50
|
|
|
|
24702
|
} |
623
|
10130
|
|
|
|
|
15101
|
|
624
|
10130
|
100
|
|
|
|
19493
|
require Data::Sah::Resolve; |
625
|
4889
|
|
|
|
|
7546
|
my $res = Data::Sah::Resolve::resolve_schema( |
626
|
|
|
|
|
|
|
{ |
627
|
|
|
|
|
|
|
schema_is_normalized => 1, |
628
|
5241
|
|
|
|
|
16904
|
allow_base_with_no_additional_clauses => 1, |
629
|
|
|
|
|
|
|
%{$args{resolve_opts} // {}}, |
630
|
|
|
|
|
|
|
}, |
631
|
10130
|
|
|
|
|
397588
|
$nschema); |
632
|
10130
|
|
|
|
|
25731
|
my $tn = $res->{type}; |
633
|
|
|
|
|
|
|
$cd->{th} = $self->get_th(name=>$tn, cd=>$cd); |
634
|
10130
|
100
|
|
|
|
33552
|
$cd->{type} = $tn; |
635
|
5060
|
|
|
|
|
13636
|
if ($nschema->[0] ne $tn) { |
636
|
5060
|
50
|
100
|
|
|
18412
|
$self->add_compile_module($cd, "Sah::Schema::$nschema->[0]"); |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
if ($args{cache} && $res->{base} && $res->{base} ne $res->{type}) { |
639
|
10130
|
|
|
|
|
49640
|
$cd->{base_schema} = $res->{base}; |
640
|
|
|
|
|
|
|
$cd->{clsets} = $res->{"clsets_after_base"}; |
641
|
|
|
|
|
|
|
} else { |
642
|
|
|
|
|
|
|
delete $cd->{base_schema}; |
643
|
|
|
|
|
|
|
$cd->{clsets} = $res->{"clsets_after_type.alt.merge.merged"}; |
644
|
10130
|
|
50
|
|
|
46408
|
} |
|
10130
|
|
|
|
|
64757
|
|
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
$self->_process_clsets($cd); |
647
|
10130
|
|
|
|
|
717678
|
|
648
|
10130
|
|
|
|
|
26396
|
if ($self->can("after_compile")) { |
649
|
10130
|
|
|
|
|
17970
|
$self->after_compile($cd); |
650
|
10130
|
50
|
|
|
|
25878
|
} |
651
|
0
|
|
|
|
|
0
|
|
652
|
|
|
|
|
|
|
if ($args{log_result}) {# && $log->is_trace) { |
653
|
10130
|
50
|
33
|
|
|
26148
|
log_trace( |
|
|
|
0
|
|
|
|
|
654
|
0
|
|
|
|
|
0
|
"Schema compilation result (compiler=%s):\n%s", |
655
|
0
|
|
|
|
|
0
|
ref($self), |
656
|
|
|
|
|
|
|
!ref($cd->{result}) && ($ENV{LINENUM} // 1) ? |
657
|
10130
|
|
|
|
|
15518
|
__linenum($cd->{result}) : |
658
|
10130
|
|
|
|
|
18145
|
$cd->{result} |
659
|
|
|
|
|
|
|
); |
660
|
|
|
|
|
|
|
} |
661
|
10130
|
|
|
|
|
26562
|
return $cd; |
662
|
|
|
|
|
|
|
} |
663
|
10092
|
100
|
|
|
|
44941
|
|
664
|
5067
|
|
|
|
|
13622
|
my ($self, $cd) = @_; |
665
|
|
|
|
|
|
|
my $cl = $cd->{clause}; |
666
|
|
|
|
|
|
|
delete $cd->{uclset}{$cl}; |
667
|
10092
|
50
|
|
|
|
25014
|
} |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
my ($self, $cd) = @_; |
670
|
|
|
|
|
|
|
my $cl = $cd->{clause}; |
671
|
|
|
|
|
|
|
delete $cd->{uclset}{$cl}; |
672
|
|
|
|
|
|
|
delete $cd->{uclset}{$_} for grep {/\A\Q$cl\E\./} keys %{$cd->{uclset}}; |
673
|
|
|
|
|
|
|
} |
674
|
0
|
0
|
0
|
|
|
0
|
|
675
|
|
|
|
|
|
|
my ($self, $cd, $note) = @_; |
676
|
10092
|
|
|
|
|
119068
|
|
677
|
|
|
|
|
|
|
$self->_die($cd, "Clause '$cd->{clause}' for type '$cd->{type}' ". |
678
|
|
|
|
|
|
|
($note ? "($note) " : "") . |
679
|
|
|
|
|
|
|
"is currently unimplemented"); |
680
|
189
|
|
|
189
|
|
973
|
} |
681
|
189
|
|
|
|
|
288
|
|
682
|
189
|
|
|
|
|
428
|
my ($self, $cd, $name, $extra_keys, $allow_duplicate) = @_; |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
my $found; |
685
|
|
|
|
|
|
|
for (@{ $cd->{modules} }) { |
686
|
81
|
|
|
81
|
|
375
|
if ($_->{name} eq $name && $_->{phase} eq $extra_keys->{phase}) { |
687
|
81
|
|
|
|
|
145
|
$found++; |
688
|
81
|
|
|
|
|
104
|
last; |
689
|
81
|
|
|
|
|
100
|
} |
|
0
|
|
|
|
|
0
|
|
|
81
|
|
|
|
|
305
|
|
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
return if $found && !$allow_duplicate; |
692
|
|
|
|
|
|
|
push @{ $cd->{modules} }, { |
693
|
0
|
|
|
0
|
|
0
|
name => $name, |
694
|
|
|
|
|
|
|
%{ $extra_keys // {} }, |
695
|
0
|
0
|
|
|
|
0
|
}; |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
my ($self, $cd, $name, $extra_keys, $allow_duplicate) = @_; |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
if ($extra_keys) { |
701
|
24205
|
|
|
24205
|
0
|
42203
|
$extra_keys = { %$extra_keys, phase => 'runtime' }; |
702
|
|
|
|
|
|
|
} else { |
703
|
24205
|
|
|
|
|
29723
|
$extra_keys = { phase => 'runtime' }; |
704
|
24205
|
|
|
|
|
28318
|
} |
|
24205
|
|
|
|
|
56141
|
|
705
|
17298
|
100
|
66
|
|
|
41309
|
$self->add_module($cd, $name, $extra_keys, $allow_duplicate); |
706
|
468
|
|
|
|
|
729
|
} |
707
|
468
|
|
|
|
|
710
|
|
708
|
|
|
|
|
|
|
my ($self, $cd, $name, $extra_keys, $allow_duplicate) = @_; |
709
|
|
|
|
|
|
|
|
710
|
24205
|
100
|
66
|
|
|
55294
|
if ($extra_keys) { |
711
|
23737
|
|
|
|
|
34664
|
$extra_keys = { %$extra_keys, phase => 'compile' }; |
712
|
|
|
|
|
|
|
} else { |
713
|
23737
|
|
50
|
|
|
26320
|
$extra_keys = { phase => 'compile' }; |
|
23737
|
|
|
|
|
110425
|
|
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
$self->add_module($cd, $name, $extra_keys, $allow_duplicate); |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
|
718
|
7653
|
|
|
7653
|
0
|
15975
|
1; |
719
|
|
|
|
|
|
|
# ABSTRACT: Base class for Sah compilers (Data::Sah::Compiler::*) |
720
|
7653
|
100
|
|
|
|
17372
|
|
721
|
4858
|
|
|
|
|
16515
|
|
722
|
|
|
|
|
|
|
=pod |
723
|
2795
|
|
|
|
|
6461
|
|
724
|
|
|
|
|
|
|
=encoding UTF-8 |
725
|
7653
|
|
|
|
|
23250
|
|
726
|
|
|
|
|
|
|
=head1 NAME |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
Data::Sah::Compiler - Base class for Sah compilers (Data::Sah::Compiler::*) |
729
|
16552
|
|
|
16552
|
0
|
35611
|
|
730
|
|
|
|
|
|
|
=head1 VERSION |
731
|
16552
|
50
|
|
|
|
32292
|
|
732
|
16552
|
|
|
|
|
56354
|
This document describes version 0.912 of Data::Sah::Compiler (from Perl distribution Data-Sah), released on 2022-08-20. |
733
|
|
|
|
|
|
|
|
734
|
0
|
|
|
|
|
0
|
=for Pod::Coverage ^(check_compile_args|def|expr|init_cd|literal|name|add_module|add_compile_module|add_runtime_module)$ |
735
|
|
|
|
|
|
|
|
736
|
16552
|
|
|
|
|
49594
|
=head1 COMPILATION DATA KEYS |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
=over |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
=item * v => int |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
Version of compilation data structure. Currently at 2. Whenever there's a |
743
|
|
|
|
|
|
|
backward-incompatible change introduced in the structure, this version number |
744
|
|
|
|
|
|
|
will be bumped. Client code can check this key to deliberately fail when it |
745
|
|
|
|
|
|
|
encounters version number that it can't handle. |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
=item * args => HASH |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
Arguments given to C<compile()>. |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
=item * compiler => OBJ |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
The compiler object. |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
=item * compiler_name => str |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
Compiler name, e.g. C<perl>, C<js>. |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
=item * is_inner => bool |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
Convenience. Will be set to 1 when this compilation is a subcompilation (i.e. |
762
|
|
|
|
|
|
|
compilation of a subschema). You can also check for C<outer_cd> to find out if |
763
|
|
|
|
|
|
|
this compilation is an inner compilation. |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
=item * outer_cd => HASH |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
If compilation is called from within another C<compile()>, this will be set to |
768
|
|
|
|
|
|
|
the outer compilation's C<$cd>. The inner compilation will inherit some values |
769
|
|
|
|
|
|
|
from the outer, like list of types (C<th_map>) and function sets (C<fsh_map>). |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
=item * th_map => HASH |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
Mapping of fully-qualified type names like C<int> and its |
774
|
|
|
|
|
|
|
C<Data::Sah::Compiler::*::TH::*> type handler object (or array, a normalized |
775
|
|
|
|
|
|
|
schema). |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
=item * fsh_map => HASH |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
Mapping of function set name like C<core> and its |
780
|
|
|
|
|
|
|
C<Data::Sah::Compiler::*::FSH::*> handler object. |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
=item * schema => ARRAY |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
The current schema (normalized) being processed. Since schema can contain other |
785
|
|
|
|
|
|
|
schemas, there will be subcompilation and this value will not necessarily equal |
786
|
|
|
|
|
|
|
to C<< $cd->{args}{schema} >>. |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
=item * spath = ARRAY |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
An array of strings, with empty array (C<[]>) as the root. Point to current |
791
|
|
|
|
|
|
|
location in schema during compilation. Inner compilation will continue/append |
792
|
|
|
|
|
|
|
the path. |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
Example: |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
# spath, with pointer to location in the schema |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
spath: ["elems"] ---- |
799
|
|
|
|
|
|
|
\ |
800
|
|
|
|
|
|
|
schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]} |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
spath: ["elems", 0] ------------ |
803
|
|
|
|
|
|
|
\ |
804
|
|
|
|
|
|
|
schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]} |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
spath: ["elems", 1, "min"] --------------------- |
807
|
|
|
|
|
|
|
\ |
808
|
|
|
|
|
|
|
schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]} |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
spath: ["elems", 2, "div_by", 1] ------------------------------------------------- |
811
|
|
|
|
|
|
|
\ |
812
|
|
|
|
|
|
|
schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]} |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
Note: aside from C<spath>, there is also the analogous C<dpath> which points to |
815
|
|
|
|
|
|
|
the location of I<data> (e.g. array element, hash key). But this is declared and |
816
|
|
|
|
|
|
|
maintained by the generated code, not by the compiler. |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=item * th => OBJ |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
Current type handler. |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=item * type => STR |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
Current type name. |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
=item * clsets => ARRAY |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
All the clause sets. Each schema might have more than one clause set, due to |
829
|
|
|
|
|
|
|
processing base type's clause set. |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
=item * clset => HASH |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
Current clause set being processed. Note that clauses are evaluated not strictly |
834
|
|
|
|
|
|
|
in clset order, but instead based on expression dependencies and priority. |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
=item * clset_dlang => HASH |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
Default language of the current clause set. This value is taken from C<< |
839
|
|
|
|
|
|
|
$cd->{clset}{default_lang} >> or C<< $cd->{outer_cd}{default_lang} >> or the |
840
|
|
|
|
|
|
|
default C<en_US>. |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
=item * clset_num => INT |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
Set to 0 for the first clause set, 1 for the second, and so on. Due to merging, |
845
|
|
|
|
|
|
|
we might process more than one clause set during compilation. |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
=item * uclset => HASH |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
Short for "unprocessed clause set", a shallow copy of C<clset>, keys will be |
850
|
|
|
|
|
|
|
removed from here as they are processed by clause handlers, remaining keys after |
851
|
|
|
|
|
|
|
processing the clause set means they are not recognized by hooks and thus |
852
|
|
|
|
|
|
|
constitutes an error. |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
=item * uclsets => ARRAY |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
All the C<uclset> for each clause set. |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
=item * clause => STR |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
Current clause name. |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
=item * cl_meta => HASH |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
Metadata information about the clause, from the clause definition. This include |
865
|
|
|
|
|
|
|
C<prio> (priority), C<attrs> (list of attributes specific for this clause), |
866
|
|
|
|
|
|
|
C<allow_expr> (whether clause allows expression in its value), etc. See |
867
|
|
|
|
|
|
|
C<Data::Sah::Type::$TYPENAME> for more information. |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
=item * cl_value => ANY |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
Clause value. Note: for putting in generated code, use C<cl_term>. |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
The clause value will be coerced if there are applicable coercion rules. To get |
874
|
|
|
|
|
|
|
the raw/original value as the schema specifies it, see C<cl_raw_value>. |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
=item * cl_raw_value => any |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
Like C<cl_value>, but without any coercion/filtering done to the value. |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
=item * cl_term => STR |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
Clause value term. If clause value is a literal (C<.is_expr> is false) then it |
883
|
|
|
|
|
|
|
is produced by passing clause value to C<literal()>. Otherwise, it is produced |
884
|
|
|
|
|
|
|
by passing clause value to C<expr()>. |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
=item * cl_is_expr => BOOL |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
A copy of C<< $cd->{clset}{"${clause}.is_expr"} >>, for convenience. |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
=item * cl_op => STR |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
A copy of C<< $cd->{clset}{"${clause}.op"} >>, for convenience. |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
=item * cl_is_multi => BOOL |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
Set to true if cl_value contains multiple clause values. This will happen if |
897
|
|
|
|
|
|
|
C<.op> is either C<and>, C<or>, or C<none> and C<< $cd->{CLAUSE_DO_MULTI} >> is |
898
|
|
|
|
|
|
|
set to true. |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
=item * indent_level => INT |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
Current level of indent when printing result using C<< $c->line() >>. 0 means |
903
|
|
|
|
|
|
|
unindented. |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
=item * all_expr_vars => ARRAY |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
All variables in all expressions in the current schema (and all of its |
908
|
|
|
|
|
|
|
subschemas). Used internally by compiler. For example (XXX syntax not not |
909
|
|
|
|
|
|
|
finalized): |
910
|
|
|
|
|
|
|
|
911
|
|
|
|
|
|
|
# schema |
912
|
|
|
|
|
|
|
[array => {of=>'str1', min_len=>1, 'max_len=' => '$min_len*3'}, |
913
|
|
|
|
|
|
|
{def => { |
914
|
|
|
|
|
|
|
str1 => [str => {min_len=>6, 'max_len=' => '$min_len*2', |
915
|
|
|
|
|
|
|
check=>'substr($_,0,1) eq "a"'}], |
916
|
|
|
|
|
|
|
}}] |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
all_expr_vars => ['schema:///clsets/0/min_len', # or perhaps .../min_len/value |
919
|
|
|
|
|
|
|
'schema://str1/clsets/0/min_len'] |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
This data can be used to order the compilation of clauses based on dependencies. |
922
|
|
|
|
|
|
|
In the above example, C<min_len> needs to be evaluated before C<max_len> |
923
|
|
|
|
|
|
|
(especially if C<min_len> is an expression). |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
=item * modules => array of hash |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
List of modules that are required, one way or another. Each element is a hash |
928
|
|
|
|
|
|
|
which must contain at least the C<name> key (module name). There are other keys |
929
|
|
|
|
|
|
|
like C<version> (minimum version), C<phase> (explained below). Some languages |
930
|
|
|
|
|
|
|
might add other keys, like C<perl> with C<use_statement> (statement to load/use |
931
|
|
|
|
|
|
|
the module, used by e.g. pragmas like C<no warnings 'void'> which are not the |
932
|
|
|
|
|
|
|
regular C<require MODULE> statement). Generally, duplicate entries (entries with |
933
|
|
|
|
|
|
|
the same C<name> and C<phase>) are avoided, except in special cases like Perl |
934
|
|
|
|
|
|
|
pragmas. |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
There are I<runtime> modules (C<phase> key set to C<runtime>), which are |
937
|
|
|
|
|
|
|
required by the generated code when running. For each entry, the only required |
938
|
|
|
|
|
|
|
key is C<name>. Other keys include: C<version> (minimum version). Some languages |
939
|
|
|
|
|
|
|
have some additional rule for this, e.g. perl has C<use_statement> (how to use |
940
|
|
|
|
|
|
|
the module, e.g. for pragma, like C<no warnings 'void'>). |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
There are also I<compile-time> modules (C<phase> key set to C<compile>), which |
943
|
|
|
|
|
|
|
are required during compilation of schema. This include coercion rule modules |
944
|
|
|
|
|
|
|
like L<Data::Sah::Coerce::perl::To_date::From_float::Epoch>, and so on. This |
945
|
|
|
|
|
|
|
information might be useful for distributions that use Data::Sah. Because |
946
|
|
|
|
|
|
|
Data::Sah is a modular library, where there are third party extensions for |
947
|
|
|
|
|
|
|
types, coercion rules, and so on, listing these modules as dependencies instead |
948
|
|
|
|
|
|
|
of a single C<Data::Sah> will ensure that dependants will pull the right |
949
|
|
|
|
|
|
|
distribution during installation. |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
=item * ccls => [HASH, ...] |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
(Result) Compiled clauses, collected during processing of schema's clauses. Each |
954
|
|
|
|
|
|
|
element will contain the compiled code in the target language, error message, |
955
|
|
|
|
|
|
|
and other information. At the end of processing, these will be joined together. |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
=item * result => ... |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
(Result) The final result. For most compilers, it will be string/text. |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
=item * has_constraint_clause => bool |
962
|
|
|
|
|
|
|
|
963
|
|
|
|
|
|
|
Convenience. True if there is at least one constraint clause in the schema. This |
964
|
|
|
|
|
|
|
I<excludes> special clause C<req> and C<forbidden>. |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
=item * has_subschema => bool |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
Convenience. True if there is at least one clause which contains a subschema. |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
=back |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
=head1 ATTRIBUTES |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
=head2 main => OBJ |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
Reference to the main Data::Sah object. |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
=head2 expr_compiler => OBJ |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
Reference to expression compiler object. In the perl compiler, for example, this |
981
|
|
|
|
|
|
|
will be an instance of L<Language::Expr::Compiler::Perl> object. |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
=head1 METHODS |
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
=head2 new() => OBJ |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
=head2 $c->compile(%args) => HASH |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
Compile schema into target language. |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
Arguments (C<*> denotes required arguments, subclass may introduce others): |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
=over 4 |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
=item * data_name => STR (default: 'data') |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
A unique name. Will be used as default for variable names, etc. Should only be |
998
|
|
|
|
|
|
|
comprised of letters/numbers/underscores. |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
=item * schema* => STR|ARRAY |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
The schema to use. Will be normalized by compiler, unless |
1003
|
|
|
|
|
|
|
C<schema_is_normalized> is set to true. |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
=item * lang => STR (default: from LANG/LANGUAGE or C<en_US>) |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
Desired output human language. Defaults (and falls back to) C<en_US>. |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
=item * mark_missing_translation => BOOL (default: 1) |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
If a piece of text is not found in desired human language, C<en_US> version of |
1012
|
|
|
|
|
|
|
the text will be used but using this format: |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
(en_US:the text to be translated) |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
If you do not want this marker, set the C<mark_missing_translation> option to 0. |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
=item * locale => STR |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
Locale name, to be set during generating human text description. This sometimes |
1021
|
|
|
|
|
|
|
needs to be if setlocale() fails to set locale using only C<lang>. |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
=item * schema_is_normalized => BOOL (default: 0) |
1024
|
|
|
|
|
|
|
|
1025
|
|
|
|
|
|
|
If set to true, instruct the compiler not to normalize the input schema and |
1026
|
|
|
|
|
|
|
assume it is already normalized. |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
=item * allow_expr => BOOL (default: 1) |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
Whether to allow expressions. If false, will die when encountering expression |
1031
|
|
|
|
|
|
|
during compilation. Usually set to false for security reason, to disallow |
1032
|
|
|
|
|
|
|
complex expressions when schemas come from untrusted sources. |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
=item * on_unhandled_attr => STR (default: 'die') |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
What to do when an attribute can't be handled by compiler (either it is an |
1037
|
|
|
|
|
|
|
invalid attribute, or the compiler has not implemented it yet). Valid values |
1038
|
|
|
|
|
|
|
include: C<die>, C<warn>, C<ignore>. |
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
=item * on_unhandled_clause => STR (default: 'die') |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
What to do when a clause can't be handled by compiler (either it is an invalid |
1043
|
|
|
|
|
|
|
clause, or the compiler has not implemented it yet). Valid values include: |
1044
|
|
|
|
|
|
|
C<die>, C<warn>, C<ignore>. |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
=item * indent_level => INT (default: 0) |
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
Start at a specified indent level. Useful when generated code will be inserted |
1049
|
|
|
|
|
|
|
into another code (e.g. inside C<sub {}> where it is nice to be able to indent |
1050
|
|
|
|
|
|
|
the inside code). |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
=item * skip_clause => ARRAY (default: []) |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
List of clauses to skip (to assume as if it did not exist). Example when |
1055
|
|
|
|
|
|
|
compiling with the human compiler: |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
# schema |
1058
|
|
|
|
|
|
|
[int => {default=>1, between=>[1, 10]}] |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
# generated human description in English |
1061
|
|
|
|
|
|
|
integer, between 1 and 10, default 1 |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
# generated human description, with skip_clause => ['default'] |
1064
|
|
|
|
|
|
|
integer, between 1 and 10 |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
=back |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
=head3 Compilation data |
1069
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
During compilation, compile() will call various hooks (listed below). The hooks |
1071
|
|
|
|
|
|
|
will be passed compilation data (C<$cd>) which is a hashref containing various |
1072
|
|
|
|
|
|
|
compilation state and result. Compilation data is written to this hashref |
1073
|
|
|
|
|
|
|
instead of on the object's attributes to make it easy to do recursive |
1074
|
|
|
|
|
|
|
compilation (compilation of subschemas). |
1075
|
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
|
Keys that are put into this compilation data include input data, compilation |
1077
|
|
|
|
|
|
|
state, and others. Many of these keys might exist only temporarily during |
1078
|
|
|
|
|
|
|
certain phases of compilation and will no longer exist at the end of |
1079
|
|
|
|
|
|
|
compilation, for example C<clause> will only exist during processing of a clause |
1080
|
|
|
|
|
|
|
and will be seen by hooks like C<before_clause> and C<after_clause>, it will not |
1081
|
|
|
|
|
|
|
be seen by C<before_all_clauses> or C<after_compile>. |
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
For a list of keys, see L</"COMPILATION DATA KEYS">. Subclasses may add more |
1084
|
|
|
|
|
|
|
data; see their respective documentation. |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
=head3 Return value |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
The compilation data will be returned as return value. Main result will be in |
1089
|
|
|
|
|
|
|
the C<result> key. There is also C<ccls>, and subclasses may put additional |
1090
|
|
|
|
|
|
|
results in other keys. Final usable result might need to be pieced together from |
1091
|
|
|
|
|
|
|
these results, depending on your needs. |
1092
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
=head3 Hooks |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
By default this base compiler does not define any hooks; subclasses can define |
1096
|
|
|
|
|
|
|
hooks to implement their compilation process. Each hook will be passed |
1097
|
|
|
|
|
|
|
compilation data, and should modify or set the compilation data as needed. The |
1098
|
|
|
|
|
|
|
hooks that compile() will call at various points, in calling order, are: |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
=over 4 |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
=item * $c->before_compile($cd) |
1103
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
Called once at the beginning of compilation. |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
=item * $c->before_handle_type($cd) |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
=item * $th->handle_type($cd) |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
=item * $c->before_all_clauses($cd) |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
Called before calling handler for any clauses. |
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
=item * $th->before_all_clauses($cd) |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
Called before calling handler for any clauses, after compiler's |
1117
|
|
|
|
|
|
|
before_all_clauses(). |
1118
|
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
=item * $c->before_clause($cd) |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
Called for each clause, before calling the actual clause handler |
1122
|
|
|
|
|
|
|
($th->clause_NAME() or $th->clause). |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
=item * $th->before_clause($cd) |
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
After compiler's before_clause() is called, I<type handler>'s before_clause() |
1127
|
|
|
|
|
|
|
will also be called if available. |
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
Input and output interpretation is the same as compiler's before_clause(). |
1130
|
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
|
=item * $th->before_clause_NAME($cd) |
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
Can be used to customize clause. |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
Introduced in v0.10. |
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
=item * $th->clause_NAME($cd) |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
Clause handler. Will be called only once (if C<$cd->{CLAUSE_DO_MULTI}> is set to |
1140
|
|
|
|
|
|
|
by other hooks before this) or once for each value in a multi-value clause (e.g. |
1141
|
|
|
|
|
|
|
when C<.op> attribute is set to C<and> or C<or>). For example, in this schema: |
1142
|
|
|
|
|
|
|
|
1143
|
|
|
|
|
|
|
[int => {"div_by&" => [2, 3, 5]}] |
1144
|
|
|
|
|
|
|
|
1145
|
|
|
|
|
|
|
C<clause_div_by()> can be called only once with C<< $cd->{cl_value} >> set to |
1146
|
|
|
|
|
|
|
[2, 3, 5] or three times, each with C<< $cd->{value} >> set to 2, 3, and 5 |
1147
|
|
|
|
|
|
|
respectively. |
1148
|
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
=item * $th->after_clause_NAME($cd) |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
Can be used to customize clause. |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
Introduced in v0.10. |
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
=item * $th->after_clause($cd) |
1156
|
|
|
|
|
|
|
|
1157
|
|
|
|
|
|
|
Called for each clause, after calling the actual clause handler |
1158
|
|
|
|
|
|
|
($th->clause_NAME()). |
1159
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
=item * $c->after_clause($cd) |
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
Called for each clause, after calling the actual clause handler |
1163
|
|
|
|
|
|
|
($th->clause_NAME()). |
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
Output interpretation is the same as $th->after_clause(). |
1166
|
|
|
|
|
|
|
|
1167
|
|
|
|
|
|
|
=item * $th->after_all_clauses($cd) |
1168
|
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
|
Called after all clauses have been compiled, before compiler's |
1170
|
|
|
|
|
|
|
after_all_clauses(). |
1171
|
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
|
=item * $c->after_all_clauses($cd) |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
Called after all clauses have been compiled. |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
=item * $c->after_compile($cd) |
1177
|
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
|
Called at the very end before compiling process end. |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
=back |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
=head2 $c->get_th |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
=head2 $c->get_fsh |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
=head1 HOMEPAGE |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>. |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
=head1 SOURCE |
1191
|
|
|
|
|
|
|
|
1192
|
|
|
|
|
|
|
Source repository is at L<https://github.com/perlancar/perl-Data-Sah>. |
1193
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
=head1 AUTHOR |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
perlancar <perlancar@cpan.org> |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
=head1 CONTRIBUTING |
1199
|
|
|
|
|
|
|
|
1200
|
|
|
|
|
|
|
|
1201
|
|
|
|
|
|
|
To contribute, you can send patches by email/via RT, or send pull requests on |
1202
|
|
|
|
|
|
|
GitHub. |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
Most of the time, you don't need to build the distribution yourself. You can |
1205
|
|
|
|
|
|
|
simply modify the code, then test via: |
1206
|
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
|
% prove -l |
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
If you want to build the distribution (e.g. to try to install it locally on your |
1210
|
|
|
|
|
|
|
system), you can install L<Dist::Zilla>, |
1211
|
|
|
|
|
|
|
L<Dist::Zilla::PluginBundle::Author::PERLANCAR>, |
1212
|
|
|
|
|
|
|
L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other |
1213
|
|
|
|
|
|
|
Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond |
1214
|
|
|
|
|
|
|
that are considered a bug and can be reported to me. |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
This software is copyright (c) 2022, 2021, 2020, 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar <perlancar@cpan.org>. |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
1221
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
1222
|
|
|
|
|
|
|
|
1223
|
|
|
|
|
|
|
=head1 BUGS |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah> |
1226
|
|
|
|
|
|
|
|
1227
|
|
|
|
|
|
|
When submitting a bug or request, please include a test-file or a |
1228
|
|
|
|
|
|
|
patch to an existing test-file that illustrates the bug or desired |
1229
|
|
|
|
|
|
|
feature. |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
=cut |