view release on metacpan or  search on metacpan

lib/Perinci/Sub/Wrapper.pm  view on Meta::CPAN

                exists($sch->[1]{default}) ? 1:0;
            if ($opt_va) {

                $self->push_lines("if (exists($argterm)) {");
                $self->indent;

                if ($argspec->{stream}) {
                    die "Error in schema for argument '$argname': must be str/buf/array if stream=1"
                        unless $sch->[0] =~ /\A(str|buf|array)\z/; # XXX allow 'any' if all of its 'of' values are str/buf/array
                    die "Error in schema for argument '$argname': must specify 'of' array clause if stream=1"
                        if $sch->[0] eq 'array' && !$sch->[1]{of};

                    $self->_errif(
                        400,
                        qq["Argument '$prefix$argname' (stream) fails validation: must be coderef"],
                        "!(ref($argterm) eq 'CODE')",
                    );
                    $self->push_lines('{ ## introduce scope because we want to declare a generic variable $i');
                    $self->indent;
                    $self->push_lines(
                        'my $i = -1;',
                        "my \$origsub = $argterm;",
                        '# arg coderef wrapper for validation',
                        "$argterm = sub {",
                    );
                    $self->indent;
                    $self->push_lines(
                        '$i++;',
                        "my \$rec = \$origsub->();",
                        'return undef unless defined $rec;',
                    );
                }

                my $dn = $argname; $dn =~ s/\W+/_/g;
                my $cd = $self->_plc->compile(
                    data_name            => $dn,
                    data_term            => $argspec->{stream} ? '$rec' : $argterm,
                    schema               => $argspec->{stream} && $sch->[0] eq 'array' ? $sch->[1]{of} : $sch,
                    schema_is_normalized => $opt_sin,
                    return_type          => 'str',
                    indent_level         => $self->get_indent_level + 1,
                    core                 => $self->{_args}{core},
                    core_or_pp           => $self->{_args}{core_or_pp},
                    pp                   => $self->{_args}{pp},
                    %{ $self->{_args}{_extra_sah_compiler_args} // {}},
                );
                die "Incompatible Data::Sah version (cd v=$cd->{v}, expected 2)" unless $cd->{v} == 2;
                for my $mod_rec (@{ $cd->{modules} }) {
                    next unless $mod_rec->{phase} eq 'runtime';
                    $self->_add_module($mod_rec->{use_statement} // $mod_rec->{name});
                }
                $self->_add_var($_, $cd->{vars}{$_})
                    for sort keys %{ $cd->{vars} };
                $cd->{result} =~ s/\A\s+//;
                $self->push_lines(
                    "my \$err_$dn;",
                    "$cd->{result};",
                );
                if ($argspec->{stream}) {
                    $self->push_lines(
                        'if ('."\$err_$dn".') { die "Record #$i of streaming argument '."'$prefix$argname'".' ($rec) fails validation: '."\$err_$dn".'" }',
                        '$rec;',
                    );
                } else {
                    $self->_errif(
                        400, qq["Argument '$prefix$argname' fails validation: \$err_$dn"],
                        "\$err_$dn");
                }
                if ($argspec->{meta}) {
                    $self->push_lines("# check subargs of $prefix$argname");
                    $self->_handle_args(
                            %args,
                            v => $argspec->{meta}{args},
                            prefix => ($prefix ? "$prefix/" : "") . "$argname/",
                            argsterm => '%{'.$argterm.'}',
                        );
                }
                if ($argspec->{element_meta}) {
                    $self->push_lines("# check element subargs of $prefix$argname");
                    my $indexterm = "$prefix$argname";
                    $indexterm =~ s/\W+/_/g;
                    $indexterm = '$i_' . $indexterm;
                    $self->push_lines('for my '.$indexterm.' (0..$#{ '.$argterm.' }) {');
                    $self->indent;
                    $self->_errif(
                        400, qq("Argument '$prefix$argname\[).qq($indexterm]' fails validation: must be hash"),
                        "ref($argterm\->[$indexterm]) ne 'HASH'");
                    $self->_handle_args(
                        %args,
                        v => $argspec->{element_meta}{args},
                        prefix => ($prefix ? "$prefix/" : "") . "$argname\[$indexterm]/",
                        argsterm => '%{'.$argterm.'->['.$indexterm.']}',
                    );
                    $self->unindent;
                    $self->push_lines('}');
                }
                $self->unindent;
                if ($argspec->{stream}) {
                    $self->push_lines('}; ## arg coderef wrapper');
                    $self->unindent;
                    $self->push_lines('} ## close scope');
                    $self->unindent;
                }
                if ($has_default_prop) {
                    $self->push_lines(
                        '} else {',
                        "    $argterm //= ".dmp($argspec->{default}).";");
                } elsif ($has_sch_default) {
                    $self->push_lines(
                        '} else {',
                        "    $argterm //= ".dmp($sch->[1]{default}).";");
                }
                $self->push_lines("} ## if exists arg $prefix$argname");
            } # if opt_va

        } elsif ($has_default_prop) {
            # doesn't have schema but have 'default' property, we still need to
            # set default here
            $self->push_lines("$argterm = ".dmp($argspec->{default}).
                                  " if !exists($argterm);");
        }