File Coverage

blib/lib/Perinci/Sub/Util/Args.pm

Criterion	Covered	Total	%
statement	69	79	87.3
branch	27	38	71.0
condition	12	12	100.0
subroutine	10	10	100.0
pod	5	5	100.0
total	123	144	85.4

package Perinci::Sub::Util::Args;

use 5.010001;
use strict 'subs', 'vars';
use warnings;

use Exporter qw(import);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2023-07-02'; # DATE
our $DIST = 'Perinci-Sub-Util'; # DIST
our $VERSION = '0.471'; # VERSION

our @EXPORT_OK = qw(
                       args_by_tag
                       argnames_by_tag
                       func_args_by_tag
                       func_argnames_by_tag
                       call_with_its_args
);

sub args_by_tag {
    my ($meta, $args, $tag) = @_;

    my @res;
    my $args_prop = $meta->{args} or return ();
    my $neg = $tag =~ s/\A!//;
    for my $argname (keys %$args_prop) {
        my $argspec = $args_prop->{$argname};
        if ($neg) {
            next unless !$argspec->{tags} ||
                !(grep {$_ eq $tag} @{$argspec->{tags}});
        } else {
            next unless $argspec->{tags} &&
                grep {$_ eq $tag} @{$argspec->{tags}};
        }
        push @res, $argname, $args->{$argname}
            if exists $args->{$argname};
    }
    @res;
}

sub argnames_by_tag {
    my ($meta, $tag) = @_;

    my @res;
    my $args_prop = $meta->{args} or return ();
    my $neg; $neg = 1 if $tag =~ s/\A!//;
    for my $argname (keys %$args_prop) {
        my $argspec = $args_prop->{$argname};
        if ($neg) {
            next unless !$argspec->{tags} ||
                !(grep {$_ eq $tag} @{$argspec->{tags}});
        } else {
            next unless $argspec->{tags} &&
                grep {$_ eq $tag} @{$argspec->{tags}};
        }
        push @res, $argname;
    }
    sort @res;
}

sub _find_meta {
    my $caller = shift;
    my $func_name = shift;

    if ($func_name =~ /(.+)::(.+)/) {
        return ${"$1::SPEC"}{$2};
    } else {
        return ${"$caller->[0]::SPEC"}{$func_name};
    }
}

sub func_args_by_tag {
    my ($func_name, $args, $tag) = @_;
    my $meta = _find_meta([caller(1)], $func_name)
        or die "Can't find Rinci function metadata for $func_name";
    args_by_tag($meta, $args, $tag);
}

sub func_argnames_by_tag {
    my ($func_name, $tag) = @_;
    my $meta = _find_meta([caller(1)], $func_name)
        or die "Can't find Rinci function metadata for $func_name";
    argnames_by_tag($meta, $tag);
}

sub call_with_its_args {
    my ($func_name, $args) = @_;

    my ($meta, $func);
    if ($func_name =~ /(.+)::(.+)/) {
        defined &{$func_name}
            or die "Function $func_name not defined";
        $func = \&{$func_name};
        $meta = ${"$1::SPEC"}{$2};
    } else {
        my @caller = caller(1);
        my $fullname = "$caller[0]::$func_name";
        defined &{$fullname}
            or die "Function $fullname not defined";
        $func = \&{$fullname};
        $meta = ${"$caller[0]::SPEC"}{$func_name};
    }
    $meta or die "Can't find Rinci function metadata for $func_name";

    my @args;
    if ($meta->{args}) {
        for my $argname (keys %{ $meta->{args} }) {
            push @args, $argname, $args->{$argname}
                if exists $args->{$argname};
        }
    }
    $func->(@args);
}

1;
# ABSTRACT: Utility routines related to Rinci arguments

__END__