File Coverage

blib/lib/Perinci/Sub/Util.pm

Criterion	Covered	Total	%
statement	125	159	78.6
branch	44	74	59.4
condition	16	37	43.2
subroutine	12	15	80.0
pod	6	6	100.0
total	203	291	69.7

package Perinci::Sub::Util;

our $DATE = '2017-01-31'; # DATE
our $VERSION = '0.46'; # VERSION

use 5.010001;
use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
                       err
                       caller
                       warn_err
                       die_err
                       gen_modified_sub
                       gen_curried_sub
               );

our %SPEC;

$SPEC{':package'} = {
    v => 1.1,
    summary => 'Helper when writing functions',
};

our $STACK_TRACE;
our @_c; # to store temporary celler() result
our $_i; # temporary variable
sub err {
    require Scalar::Util;

    # get information about caller
    my @caller = CORE::caller(1);
    if (!@caller) {
        # probably called from command-line (-e)
        @caller = ("main", "-e", 1, "program");
    }

    my ($status, $msg, $meta, $prev);

    for (@_) {
        my $ref = ref($_);
        if ($ref eq 'ARRAY') { $prev = $_ }
        elsif ($ref eq 'HASH') { $meta = $_ }
        elsif (!$ref) {
            if (Scalar::Util::looks_like_number($_)) {
                $status = $_;
            } else {
                $msg = $_;
            }
        }
    }

    $status //= 500;
    $msg  //= "$caller[3] failed";
    $meta //= {};
    $meta->{prev} //= $prev if $prev;

    # put information on who produced this error and where/when
    if (!$meta->{logs}) {

        # should we produce a stack trace?
        my $stack_trace;
        {
            no warnings;
            # we use Carp::Always as a sign that user wants stack traces
            last unless $STACK_TRACE // $INC{"Carp/Always.pm"};
            # stack trace is already there in previous result's log
            last if $prev && ref($prev->[3]) eq 'HASH' &&
                ref($prev->[3]{logs}) eq 'ARRAY' &&
                    ref($prev->[3]{logs}[0]) eq 'HASH' &&
                        $prev->[3]{logs}[0]{stack_trace};
            $stack_trace = [];
            $_i = 1;
            while (1) {
                {
                    package DB;
                    @_c = CORE::caller($_i);
                    if (@_c) {
                        $_c[4] = [@DB::args];
                    }
                }
                last unless @_c;
                push @$stack_trace, [@_c];
                $_i++;
            }
        }
        push @{ $meta->{logs} }, {
            type    => 'create',
            time    => time(),
            package => $caller[0],
            file    => $caller[1],
            line    => $caller[2],
            func    => $caller[3],
            ( stack_trace => $stack_trace ) x !!$stack_trace,
        };
    }

    #die;
    [$status, $msg, undef, $meta];
}

sub warn_err {
    require Carp;

    my $res = err(@_);
    Carp::carp("ERROR $res->[0]: $res->[1]");
}

sub die_err {
    require Carp;

    my $res = err(@_);
    Carp::croak("ERROR $res->[0]: $res->[1]");
}

sub caller {
    my $n0 = shift;
    my $n  = $n0 // 0;

    my $pkg = $Perinci::Sub::Wrapper::default_wrapped_package //
        'Perinci::Sub::Wrapped';

    my @r;
    my $i =  0;
    my $j = -1;
    while ($i <= $n+1) { # +1 for this sub itself
        $j++;
        @r = CORE::caller($j);
        last unless @r;
        if ($r[0] eq $pkg && $r[1] =~ /^\(eval /) {
            next;
        }
        $i++;
    }

    return unless @r;
    return defined($n0) ? @r : $r[0];
}

$SPEC{gen_modified_sub} = {
    v => 1.1,
    summary => 'Generate modified metadata (and subroutine) based on another',
    description => <<'_',

Often you'll want to create another sub (and its metadata) based on another, but
with some modifications, e.g. add/remove/rename some arguments, change summary,
add/remove some properties, and so on.

Instead of cloning the Rinci metadata and modify it manually yourself, this
routine provides some shortcuts.

You can specify base sub/metadata using `base_name` (string, subroutine name,
either qualified or not) or `base_code` (coderef) + `base_meta` (hash).

_
    args => {
        base_name => {
            summary => 'Subroutine name (either qualified or not)',
            schema => 'str*',
            description => <<'_',

If not qualified with package name, will be searched in the caller's package.
Rinci metadata will be searched in `%SPEC` package variable.

Alternatively, you can also specify `base_code` and `base_meta`.

_
        },
        base_code => {
            summary => 'Base subroutine code',
            schema  => 'code*',
            description => <<'_',

If you specify this, you'll also need to specify `base_meta`.

Alternatively, you can specify `base_name` instead, to let this routine search
the base subroutine from existing Perl package.

_
        },
        base_meta => {
            summary => 'Base Rinci metadata',
            schema  => 'hash*', # XXX defhash/rifunc
        },
        output_name => {
            summary => 'Where to install the modified sub',
            schema  => 'str*',
            description => <<'_',

Subroutine will be put in the specified name. If the name is not qualified with
package name, will use caller's package. If no `output_code` is specified, the
base subroutine reference will be assigned here.

Note that this argument is optional.

_
        },
        output_code => {
            summary => 'Code for the modified sub',
            schema  => 'code*',
            description => <<'_',

If not specified will use `base_code` (which will then be required).

_
        },
        summary => {
            summary => 'Summary for the mod subroutine',
            schema  => 'str*',
        },
        description => {
            summary => 'Description for the mod subroutine',
            schema  => 'str*',
        },
        remove_args => {
            summary => 'List of arguments to remove',
            schema  => 'array*',
        },
        add_args => {
            summary => 'Arguments to add',
            schema  => 'hash*',
        },
        replace_args => {
            summary => 'Arguments to add',
            schema  => 'hash*',
        },
        rename_args => {
            summary => 'Arguments to rename',
            schema  => 'hash*',
        },
        modify_args => {
            summary => 'Arguments to modify',
            description => <<'_',

For each argument you can specify a coderef. The coderef will receive the
argument ($arg_spec) and is expected to modify the argument specification.

_
            schema  => 'hash*',
        },
        modify_meta => {
            summary => 'Specify code to modify metadata',
            schema  => 'code*',
            description => <<'_',

Code will be called with arguments ($meta) where $meta is the cloned Rinci
metadata.

_
        },
        install_sub => {
            schema  => 'bool',
            default => 1,
        },
    },
    result => {
        schema => ['hash*' => {
            keys => {
                code => ['code*'],
                meta => ['hash*'], # XXX defhash/risub
            },
        }],
    },
};
sub gen_modified_sub {
    require Function::Fallback::CoreOrPP;

    my %args = @_;

    # get base code/meta
    my ($base_code, $base_meta);
    if ($args{base_name}) {
        my ($pkg, $leaf);
        if ($args{base_name} =~ /(.+)::(.+)/) {
            ($pkg, $leaf) = ($1, $2);
        } else {
            $pkg  = CORE::caller();
            $leaf = $args{base_name};
        }
        no strict 'refs';
        $base_code = \&{"$pkg\::$leaf"};
        $base_meta = ${"$pkg\::SPEC"}{$leaf};
        die "Can't find Rinci metadata for $pkg\::$leaf" unless $base_meta;
    } elsif ($args{base_meta}) {
        $base_meta = $args{base_meta};
        $base_code = $args{base_code}
            or die "Please specify base_code";
    } else {
        die "Please specify base_name or base_code+base_meta";
    }

    my $output_meta = Function::Fallback::CoreOrPP::clone($base_meta);
    my $output_code = $args{output_code} // $base_code;

    # modify metadata
    for (qw/summary description/) {
        $output_meta->{$_} = $args{$_} if $args{$_};
    }
    if ($args{remove_args}) {
        delete $output_meta->{args}{$_} for @{ $args{remove_args} };
    }
    if ($args{add_args}) {
        for my $k (keys %{ $args{add_args} }) {
            my $v = $args{add_args}{$k};
            die "Can't add arg '$k' in mod sub: already exists"
                if $output_meta->{args}{$k};
            $output_meta->{args}{$k} = $v;
        }
    }
    if ($args{replace_args}) {
        for my $k (keys %{ $args{replace_args} }) {
            my $v = $args{replace_args}{$k};
            die "Can't replace arg '$k' in mod sub: doesn't exist"
                unless $output_meta->{args}{$k};
            $output_meta->{args}{$k} = $v;
        }
    }
    if ($args{rename_args}) {
        for my $old (keys %{ $args{rename_args} }) {
            my $new = $args{rename_args}{$old};
            my $as = $output_meta->{args}{$old};
            die "Can't rename arg '$old' in mod sub: doesn't exist" unless $as;
            die "Can't rename arg '$old'->'$new' in mod sub: ".
                "new name already exist" if $output_meta->{args}{$new};
            $output_meta->{args}{$new} = $as;
            delete $output_meta->{args}{$old};
        }
    }
    if ($args{modify_args}) {
        for (keys %{ $args{modify_args} }) {
            $args{modify_args}{$_}->($output_meta->{args}{$_});
        }
    }
    if ($args{modify_meta}) {
        $args{modify_meta}->($output_meta);
    }

    # install
    if ($args{output_name}) {
        my ($pkg, $leaf);
        if ($args{output_name} =~ /(.+)::(.+)/) {
            ($pkg, $leaf) = ($1, $2);
        } else {
            $pkg  = CORE::caller();
            $leaf = $args{output_name};
        }
        no strict 'refs';
        no warnings 'redefine';
        *{"$pkg\::$leaf"}       = $output_code if $args{install_sub} // 1;
        ${"$pkg\::SPEC"}{$leaf} = $output_meta;
    }

    [200, "OK", {code=>$output_code, meta=>$output_meta}];
}

$SPEC{gen_curried_sub} = {
    v => 1.1,
    summary => 'Generate curried subroutine (and its metadata)',
    description => <<'_',

This is a more convenient helper than `gen_modified_sub` if you want to create a
new subroutine that has some of its arguments preset (so they no longer need to
be present in the new metadata).

For more general needs of modifying a subroutine (e.g. add some arguments,
modify some arguments, etc) use `gen_modified_sub`.

_
    args => {
        base_name => {
            summary => 'Subroutine name (either qualified or not)',
            schema => 'str*',
            description => <<'_',

If not qualified with package name, will be searched in the caller's package.
Rinci metadata will be searched in `%SPEC` package variable.

_
            req => 1,
            pos => 0,
        },
        set_args => {
            summary => 'Arguments to set',
            schema  => 'hash*',
        },
        output_name => {
            summary => 'Where to install the modified sub',
            schema  => 'str*',
            description => <<'_',

Subroutine will be put in the specified name. If the name is not qualified with
package name, will use caller's package.

_
            req => 1,
            pos => 2,
        },
    },
    args_as => 'array',
    result_naked => 1,
};
sub gen_curried_sub {
    my ($base_name, $set_args, $output_name) = @_;

    my $caller = CORE::caller();

    my ($base_pkg, $base_leaf);
    if ($base_name =~ /(.+)::(.+)/) {
        ($base_pkg, $base_leaf) = ($1, $2);
    } else {
        $base_pkg  = $caller;
        $base_leaf = $base_name;
    }

    my ($output_pkg, $output_leaf);
    if ($output_name =~ /(.+)::(.+)/) {
        ($output_pkg, $output_leaf) = ($1, $2);
    } else {
        $output_pkg  = $caller;
        $output_leaf = $output_name;
    }

    my $base_sub = \&{"$base_pkg\::$base_leaf"};

    my $res = gen_modified_sub(
        base_name   => "$base_pkg\::$base_leaf",
        output_name => "$output_pkg\::$output_leaf",
        output_code => sub {
            no strict 'refs';
            $base_sub->(@_, %$set_args);
        },
        remove_args => [keys %$set_args],
        install => 1,
    );

    die "Can't generate curried sub: $res->[0] - $res->[1]"
        unless $res->[0] == 200;

    1;
}

1;
# ABSTRACT: Helper when writing functions

__END__