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

package Data::Sah::Filter;

use strict 'subs', 'vars';
use warnings;
no warnings 'once';
use Log::ger;

use Data::Sah::FilterCommon;
use Exporter qw(import);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2023-06-21'; # DATE
our $DIST = 'Data-Sah-Filter'; # DIST
our $VERSION = '0.021'; # VERSION

our @EXPORT_OK = qw(gen_filter);

our %SPEC;

our $Log_Filter_Code = $ENV{LOG_SAH_FILTER_CODE} // 0;

$SPEC{gen_filter} = {
    v => 1.1,
    summary => 'Generate filter code',
    description => <<'_',

This is mostly for testing. Normally the filter rules will be used from
.

_
    args => {
        %Data::Sah::FilterCommon::gen_filter_args,
    },
    result_naked => 1,
};
sub gen_filter {
    my %args = @_;

    my $rt = $args{return_type} // 'val';

    my $rules = Data::Sah::FilterCommon::get_filter_rules(
        %args,
        compiler=>'perl',
        data_term=>'$data',
    );

    my $code;
    if (@$rules) {
        my $code_require = '';
        my %mem;
        for my $rule (@$rules) {
            next unless $rule->{modules};
            for my $mod (keys %{$rule->{modules}}) {
                next if $mem{$mod}++;
                $code_require .= "require $mod;\n";
            }
        }

        my $code_filter = "";
        my $has_defined_tmp;
        for my $rule (@$rules) {
            if ($rule->{meta}{might_fail}) {
                $code_filter .= "    my \$tmp;\n" unless $has_defined_tmp++;
                $code_filter .= "    \$tmp = $rule->{expr_filter};\n";
                if ($rt eq 'val') {
                    $code_filter .= "    return undef if \$tmp->[0];\n";
                } else {
                    $code_filter .= "    return \$tmp if \$tmp->[0];\n";
                }
                $code_filter .= "    \$data = \$tmp->[1];\n";
            } else {
                $code_filter .= "    \$data = $rule->{expr_filter};\n";
            }
        }

        $code = join(
            "",
            $code_require,
            "sub {\n",
            "    my \$data = shift;\n",
            "    unless (defined \$data) {\n",
            "        return ", ($rt eq 'val' ? "undef" : "[undef, undef]"), "\n",
            "    }\n",
            $code_filter, "\n",
            "    ", ($rt eq 'val' ? "\$data" : "[undef, \$data]"), ";\n",
            "}",
        );
    } else {
        if ($rt eq 'val') {
            $code = 'sub { $_[0] }';
        } else {
            $code = 'sub { [undef, $_[0]] }';
        }
    }

    if ($Log_Filter_Code) {
        log_trace("Filter code (gen args: %s): %s", \%args, $code);
    }

    return $code if $args{source};

    my $filter = eval $code; ## no critic: BuiltinFunctions::ProhibitStringyEval
    die if $@;
    $filter;
}

1;
# ABSTRACT: Filtering for Data::Sah

__END__