view release on metacpan or  search on metacpan

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

package Aion::Types;
# Типы-валидаторы для Aion

use 5.22.0;
no strict; no warnings; no diagnostics;
use common::sense;

use Aion::Type;
use Attribute::Handlers;
use List::Util qw/all any/;
use Exporter qw/import/;
use Scalar::Util qw/looks_like_number reftype blessed/;
use Sub::Util qw/prototype set_prototype subname set_subname/;

require Exporter;
our @EXPORT = our @EXPORT_OK = grep {
	*{$Aion::Types::{$_}}{CODE}	&& !/^(_|(NaN|import|all|any|looks_like_number|reftype|blessed|prototype|set_prototype|subname set_subname)\z)/n
} keys %Aion::Types::;

sub UNIVERSAL::Isa : ATTR(CODE) {
    my ($pkg, $symbol, $referent, $attr, $data, $phase, $file, $line) = @_;
    my $args_of_meth = "Arguments of method `" . *{$symbol}{NAME} . "`";
    my $returns_of_meth = "Returns of method `" . *{$symbol}{NAME} . "`";
    my $return_of_meth = "Return of method `" . *{$symbol}{NAME} . "`";

	my @signature = map { ref($_)? $_: $pkg->can($_)->() } @$data;

	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
        }
    };

	set_prototype prototype($referent), $sub;
	set_subname subname($referent) . "__Isa", $sub;

	*$symbol = $sub
}

BEGIN {
my $TRUE = sub {1};

# Создание типа
sub subtype(@) {
	my $save = my $name = shift;
	my %o = @_;
	
	my ($as, $init_where, $where, $awhere, $message) = delete @o{qw/as init_where where awhere message/};

	die "subtype $save unused keys left: " . join ", ", keys %o if keys %o;

	my $is_maybe_arg; my $is_arg;
	$name =~ s/(`?)(\[.*)/ $is_maybe_arg = $1; $is_arg = $2; ''/e;

	my $pkg = scalar caller;
	die "subtype $save: ${pkg}::$name exists!" if *{"${pkg}::$name"}{CODE};

	if($is_maybe_arg) {
		die "subtype $save: needs a awhere" if !$awhere;
	} else {
		die "subtype $save: awhere is excess" if $awhere;
	}
	
	die "subtype $save: needs a where" if $is_arg && !($where || $awhere);