File Coverage

blib/lib/Data/Sah/CoerceCommon.pm
Criterion Covered Total %
statement 58 65 89.2
branch 21 30 70.0
condition 10 23 43.4
subroutine 3 3 100.0
pod 1 1 100.0
total 93 122 76.2


line stmt bran cond sub pod time code
1             package Data::Sah::CoerceCommon;
2              
3 11     11   245 use 5.010001;
  11         43  
4 11     11   67 use strict 'subs', 'vars';
  11         18  
  11         14428  
5              
6             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
7             our $DATE = '2021-10-18'; # DATE
8             our $DIST = 'Data-Sah-Coerce'; # DIST
9             our $VERSION = '0.051'; # VERSION
10              
11             our $SUPPORT_OLD_PREFIX = $ENV{PERL_DATA_SAH_COERCE_SUPPORT_OLD_PREFIX} // 1;
12              
13             our %Default_Rules = (
14             perl => {
15             bool => [qw//],
16             datenotime => [qw/From_float::epoch From_obj::datetime From_obj::time_moment From_str::iso8601/],
17             date => [qw/From_float::epoch From_obj::datetime From_obj::time_moment From_str::iso8601/],
18             datetime => [qw/From_float::epoch From_obj::datetime From_obj::time_moment From_str::iso8601/],
19             duration => [qw/From_float::seconds From_obj::datetime_duration From_str::human From_str::iso8601/],
20             float => [qw/From_str::percent/],
21             num => [qw/From_str::percent/],
22             timeofday => [qw/From_obj::date_timeofday From_str::hms/],
23             },
24             js => {
25             bool => [qw/From_float::zero_one From_str::common_words/],
26             datenotime => [qw/From_float::epoch From_obj::date From_str::date_parse/],
27             date => [qw/From_float::epoch From_obj::date From_str::date_parse/],
28             datetime => [qw/From_float::epoch From_obj::date From_str::date_parse/],
29             duration => [qw/From_float::seconds From_str::iso8601/],
30             #float => [qw/From_str::percent/],
31             #num => [qw/From_str::percent/],
32             timeofday => [qw/From_str::hms/],
33             },
34             );
35              
36             my %common_args = (
37             type => {
38             schema => 'sah::type_name*',
39             req => 1,
40             pos => 0,
41             },
42             coerce_to => {
43             schema => 'str*',
44             description => <<'_',
45              
46             Some Sah types, like `date`, can be represented in a choice of types in the
47             target language. For example, in Perl you can store it as a floating number
48             a.k.a. `float(epoch)`, or as a <pm:DateTime> object, or <pm:Time::Moment>
49             object. Storing in DateTime can be convenient for date manipulation but requires
50             an overhead of loading the module and storing in a bulky format. The choice is
51             yours to make, via this setting.
52              
53             _
54             },
55             coerce_rules => {
56             summary => 'A specification of coercion rules to use (or avoid)',
57             schema => ['array*', of=>'str*'],
58             description => <<'_',
59              
60             This setting is used to specify which coercion rules to use (or avoid) in a
61             flexible way. Each element is a string, in the form of either `NAME` to mean
62             specifically include a rule, or `!NAME` to exclude a rule.
63              
64             Some coercion modules are used by default, unless explicitly avoided using the
65             '!NAME' rule.
66              
67             To not use any rules:
68              
69             To use the default rules plus R1 and R2:
70              
71             ['R1', 'R2']
72              
73             To use the default rules but not R1 and R2:
74              
75             ['!R1', '!R2']
76              
77             _
78             },
79             );
80              
81             my %gen_coercer_args = (
82             %common_args,
83             return_type => {
84             schema => ['str*', {
85             in => [qw/val bool_coerced+val bool_coerced+str_errmsg+val/],
86             prefilters => [
87             ["Str::replace_map", {map=>{
88             "status+val" => "bool_coerced+val",
89             "status+err+val" => "bool_coerced+str_errmsg+val",
90             }}],
91             ],
92             }],
93             default => 'val',
94             description => <<'_',
95              
96             `val` means the coercer will return the input (possibly) coerced or undef if
97             coercion fails.
98              
99             `bool_coerced+val` means the coercer will return a 2-element array. The first
100             element is a bool value set to 1 if coercion has been performed or 0 if
101             otherwise. The second element is the (possibly) coerced input.
102              
103             `bool_coerced+str_errmsg+val` means the coercer will return a 3-element array.
104             The first element is a bool value set to 1 if coercion has been performed or 0
105             if otherwise. The second element is the error message string which will be set
106             if there is a failure in coercion (or undef if coercion is successful). The
107             third element is the (possibly) coerced input.
108              
109             _
110             },
111             source => {
112             summary => 'If set to true, will return coercer source code string'.
113             ' instead of compiled code',
114             schema => 'bool',
115             },
116             );
117              
118             our %SPEC;
119              
120             $SPEC{get_coerce_rules} = {
121             v => 1.1,
122             summary => 'Get coerce rules',
123             description => <<'_',
124              
125             This routine determines coerce rule modules to use (based on the default set and
126             `coerce_rules` specified), loads them, filters out modules with old/incompatible
127             metadata version, and return the list of rules.
128              
129             This common routine is used by <pm:Data::Sah> compilers, as well as
130             <pm:Data::Sah::Coerce> and <pm:Data::Sah::CoerceJS>.
131              
132             _
133             args => {
134             %common_args,
135             compiler => {
136             schema => 'str*',
137             req => 1,
138             },
139             data_term => {
140             schema => 'str*',
141             req => 1,
142             },
143             },
144             };
145             sub get_coerce_rules {
146 26     26 1 26957 my %args = @_;
147              
148 26         65 my $type = $args{type};
149 26         57 my $compiler = $args{compiler};
150 26         49 my $dt = $args{data_term};
151              
152 26         53 my $typen = $type; $typen =~ s/::/__/g;
  26         78  
153 26         91 my $old_prefix = "Data::Sah::Coerce::$compiler\::$typen\::"; # deprecated, <0.034, will be removed in the future
154 26         76 my $prefix = "Data::Sah::Coerce::$compiler\::To_$typen\::";
155              
156 26 50       49 my @rules0 = @{ $Default_Rules{$compiler}{$typen} || [] };
  26         160  
157 26   100     56 for my $item (@{ $args{coerce_rules} // [] }) {
  26         155  
158 9 100       28 my $rule_name = ref $item eq 'ARRAY' ? $item->[0] : $item;
159 9         29 my $is_exclude = $rule_name =~ s/\A!//;
160 9 50 33     93 if ($SUPPORT_OLD_PREFIX && $rule_name =~ /\A\w+\z/) {
    50          
161             # old name
162             } elsif ($rule_name =~ /\AFrom_[A-Za-z0-9_]+::[A-Za-z0-9_]+\z/) {
163             # new name
164             } else {
165 0         0 die "Invalid syntax for coercion rule item '$item', please ".
166             "only use From_<type>::<description>";
167             }
168 9 100       24 if ($is_exclude) {
169 4         9 @rules0 = grep { $_ ne $rule_name } @rules0;
  15         52  
170             } else {
171 5 50       20 push @rules0, $item unless grep { $_ eq $rule_name } @rules0;
  4         11  
172             }
173             }
174              
175 26         64 my @rules;
176 26         66 for my $item (@rules0) {
177 78 100       197 my $rule_name = ref $item eq 'ARRAY' ? $item->[0] : $item;
178 78 100       181 my $rule_gen_args = ref $item eq 'ARRAY' ? $item->[1] : undef;
179 78   33     454 my $is_old_name = $SUPPORT_OLD_PREFIX && $rule_name =~ /\A\w+\z/;
180 78 50       215 my $mod = ($is_old_name ? $old_prefix : $prefix) . $rule_name;
181 78         475 (my $mod_pm = "$mod.pm") =~ s!::!/!g;
182 78         15002 require $mod_pm;
183 77         162 my $rule_meta = &{"$mod\::meta"};
  77         518  
184 77   50     236 my $rule_v = ($rule_meta->{v} // 1);
185 77 50 33     509 if ($rule_v != 3 && $rule_v != 4) {
186 0         0 warn "Only coercion rule module following metadata version 3/4 is ".
187             "supported, this rule module '$mod' follows metadata version ".
188             "$rule_v and will not be used";
189 0         0 next;
190             }
191 77         334 my $rule = &{"$mod\::coerce"}(
192             data_term => $dt,
193             coerce_to => $args{coerce_to},
194 77         190 (args => $rule_gen_args) x !!$rule_gen_args,
195             );
196 77         166 $rule->{name} = $rule_name;
197 77         120 $rule->{meta} = $rule_meta;
198 77         206 push @rules, $rule;
199             }
200              
201             # sort by priority (then name)
202             @rules = sort {
203 25         129 ($a->{meta}{prio}//50) <=> ($b->{meta}{prio}//50) ||
204             $a->{name} cmp $b->{name}
205 66 50 50     319 } @rules;
      50        
206              
207             # precludes
208             {
209 25         45 my $i = 0;
  25         53  
210 25         79 while ($i < @rules) {
211 73         148 my $rule = $rules[$i];
212 73 100       161 if ($rule->{meta}{precludes}) {
213 13         54 for my $j (reverse 0 .. $#rules) {
214 50 100       111 next if $j == $i;
215 37         56 my $match;
216 37         52 for my $p (@{ $rule->{meta}{precludes} }) {
  37         84  
217 37 50 33     284 if (ref($p) eq 'Regexp' && $rules[$j]{name} =~ $p ||
      33        
218             $rules[$j]{name} eq $p) {
219 0         0 $match = 1;
220 0         0 last;
221             }
222             }
223 37 50       97 next unless $match;
224 0         0 warn "Coercion rule $rules[$j]{name} is precluded by rule $rule->{name}";
225 0         0 splice @rules, $j, 1;
226             }
227             }
228 73         156 $i++;
229             }
230             }
231              
232 25         120 \@rules;
233             }
234              
235             1;
236             # ABSTRACT: Common stuffs for Data::Sah::Coerce and Data::Sah::CoerceJS
237              
238             __END__
239              
240             =pod
241              
242             =encoding UTF-8
243              
244             =head1 NAME
245              
246             Data::Sah::CoerceCommon - Common stuffs for Data::Sah::Coerce and Data::Sah::CoerceJS
247              
248             =head1 VERSION
249              
250             This document describes version 0.051 of Data::Sah::CoerceCommon (from Perl distribution Data-Sah-Coerce), released on 2021-10-18.
251              
252             =head1 FUNCTIONS
253              
254              
255             =head2 get_coerce_rules
256              
257             Usage:
258              
259             get_coerce_rules(%args) -> [$status_code, $reason, $payload, \%result_meta]
260              
261             Get coerce rules.
262              
263             This routine determines coerce rule modules to use (based on the default set and
264             C<coerce_rules> specified), loads them, filters out modules with old/incompatible
265             metadata version, and return the list of rules.
266              
267             This common routine is used by L<Data::Sah> compilers, as well as
268             L<Data::Sah::Coerce> and L<Data::Sah::CoerceJS>.
269              
270             This function is not exported.
271              
272             Arguments ('*' denotes required arguments):
273              
274             =over 4
275              
276             =item * B<coerce_rules> => I<array[str]>
277              
278             A specification of coercion rules to use (or avoid).
279              
280             This setting is used to specify which coercion rules to use (or avoid) in a
281             flexible way. Each element is a string, in the form of either C<NAME> to mean
282             specifically include a rule, or C<!NAME> to exclude a rule.
283              
284             Some coercion modules are used by default, unless explicitly avoided using the
285             '!NAME' rule.
286              
287             To not use any rules:
288              
289             To use the default rules plus R1 and R2:
290              
291             ['R1', 'R2']
292              
293             To use the default rules but not R1 and R2:
294              
295             ['!R1', '!R2']
296              
297             =item * B<coerce_to> => I<str>
298              
299             Some Sah types, like C<date>, can be represented in a choice of types in the
300             target language. For example, in Perl you can store it as a floating number
301             a.k.a. C<float(epoch)>, or as a L<DateTime> object, or L<Time::Moment>
302             object. Storing in DateTime can be convenient for date manipulation but requires
303             an overhead of loading the module and storing in a bulky format. The choice is
304             yours to make, via this setting.
305              
306             =item * B<compiler>* => I<str>
307              
308             =item * B<data_term>* => I<str>
309              
310             =item * B<type>* => I<sah::type_name>
311              
312              
313             =back
314              
315             Returns an enveloped result (an array).
316              
317             First element ($status_code) is an integer containing HTTP-like status code
318             (200 means OK, 4xx caller error, 5xx function error). Second element
319             ($reason) is a string containing error message, or something like "OK" if status is
320             200. Third element ($payload) is the actual result, but usually not present when enveloped result is an error response ($status_code is not 2xx). Fourth
321             element (%result_meta) is called result metadata and is optional, a hash
322             that contains extra information, much like how HTTP response headers provide additional metadata.
323              
324             Return value: (any)
325              
326             =head1 ENVIRONMENT
327              
328             =head2 PERL_DATA_SAH_COERCE_SUPPORT_OLD_PREFIX
329              
330             If set to false, will not support old prefix
331             (Data::Sah::Coerce::<$TARGET_TYPE>::<$SOURCE_TYPE_AND_DESC>. Mainly for testing.
332              
333             =head1 HOMEPAGE
334              
335             Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah-Coerce>.
336              
337             =head1 SOURCE
338              
339             Source repository is at L<https://github.com/perlancar/perl-Data-Sah-Coerce>.
340              
341             =head1 AUTHOR
342              
343             perlancar <perlancar@cpan.org>
344              
345             =head1 CONTRIBUTING
346              
347              
348             To contribute, you can send patches by email/via RT, or send pull requests on
349             GitHub.
350              
351             Most of the time, you don't need to build the distribution yourself. You can
352             simply modify the code, then test via:
353              
354             % prove -l
355              
356             If you want to build the distribution (e.g. to try to install it locally on your
357             system), you can install L<Dist::Zilla>,
358             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
359             Dist::Zilla plugin and/or Pod::Weaver::Plugin. Any additional steps required
360             beyond that are considered a bug and can be reported to me.
361              
362             =head1 COPYRIGHT AND LICENSE
363              
364             This software is copyright (c) 2021, 2020, 2019, 2018, 2017, 2016 by perlancar <perlancar@cpan.org>.
365              
366             This is free software; you can redistribute it and/or modify it under
367             the same terms as the Perl 5 programming language system itself.
368              
369             =head1 BUGS
370              
371             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah-Coerce>
372              
373             When submitting a bug or request, please include a test-file or a
374             patch to an existing test-file that illustrates the bug or desired
375             feature.
376              
377             =cut