view release on metacpan or  search on metacpan

lib/Aion/Meta/Subroutine.pm  view on Meta::CPAN

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 eq $other_type;
		}