File Coverage

blib/lib/Data/Sah/Compiler.pm

Criterion	Covered	Total	%
statement	359	425	84.4
branch	133	194	68.5
condition	68	120	56.6
subroutine	23	30	76.6
pod	3	11	27.2
total	586	780	75.1

use 5.010;
use strict;
use warnings;

#use Carp;
use Mo qw(default);
use Role::Tiny::With;
use Log::ger;
use Scalar::Util qw(blessed);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-10-19'; # DATE
our $DIST = 'Data-Sah'; # DIST
our $VERSION = '0.914'; # VERSION

our %coercer_cache; # key=type, value=coercer coderef

with 'Data::Sah::Compiler::TextResultRole';

has main => (is => 'rw');

# BEGIN COPIED FROM String::LineNumber
    my ($str, $opts) = @_;
    $opts //= {};
    $opts->{width}      //= 4;
    $opts->{zeropad}    //= 0;
    $opts->{skip_empty} //= 1;

    my $i = 0;
        $str =~ s/^(([\t ]*\S)?.*)/
                sprintf(join("",
                                          "%",
                                          ($opts->{zeropad} && !($opts->{skip_empty}
                                                                                                && !defined($2)) ? "0" : ""),
                                          $opts->{width}, "s",
                                          "|%s"),
                                ++$i && $opts->{skip_empty} && !defined($2) ? "" : $i,
                                $1)/meg;

    $str;
}
# END COPIED FROM String::LineNumber

    die "BUG: Please override name()";
}

# literal representation in target language
    die "BUG: Please override literal()";
}

# compile expression to target language
    die "BUG: Please override expr()";
}

    my ($self, $cd, $msg) = @_;
    die join(
        "",
        "Sah ". $self->name . " compiler: ",
        "at schema:/", join("/", @{$cd->{spath} // []}), ": ",
        # XXX show (snippet of) current schema
        $msg,
    );
}

# form dependency list from which clauses are mentioned in expressions NEED TO
# BE UPDATED: NEED TO CHECK EXPR IN ALL ATTRS FOR THE WHOLE SCHEMA/SUBSCHEMAS
# (NOT IN THE CURRENT CLSET ONLY), THERE IS NO LONGER A ctbl, THE WAY EXPR IS
# STORED IS NOW DIFFERENT. PLAN: NORMALIZE ALL SUBSCHEMAS, GATHER ALL EXPR VARS
# AND STORE IN $cd->{all_expr_vars} (SKIP DOING THIS IS
# $cd->{outer_cd}{all_expr_vars} is already defined).
    #require Data::Graph::Util;
    require Language::Expr::Interpreter::var_enumer;

    my ($self, $cd, $ctbl) = @_;
    my $main = $self->main;

    my %depends;
    for my $crec (values %$ctbl) {
        my $cn = $crec->{name};
        my $expr = defined($crec->{expr}) ? $crec->{value} :
            $crec->{attrs}{expr};
        if (defined $expr) {
            my $vars = $main->_var_enumer->eval($expr);
            for (@$vars) {
                /^\w+$/ or $self->_die($cd,
                    "Invalid variable syntax '$_', ".
                        "currently only the form \$abc is supported");
                $ctbl->{$_} or $self->_die($cd,
                    "Unhandled clause specified in variable '$_'");
            }
            $depends{$cn} = $vars;
            for (@$vars) {
                push @{ $ctbl->{$_}{depended_by} }, $cn;
            }
        } else {
            $depends{$cn} = [];
        }
    }
    #$log->tracef("deps: %s", \%depends);
    #my @sorted = Data::Graph::Util::toposort(\%depends); # dies when cyclic
    #$log->tracef("sorted: %s", \@sorted);
    my %rsched = #map
        #{@{ $depends{$sched->[$_]} } ? ($sched->[$_] => $_) : ()}
        #    0..@$sched-1;
        (); # TMP
    #$log->tracef("deps: %s", \%rsched);
    \%rsched;
}

# generate a list of clauses in clsets, in order of evaluation. clauses are
# sorted based on expression dependencies and priority. result is array of
# [CLSET_NUM, CLAUSE, CLAUSEMETA] triplets, e.g. ([0, 'default', {...}], [1,
# 'default', {...}], [0, 'min', {...}], [0, 'max', {...}]).
    my ($self, $cd, $clsets) = @_;
    my $tn = $cd->{type};
    my $th = $cd->{th};

    my $deps;
    ## temporarily disabled, expr needs to be sorted globally
    #if ($self->_clset_has_expr($clset)) {
    #    $deps = $self->_form_deps($ctbl);
    #} else {
    #    $deps = {};
    #}
    #$deps = {};

    my $sorter = sub {
        my ($ia, $ca, $metaa) = @$a;
        my ($ib, $cb, $metab) = @$b;
        my $res;

        # dependency
        #$res = ($deps->{"$ca.$ia"} // -1) <=> ($deps->{"$cb.$ib"} // -1);
        #return $res if $res;

        {
            $res = $metaa->{prio} <=> $metab->{prio};
            #$log->errorf("TMP:   sort1");
            last if $res;

            # prio from schema
            my $sprioa = $clsets->[$ia]{"$ca.prio"} // 50;
            my $spriob = $clsets->[$ib]{"$cb.prio"} // 50;
            $res = $sprioa <=> $spriob;
            #$log->errorf("TMP:   sort2");
            last if $res;

            # alphabetical order of clause name
            $res = $ca cmp $cb;
            #$log->errorf("TMP:   sort3");
            last if $res;

            # clause set order
            $res = $ia <=> $ib;
            #$log->errorf("TMP:   sort4");
            last if $res;

            $res = 0;
        }

        #$log->errorf("TMP:   sort [%s,%s] vs [%s,%s] = %s", $ia, $ca, $ib, $cb, $res);
        $res;
    };

    my @clauses;
    for my $i (0..@$clsets-1) {
        for my $k (grep {!/\A_/ && !/\./} keys %{$clsets->[$i]}) {
            my $meta;
            eval {
                $meta = "Data::Sah::Type::$tn"->${\("clausemeta_$k")};
            };
            if ($@) {
                for ($cd->{args}{on_unhandled_clause}) {
                    my $msg = "Unhandled clause for type $tn: $k ($@)";
                    next if $_ eq 'ignore';
                    next if $_ eq 'warn'; # don't produce multiple warnings
                    $self->_die($cd, $msg);
                }
            }
            $meta //= {prio=>50};
            push @clauses, [$i, $k, $meta];
        }
    }

    my $res = [sort $sorter @clauses];
    #$log->errorf("TMP: sorted clauses: %s", $res);
    $res;
}

    my ($self, %args) = @_;
    my $cd    = $args{cd};
    my $name  = $args{name};

    my $th_map = $cd->{th_map};
    return $th_map->{$name} if $th_map->{$name};

    if ($args{load} // 1) {
        no warnings;
        $self->_die($cd, "Invalid syntax for type name '$name', please use ".
                        "letters/numbers/underscores only")
            unless $name =~ $Data::Sah::type_re;
        my $main = $self->main;
        my $module = ref($self) . "::TH::$name";
        if (!eval "require $module; 1") { ## no critic: BuiltinFunctions::ProhibitStringyEval
            $self->_die($cd, "Can't load type handler $module".
                            ($@ ? ": $@" : ""));
        }
        $self->add_compile_module($cd, $module, {category=>'type_handler'});

        my $obj = $module->new(compiler=>$self);
        $th_map->{$name} = $obj;
    }
    return $th_map->{$name};
}

    my ($self, %args) = @_;
    my $cd    = $args{cd};
    my $name  = $args{name};

    my $fsh_table = $cd->{fsh_table};
    return $fsh_table->{$name} if $fsh_table->{$name};

    if ($args{load} // 1) {
        no warnings;
        $self->_die($cd, "Invalid syntax for func set name '$name', ".
                        "please use letters/numbers/underscores")
            unless $name =~ $Data::Sah::funcset_re;
        my $module = ref($self) . "::FSH::$name";
        if (!eval "require $module; 1") { ## no critic: BuiltinFunctions::ProhibitStringyEval
            $self->_die($cd, "Can't load func set handler $module".
                            ($@ ? ": $@" : ""));
        }

        my $obj = $module->new();
        $fsh_table->{$name} = $obj;
    }
    return $fsh_table->{$name};
}

    require Time::HiRes;

    my ($self, %args) = @_;

    my $cd = {};
    $cd->{v} = 2;
    $cd->{args} = \%args;
    $cd->{compiler} = $self;
    $cd->{compiler_name} = $self->name;

    if (my $ocd = $args{outer_cd}) {
        # for checking later, because outer_cd might be autovivified to hash
        # later
        $cd->{is_inner}       = 1;

        $cd->{outer_cd}     = $ocd;
        $cd->{indent_level} = $ocd->{indent_level};
        $cd->{th_map}       = { %{ $ocd->{th_map}  } };
        $cd->{fsh_map}      = { %{ $ocd->{fsh_map} } };
        $cd->{default_lang} = $ocd->{default_lang};
        $cd->{spath}        = [@{ $ocd->{spath} }];
    } else {
        $cd->{indent_level} = $cd->{args}{indent_level} // 0;
        $cd->{th_map}       = {};
        $cd->{fsh_map}      = {};
        # we use || here because in some env, LANG/LANGUAGE is set to ''
        $cd->{default_lang} = $ENV{LANG} || "en_US";
        $cd->{default_lang} =~ s/\..+//; # en_US.UTF-8 -> en_US
        $cd->{spath}        = [];
    }
    $cd->{_id} = Time::HiRes::gettimeofday(); # compilation id
    $cd->{ccls} = [];

    $cd;
}

    my ($self, $args) = @_;

    return if $args->{_args_checked}++;

    $args->{data_name} //= 'data';
    $args->{data_name} =~ /\A[A-Za-z_]\w*\z/ or $self->_die(
        {}, "Invalid syntax in data_name '$args->{data_name}', ".
            "please use letters/nums only");
    $args->{allow_expr} //= 1;
    $args->{on_unhandled_attr}   //= 'die';
    $args->{on_unhandled_clause} //= 'die';
    $args->{skip_clause}         //= [];
    $args->{mark_missing_translation} //= 1;
    for ($args->{lang}) {
        $_ //= $ENV{LANG} || $ENV{LANGUAGE} || "en_US";
        s/\W.*//; # LANG=en_US.UTF-8, LANGUAGE=en_US:en
    }
    # locale, no default
}

    my ($self, $cd, $clset_num, $clause) = @_;

    my $th = $cd->{th};
    my $tn = $cd->{type};
    my $clsets = $cd->{clsets};

    my $clset = $clsets->[$clset_num];
    local $cd->{spath}       = [@{$cd->{spath}}, $clause];
    local $cd->{clset}       = $clset;
    local $cd->{clset_num}   = $clset_num;
    local $cd->{uclset}      = $cd->{uclsets}[$clset_num];
    local $cd->{clset_dlang} = $cd->{_clset_dlangs}[$clset_num];
    #$log->tracef("Processing clause %s", $clause);

    delete $cd->{uclset}{$clause};
    delete $cd->{uclset}{"$clause.prio"};

    if (grep { $_ eq $clause } @{ $cd->{args}{skip_clause} }) {
        delete $cd->{uclset}{$_}
            for grep {/^\Q$clause\E(\.|\z)/} keys(%{$cd->{uclset}});
        return;
    }

    my $meth  = "clause_$clause";
    my $mmeth = "clausemeta_$clause";
    unless ($th->can($meth)) {
        for ($cd->{args}{on_unhandled_clause}) {
            next if $_ eq 'ignore';
            do { warn "Can't handle clause $clause"; next }
                if $_ eq 'warn';
            $self->_die($cd, "Can't handle clause $clause");
        }
    }

    # put information about the clause to $cd

    my $meta;
    if ($th->can($mmeth)) {
        $meta = $th->$mmeth;
    } else {
        $meta = {};
    }
    local $cd->{cl_meta} = $meta;
    $self->_die($cd, "Clause $clause doesn't allow expression")
        if $clset->{"$clause.is_expr"} && !$meta->{allow_expr};
    for my $a (keys %{ $meta->{attrs} }) {
        my $av = $meta->{attrs}{$a};
        $self->_die($cd, "Attribute $clause.$a doesn't allow ".
                        "expression")
            if $clset->{"$clause.$a.is_expr"} && !$av->{allow_expr};
    }
    local $cd->{clause} = $clause;
    my $cv = $clset->{$clause};
    my $ie = $clset->{"$clause.is_expr"};
    my $op = $clset->{"$clause.op"};

    # store original value before being coerced/normalized
    local $cd->{cl_raw_value}   = $cv;

    # coerce clause value (with default coerce rules & x.perl.coerce_to). XXX it
    # should be validate + coerce but for now we do coerce to reduce compilation
    # overhead.
    {
        last if $ie;
        my $coerce_type = $meta->{schema}[0] or last;
        my $value_is_array;
        if ($coerce_type eq '_same') {
            $coerce_type = $cd->{type};
        } elsif ($coerce_type eq '_same_elem') {
            $coerce_type = $cd->{nschema}[1]{of} //
                $cd->{nschema}[1]{each_elem} // 'any';
        } elsif ($clause eq 'between' || $clause eq 'xbetween') { # XXX special cased for now
            $coerce_type = $cd->{type};
            $value_is_array = 1;
        }
        my $coercer = $coercer_cache{$coerce_type};
        if (!$coercer) {
            require Data::Sah::Coerce;
            $coercer = Data::Sah::Coerce::gen_coercer(
                type => $coerce_type,
                return_type=>'status+err+val',
                (coerce_to => $cd->{coerce_to}) x !!$cd->{coerce_to},
            );
            $coercer_cache{$coerce_type} = $coercer;
        }
        my ($cstatus, $cerr);
        if ($op && ($op eq 'or' || $op eq 'and')) {
            for my $cv2 (@$cv) {
                if ($value_is_array) {
                    $cv2 = [@$cv2]; # shallow copy
                    for (@$cv2) {
                        ($cstatus, $cerr, $_) = @{ $coercer->($_) };
                        if ($cerr) {
                            $self->_die($cd, "Can't coerce clause value $_: $cerr");
                        }
                    }
                } else {
                    ($cstatus, $cerr, $cv) = @{ $coercer->($cv) };
                    if ($cerr) {
                        $self->_die($cd, "Can't coerce clause value $cv: $cerr");
                    }
                }
            }
        } else {
            if ($value_is_array) {
                $cv = [@$cv]; # shallow copy
                for (@$cv) {
                    my $cf;
                    ($cstatus, $cerr, $_) = @{ $coercer->($_) };
                    if ($cerr) {
                        $self->_die($cd, "Can't coerce clause value $_: $cerr");
                    }
                }
            } else {
                ($cstatus, $cerr, $cv) = @{ $coercer->($cv) };
                if ($cerr) {
                    $self->_die($cd, "Can't coerce clause value $cv: $cerr");
                }
            }
        }
        #$log->tracef("Coerced clause value %s to %s (type=%s)",
        #             $cd->{cl_raw_value}, $cv, $coerce_type);
    }

    local $cd->{cl_value}   = $cv;
    local $cd->{cl_term}    = $ie ? $self->expr($cd, $cv) : $self->literal($cv);
    local $cd->{cl_is_expr} = $ie;
    local $cd->{cl_op}      = $op;
    delete $cd->{uclset}{"$clause.is_expr"};
    delete $cd->{uclset}{"$clause.op"};

    if ($self->can("before_clause")) {
        $self->before_clause($cd);
    }
    if ($th->can("before_clause")) {
        $th->before_clause($cd);
    }
    my $tmpnam = "before_clause_$clause";
    if ($th->can($tmpnam)) {
        $th->$tmpnam($cd);
    }

    my $is_multi;
    if (defined($op) && !$ie) {
        if ($op =~ /\A(and|or|none)\z/) {
            $is_multi = 1;
        } elsif ($op eq 'not') {
            $is_multi = 0;
        } else {
            $self->_die($cd, "Invalid value for $clause.op, ".
                            "must be one of and/or/not/none");
        }
    }
    $self->_die($cd, "'$clause.op' attribute set to $op, ".
                    "but value of '$clause' clause not an array")
        if $is_multi && ref($cv) ne 'ARRAY';
    if (!$th->can($meth)) {
        # skip
    } elsif ($cd->{CLAUSE_DO_MULTI} || !$is_multi) {
        local $cd->{cl_is_multi} = 1 if $is_multi;
        $th->$meth($cd);
    } else {
        my $i = 0;
        for my $cv2 (@$cv) {
            local $cd->{spath} = [@{ $cd->{spath} }, $i];
            local $cd->{cl_value} = $cv2;
            local $cd->{cl_term}  = $self->literal($cv2);
            local $cd->{_debug_ccl_note} = "" if $i;
            $i++;
            $th->$meth($cd);
        }
    }

    $tmpnam = "after_clause_$clause";
    if ($th->can($tmpnam)) {
        $th->$tmpnam($cd);
    }
    if ($th->can("after_clause")) {
        $th->after_clause($cd);
    }
    if ($self->can("after_clause")) {
        $self->after_clause($cd);
    }

    delete $cd->{uclset}{"$clause.err_msg"};
    delete $cd->{uclset}{"$clause.err_level"};
    delete $cd->{uclset}{$_} for
        grep {/\A\Q$clause\E\.human(\..+)?\z/} keys(%{$cd->{uclset}});
}

    my ($self, $cd, $which) = @_;

    # $which can be left undef/false if called from compile(), or set to 'from
    # clause_clset' if called from within clause_clset(), in which case
    # before_handle_type, handle_type, before_all_clauses, and after_all_clauses
    # won't be called.

    my $th = $cd->{th};
    my $tn = $cd->{type};
    my $clsets = $cd->{clsets};

    my $cname = $self->name;
    local $cd->{uclsets} = [];
    $cd->{_clset_dlangs} = []; # default lang for each clset
    for my $clset (@$clsets) {
        for (keys %$clset) {
            if (!$cd->{args}{allow_expr} && /\.is_expr\z/ && $clset->{$_}) {
                $self->_die($cd, "Expression not allowed: $_");
            }
        }
        $cd->{coerce_to} //= $clset->{'x.perl.coerce_to'} if $clset->{'x.perl.coerce_to'};
        push @{ $cd->{uclsets} }, {
            map {$_=>$clset->{$_}}
                grep {
                    !/\A_|\._|\Ax\./ && (!/\Ac\./ || /\Ac\.\Q$cname\E\./)
                } keys %$clset
        };
        my $dl = $clset->{default_lang} //
            ($cd->{outer_cd} ? $cd->{outer_cd}{clset_dlang} : undef) //
                "en_US";
        push @{ $cd->{_clset_dlangs} }, $dl;
    }

    my $clauses = $self->_get_clauses_from_clsets($cd, $clsets);
    $cd->{has_constraint_clause} = 0;
    $cd->{has_subschema} = 0;
    #$cd->{inspect_elem} = 0; # currently not needed
    for my $cl (@$clauses) {
        # 0=clset_num, 1=cl name, 2=cl meta
        next if $cl->[1] =~ /\A(req|forbidden)\z/;
        $cd->{has_subschema} = 1 if $cl->[2]{subschema};
        #$cd->{inspect_elem}  = 1 if $cl->[2]{inspect_elem};
        if ($cl->[2]{tags} && grep {$_ eq 'constraint'} @{ $cl->[2]{tags} }) {
            $cd->{has_constraint_clause} = 1;
        }
    }

    if ($which) {
        # {before,after}_clause_sets is currently internal/undocumented, created
        # only for clause_clset
        if ($self->can("before_clause_sets")) {
            $self->before_clause_sets($cd);
        }
        if ($th->can("before_clause_sets")) {
            $th->before_clause_sets($cd);
        }
    } else {
        if ($self->can("before_handle_type")) {
            $self->before_handle_type($cd);
        }

        $th->handle_type($cd);

        if ($self->can("before_all_clauses")) {
            $self->before_all_clauses($cd);
        }
        if ($th->can("before_all_clauses")) {
            $th->before_all_clauses($cd);
        }
    }

    for my $clause0 (@$clauses) {
        my ($clset_num, $clause) = @$clause0;
        $self->_process_clause($cd, $clset_num, $clause);
    } # for clause

    for my $uclset (@{ $cd->{uclsets} }) {
        if (keys %$uclset) {
            for ($cd->{args}{on_unhandled_attr}) {
                my $msg = "Unhandled attribute(s) for type $tn: ".
                    join(", ", keys %$uclset);
                next if $_ eq 'ignore';
                do { warn $msg; next } if $_ eq 'warn';
                $self->_die($cd, $msg);
            }
        }
    }

    if ($which) {
        # {before,after}_clause_sets is currently internal/undocumented, created
        # only for clause_clset
        if ($th->can("after_clause_sets")) {
            $th->after_clause_sets($cd);
        }
        if ($self->can("after_clause_sets")) {
            $self->after_clause_sets($cd);
        }
    } else {
        if ($th->can("after_all_clauses")) {
            $th->after_all_clauses($cd);
        }
        if ($self->can("after_all_clauses")) {
            $self->after_all_clauses($cd);
        }
    }
}

    my ($self, %args) = @_;

    # XXX schema
    $self->check_compile_args(\%args);

    my $main   = $self->main;
    my $cd     = $self->init_cd(%args);

    if ($self->can("before_compile")) {
        $self->before_compile($cd);
    }

    # normalize schema
    my $schema0 = $args{schema} or $self->_die($cd, "No schema");
    my $nschema;
    if ($args{schema_is_normalized}) {
        $nschema = $schema0;
        #$log->tracef("schema already normalized, skipped normalization");
    } else {
        $nschema = $main->normalize_schema($schema0);
        #$log->tracef("normalized schema=%s", $nschema);
    }
    $cd->{nschema} = $nschema;
    local $cd->{schema} = $nschema;

    if ($self->can("before_resolve")) {
        my $res = $self->before_resolve($cd);
        return $cd if ($res//0) == 99;
    }

    require Data::Sah::Resolve;
    my $res = Data::Sah::Resolve::resolve_schema(
        {
            schema_is_normalized => 1,
            allow_base_with_no_additional_clauses => 1,
            %{$args{resolve_opts} // {}},
        },
        $nschema);
    my $tn        = $res->{type};
    $cd->{th}     = $self->get_th(name=>$tn, cd=>$cd);
    $cd->{type}   = $tn;
    if ($nschema->[0] ne $tn) {
        $self->add_compile_module($cd, "Sah::Schema::$nschema->[0]");
    }
    if ($args{cache} && $res->{base} && $res->{base} ne $res->{type}) {
        $cd->{base_schema} = $res->{base};
        $cd->{clsets} = $res->{"clsets_after_base"};
    } else {
        delete $cd->{base_schema};
        $cd->{clsets} = $res->{"clsets_after_type.alt.merge.merged"};
    }

    $self->_process_clsets($cd);

    if ($self->can("after_compile")) {
        $self->after_compile($cd);
    }

    if ($args{log_result}) {# && $log->is_trace) {
        log_trace(
            "Schema compilation result (compiler=%s):\n%s",
            ref($self),
            !ref($cd->{result}) && ($ENV{LINENUM} // 1) ?
                __linenum($cd->{result}) :
                $cd->{result}
            );
    }
    return $cd;
}

    my ($self, $cd) = @_;
    my $cl = $cd->{clause};
    delete $cd->{uclset}{$cl};
}

    my ($self, $cd) = @_;
    my $cl = $cd->{clause};
    delete $cd->{uclset}{$cl};
    delete $cd->{uclset}{$_} for grep {/\A\Q$cl\E\./} keys %{$cd->{uclset}};
}

    my ($self, $cd, $note) = @_;

    $self->_die($cd, "Clause '$cd->{clause}' for type '$cd->{type}' ".
                    ($note ? "($note) " : "") .
                        "is currently unimplemented");
}

    my ($self, $cd, $name, $extra_keys, $allow_duplicate) = @_;

    my $found;
    for (@{ $cd->{modules} }) {
        if ($_->{name} eq $name && $_->{phase} eq $extra_keys->{phase}) {
            $found++;
            last;
        }
    }
    return if $found && !$allow_duplicate;
    push @{ $cd->{modules} }, {
        name => $name,
        %{ $extra_keys // {} },
    };
}

    my ($self, $cd, $name, $extra_keys, $allow_duplicate) = @_;

    if ($extra_keys) {
        $extra_keys = { %$extra_keys, phase => 'runtime' };
    } else {
        $extra_keys = { phase => 'runtime' };
    }
    $self->add_module($cd, $name, $extra_keys, $allow_duplicate);
}

    my ($self, $cd, $name, $extra_keys, $allow_duplicate) = @_;

    if ($extra_keys) {
        $extra_keys = { %$extra_keys, phase => 'compile' };
    } else {
        $extra_keys = { phase => 'compile' };
    }
    $self->add_module($cd, $name, $extra_keys, $allow_duplicate);
}

1;
# ABSTRACT: Base class for Sah compilers (Data::Sah::Compiler::*)


=pod

=encoding UTF-8

=head1 NAME

Data::Sah::Compiler - Base class for Sah compilers (Data::Sah::Compiler::*)

=head1 VERSION

This document describes version 0.914 of Data::Sah::Compiler (from Perl distribution Data-Sah), released on 2022-10-19.

=for Pod::Coverage ^(check_compile_args|def|expr|init_cd|literal|name|add_module|add_compile_module|add_runtime_module)$

=head1 COMPILATION DATA KEYS

=over

=item * v => int

Version of compilation data structure. Currently at 2. Whenever there's a
backward-incompatible change introduced in the structure, this version number
will be bumped. Client code can check this key to deliberately fail when it
encounters version number that it can't handle.

=item * args => HASH

Arguments given to C<compile()>.

=item * compiler => OBJ

The compiler object.

=item * compiler_name => str

Compiler name, e.g. C<perl>, C<js>.

=item * is_inner => bool

Convenience. Will be set to 1 when this compilation is a subcompilation (i.e.
compilation of a subschema). You can also check for C<outer_cd> to find out if
this compilation is an inner compilation.

=item * outer_cd => HASH

If compilation is called from within another C<compile()>, this will be set to
the outer compilation's C<$cd>. The inner compilation will inherit some values
from the outer, like list of types (C<th_map>) and function sets (C<fsh_map>).

=item * th_map => HASH

Mapping of fully-qualified type names like C<int> and its
C<Data::Sah::Compiler::*::TH::*> type handler object (or array, a normalized
schema).

=item * fsh_map => HASH

Mapping of function set name like C<core> and its
C<Data::Sah::Compiler::*::FSH::*> handler object.

=item * schema => ARRAY

The current schema (normalized) being processed. Since schema can contain other
schemas, there will be subcompilation and this value will not necessarily equal
to C<< $cd->{args}{schema} >>.

=item * spath = ARRAY

An array of strings, with empty array (C<[]>) as the root. Point to current
location in schema during compilation. Inner compilation will continue/append
the path.

Example:

 # spath, with pointer to location in the schema

 spath: ["elems"] ----
                      \
 schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]}

 spath: ["elems", 0] ------------
                                 \
 schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]}

 spath: ["elems", 1, "min"] ---------------------
                                                 \
 schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]}

 spath: ["elems", 2, "div_by", 1] -------------------------------------------------
                                                                                   \
 schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]}

Note: aside from C<spath>, there is also the analogous C<dpath> which points to
the location of I<data> (e.g. array element, hash key). But this is declared and
maintained by the generated code, not by the compiler.

=item * th => OBJ

Current type handler.

=item * type => STR

Current type name.

=item * clsets => ARRAY

All the clause sets. Each schema might have more than one clause set, due to
processing base type's clause set.

=item * clset => HASH

Current clause set being processed. Note that clauses are evaluated not strictly
in clset order, but instead based on expression dependencies and priority.

=item * clset_dlang => HASH

Default language of the current clause set. This value is taken from C<<
$cd->{clset}{default_lang} >> or C<< $cd->{outer_cd}{default_lang} >> or the
default C<en_US>.

=item * clset_num => INT

Set to 0 for the first clause set, 1 for the second, and so on. Due to merging,
we might process more than one clause set during compilation.

=item * uclset => HASH

Short for "unprocessed clause set", a shallow copy of C<clset>, keys will be
removed from here as they are processed by clause handlers, remaining keys after
processing the clause set means they are not recognized by hooks and thus
constitutes an error.

=item * uclsets => ARRAY

All the C<uclset> for each clause set.

=item * clause => STR

Current clause name.

=item * cl_meta => HASH

Metadata information about the clause, from the clause definition. This include
C<prio> (priority), C<attrs> (list of attributes specific for this clause),
C<allow_expr> (whether clause allows expression in its value), etc. See
C<Data::Sah::Type::$TYPENAME> for more information.

=item * cl_value => ANY

Clause value. Note: for putting in generated code, use C<cl_term>.

The clause value will be coerced if there are applicable coercion rules. To get
the raw/original value as the schema specifies it, see C<cl_raw_value>.

=item * cl_raw_value => any

Like C<cl_value>, but without any coercion/filtering done to the value.

=item * cl_term => STR

Clause value term. If clause value is a literal (C<.is_expr> is false) then it
is produced by passing clause value to C<literal()>. Otherwise, it is produced
by passing clause value to C<expr()>.

=item * cl_is_expr => BOOL

A copy of C<< $cd->{clset}{"${clause}.is_expr"} >>, for convenience.

=item * cl_op => STR

A copy of C<< $cd->{clset}{"${clause}.op"} >>, for convenience.

=item * cl_is_multi => BOOL

Set to true if cl_value contains multiple clause values. This will happen if
C<.op> is either C<and>, C<or>, or C<none> and C<< $cd->{CLAUSE_DO_MULTI} >> is
set to true.

=item * indent_level => INT

Current level of indent when printing result using C<< $c->line() >>. 0 means
unindented.

=item * all_expr_vars => ARRAY

All variables in all expressions in the current schema (and all of its
subschemas). Used internally by compiler. For example (XXX syntax not not
finalized):

 # schema
 [array => {of=>'str1', min_len=>1, 'max_len=' => '$min_len*3'},
  {def => {
      str1 => [str => {min_len=>6, 'max_len=' => '$min_len*2',
                       check=>'substr($_,0,1) eq "a"'}],
  }}]

 all_expr_vars => ['schema:///clsets/0/min_len', # or perhaps .../min_len/value
                   'schema://str1/clsets/0/min_len']

This data can be used to order the compilation of clauses based on dependencies.
In the above example, C<min_len> needs to be evaluated before C<max_len>
(especially if C<min_len> is an expression).

=item * modules => array of hash

List of modules that are required, one way or another. Each element is a hash
which must contain at least the C<name> key (module name). There are other keys
like C<version> (minimum version), C<phase> (explained below). Some languages
might add other keys, like C<perl> with C<use_statement> (statement to load/use
the module, used by e.g. pragmas like C<no warnings 'void'> which are not the
regular C<require MODULE> statement). Generally, duplicate entries (entries with
the same C<name> and C<phase>) are avoided, except in special cases like Perl
pragmas.

There are I<runtime> modules (C<phase> key set to C<runtime>), which are
required by the generated code when running. For each entry, the only required
key is C<name>. Other keys include: C<version> (minimum version). Some languages
have some additional rule for this, e.g. perl has C<use_statement> (how to use
the module, e.g. for pragma, like C<no warnings 'void'>).

There are also I<compile-time> modules (C<phase> key set to C<compile>), which
are required during compilation of schema. This include coercion rule modules
like L<Data::Sah::Coerce::perl::To_date::From_float::Epoch>, and so on. This
information might be useful for distributions that use Data::Sah. Because
Data::Sah is a modular library, where there are third party extensions for
types, coercion rules, and so on, listing these modules as dependencies instead
of a single C<Data::Sah> will ensure that dependants will pull the right
distribution during installation.

=item * ccls => [HASH, ...]

(Result) Compiled clauses, collected during processing of schema's clauses. Each
element will contain the compiled code in the target language, error message,
and other information. At the end of processing, these will be joined together.

=item * result => ...

(Result) The final result. For most compilers, it will be string/text.

=item * has_constraint_clause => bool

Convenience. True if there is at least one constraint clause in the schema. This
I<excludes> special clause C<req> and C<forbidden>.

=item * has_subschema => bool

Convenience. True if there is at least one clause which contains a subschema.

=back

=head1 ATTRIBUTES

=head2 main => OBJ

Reference to the main Data::Sah object.

=head2 expr_compiler => OBJ

Reference to expression compiler object. In the perl compiler, for example, this
will be an instance of L<Language::Expr::Compiler::Perl> object.

=head1 METHODS

=head2 new() => OBJ

=head2 $c->compile(%args) => HASH

Compile schema into target language.

Arguments (C<*> denotes required arguments, subclass may introduce others):

=over 4

=item * data_name => STR (default: 'data')

A unique name. Will be used as default for variable names, etc. Should only be
comprised of letters/numbers/underscores.

=item * schema* => STR|ARRAY

The schema to use. Will be normalized by compiler, unless
C<schema_is_normalized> is set to true.

=item * lang => STR (default: from LANG/LANGUAGE or C<en_US>)

Desired output human language. Defaults (and falls back to) C<en_US>.

=item * mark_missing_translation => BOOL (default: 1)

If a piece of text is not found in desired human language, C<en_US> version of
the text will be used but using this format:

 (en_US:the text to be translated)

If you do not want this marker, set the C<mark_missing_translation> option to 0.

=item * locale => STR

Locale name, to be set during generating human text description. This sometimes
needs to be if setlocale() fails to set locale using only C<lang>.

=item * schema_is_normalized => BOOL (default: 0)

If set to true, instruct the compiler not to normalize the input schema and
assume it is already normalized.

=item * allow_expr => BOOL (default: 1)

Whether to allow expressions. If false, will die when encountering expression
during compilation. Usually set to false for security reason, to disallow
complex expressions when schemas come from untrusted sources.

=item * on_unhandled_attr => STR (default: 'die')

What to do when an attribute can't be handled by compiler (either it is an
invalid attribute, or the compiler has not implemented it yet). Valid values
include: C<die>, C<warn>, C<ignore>.

=item * on_unhandled_clause => STR (default: 'die')

What to do when a clause can't be handled by compiler (either it is an invalid
clause, or the compiler has not implemented it yet). Valid values include:
C<die>, C<warn>, C<ignore>.

=item * indent_level => INT (default: 0)

Start at a specified indent level. Useful when generated code will be inserted
into another code (e.g. inside C<sub {}> where it is nice to be able to indent
the inside code).

=item * skip_clause => ARRAY (default: [])

List of clauses to skip (to assume as if it did not exist). Example when
compiling with the human compiler:

 # schema
 [int => {default=>1, between=>[1, 10]}]

 # generated human description in English
 integer, between 1 and 10, default 1

 # generated human description, with skip_clause => ['default']
 integer, between 1 and 10

=back

=head3 Compilation data

During compilation, compile() will call various hooks (listed below). The hooks
will be passed compilation data (C<$cd>) which is a hashref containing various
compilation state and result. Compilation data is written to this hashref
instead of on the object's attributes to make it easy to do recursive
compilation (compilation of subschemas).

Keys that are put into this compilation data include input data, compilation
state, and others. Many of these keys might exist only temporarily during
certain phases of compilation and will no longer exist at the end of
compilation, for example C<clause> will only exist during processing of a clause
and will be seen by hooks like C<before_clause> and C<after_clause>, it will not
be seen by C<before_all_clauses> or C<after_compile>.

For a list of keys, see L</"COMPILATION DATA KEYS">. Subclasses may add more
data; see their respective documentation.

=head3 Return value

The compilation data will be returned as return value. Main result will be in
the C<result> key. There is also C<ccls>, and subclasses may put additional
results in other keys. Final usable result might need to be pieced together from
these results, depending on your needs.

=head3 Hooks

By default this base compiler does not define any hooks; subclasses can define
hooks to implement their compilation process. Each hook will be passed
compilation data, and should modify or set the compilation data as needed. The
hooks that compile() will call at various points, in calling order, are:

=over 4

=item * $c->before_compile($cd)

Called once at the beginning of compilation.

=item * $c->before_handle_type($cd)

=item * $th->handle_type($cd)

=item * $c->before_all_clauses($cd)

Called before calling handler for any clauses.

=item * $th->before_all_clauses($cd)

Called before calling handler for any clauses, after compiler's
before_all_clauses().

=item * $c->before_clause($cd)

Called for each clause, before calling the actual clause handler
($th->clause_NAME() or $th->clause).

=item * $th->before_clause($cd)

After compiler's before_clause() is called, I<type handler>'s before_clause()
will also be called if available.

Input and output interpretation is the same as compiler's before_clause().

=item * $th->before_clause_NAME($cd)

Can be used to customize clause.

Introduced in v0.10.

=item * $th->clause_NAME($cd)

Clause handler. Will be called only once (if C<$cd->{CLAUSE_DO_MULTI}> is set to
by other hooks before this) or once for each value in a multi-value clause (e.g.
when C<.op> attribute is set to C<and> or C<or>). For example, in this schema:

 [int => {"div_by&" => [2, 3, 5]}]

C<clause_div_by()> can be called only once with C<< $cd->{cl_value} >> set to
[2, 3, 5] or three times, each with C<< $cd->{value} >> set to 2, 3, and 5
respectively.

=item * $th->after_clause_NAME($cd)

Can be used to customize clause.

Introduced in v0.10.

=item * $th->after_clause($cd)

Called for each clause, after calling the actual clause handler
($th->clause_NAME()).

=item * $c->after_clause($cd)

Called for each clause, after calling the actual clause handler
($th->clause_NAME()).

Output interpretation is the same as $th->after_clause().

=item * $th->after_all_clauses($cd)

Called after all clauses have been compiled, before compiler's
after_all_clauses().

=item * $c->after_all_clauses($cd)

Called after all clauses have been compiled.

=item * $c->after_compile($cd)

Called at the very end before compiling process end.

=back

=head2 $c->get_th

=head2 $c->get_fsh

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.

=head1 AUTHOR

perlancar <[e-mail]>

=head1 CONTRIBUTING


To contribute, you can send patches by email/via RT, or send pull requests on
GitHub.

Most of the time, you don't need to build the distribution yourself. You can
simply modify the code, then test via:

 % prove -l

If you want to build the distribution (e.g. to try to install it locally on your
system), you can install L<Dist::Zilla>,
L<Dist::Zilla::PluginBundle::Author::PERLANCAR>,
L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond
that are considered a bug and can be reported to me.

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2022, 2021, 2020, 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar <[e-mail]>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=cut