File Coverage

blib/lib/Function/Interface/Impl.pm

Criterion	Covered	Total	%
statement	97	97	100.0
branch	30	30	100.0
condition	3	3	100.0
subroutine	22	22	100.0
pod	8	8	100.0
total	160	160	100.0

package Function::Interface::Impl;

use v5.14.0;
use warnings;

our $VERSION = "0.06";

use Class::Load qw(try_load_class is_class_loaded);
use Scalar::Util qw(blessed);
use Import::Into;
use B::Hooks::EndOfScope;

use Function::Interface;
use Function::Parameters;
use Function::Return;

sub import {
    my $class = shift;
    my @interface_packages = @_;
    my ($pkg, $filename, $line) = caller;

    for (@interface_packages) {
        _register_check_list($pkg, $_, $filename, $line);
    }

    Function::Parameters->import::into($pkg);
    Function::Return->import::into($pkg);

    on_scope_end {
        _check_impl();
    }
}

our @CHECK_LIST;
my %IMPL_CHECKED;
sub _check_impl {
    while (my $data = shift @CHECK_LIST) {
        my ($package, $interface_package, @fl) = @$data{qw/package interface_package filename line/};
        assert_valid($package, $interface_package, @fl);

        # for Function::Interface::Types#ImplOf
        $IMPL_CHECKED{$package}{$interface_package} = !!1;
    }
}

sub _register_check_list {
    my ($package, $interface_package, $filename, $line) = @_;

    push @CHECK_LIST => +{
        package           => $package,
        interface_package => $interface_package,
        filename          => $filename,
        line              => $line,
    }
}

sub assert_valid {
    my ($package, $interface_package, $filename, $line) = @_;
    my @fl = ($filename, $line);

    {
        my $ok = is_class_loaded($package);
        return _error("implements package is not loaded yet. required to use $package", @fl) if !$ok;
    }

    {
        my ($ok, $e) = try_load_class($interface_package);
        return _error("cannot load interface package: $e", @fl) if !$ok;
    }

    my $iinfo = info_interface($interface_package)
            or return _error("cannot get interface info", @fl);

    for my $ifunction_info (@{$iinfo->functions}) {
        my $fname = $ifunction_info->subname;
        my $def   = $ifunction_info->definition;

        my $code = $package->can($fname)
            or return _error("function `$fname` is required. Interface: $def", @fl);

        my $pinfo = info_params($code)
            or return _error("cannot get function `$fname` parameters info. Interface: $def", @fl);
        my $rinfo = info_return($code)
            or return _error("cannot get function `$fname` return info. Interface: $def", @fl);

        check_params($pinfo, $ifunction_info)
            or return _error("function `$fname` is invalid parameters. Interface: $def", @fl);
        check_return($rinfo, $ifunction_info)
            or return _error("function `$fname` is invalid return. Interface: $def", @fl);
    }
}

sub _error {
    my ($msg, $filename, $line) = @_;
    die sprintf "implements error: %s at %s line %s\n\tdied", $msg, $filename, $line;
}

sub info_interface {
    my $interface_package = shift;
    Function::Interface::info($interface_package)
}

sub info_params {
    my $code = shift;
    Function::Parameters::info($code)
}

sub info_return {
    my $code = shift;
    Function::Return::info($code)
}

sub check_params {
    my ($pinfo, $ifunction_info) = @_;

    return unless $ifunction_info->keyword eq $pinfo->keyword;

    my $params_count = 0;
    for my $key (qw/positional_required positional_optional named_required named_optional/) {
        my @params = $pinfo->$key;
        $params_count += @params;

        for my $i (0 .. $#{$ifunction_info->$key}) {
            my $ifp = $ifunction_info->$key->[$i];
            my $p = $params[$i];
            return unless check_param($p, $ifp);
        }
    }

    return unless $params_count == @{$ifunction_info->params};
    return !!1
}

sub check_param {
    my ($param, $iparam) = @_;
    return unless $param;
    return $iparam->type eq $param->type
        && $iparam->name eq $param->name
}

sub check_return {
    my ($rinfo, $ifunction_info) = @_;

    return unless @{$rinfo->types} == @{$ifunction_info->return};

    for my $i (0 .. $#{$ifunction_info->return}) {
        my $ifr = $ifunction_info->return->[$i];
        my $type = $rinfo->types->[$i];
        return unless $ifr->type eq $type;
    }
    return !!1;
}

sub impl_of {
    my ($package, $interface_package) = @_;
    $package = ref $package ? blessed($package) : $package;
    $IMPL_CHECKED{$package}{$interface_package}
}

1;
__END__