File Coverage

blib/lib/Data/Sah/Compiler/perl/TH/date.pm
Criterion Covered Total %
statement 34 92 36.9
branch 4 74 5.4
condition 2 2 100.0
subroutine 8 9 88.8
pod 0 3 0.0
total 48 180 26.6


line stmt bran cond sub pod time code
1              
2             use 5.010;
3 5     5   919 use strict;
  5         15  
4 5     5   22 use warnings;
  5         8  
  5         84  
5 5     5   17 #use Log::Any '$log';
  5         10  
  5         149  
6              
7             use Mo qw(build default);
8 5     5   24 use Role::Tiny::With;
  5         8  
  5         28  
9 5     5   1237 use Scalar::Util qw(blessed looks_like_number);
  5         11  
  5         220  
10 5     5   27  
  5         9  
  5         5266  
11             extends 'Data::Sah::Compiler::perl::TH';
12             with 'Data::Sah::Type::date';
13              
14             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
15             our $DATE = '2022-08-20'; # DATE
16             our $DIST = 'Data-Sah'; # DIST
17             our $VERSION = '0.912'; # VERSION
18              
19             my ($self, $cd) = @_;
20             my $c = $self->compiler;
21 44     44 0 117 my $dt = $cd->{data_term};
22 44         157  
23 44         210 $cd->{coerce_to} = $cd->{nschema}[1]{"x.perl.coerce_to"} // 'float(epoch)';
24              
25 44   100     173 my $coerce_to = $cd->{coerce_to};
26              
27 44         78 if ($coerce_to eq 'float(epoch)') {
28             $cd->{_ccl_check_type} = "!ref($dt) && $dt =~ /\\A[0-9]+\\z/";
29 44 50       89 } elsif ($coerce_to eq 'DateTime') {
    0          
    0          
30 44         146 $c->add_runtime_module($cd, 'Scalar::Util');
31             $cd->{_ccl_check_type} = "Scalar::Util::blessed($dt) && $dt\->isa('DateTime')";
32 0         0 } elsif ($coerce_to eq 'Time::Moment') {
33 0         0 $c->add_runtime_module($cd, 'Scalar::Util');
34             $cd->{_ccl_check_type} = "Scalar::Util::blessed($dt) && $dt\->isa('Time::Moment')";
35 0         0 } else {
36 0         0 die "BUG: Unknown coerce_to value '$coerce_to', use either ".
37             "float(epoch), DateTime, or Time::Moment";
38 0         0 }
39             }
40              
41             my ($self, $which, $cd) = @_;
42             my $c = $self->compiler;
43             my $cv = $cd->{cl_value};
44 0     0 0 0 my $ct = $cd->{cl_term};
45 0         0 my $dt = $cd->{data_term};
46 0         0  
47 0         0 if ($cd->{cl_is_expr}) {
48 0         0 # i'm lazy, technical debt
49             $c->_die($cd, "date's comparison with expression not yet supported");
50 0 0       0 }
51              
52 0         0 my $coerce_to = $cd->{coerce_to};
53             if ($coerce_to eq 'float(epoch)') {
54             if ($which eq 'is') {
55 0         0 $c->add_ccl($cd, "$dt == $ct");
56 0 0       0 } elsif ($which eq 'in') {
    0          
    0          
57 0 0       0 $c->add_runtime_module($cd, 'List::Util');
    0          
58 0         0 $c->add_ccl($cd, "List::Util::first(sub{$dt == \$_}, $ct)");
59             }
60 0         0 } elsif ($coerce_to eq 'DateTime') {
61 0         0 # we need to encode this because otherwise just dumping DateTime object
62             # $cv will be unwieldy
63             my $ect = "DateTime->from_epoch(epoch=>".$cv->epoch.")";
64              
65             if ($which eq 'is') {
66 0         0 $c->add_ccl($cd, "DateTime->compare($dt, $ect)==0");
67             } elsif ($which eq 'in') {
68 0 0       0 $c->add_runtime_module($cd, 'List::Util');
    0          
69 0         0 $c->add_ccl($cd, "List::Util::first(sub{DateTime->compare($dt, \$_)==0}, $ect)");
70             }
71 0         0 } elsif ($coerce_to eq 'Time::Moment') {
72 0         0 # we need to encode this because otherwise just dumping DateTime object
73             # $cv will be unwieldy
74             my $ect = "Time::Moment->from_epoch(".$cv->epoch.")";
75              
76             if ($which eq 'is') {
77 0         0 $c->add_ccl($cd, "$dt\->compare($ect)==0");
78             } elsif ($which eq 'in') {
79 0 0       0 $c->add_runtime_module($cd, 'List::Util');
    0          
80 0         0 $c->add_ccl($cd, "List::Util::first(sub{$dt\->compare(\$_)==0}, $ect)");
81             }
82 0         0 }
83 0         0 }
84              
85             my ($self, $which, $cd) = @_;
86             my $c = $self->compiler;
87             my $cv = $cd->{cl_value};
88             my $ct = $cd->{cl_term};
89 17     17 0 37 my $dt = $cd->{data_term};
90 17         49  
91 17         72 if ($cd->{cl_is_expr}) {
92 17         29 # i'm lazy, technical debt
93 17         34 $c->_die($cd, "date's comparison with expression not yet supported");
94             }
95 17 50       34  
96             my $coerce_to = $cd->{coerce_to};
97 0         0 if ($coerce_to eq 'float(epoch)') {
98             if ($which eq 'min') {
99             $c->add_ccl($cd, "$dt >= $cv");
100 17         32 } elsif ($which eq 'xmin') {
101 17 50       42 $c->add_ccl($cd, "$dt > $cv");
    0          
    0          
102 17 50       39 } elsif ($which eq 'max') {
    0          
    0          
    0          
    0          
    0          
103 17         69 $c->add_ccl($cd, "$dt <= $cv");
104             } elsif ($which eq 'xmax') {
105 0           $c->add_ccl($cd, "$dt < $cv");
106             } elsif ($which eq 'between') {
107 0           $c->add_ccl($cd, "$dt >= $cv->[0] && $dt <= $cv->[1]");
108             } elsif ($which eq 'xbetween') {
109 0           $c->add_ccl($cd, "$dt > $cv->[0] && $dt < $cv->[1]");
110             }
111 0           } elsif ($coerce_to eq 'DateTime') {
112             # we need to encode this because otherwise just dumping DateTime object
113 0           # $cv will be unwieldy
114             my ($ect, $ect0, $ect1);
115             if (ref($cv) eq 'ARRAY') {
116             $ect0 = "DateTime->from_epoch(epoch=>".$cv->[0]->epoch.")";
117             $ect1 = "DateTime->from_epoch(epoch=>".$cv->[1]->epoch.")";
118 0           } else {
119 0 0         $ect = "DateTime->from_epoch(epoch=>".$cv->epoch.")";
120 0           }
121 0            
122             if ($which eq 'min') {
123 0           $c->add_ccl($cd, "DateTime->compare($dt, $ect) >= 0");
124             } elsif ($which eq 'xmin') {
125             $c->add_ccl($cd, "DateTime->compare($dt, $ect) > 0");
126 0 0         } elsif ($which eq 'max') {
    0          
    0          
    0          
    0          
    0          
127 0           $c->add_ccl($cd, "DateTime->compare($dt, $ect) <= 0");
128             } elsif ($which eq 'xmax') {
129 0           $c->add_ccl($cd, "DateTime->compare($dt, $ect) < 0");
130             } elsif ($which eq 'between') {
131 0           $c->add_ccl($cd, "DateTime->compare($dt, $ect0) >= 0 && DateTime->compare($dt, $ect1) <= 0");
132             } elsif ($which eq 'xbetween') {
133 0           $c->add_ccl($cd, "DateTime->compare($dt, $ect0) > 0 && DateTime->compare($dt, $ect1) < 0");
134             }
135 0           } elsif ($coerce_to eq 'Time::Moment') {
136             # we need to encode this because otherwise just dumping DateTime object
137 0           # $cv will be unwieldy
138             my ($ect, $ect0, $ect1);
139             if (ref($cv) eq 'ARRAY') {
140             $ect0 = "Time::Moment->from_epoch(".$cv->[0]->epoch.")";
141             $ect1 = "Time::Moment->from_epoch(".$cv->[1]->epoch.")";
142 0           } else {
143 0 0         $ect = "Time::Moment->from_epoch(".$cv->epoch.")";
144 0           }
145 0            
146             if ($which eq 'min') {
147 0           $c->add_ccl($cd, "$dt\->compare($ect) >= 0");
148             } elsif ($which eq 'xmin') {
149             $c->add_ccl($cd, "$dt\->compare($ect) > 0");
150 0 0         } elsif ($which eq 'max') {
    0          
    0          
    0          
    0          
    0          
151 0           $c->add_ccl($cd, "$dt\->compare($ect) <= 0");
152             } elsif ($which eq 'xmax') {
153 0           $c->add_ccl($cd, "$dt\->compare($ect) < 0");
154             } elsif ($which eq 'between') {
155 0           $c->add_ccl($cd, "$dt\->compare($ect0) >= 0 && $dt\->compare($ect1) <= 0");
156             } elsif ($which eq 'xbetween') {
157 0           $c->add_ccl($cd, "$dt\->compare($ect0) > 0 && $dt\->compare($ect1) < 0");
158             }
159 0           }
160             }
161 0            
162             1;
163             # ABSTRACT: perl's type handler for type "date"
164              
165              
166             =pod
167              
168             =encoding UTF-8
169              
170             =head1 NAME
171              
172             Data::Sah::Compiler::perl::TH::date - perl's type handler for type "date"
173              
174             =head1 VERSION
175              
176             This document describes version 0.912 of Data::Sah::Compiler::perl::TH::date (from Perl distribution Data-Sah), released on 2022-08-20.
177              
178             =head1 DESCRIPTION
179              
180             The C<date> type can be represented using one of three choices: int (epoch),
181             L<DateTime> object, or L<Time::Moment> object. This choice can be specified in
182             the schema using clause attribute C<x.perl.coerce_to>, e.g.:
183              
184             ["date", "x.perl.coerce_to"=>"float(epoch)"]
185             ["date", "x.perl.coerce_to"=>"DateTime"]
186             ["date", "x.perl.coerce_to"=>"Time::Moment"]
187              
188             =for Pod::Coverage ^(clause_.+|superclause_.+|handle_.+|before_.+|after_.+)$
189              
190             =head1 COMPILATION DATA KEYS
191              
192             =over
193              
194             =item * B<coerce_to> => str
195              
196             By default will be set to C<float(epoch)>. Other valid values include:
197             C<DateTime>, C<Time::Moment>.
198              
199             =back
200              
201             =head1 HOMEPAGE
202              
203             Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
204              
205             =head1 SOURCE
206              
207             Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
208              
209             =head1 AUTHOR
210              
211             perlancar <perlancar@cpan.org>
212              
213             =head1 CONTRIBUTING
214              
215              
216             To contribute, you can send patches by email/via RT, or send pull requests on
217             GitHub.
218              
219             Most of the time, you don't need to build the distribution yourself. You can
220             simply modify the code, then test via:
221              
222             % prove -l
223              
224             If you want to build the distribution (e.g. to try to install it locally on your
225             system), you can install L<Dist::Zilla>,
226             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>,
227             L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
228             Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond
229             that are considered a bug and can be reported to me.
230              
231             =head1 COPYRIGHT AND LICENSE
232              
233             This software is copyright (c) 2022, 2021, 2020, 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar <perlancar@cpan.org>.
234              
235             This is free software; you can redistribute it and/or modify it under
236             the same terms as the Perl 5 programming language system itself.
237              
238             =head1 BUGS
239              
240             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
241              
242             When submitting a bug or request, please include a test-file or a
243             patch to an existing test-file that illustrates the bug or desired
244             feature.
245              
246             =cut