File Coverage

blib/lib/Data/Sah/Compiler/perl/TH/cistr.pm
Criterion Covered Total %
statement 66 82 80.4
branch 21 32 65.6
condition n/a
subroutine 12 15 80.0
pod 0 6 0.0
total 99 135 73.3


line stmt bran cond sub pod time code
1              
2             use 5.010;
3 2     2   41 use strict;
  2         7  
4 2     2   9 use warnings;
  2         3  
  2         40  
5 2     2   9 #use Log::Any '$log';
  2         3  
  2         67  
6              
7             use Mo qw(build default);
8 2     2   10 use Role::Tiny::With;
  2         4  
  2         10  
9 2     2   491  
  2         3  
  2         2472  
10             extends 'Data::Sah::Compiler::perl::TH::str';
11             with 'Data::Sah::Type::cistr';
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 521     521 0 1097 my $dt = $cd->{data_term};
21 521         1409  
22 521         2337 # XXX only do this when there are clauses
23              
24             # convert to lowercase so we don't lc() the data repeatedly
25             $self->set_tmp_data_term($cd, "lc($dt)");
26             }
27 521         1915  
28             my ($self, $cd) = @_;
29             my $c = $self->compiler;
30             my $dt = $cd->{data_term};
31 517     517 0 1047  
32 517         1422 $self->restore_data_term($cd);
33 517         2145 }
34              
35 517         1488 my ($self, $which, $cd) = @_;
36             my $c = $self->compiler;
37             my $ct = $cd->{cl_term};
38             my $dt = $cd->{data_term};
39 289     289 0 519  
40 289         750 if ($which eq 'is') {
41 289         1185 $c->add_ccl($cd, "$dt eq lc($ct)");
42 289         464 } elsif ($which eq 'in') {
43             if ($dt =~ /\$_\b/) {
44 289 100       777 $c->add_ccl($cd, "do { my \$_sahv_dt = $dt; grep { lc(\$_) eq \$_sahv_dt } \@{ $ct } }");
    50          
45 150         498 } else {
46             $c->add_ccl($cd, "grep { lc(\$_) eq $dt } \@{ $ct }");
47 139 50       409 }
48 0         0 }
49             }
50 139         508  
51             my ($self, $which, $cd) = @_;
52             my $c = $self->compiler;
53             my $cv = $cd->{cl_value};
54             my $ct = $cd->{cl_term};
55             my $dt = $cd->{data_term};
56 192     192 0 324  
57 192         481 if ($which eq 'min') {
58 192         739 $c->add_ccl($cd, "$dt ge lc($ct)");
59 192         319 } elsif ($which eq 'xmin') {
60 192         323 $c->add_ccl($cd, "$dt gt lc($ct)");
61             } elsif ($which eq 'max') {
62 192 100       696 $c->add_ccl($cd, "$dt le lc($ct)");
    100          
    100          
    100          
    100          
    50          
63 9         29 } elsif ($which eq 'xmax') {
64             $c->add_ccl($cd, "$dt lt lc($ct)");
65 9         28 } elsif ($which eq 'between') {
66             if ($cd->{cl_is_expr}) {
67 9         28 $c->add_ccl($cd, "$dt ge lc($ct\->[0]) && ".
68             "$dt le lc($ct\->[1])");
69 9         29 } else {
70             # simplify code
71 144 50       280 $c->add_ccl($cd, "$dt ge ".$c->literal(lc $cv->[0]).
72 0         0 " && $dt le ".$c->literal(lc $cv->[1]));
73             }
74             } elsif ($which eq 'xbetween') {
75             if ($cd->{cl_is_expr}) {
76 144         485 $c->add_ccl($cd, "$dt gt lc($ct\->[0]) && ".
77             "$dt lt lc($ct\->[1])");
78             } else {
79             # simplify code
80 12 50       24 $c->add_ccl($cd, "$dt gt ".$c->literal(lc $cv->[0]).
81 0         0 " && $dt lt ".$c->literal(lc $cv->[1]));
82             }
83             }
84             }
85 12         43  
86             my ($self_th, $which, $cd) = @_;
87             my $c = $self_th->compiler;
88             my $cv = $cd->{cl_value};
89             my $ct = $cd->{cl_term};
90             my $dt = $cd->{data_term};
91              
92 73     73 0 154 if ($which eq 'has') {
93 73         208 $c->add_ccl($cd, "index($dt, lc($ct)) > -1");
94 73         301 } else {
95 73         126 $self_th->SUPER::superclause_has_elems($which, $cd);
96 73         125 }
97             }
98 73 100       161  
99 18         65 # turn "(?-xism:blah)" to "(?i-xsm:blah)"
100             my $re = shift;
101 55         162  
102             if ($^V ge v5.14.0) {
103             state $sub = sub { my $s = shift; $s =~ /i/ ? $s : "i$s" };
104             $re =~ s/\A\(\?\^(\w*):/"(?".$sub->($1).":"/e;
105             } else {
106             state $subl = sub { my $s = shift; $s =~ /i/ ? $s : "i$s" };
107 30     30   53 state $subr = sub { my $s = shift; $s =~ s/i//; $s };
108             $re =~ s/\A\(\?(\w*)-(\w*):/"(?".$subl->($1)."-".$subr->($2).":"/e;
109 30 50       204 }
110 30 0   0   58 return $re;
  0         0  
  0         0  
111 30         60 }
  0         0  
112              
113 0 0   0   0 my ($self, $cd) = @_;
  0         0  
  0         0  
114 0     0   0 my $c = $self->compiler;
  0         0  
  0         0  
  0         0  
115 0         0 my $cv = $cd->{cl_value};
  0         0  
116             my $ct = $cd->{cl_term};
117 30         77 my $dt = $cd->{data_term};
118              
119             if ($cd->{cl_is_expr}) {
120             $c->add_ccl($cd, join(
121 31     31 0 68 "",
122 31         88 "ref($ct) eq 'Regexp' ? $dt =~ qr/$ct/i : ",
123 31         149 "do { my \$_sahv_re = $ct; eval { \$_sahv_re = /\$_sahv_re/i; 1 } && ",
124 31         68 "$dt =~ \$_sahv_re }",
125 31         65 ));
126             } else {
127 31 50       78 # simplify code and we can check regex at compile time
128 0         0 my $re = $c->_str2reliteral($cd, $cv);
129             $re = __change_re_str_switch($re);
130             $c->add_ccl($cd, "$dt =~ /$re/i");
131             }
132             }
133              
134             1;
135             # ABSTRACT: perl's type handler for type "cistr"
136 31         90  
137 30         1285  
138 30         135 =pod
139              
140             =encoding UTF-8
141              
142             =head1 NAME
143              
144             Data::Sah::Compiler::perl::TH::cistr - perl's type handler for type "cistr"
145              
146             =head1 VERSION
147              
148             This document describes version 0.912 of Data::Sah::Compiler::perl::TH::cistr (from Perl distribution Data-Sah), released on 2022-08-20.
149              
150             =for Pod::Coverage ^(clause_.+|superclause_.+|handle_.+|before_.+|after_.+)$
151              
152             =head1 NOTES
153              
154             Should probably be reimplemented using special Perl string type, or special Perl
155             operators, instead of simulated using C<lc()> on a per-clause basis. The
156             implementation as it is now is not "contagious", e.g. C<< [cistr =>
157             check_each_elem => '$_ eq "A"'] >> should be true even if data is C<"Aaa">,
158             since one would expect C<< $_ eq "A" >> is also done case-insensitively, but it
159             is currently internally implemented by converting data to lowercase and
160             splitting per character to become C<< ["a", "a", "a"] >>.
161              
162             Or, avoid C<cistr> altogether and use C<prefilters> to convert to
163             lowercase/uppercase first before processing.
164              
165             =head1 HOMEPAGE
166              
167             Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
168              
169             =head1 SOURCE
170              
171             Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
172              
173             =head1 AUTHOR
174              
175             perlancar <perlancar@cpan.org>
176              
177             =head1 CONTRIBUTING
178              
179              
180             To contribute, you can send patches by email/via RT, or send pull requests on
181             GitHub.
182              
183             Most of the time, you don't need to build the distribution yourself. You can
184             simply modify the code, then test via:
185              
186             % prove -l
187              
188             If you want to build the distribution (e.g. to try to install it locally on your
189             system), you can install L<Dist::Zilla>,
190             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>,
191             L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
192             Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond
193             that are considered a bug and can be reported to me.
194              
195             =head1 COPYRIGHT AND LICENSE
196              
197             This software is copyright (c) 2022, 2021, 2020, 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar <perlancar@cpan.org>.
198              
199             This is free software; you can redistribute it and/or modify it under
200             the same terms as the Perl 5 programming language system itself.
201              
202             =head1 BUGS
203              
204             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
205              
206             When submitting a bug or request, please include a test-file or a
207             patch to an existing test-file that illustrates the bug or desired
208             feature.
209              
210             =cut