File Coverage

blib/lib/Data/Sah/Compiler/perl/TH/array.pm
Criterion Covered Total %
statement 81 86 94.1
branch 25 38 65.7
condition 5 5 100.0
subroutine 10 10 100.0
pod 0 4 0.0
total 121 143 84.6


line stmt bran cond sub pod time code
1              
2             use 5.010;
3 6     6   91 use strict;
  6         17  
4 6     6   25 use warnings;
  6         10  
  6         115  
5 6     6   24 use Log::ger;
  6         8  
  6         136  
6 6     6   26  
  6         9  
  6         35  
7             use Mo qw(build default);
8 6     6   1218 use Role::Tiny::With;
  6         12  
  6         33  
9 6     6   1432  
  6         22  
  6         5952  
10             extends 'Data::Sah::Compiler::perl::TH';
11             with 'Data::Sah::Type::array';
12              
13             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
14             our $DATE = '2022-08-20'; # DATE
15             our $DIST = 'Data-Sah'; # DIST
16             our $VERSION = '0.912'; # VERSION
17              
18             my ($self, $cd) = @_;
19             my $c = $self->compiler;
20 403     403 0 721  
21 403         1187 my $dt = $cd->{data_term};
22             $cd->{_ccl_check_type} = "ref($dt) eq 'ARRAY'";
23 403         1696 }
24 403         1155  
25             my ($self, $which, $cd) = @_;
26             my $c = $self->compiler;
27             my $ct = $cd->{cl_term};
28 288     288 0 479 my $dt = $cd->{data_term};
29 288         693  
30 288         1111 $c->add_runtime_module($cd, $cd->{args}{dump_module});
31 288         420  
32             if ($which eq 'is') {
33 288         777 $c->add_ccl($cd, $c->expr_dump($cd, $dt).' eq '.$c->expr_dump($cd, $ct));
34             } elsif ($which eq 'in') {
35 288 100       782 $c->add_ccl($cd, "do { my \$_sahv_dt_str = ".$c->expr_dump($cd, $dt)."; my \$_sahv_res = 0; " .
    50          
36 150         358 "for my \$_sahv_el (\@{ $ct }) { my \$_sahv_el_str = ".$c->expr_dump($cd, "\$_sahv_el")."; ".
37             "if (\$_sahv_dt_str eq \$_sahv_el_str) { \$_sahv_res = 1; last } } \$_sahv_res }");
38 138         297 }
39             }
40              
41             my ($self_th, $which, $cd) = @_;
42             my $c = $self_th->compiler;
43             my $cv = $cd->{cl_value};
44             my $ct = $cd->{cl_term};
45 123     123 0 227 my $dt = $cd->{data_term};
46 123         305  
47 123         475 if ($which eq 'len') {
48 123         157 $c->add_ccl($cd, "\@{$dt} == $ct");
49 123         182 } elsif ($which eq 'min_len') {
50             $c->add_ccl($cd, "\@{$dt} >= $ct");
51 123 100       442 } elsif ($which eq 'max_len') {
    100          
    100          
    100          
    100          
    100          
    50          
    0          
    0          
    0          
    0          
52 6         21 $c->add_ccl($cd, "\@{$dt} <= $ct");
53             } elsif ($which eq 'len_between') {
54 34         97 if ($cd->{cl_is_expr}) {
55             $c->add_ccl(
56 21         57 $cd, "\@{$dt} >= $ct\->[0] && \@{$dt} >= $ct\->[1]");
57             } else {
58 6 50       12 # simplify code
59 0         0 $c->add_ccl(
60             $cd, "\@{$dt} >= $cv->[0] && \@{$dt} <= $cv->[1]");
61             }
62             } elsif ($which eq 'has') {
63 6         24 $c->add_runtime_module($cd, $cd->{args}{dump_module});
64             $c->add_ccl($cd, "do { my \$_sahv_ct_str = ".$c->expr_dump($cd, $ct)."; my \$_sahv_res = 0; " .
65             "for my \$_sahv_el (\@{ $dt }) { my \$_sahv_el_str = ".$c->expr_dump($cd, "\$_sahv_el")."; ".
66             "if (\$_sahv_ct_str eq \$_sahv_el_str) { \$_sahv_res = 1; last } } \$_sahv_res }");
67 19         53 } elsif ($which eq 'each_index') {
68 19         64 $self_th->set_tmp_data_term($cd) if $cd->{args}{data_term_includes_topic_var};
69             $self_th->gen_each($cd, "0..\@{$cd->{data_term}}-1", '_', '$_');
70             $self_th->restore_data_term($cd) if $cd->{args}{data_term_includes_topic_var};
71             } elsif ($which eq 'each_elem') {
72 6 50       16 $self_th->set_tmp_data_term($cd) if $cd->{args}{data_term_includes_topic_var};
73 6         25 $self_th->gen_each($cd, "0..\@{$cd->{data_term}}-1", '_', "$cd->{data_term}\->[\$_]");
74 6 50       25 $self_th->restore_data_term($cd) if $cd->{args}{data_term_includes_topic_var};
75             } elsif ($which eq 'check_each_index') {
76 31 100       119 $self_th->compiler->_die_unimplemented_clause($cd);
77 31         170 } elsif ($which eq 'check_each_elem') {
78 31 100       146 $self_th->compiler->_die_unimplemented_clause($cd);
79             } elsif ($which eq 'uniq') {
80 0         0 $self_th->compiler->_die_unimplemented_clause($cd);
81             } elsif ($which eq 'exists') {
82 0         0 $self_th->compiler->_die_unimplemented_clause($cd);
83             }
84 0         0 }
85              
86 0         0 my ($self_th, $cd) = @_;
87             my $c = $self_th->compiler;
88             my $cv = $cd->{cl_value};
89             my $dt = $cd->{data_term};
90              
91 30     30 0 54 local $cd->{_subdata_level} = $cd->{_subdata_level} + 1;
92 30         74  
93 30         118 my $jccl;
94 30         48 {
95             local $cd->{ccls} = [];
96 30         65  
97             my $cdef = $cd->{clset}{"elems.create_default"} // 1;
98 30         41 delete $cd->{uclset}{"elems.create_default"};
99              
100 30         37 for my $i (0..@$cv-1) {
  30         56  
101             local $cd->{spath} = [@{$cd->{spath}}, $i];
102 30   100     85 my $nsch = $c->main->normalize_schema($cv->[$i]);
103 30         47 my $edt = "$dt\->[$i]";
104             my %iargs = %{$cd->{args}};
105 30         66 $iargs{outer_cd} = $cd;
106 60         82 $iargs{data_name} = "$cd->{args}{data_name}_$i";
  60         199  
107 60         170 $iargs{data_term} = $edt;
108 60         2093 $iargs{schema} = $nsch;
109 60         76 $iargs{schema_is_normalized} = 1;
  60         651  
110 60         163 $iargs{cache} = $cd->{args}{cache};
111 60         122 $iargs{indent_level}++;
112 60         95 my $icd = $c->compile(%iargs);
113 60         78 my @code = (
114 60         112 ($c->indent_str($cd), "(\$_sahv_dpath->[-1] = $i),\n") x !!$cd->{use_dpath},
115 60         97 $icd->{result}, "\n",
116 60         78 );
117 60         298 my $ires = join("", @code);
118             local $cd->{_debug_ccl_note} = "elem: $i";
119             if ($cdef && defined($nsch->[1]{default})) {
120 60         253 $c->add_ccl($cd, $ires);
121             } else {
122 60         546 $c->add_ccl($cd, "\@{$dt} < ".($i+1)." || ($ires)");
123 60         134 }
124 60 100 100     212 }
125 18         47 $jccl = $c->join_ccls(
126             $cd, $cd->{ccls}, {err_msg => ''});
127 42         172 }
128             $c->add_ccl($cd, $jccl, {subdata=>1});
129             }
130              
131 30         100 1;
132             # ABSTRACT: perl's type handler for type "array"
133 30         139  
134              
135             =pod
136              
137             =encoding UTF-8
138              
139             =head1 NAME
140              
141             Data::Sah::Compiler::perl::TH::array - perl's type handler for type "array"
142              
143             =head1 VERSION
144              
145             This document describes version 0.912 of Data::Sah::Compiler::perl::TH::array (from Perl distribution Data-Sah), released on 2022-08-20.
146              
147             =for Pod::Coverage ^(clause_.+|superclause_.+)$
148              
149             =head1 HOMEPAGE
150              
151             Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
152              
153             =head1 SOURCE
154              
155             Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
156              
157             =head1 AUTHOR
158              
159             perlancar <perlancar@cpan.org>
160              
161             =head1 CONTRIBUTING
162              
163              
164             To contribute, you can send patches by email/via RT, or send pull requests on
165             GitHub.
166              
167             Most of the time, you don't need to build the distribution yourself. You can
168             simply modify the code, then test via:
169              
170             % prove -l
171              
172             If you want to build the distribution (e.g. to try to install it locally on your
173             system), you can install L<Dist::Zilla>,
174             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>,
175             L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
176             Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond
177             that are considered a bug and can be reported to me.
178              
179             =head1 COPYRIGHT AND LICENSE
180              
181             This software is copyright (c) 2022, 2021, 2020, 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar <perlancar@cpan.org>.
182              
183             This is free software; you can redistribute it and/or modify it under
184             the same terms as the Perl 5 programming language system itself.
185              
186             =head1 BUGS
187              
188             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
189              
190             When submitting a bug or request, please include a test-file or a
191             patch to an existing test-file that illustrates the bug or desired
192             feature.
193              
194             =cut