File Coverage

blib/lib/Function/Return.pm

Criterion	Covered	Total	%
statement	160	197	81.2
branch	62	116	53.4
condition	4	4	100.0
subroutine	30	31	96.7
pod	3	3	100.0
total	259	351	73.7

package Function::Return;

use v5.14.0;
use warnings;

our $VERSION = "0.15";

use Attribute::Handlers;
use B::Hooks::EndOfScope;

use Scope::Upper ();
use Sub::Meta;
use Sub::Meta::Library;
use Sub::Meta::Finder::FunctionParameters;
use namespace::autoclean;

my @RETURN_ARGS;
my %NO_CHECK;

sub import {
    my $class = shift;
    my %args = @_;

    my $pkg = $args{pkg} ? $args{pkg} : scalar caller;
    $NO_CHECK{$pkg} = !!$args{no_check} if exists $args{no_check};

    {
        # allow importing package to use attribute
        no strict qw(refs);
        my $MODIFY_CODE_ATTRIBUTES = \&Attribute::Handlers::UNIVERSAL::MODIFY_CODE_ATTRIBUTES;
        *{"${pkg}::MODIFY_CODE_ATTRIBUTES"} = $MODIFY_CODE_ATTRIBUTES;
        *{"${pkg}::_ATTR_CODE_Return"} = $class->can('Return');
    }

    #
    # How to install meta information
    #   1. At the BEGIN phase, write down the meta information via the `Return` attribute.
    #   2. At the compile phase, install the meta information in bulk via this `import` subroutine.
    #
    # In short,
    #   once Function::Return#import is compiled, the meta-information can be retrieved.
    #
    # The Reason Why?
    #
    #   First NG CASE:
    #     At the **CHECK** phase, write down the meta information via the Return attribute. (Attribute::Handler's default case)
    #     Then, cannot support lazy load.
    #     Ref: case_lazy_load.t
    #
    #   Second NG CASE:
    #     At the compile phase, install the meta information in **each** via this **Return** attribute.
    #     Then, unable to retrieve meta information for Function::Return from places that are compiled before the Return attribute.
    #     Ref: case_load_and_get_meta.t
    #
    on_scope_end {
        while (my $args = shift @RETURN_ARGS) {
            my ($pkg, $sub, $types) = @$args;
            my $no_check = exists $NO_CHECK{$pkg} ? $NO_CHECK{$pkg} : ($ENV{FUNCTION_RETURN_NO_CHECK}//0);

            if ($no_check) {
                $class->_register_submeta($pkg, $sub, $types);
            }
            else {
                $class->_register_submeta_and_install($pkg, $sub, $types);
            }
        }
    };

    return;
}

sub Return :ATTR(CODE,BEGIN) {
    my $class = __PACKAGE__;
    my ($pkg, undef, $sub, undef, $types) = @_;
    $types //= [];

    push @RETURN_ARGS => [$pkg, $sub, $types];
    return;
}

sub meta {
    my ($sub) = @_;
    Sub::Meta::Library->get($sub);
}

sub wrap_sub {
    my ($class, $sub, $types) = @_;

    my $meta = Sub::Meta->new(sub => $sub);
    my $shortname = $meta->subname;

    { # check type
        my $file = $meta->file;
        my $line = $meta->line;
        for my $type (@$types) {
            for (qw/check get_message/) {
                die "Invalid type: $type. require `$_` method at $file line $line.\n"
                    unless $type->can($_)
            }
        }
    }

    my @src;
    push @src => sprintf('_croak "Required list context in fun %s because of multiple return values function" if !wantarray;', $shortname) if @$types > 1;

    # force LIST context.
    push @src => 'my @ret = &Scope::Upper::uplevel($sub, @_, &Scope::Upper::CALLER(0));';

    # return Empty List
    push @src => 'return if !@ret;' if @$types == 0;

    # check count
    push @src => sprintf(q|_croak qq!Too few return values for fun %s (expected %s, got @{[map { defined $_ ? $_ : 'undef' } @ret]})! if @ret < %d;|,
                         $shortname, "@$types", scalar @$types) if @$types > 0;

    push @src => sprintf(q|_croak qq!Too many return values for fun %s (expected %s, got @{[map { defined $_ ? $_ : 'undef' } @ret]})! if @ret > %d;|,
                         $shortname, "@$types", scalar @$types);

    # type check
    for my $i (0 .. $#$types) {
        push @src => sprintf(q|_croak qq!Invalid return in fun %s: return %d: @{[$types->[%d]->get_message($ret[%d])]}! unless $types->[%d]->check($ret[%d]);|, $shortname, $i, $i, $i, $i,$i)
    }

    push @src => 'return @ret;'    if @$types > 1;
    push @src => 'return $ret[0];' if @$types == 1;

    my $src = join "\n", @src;
    my $code = eval "sub { $src }"; ## no critic
    return $code;
}

sub _croak {
    my (undef, $file, $line) = caller 1;
    die @_, " at $file line $line.\n"
}

sub _register_submeta {
    my ($class, $pkg, $sub, $types) = @_;

    my $meta = Sub::Meta->new(sub => $sub, stashname => $pkg);
    $meta->set_returns(_normalize_types($types));

    if (my $materials = Sub::Meta::Finder::FunctionParameters::find_materials($sub)) {
        $meta->set_is_method($materials->{is_method});
        $meta->set_parameters($materials->{parameters});
    }

    Sub::Meta::Library->register($sub, $meta);
    return;
}

sub _register_submeta_and_install {
    my ($class, $pkg, $sub, $types) = @_;

    my $original_meta = Sub::Meta->new(sub => $sub);
    my $wrapped  = $class->wrap_sub($sub, $types);

    my $meta = Sub::Meta->new(sub => $wrapped, stashname => $pkg);
    $meta->set_returns(_normalize_types($types));

    if (my $materials = Sub::Meta::Finder::FunctionParameters::find_materials($sub)) {
        $meta->set_is_method($materials->{is_method});
        $meta->set_parameters($materials->{parameters});
    }

    $meta->apply_meta($original_meta);
    Sub::Meta::Library->register($wrapped, $meta);

    {
        no strict qw(refs);
        no warnings qw(redefine);
        *{$meta->fullname} = $wrapped;
    }
    return;
}

sub _normalize_types {
    my $types = shift;
    if (@$types == 1) {
        return $types->[0];
    }
    else {
        return $types;
    }
}

1;
__END__