File Coverage

blib/lib/Aion/Meta/Subroutine.pm

Criterion	Covered	Total	%
statement	65	67	97.0
branch	11	14	78.5
condition	1	3	33.3
subroutine	19	19	100.0
pod	4	4	100.0
total	100	107	93.4

package Aion::Meta::Subroutine;
# Описывает функцию с сигнатурой

use common::sense;

use Aion::Meta::Util qw//;
use Aion::Types qw/Tuple/;
use Scalar::Util qw//;
use Sub::Util qw//;

Aion::Meta::Util::create_getters(qw/pkg subname signature referent wrapsub/);

sub new {
	my $cls = shift;
	bless {@_}, ref $cls || $cls;
}

sub wrap_sub {
	my ($self) = @_;

	my ($pkg, $subname, $signature, $referent) = @$self{qw/pkg subname signature referent/};

	my $args_of_meth = "Arguments of method `$subname`";
	my $returns_of_meth = "Returns of method `$subname`";
	my $return_of_meth = "Return of method `$subname`";

	my @signature = @$signature;
	my $ret = pop @signature;

	my ($ret_array, $ret_scalar) = exists $ret->{is_wantarray}? @{$ret->{args}}: (Tuple([$ret]), $ret);

	my $args = Tuple(\@signature);

	my $sub = sub {
		$args->validate(\@_, $args_of_meth);
		wantarray? do {
			my @returns = $referent->(@_);
			$ret_array->validate(\@returns, $returns_of_meth);
			@returns
		}: do {
			my $return = $referent->(@_);
			$ret_scalar->validate($return, $return_of_meth);
			$return
		}
	};

	Sub::Util::set_prototype Sub::Util::prototype($referent), $sub;
	Sub::Util::set_subname Sub::Util::subname($referent), $sub;

	*{"$pkg\::$subname"} = $sub if $subname ne '__ANON__';

	$self->{wrapsub} = $sub;
	$Aion::META{$pkg}{subroutine}{$subname} = $self;

	my $key = pack "J", Scalar::Util::refaddr $sub;
	$Aion::Isa{$key} = $self;
	Scalar::Util::weaken $Aion::Isa{$key};

	$self
}

sub compare {
	my ($self, $subroutine) = @_;

	die "Requires subroutine ${\$self->name}" unless $subroutine->isa('Aion::Meta::Subroutine');

	my $i = 0;
	my $signature = $subroutine->signature;
	my $fail = 0;

	if(@$signature == @{$self->signature}) {
		for my $type (@{$self->{signature}}) {
			my $other_type = $signature->[$i++];
			$fail = 1, last unless $type <= $other_type;
		}
	} else {
		$fail = 1;
	}

	die "Signature mismatch: ${\$self->stringify} <=> ${\$subroutine->stringify}" if $fail;
}

sub stringify {
	my ($self) = @_;

	my ($pkg, $subname) = @$self{qw/pkg subname/};
	my $signature = join " => ", @{$self->signature};
	return "$subname($signature) of $pkg";
}

1;

__END__