File Coverage

blib/lib/Data/Sah/Filter.pm
Criterion Covered Total %
statement 44 52 84.6
branch 14 24 58.3
condition 2 2 100.0
subroutine 7 7 100.0
pod 1 1 100.0
total 68 86 79.0


line stmt bran cond sub pod time code
1             package Data::Sah::Filter;
2              
3 1     1   67585 use strict 'subs', 'vars';
  1         12  
  1         35  
4 1     1   6 use warnings;
  1         1  
  1         26  
5 1     1   4 no warnings 'once';
  1         2  
  1         26  
6 1     1   1692 use Log::ger;
  1         52  
  1         5  
7              
8 1     1   644 use Data::Sah::FilterCommon;
  1         2  
  1         35  
9 1     1   6 use Exporter qw(import);
  1         1  
  1         582  
10              
11             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
12             our $DATE = '2023-04-25'; # DATE
13             our $DIST = 'Data-Sah-Filter'; # DIST
14             our $VERSION = '0.019'; # VERSION
15              
16             our @EXPORT_OK = qw(gen_filter);
17              
18             our %SPEC;
19              
20             our $Log_Filter_Code = $ENV{LOG_SAH_FILTER_CODE} // 0;
21              
22             $SPEC{gen_filter} = {
23             v => 1.1,
24             summary => 'Generate filter code',
25             description => <<'_',
26              
27             This is mostly for testing. Normally the filter rules will be used from
28             .
29              
30             _
31             args => {
32             %Data::Sah::FilterCommon::gen_filter_args,
33             },
34             result_naked => 1,
35             };
36             sub gen_filter {
37 6     6 1 23298 my %args = @_;
38              
39 6   100     24 my $rt = $args{return_type} // 'val';
40              
41 6         25 my $rules = Data::Sah::FilterCommon::get_filter_rules(
42             %args,
43             compiler=>'perl',
44             data_term=>'$data',
45             );
46              
47 6         11 my $code;
48 6 50       12 if (@$rules) {
49 6         9 my $code_require = '';
50 6         9 my %mem;
51 6         13 for my $rule (@$rules) {
52 8 50       19 next unless $rule->{modules};
53 0         0 for my $mod (keys %{$rule->{modules}}) {
  0         0  
54 0 0       0 next if $mem{$mod}++;
55 0         0 $code_require .= "require $mod;\n";
56             }
57             }
58              
59 6         12 my $code_filter = "";
60 6         8 my $has_defined_tmp;
61 6         11 for my $rule (@$rules) {
62 8 100       14 if ($rule->{meta}{might_fail}) {
63 4 50       14 $code_filter .= " my \$tmp;\n" unless $has_defined_tmp++;
64 4         10 $code_filter .= " \$tmp = $rule->{expr_filter};\n";
65 4 100       9 if ($rt eq 'val') {
66 2         5 $code_filter .= " return undef if \$tmp->[0];\n";
67             } else {
68 2         4 $code_filter .= " return \$tmp if \$tmp->[0];\n";
69             }
70 4         6 $code_filter .= " \$data = \$tmp->[1];\n";
71             } else {
72 4         14 $code_filter .= " \$data = $rule->{expr_filter};\n";
73             }
74             }
75              
76 6 100       32 $code = join(
    100          
77             "",
78             $code_require,
79             "sub {\n",
80             " my \$data = shift;\n",
81             " unless (defined \$data) {\n",
82             " return ", ($rt eq 'val' ? "undef" : "[undef, undef]"), "\n",
83             " }\n",
84             $code_filter, "\n",
85             " ", ($rt eq 'val' ? "\$data" : "[undef, \$data]"), ";\n",
86             "}",
87             );
88             } else {
89 0 0       0 if ($rt eq 'val') {
90 0         0 $code = 'sub { $_[0] }';
91             } else {
92 0         0 $code = 'sub { [undef, $_[0]] }';
93             }
94             }
95              
96 6 50       16 if ($Log_Filter_Code) {
97 0         0 log_trace("Filter code (gen args: %s): %s", \%args, $code);
98             }
99              
100 6 50       16 return $code if $args{source};
101              
102 6         1116 my $filter = eval $code; ## no critic: BuiltinFunctions::ProhibitStringyEval
103 6 50       20 die if $@;
104 6         55 $filter;
105             }
106              
107             1;
108             # ABSTRACT: Filtering for Data::Sah
109              
110             __END__