File Coverage

blib/lib/Data/Sah/Compiler.pm
Criterion Covered Total %
statement 359 425 84.4
branch 133 194 68.5
condition 68 120 56.6
subroutine 23 30 76.6
pod 3 11 27.2
total 586 780 75.1


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