Aion
4 results

 view release on metacpan or  search on metacpan

lib/Aion.pm  view on Meta::CPAN 

use Scalar::Util qw/blessed weaken/;
use Aion::Types qw//;

# Когда осуществлять проверки:
#   ro - только при выдаче
#   wo - только при установке
#   rw - при выдаче и уcтановке
#   no - никогда не проверять
use config ISA => 'rw';

sub export($@);

# Классы в которых подключён Aion с метаинформацией
our %META;

# Вызывается из другого пакета, для импорта данного
sub import {
	my ($cls, $attr) = @_;
	my $pkg = caller;

	*{"${pkg}::isa"} = \&isa if \&isa != $pkg->can('isa');

lib/Aion.pm  view on Meta::CPAN 

			trigger => \&trigger_aspect,
			release => \&release_aspect,
			clearer => \&clearer_aspect,
		}
	};

    eval "package $pkg; use Aion::Types; 1" or die;
}

# Экспортирует функции в пакет, если их там ещё нет
sub export($@) {
	my $pkg = shift;
	for my $sub (@_) {
		my $can = $pkg->can($sub);
		die "$pkg can $sub!" if $can && $can != \&$sub;
		*{"${pkg}::$sub"} = \&$sub unless $can;
	}
}

# Экспортирует функции в пакет, если их там ещё нет
sub is_aion($) {
	my $pkg = shift;
	die "$pkg is'nt class of Aion!" if !exists $META{$pkg};
}

#@category Aspects

sub _weaken_init {
	my ($self, $feature) = @_;
	weaken $self->{$feature->{name}};
}

lib/Aion.pm  view on Meta::CPAN 

	my ($cls, $name, $clearer, $construct, $feature) = @_;

	$feature->{clearer} = $clearer;
	*{"${cls}::DESTROY"} = \&destroy unless $cls->can('DESTROY');
	*{"${cls}::${name}__CLEARER"} = $clearer;
	
	die "Is DESTROY in Aion class ($cls): not set aion destroy!" if $cls->can('DESTROY') != \&destroy;
}

# Расширяет класс или роль
sub inherits($$@) {
    my $pkg = shift; my $with = shift;

	is_aion $pkg;

    my $FEATURE = $Aion::META{$pkg}{feature};
    my $ASPECT = $Aion::META{$pkg}{aspect};

    # Добавляем наследуемые свойства и атрибуты
	for my $module (@_) {
        eval "require $module" or die unless $module->can('with') || $module->can('new');

lib/Aion.pm  view on Meta::CPAN 

			my @not_requires = grep { !$pkg->can($_) } @$requires;

			do { local $, = ", "; die "@not_requires requires!" } if @not_requires;
		}
    }

    return;
}

# Наследование классов
sub extends(@) {
	my $pkg = caller;

	is_aion $pkg;

	push @{"${pkg}::ISA"}, @_;
	push @{$Aion::META{$pkg}{extends}}, @_;

    unshift @_, $pkg, 0;
    goto &inherits;
}

# Расширение ролями
sub with(@) {
	my $pkg = caller;

	is_aion $pkg;

	push @{"${pkg}::ISA"}, @_;
	push @{$Aion::META{$pkg}{with}}, @_;

    unshift @_, $pkg, 1;
    goto &inherits;
}

# Требуются подпрограммы
sub requires(@) {
    my $pkg = caller;

	is_aion $pkg;

    push @{$Aion::META{$pkg}{requires}}, @_;
    return;
}

# Добавляется аспект
sub aspect($$) {
	my ($name, $sub) = @_;
    my $pkg = caller;

	is_aion $pkg;

	my $ASPECT = $Aion::META{$pkg}{aspect};
	die "Aspect `$name` exists!" if exists $ASPECT->{$name};
    $ASPECT->{$name} = $sub;
    return;
}

lib/Aion.pm  view on Meta::CPAN 

	my $meta = $Aion::META{ref $self};
	for my $name (@_) {
		my $feature = $meta->{feature}{$name};
		$feature->{clearer}->($self) if $feature and $feature->{clearer} and exists $self->{$name};
	}
    delete @$self{@_};
    $self
}

# Создаёт свойство
sub has(@) {
	my $property = shift;

    return exists $property->{$_[0]} if blessed $property;

	my $pkg = caller;
	is_aion $pkg;

    my %opt = @_;
	my $meta = $Aion::META{$pkg};

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


Syntax sugar for `coerce`.

# ATTRIBUTES

## Isa (@signature)

Check the subroutine signature: arguments and returns.

```perl
sub minint($$) : Isa(Int => Int => Int) {
	my ($x, $y) = @_;
	$x < $y? $x : $y
}

minint 6, 5; # -> 5
eval {minint 5.5, 2}; $@ # ~> Arguments of method `minint` must have the type Tuple\[Int, Int\]\.
```

Attribute `Isa` is subroutine `UNIVERSAL::Isa`.

```perl
sub half($) {
	my ($x) = @_;
	$x / 2
}

UNIVERSAL::Isa(
	__PACKAGE__,
	*half,
	\&half,
	undef,
	[Int => Int],

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

	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;

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

	} elsif($is_arg) {
		$type->{test} = $where;
		$type->make_arg($pkg)
	} else {
		$type->{test} = $where // $TRUE;
		$type->make($pkg)
	}
}
}

sub as($) { (as => @_) }
sub init_where(&@) { (init_where => @_) }
sub where(&@) { (where => @_) }
sub awhere(&@) { (awhere => @_) }
sub message(&@) { (message => @_) }

sub SELF() { $Aion::Type::SELF }
sub ARGS() { wantarray? @{$Aion::Type::SELF->{args}}: $Aion::Type::SELF->{args} }
sub A() { $Aion::Type::SELF->{args}[0] }
sub B() { $Aion::Type::SELF->{args}[1] }
sub C() { $Aion::Type::SELF->{args}[2] }
sub D() { $Aion::Type::SELF->{args}[3] }

sub M() :lvalue { $Aion::Type::SELF->{M} }
sub N() :lvalue { $Aion::Type::SELF->{N} }

# Создание транслятора. У типа может быть сколько угодно трансляторов из других типов
# coerce Type, from OtherType, via {...}
sub coerce(@) {
	my ($type, %o) = @_;
	my ($from, $via) = delete @o{qw/from via/};

	die "coerce $type unused keys left: " . join ", ", keys %o if keys %o;
	die "coerce $type not Aion::Type!" unless UNIVERSAL::isa($type, "Aion::Type");
	die "coerce $type: from is'nt Aion::Type!" unless UNIVERSAL::isa($from, "Aion::Type");
	die "coerce $type: via is not subroutine!" unless ref $via eq "CODE";

	push @{$type->{coerce}}, [$from, $via];
	return;
}

sub from($) { (from => $_[0]) }
sub via(&) { (via => $_[0]) }

BEGIN {

subtype "Any";
	subtype "Control", as &Any;
		subtype "Union[A, B...]", as &Control,
			where { my $val = $_; any { $_->include($val) } ARGS };
		subtype "Intersection[A, B...]", as &Control,
			where { my $val = $_; all { $_->include($val) } ARGS };
		subtype "Exclude[A, B...]", as &Control,

t/aion/types.t  view on Meta::CPAN 

# 
# Syntax sugar for `coerce`.
# 
# # ATTRIBUTES
# 
# ## Isa (@signature)
# 
# Check the subroutine signature: arguments and returns.
# 
done_testing; }; subtest 'Isa (@signature)' => sub { 
sub minint($$) : Isa(Int => Int => Int) {
	my ($x, $y) = @_;
	$x < $y? $x : $y
}

::is scalar do {minint 6, 5;}, scalar do{5}, 'minint 6, 5; # -> 5';
::like scalar do {eval {minint 5.5, 2}; $@}, qr!Arguments of method `minint` must have the type Tuple\[Int, Int\]\.!, 'eval {minint 5.5, 2}; $@ # ~> Arguments of method `minint` must have the type Tuple\[Int, Int\]\.';

# 
# Attribute `Isa` is subroutine `UNIVERSAL::Isa`.
# 

sub half($) {
	my ($x) = @_;
	$x / 2
}

UNIVERSAL::Isa(
	__PACKAGE__,
	*half,
	\&half,
	undef,
	[Int => Int],



( run in 0.285 second using v1.01-cache-2.11-cpan-cba739cd03b )