view release on metacpan or  search on metacpan

script/pick-random-lines  view on Meta::CPAN

#
#This software is copyright (c) 2022, 2018, 2015, 2014 by perlancar <perlancar@cpan.org>.
#
#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-Normalize>
#
#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
### Data/Sah/Resolve.pm ###
#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 {