Aion
view release on metacpan or search on metacpan
lib/Aion/Types.pm view on Meta::CPAN
package Aion::Types;
# Типы-валидаторы Ð´Ð»Ñ Aion
use common::sense;
use Aion::Meta::Util qw/subref_is_reachable/;
use Aion::Type;
use List::Util qw/all any first/;
use Exporter qw/import/;
require overload;
use Scalar::Util qw/looks_like_number reftype refaddr blessed/;
use Sub::Util qw//;
our @EXPORT = our @EXPORT_OK = grep {
*{$Aion::Types::{$_}}{CODE} && !/^(_|(NaN|import|all|any|first|looks_like_number|reftype|refaddr|blessed|subref_is_reachable)\z)/n
} keys %Aion::Types::;
# Обрабатываем атрибут :Isa
sub MODIFY_CODE_ATTRIBUTES {
my ($pkg, $referent, @attributes) = @_;
grep { /^Isa\((.*)\)\z/s? do { _Isa($pkg, $referent, $1); 0 }: 1 } @attributes
}
sub _Isa {
my ($pkg, $referent, $data) = @_;
my $subname = Sub::Util::subname $referent;
$subname =~ s/^.*:://;
die "Anonymous subroutine cannot use :Isa!" if $subname eq '__ANON__';
my @signature = eval "package $pkg; map { UNIVERSAL::isa(\$_, 'Aion::Type')? \$_: __PACKAGE__->can(\$_)? __PACKAGE__->can(\$_)->(): Aion::Types::External([\$_]) } ($data)";
die if $@;
die "$pkg\::$subname has no return type!" if @signature == 0;
require Aion::Meta::Subroutine;
my $subroutine = Aion::Meta::Subroutine->new(
pkg => $pkg,
subname => $subname,
signature => \@signature,
referent => $referent,
);
if(!subref_is_reachable($referent)) {
$Aion::META{$pkg}{require}{$subname} = $subroutine;
} else {
my $require = delete $Aion::META{$pkg}{require}{$subname};
$require->compare($subroutine) if $require;
my $overload = $Aion::META{$pkg}{subroutine}{$subname};
$overload->compare($subroutine) if $overload;
$subroutine->wrap_sub;
}
}
BEGIN {
my $TRUE = sub {1};
my $INIT_ARGS = sub { @{&ARGS} = map External([$_]), @{&ARGS} };
my $INIT_KW_ARGS = sub { @{&ARGS} = List::Util::pairmap { $a => External([$b]) } @{&ARGS} };
# Создание типа
sub subtype(@) {
my $subtype = shift;
my %o = @_;
my ($as, $init_where, $where, $awhere, $message) = delete @o{qw/as init_where where awhere message/};
$as = External([$as]) if defined $as;
die "subtype $subtype unused keys left: " . join ", ", keys %o if keys %o;
die "subtype format is Name or Name[args] or Name`[args]" if $subtype !~ /^([A-Z_]\w*)(?:(\`)?\[(.*)\])?$/i;
my ($name, $is_maybe_arg, $is_arg) = ($1, $2, $3);
lib/Aion/Types.pm view on Meta::CPAN
Tuple([Object(["Aion::Type"])])->validate(scalar ARGS, "Arguments Option[A]")
}
where { A->test };
subtype "Wantarray[A, S]", as &Control,
init_where {
SELF->{is_wantarray} = 1;
Tuple([Object(["Aion::Type"]), Object(["Aion::Type"])])->validate(scalar ARGS, "Arguments Wantarray[A, S]")
}
where { ... };
subtype "Item", as &Any;
sub External($) {
local $_ = $_[0][0];
UNIVERSAL::isa($_, 'Aion::Type')? $_:
defined($_) && ref $_ eq ""? Object([$_]): do {
CodeLike()->validate($_, "External type");
Aion::Type->new(
name => 'External',
as => &Item,
args => $_[0],
test => $_,
UNIVERSAL::can($_, 'coerce')
? (coerce => [[&Any, (sub { my ($ex) = @_; sub { $ex->coerce } })->($_)]])
: (),
)
}
}
subtype "Bool", as &Item, where { ref $_ eq "" and /^(1|0|)\z/ };
subtype "BoolLike", as &Item, where {
return 1 if overload::Method($_, 'bool');
my $m = overload::Method($_, '0+');
Bool()->include($m ? $m->($_) : $_) };
subtype "Enum[e...]", as &Item, where { $_ ~~ ARGS };
subtype "Maybe[A]", as &Item, where { !defined($_) || A->test };
subtype "Undef", as &Item, where { !defined $_ };
subtype "Defined", as &Item, where { defined $_ };
subtype "Value", as &Defined, where { "" eq ref $_ };
subtype "Version", as &Value, where { "VSTRING" eq ref \$_ };
subtype "Str", as &Value, where { "SCALAR" eq ref \$_ };
subtype "Uni", as &Str, where { utf8::is_utf8($_) || /[\x80-\xFF]/a };
subtype "Bin", as &Str, where { !utf8::is_utf8($_) && !/[\x80-\xFF]/a };
subtype "NonEmptyStr", as &Str, where { /\S/ };
subtype "StartsWith[start]", as &Str,
init_where { M = qr/^${\ quotemeta A}/ },
where { $_ =~ M };
subtype "EndsWith[end]", as &Str,
init_where { N = qr/${\ quotemeta A}$/ },
where { $_ =~ N };
subtype "Email", as &Str, where { /@/ };
subtype "Tel", as &Str, where { /^\+\d{7,}\z/ };
subtype "Url", as &Str, where { /^https?:\/\// };
subtype "Path", as &Str, where { /^\// };
subtype "Html", as &Str, where { /^\s*<(!doctype\s+html|html)\b/i };
subtype "StrDate", as &Str, where { /^\d{4}-\d{2}-\d{2}\z/ };
subtype "StrDateTime", as &Str, where { /^\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}\z/ };
subtype "StrMatch[regexp]", as &Str, where { $_ =~ A };
subtype "ClassName", as &Str, where { !!$_->can('new') };
subtype "RoleName", as &Str, where { !$_->can('new') && !!(@{"$_\::ISA"} || first { *{$_}{CODE} } values %{"$_\::"}) };
subtype "StrRat", as &Str, where { m!\s*/\s*!? &Num->include($`) && &Num->include($`): &Num->test };
subtype "Num", as &Str, where { looks_like_number($_) && /[\dfn]\z/i };
subtype "PositiveNum", as &Num, where { $_ >= 0 };
subtype "Int", as &Num, where { /^[-+]?\d+\z/ };
subtype "PositiveInt", as &Int, where { $_ >= 0 };
subtype "Nat", as &Int, where { $_ > 0 };
subtype "Ref", as &Defined, where { "" ne ref $_ };
subtype "Tied`[class]", as &Ref,
where { my $ref = reftype($_); !!(
$ref eq "HASH"? tied %$_:
$ref eq "ARRAY"? tied @$_:
$ref eq "SCALAR"? tied $$_:
0
) }
awhere { my $ref = reftype($_);
$ref eq "HASH"? A eq ref tied %$_:
$ref eq "ARRAY"? A eq ref tied @$_:
$ref eq "SCALAR"? A eq ref tied $$_:
""
};
subtype "LValueRef", as &Ref, where { ref $_ eq "LVALUE" };
subtype "FormatRef", as &Ref, where { ref $_ eq "FORMAT" };
subtype "CodeRef", as &Ref, where { ref $_ eq "CODE" };
subtype "NamedCode[subname]", as &CodeRef, where { Sub::Util::subname($_) ~~ A };
subtype "ProtoCode[prototype]", as &CodeRef, where { Sub::Util::prototype($_) ~~ A };
subtype "ForwardRef", as &CodeRef, where { !subref_is_reachable($_) };
subtype "ImplementRef", as &CodeRef, where { subref_is_reachable($_) };
subtype "Isa[type...]", as &CodeRef,
init_where {
my $pkg = caller(2);
SELF->{args} = [ map { External([UNIVERSAL::isa($_, 'Aion::Type')? $_: $pkg->can($_)? $pkg->can($_)->(): $_]) } ARGS ]
}
where {
my $subroutine = $Aion::Isa{pack "J", refaddr $_} or return "";
my $signature = $subroutine->{signature};
my $args = ARGS;
return "" if @$signature != @$args;
my $i = 0;
for my $type (@$args) {
return "" unless $signature->[$i++] eq $type;
}
1
};
subtype "RegexpRef", as &Ref, where { ref $_ eq "Regexp" };
subtype "ValueRef`[A]", as &Ref,
where { ref($_) ~~ ["SCALAR", "REF"] }
awhere { ref($_) ~~ ["SCALAR", "REF"] && A->include($$_) };
subtype "ScalarRef`[A]", as &ValueRef,
where { ref $_ eq "SCALAR" }
awhere { ref $_ eq "SCALAR" && A->include($$_) };
subtype "RefRef`[A]", as &ValueRef,
where { ref $_ eq "REF" }
awhere { ref $_ eq "REF" && A->include($$_) };
subtype "GlobRef", as &Ref, where { ref $_ eq "GLOB" };
subtype "FileHandle", as &GlobRef,
where { !!*$_{IO} };
subtype "ArrayRef`[A]", as &Ref,
where { ref $_ eq "ARRAY" }
awhere { my $A = A; ref $_ eq "ARRAY" && all { $A->test } @$_ };
subtype "HashRef`[A]", as &Ref,
lib/Aion/Types.pm view on Meta::CPAN
subtype "CycleTuple[A...]", as &ArrayRef,
init_where { $tuple_args->validate(scalar ARGS, "Arguments CycleTuple[A...]") }
where {
my $k = 0;
while($k < @$_) {
for my $A (ARGS) {
return "" if $A->exclude($_->[$k++]);
}
}
$k == @$_
};
my $dict_args = CycleTuple([&Str, Object(['Aion::Type'])]);
subtype "Dict[k => A, ...]", as &HashRef,
init_where { $dict_args->validate(scalar ARGS, "Arguments Dict[k => A, ...]") }
where {
my $count = 0; my $k;
for my $A (ARGS) {
$k = $A, next unless ref $A;
if(exists $_->{$k}) {
return "" if $A->exclude($_->{$k});
$count++;
} else {
return "" if !exists $A->{is_option};
}
}
$count == keys %$_
};
subtype "RegexpLike", as &Ref,
where { reftype($_) eq "REGEXP" || !!overload::Method($_, 'qr') };
subtype "CodeLike", as &Ref,
where { reftype($_) eq "CODE" || !!overload::Method($_, '&{}') };
subtype "ArrayLike`[A]", as &Ref,
where { reftype($_) eq "ARRAY" || !!overload::Method($_, '@{}') }
awhere { &ArrayLike->test && do { my $A = A; all { $A->test } @$_ }};
my $init_limit = sub { if(@{&ARGS} == 1) { SELF->{min} = 0; SELF->{max} = A } else { SELF->{min} = A; SELF->{max} = B } };
subtype "Lim[from, to?]", as &ArrayLike,
init_where => $init_limit,
where { SELF->{min} <= @$_ && @$_ <= SELF->{max} };
subtype "HashLike`[A]", as &Ref,
where { reftype($_) eq "HASH" || !!overload::Method($_, "%{}") }
awhere { &HashLike->test && do { my $A = A; all { $A->test } values %$_ }};
subtype "HasProp[p...]", as &HashLike,
where { my $x = $_; all { exists $x->{$_} } ARGS };
subtype "LimKeys[from, to?]", as &HashLike,
init_where => $init_limit,
where { SELF->{min} <= scalar keys %$_ && scalar keys %$_ <= SELF->{max} };
subtype "Like", as (&Str | &Object);
subtype "HasMethods[m...]", as &Like,
where { my $x = $_; all { $x->can($_) } ARGS };
subtype "Overload`[m...]", as &Like,
where { !!overload::Overloaded($_) }
awhere { my $x = $_; all { overload::Method($x, $_) } ARGS };
subtype "InstanceOf[class...]", as &Like, where { my $x = $_; all { $x->isa($_) } ARGS };
subtype "ConsumerOf[role...]", as &Like, where { my $x = $_; all { $x->DOES($_) } ARGS };
subtype "StrLike", as &Like, where { !blessed($_) or !!overload::Method($_, '""') };
subtype "Len[from, to?]", as &StrLike,
init_where => $init_limit,
where { SELF->{min} <= length($_) && length($_) <= SELF->{max} };
subtype "NumLike", as &Like, where { looks_like_number($_) };
subtype "Float", as &NumLike, where { -3.402823466E+38 <= $_ && $_ <= 3.402823466E+38 };
my $_from; my $_to;
subtype "Double", as &NumLike, where {
$_from //= do { require Math::BigFloat; Math::BigFloat->new('-1.7976931348623157e+308') };
$_to //= do { require Math::BigFloat; Math::BigFloat->new( '1.7976931348623157e+308') };
$_from <= $_ && $_ <= $_to;
};
subtype "Range[from, to]", as &NumLike, where { A <= $_ && $_ <= B };
my $_8bits;
subtype "Bytes[n]", as &NumLike,
init_where {
my $bits = A < 8? 8: ($_8bits //= do {
require Math::BigInt;
Math::BigInt->new(8)
});
my $N = 1 << ($bits * A - 1);
N = -$N;
M = $N-1;
}
where { N <= $_ && $_ <= M };
subtype "PositiveBytes[n]", as &NumLike,
init_where {
my $bits = A < 8? 8: ($_8bits //= do {
require Math::BigInt;
Math::BigInt->new(8)
});
M = (1 << ($bits*A)) - 1;
}
where { 0 <= $_ && $_ <= M };
coerce &Str => from &Undef => via { "" };
coerce &Int => from &Num => via { int($_+($_ < 0? -.5: .5)) };
coerce &Bool => from &Any => via { !!$_ };
subtype 'Join[separator]', as &Str;
coerce &Join, from &ArrayRef, via { join A, @$_ };
subtype 'Split[separator]', as &ArrayRef;
coerce &Split, from &Str, via { [split A, $_] };
subtype "Rat", as 'Math::BigRat';
coerce &Rat => from &StrRat => via { Math::BigRat->new($_) };
};
1;
__END__
=encoding utf-8
=head1 NAME
Aion::Types - a library of standard validators and it is used to create new validators
=head1 SYNOPSIS
use Aion::Types;
( run in 2.721 seconds using v1.01-cache-2.11-cpan-fe3c2283af0 )