File Coverage

blib/lib/Data/Sah/Compiler/perl/TH/str.pm
Criterion Covered Total %
statement 80 89 89.8
branch 41 62 66.1
condition n/a
subroutine 12 12 100.0
pod 0 7 0.0
total 133 170 78.2


line stmt bran cond sub pod time code
1              
2             use 5.010;
3 6     6   520 use strict;
  6         17  
4 6     6   30 use warnings;
  6         9  
  6         101  
5 6     6   22 #use Log::Any '$log';
  6         10  
  6         165  
6              
7             use Mo qw(build default);
8 6     6   29 use Role::Tiny::With;
  6         16  
  6         34  
9 6     6   1427  
  6         11  
  6         7014  
10             extends 'Data::Sah::Compiler::perl::TH';
11             with 'Data::Sah::Type::str';
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 1589     1589 0 3536  
21 1589         5655 my $dt = $cd->{data_term};
22             $cd->{_ccl_check_type} = "!ref($dt)";
23 1589         7255 }
24 1589         4820  
25             my ($self, $which, $cd) = @_;
26             my $c = $self->compiler;
27             my $ct = $cd->{cl_term};
28 580     580 0 1128 my $dt = $cd->{data_term};
29 580         2006  
30 580         2802 if ($which eq 'is') {
31 580         1005 $c->add_ccl($cd, "$dt eq $ct");
32             } elsif ($which eq 'in') {
33 580 100       1781 if ($dt =~ /\$_\b/) {
    50          
34 300         1194 $c->add_ccl($cd, "do { my \$_sahv_dt = $dt; grep { \$_ eq \$_sahv_dt } \@{ $ct } }");
35             } else {
36 280 100       701 $c->add_ccl($cd, "grep { \$_ eq $dt } \@{ $ct }");
37 1         5 }
38             }
39 279         925 }
40              
41             my ($self, $which, $cd) = @_;
42             my $c = $self->compiler;
43             my $cv = $cd->{cl_value};
44             my $ct = $cd->{cl_term};
45 384     384 0 1198 my $dt = $cd->{data_term};
46 384         1447  
47 384         1946 if ($which eq 'min') {
48 384         739 $c->add_ccl($cd, "$dt ge $ct");
49 384         842 } elsif ($which eq 'xmin') {
50             $c->add_ccl($cd, "$dt gt $ct");
51 384 100       2965 } elsif ($which eq 'max') {
    100          
    100          
    100          
    100          
    50          
52 18         55 $c->add_ccl($cd, "$dt le $ct");
53             } elsif ($which eq 'xmax') {
54 18         64 $c->add_ccl($cd, "$dt lt $ct");
55             } elsif ($which eq 'between') {
56 18         57 if ($cd->{cl_is_expr}) {
57             $c->add_ccl($cd, "$dt ge $ct\->[0] && $dt le $ct\->[1]");
58 18         90 } else {
59             # simplify code
60 288 50       848 $c->add_ccl($cd, "$dt ge ".$c->literal($cv->[0]).
61 0         0 " && $dt le ".$c->literal($cv->[1]));
62             }
63             } elsif ($which eq 'xbetween') {
64 288         1259 if ($cd->{cl_is_expr}) {
65             $c->add_ccl($cd, "$dt gt $ct\->[0] && $dt lt $ct\->[1]");
66             } else {
67             # simplify code
68 24 50       75 $c->add_ccl($cd, "$dt gt ".$c->literal($cv->[0]).
69 0         0 " && $dt lt ".$c->literal($cv->[1]));
70             }
71             }
72 24         110 }
73              
74             my ($self_th, $which, $cd) = @_;
75             my $c = $self_th->compiler;
76             my $cv = $cd->{cl_value};
77             my $ct = $cd->{cl_term};
78             my $dt = $cd->{data_term};
79 213     213 0 549  
80 213         792 if ($which eq 'len') {
81 213         1007 $c->add_ccl($cd, "length($dt) == $ct");
82 213         584 } elsif ($which eq 'min_len') {
83 213         445 $c->add_ccl($cd, "length($dt) >= $ct");
84             } elsif ($which eq 'max_len') {
85 213 100       1339 $c->add_ccl($cd, "length($dt) <= $ct");
    100          
    100          
    100          
    100          
    100          
    50          
    0          
    0          
    0          
    0          
86 84         382 } elsif ($which eq 'len_between') {
87             if ($cd->{cl_is_expr}) {
88 30         192 $c->add_ccl(
89             $cd, "length($dt) >= $ct\->[0] && ".
90 9         42 "length($dt) >= $ct\->[1]");
91             } else {
92 18 50       52 # simplify code
93 0         0 $c->add_ccl(
94             $cd, "length($dt) >= $cv->[0] && ".
95             "length($dt) <= $cv->[1]");
96             }
97             } elsif ($which eq 'has') {
98 18         126 $c->add_ccl($cd, "index($dt, $ct) >= 0");
99             } elsif ($which eq 'each_index') {
100             $self_th->set_tmp_data_term($cd) if $cd->{args}{data_term_includes_topic_var};
101             $self_th->gen_each($cd, "0..length($cd->{data_term})-1", '_', '$_');
102             $self_th->restore_data_term($cd) if $cd->{args}{data_term_includes_topic_var};
103 36         143 } elsif ($which eq 'each_elem') {
104             $self_th->set_tmp_data_term($cd) if $cd->{args}{data_term_includes_topic_var};
105 18 50       69 $self_th->gen_each($cd, "0..length($cd->{data_term})-1", '_', "substr($cd->{data_term}, \$_, 1)");
106 18         136 $self_th->restore_data_term($cd) if $cd->{args}{data_term_includes_topic_var};
107 18 50       136 } elsif ($which eq 'check_each_index') {
108             $self_th->compiler->_die_unimplemented_clause($cd);
109 18 50       69 } elsif ($which eq 'check_each_elem') {
110 18         156 $self_th->compiler->_die_unimplemented_clause($cd);
111 18 50       129 } elsif ($which eq 'uniq') {
112             $self_th->compiler->_die_unimplemented_clause($cd);
113 0         0 } elsif ($which eq 'exists') {
114             $self_th->compiler->_die_unimplemented_clause($cd);
115 0         0 }
116             }
117 0         0  
118             my ($self, $cd) = @_;
119 0         0 my $c = $self->compiler;
120             my $cv = $cd->{cl_value};
121             my $ct = $cd->{cl_term};
122             my $dt = $cd->{data_term};
123              
124 9     9 0 27 $c->_die($cd, "Only 'utf8' encoding is currently supported")
125 9         29 unless $cv eq 'utf8';
126 9         44 # currently does nothing
127 9         18 }
128 9         23  
129             my ($self, $cd) = @_;
130 9 50       35 my $c = $self->compiler;
131             my $cv = $cd->{cl_value};
132             my $ct = $cd->{cl_term};
133             my $dt = $cd->{data_term};
134              
135             if ($cd->{cl_is_expr}) {
136 64     64 0 187 $c->add_ccl($cd, join(
137 64         301 "",
138 64         324 "ref($ct) eq 'Regexp' ? $dt =~ $ct : ",
139 64         225 "do { my \$_sahv_re = $ct; eval { \$_sahv_re = /\$_sahv_re/; 1 } && ",
140 64         188 "$dt =~ \$_sahv_re }",
141             ));
142 64 50       181 } else {
143 0         0 # simplify code and we can check regex at compile time
144             my $re = $c->_str2reliteral($cd, $cv);
145             $c->add_ccl($cd, "$dt =~ qr($re)");
146             }
147             }
148              
149             my ($self, $cd) = @_;
150             my $c = $self->compiler;
151 64         272 my $cv = $cd->{cl_value};
152 62         3693 my $ct = $cd->{cl_term};
153             my $dt = $cd->{data_term};
154              
155             if ($cd->{cl_is_expr}) {
156             $c->add_ccl($cd, join(
157 36     36 0 92 "",
158 36         108 "do { my \$_sahv_re = $dt; ",
159 36         207 "(eval { \$_sahv_re = qr/\$_sahv_re/; 1 } ? 1:0) == ($ct ? 1:0) }",
160 36         63 ));
161 36         69 } else {
162             # simplify code
163 36 50       91 $c->add_ccl($cd, join(
164 0         0 "",
165             "do { my \$_sahv_re = $dt; ",
166             ($cv ? "" : "!"), "(eval { \$_sahv_re = qr/\$_sahv_re/; 1 })",
167             "}",
168             ));
169             }
170             }
171 36 100       180  
172             1;
173             # ABSTRACT: perl's type handler for type "str"
174              
175              
176             =pod
177              
178             =encoding UTF-8
179              
180             =head1 NAME
181              
182             Data::Sah::Compiler::perl::TH::str - perl's type handler for type "str"
183              
184             =head1 VERSION
185              
186             This document describes version 0.912 of Data::Sah::Compiler::perl::TH::str (from Perl distribution Data-Sah), released on 2022-08-20.
187              
188             =for Pod::Coverage ^(clause_.+|superclause_.+)$
189              
190             =head1 HOMEPAGE
191              
192             Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
193              
194             =head1 SOURCE
195              
196             Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
197              
198             =head1 AUTHOR
199              
200             perlancar <perlancar@cpan.org>
201              
202             =head1 CONTRIBUTING
203              
204              
205             To contribute, you can send patches by email/via RT, or send pull requests on
206             GitHub.
207              
208             Most of the time, you don't need to build the distribution yourself. You can
209             simply modify the code, then test via:
210              
211             % prove -l
212              
213             If you want to build the distribution (e.g. to try to install it locally on your
214             system), you can install L<Dist::Zilla>,
215             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>,
216             L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
217             Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond
218             that are considered a bug and can be reported to me.
219              
220             =head1 COPYRIGHT AND LICENSE
221              
222             This software is copyright (c) 2022, 2021, 2020, 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar <perlancar@cpan.org>.
223              
224             This is free software; you can redistribute it and/or modify it under
225             the same terms as the Perl 5 programming language system itself.
226              
227             =head1 BUGS
228              
229             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
230              
231             When submitting a bug or request, please include a test-file or a
232             patch to an existing test-file that illustrates the bug or desired
233             feature.
234              
235             =cut