view release on metacpan or  search on metacpan

lib/Data/Sah/Resolve.pm  view on Meta::CPAN

package Data::Sah::Resolve;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-07-29'; # DATE
our $DIST = 'Data-Sah-Resolve'; # DIST
our $VERSION = '0.011'; # VERSION

use 5.010001;
use strict;
use warnings;

use Exporter qw(import);
our @EXPORT_OK = qw(resolve_schema);

sub _clset_has_merge {
    my $clset = shift;
    for (keys %$clset) {
        return 1 if /\Amerge\./;
    }
    0;
}

sub _resolve {
    my ($opts, $res) = @_;

    my $type = $res->{type};
    die "Cannot resolve Sah schema: circular schema definition: ".
        join(" -> ", @{$res->{resolve_path}}, $type)
        if grep { $type eq $_ } @{$res->{resolve_path}};

    unshift @{$res->{resolve_path}}, $type;

    # check whether $type is a built-in Sah type
    (my $typemod_pm = "Data/Sah/Type/$type.pm") =~ s!::!/!g;
    eval { require $typemod_pm; 1 };
    my $err = $@;
    unless ($err) {
        # already a builtin-type, so we stop here
        return;
    }
    die "Cannot resolve Sah schema: can't check whether $type is a builtin Sah type: $err"
        unless $err =~ /\ACan't locate/;

    # not a type, try a schema under Sah::Schema
    my $schmod = "Sah::Schema::$type";
    (my $schmod_pm = "$schmod.pm") =~ s!::!/!g;
    eval { require $schmod_pm; 1 };
    die "Cannot resolve Sah schema: not a known built-in Sah type '$type' (can't locate ".
        "Data::Sah::Type::$type) and not a known schema name '$type' ($@)"
            if $@;
    no strict 'refs';
    my $sch2 = ${"$schmod\::schema"};
    die "Cannot resolve Sah schema: BUG: Schema module $schmod doesn't contain \$schema"
        unless $sch2;
    $res->{type} = $sch2->[0];
    unshift @{ $res->{clsets_after_type} }, $sch2->[1];
    _resolve($opts, $res);
}

sub resolve_schema {
    my $opts = ref($_[0]) eq 'HASH' ? shift : {};
    my $sch = shift;

    # normalize
    unless ($opts->{schema_is_normalized}) {
        require Data::Sah::Normalize;
        $sch =  Data::Sah::Normalize::normalize_schema($sch);
    }

    my $res = {
        v => 2,
        type => $sch->[0],
        clsets_after_type => [$sch->[1]],
        resolve_path => [],
    };

    # resolve
    _resolve($opts, $res);

    # determine the "base restrictions" base
    my @clsets_have_merge;
    my $has_merge_prefixes; # whether any of the clsets have merge prefixes
    for (@{ $res->{clsets_after_type} }) {
        push @clsets_have_merge, _clset_has_merge($_);
        $has_merge_prefixes++ if $clsets_have_merge[-1];
    }
    # TODO: sanity check: the innermost base schema should not have merge prefixes
    my $idx = $#clsets_have_merge;
    while ($idx >= 0) {
        if ($opts->{allow_base_with_no_additional_clauses}) {
            last if !$clsets_have_merge[$idx];
        } else {
            last if keys(%{$res->{clsets_after_type}[$idx]}) > 0 && !$clsets_have_merge[$idx];
        }
        $idx--;
    }
    #use DD; dd $res->{clsets_after_type}; dd \@clsets_have_merge;
    $res->{base} = $res->{resolve_path}[$idx];
    $res->{clsets_after_base} = [grep {keys(%$_) > 0} @{ $res->{clsets_after_type} }[$idx .. $#clsets_have_merge]];

    # merge
    my @merged_clsets;
  MERGE: {
        unless ($has_merge_prefixes) {
            @merged_clsets = grep { keys(%$_)>0 } @{ $res->{clsets_after_type} };
            last;
        }
        @merged_clsets = ($res->{clsets_after_type}[0]);
        for my $i (1 .. $#clsets_have_merge) {
            my $clset = $res->{clsets_after_type}[$i];
            next unless keys(%$clset) > 0;
            if ($clsets_have_merge[$i]) {
                state $merger = do {