File Coverage

blib/lib/Aion.pm

Criterion	Covered	Total	%
statement	685	842	81.3
branch	166	304	54.6
condition	43	117	36.7
subroutine	120	121	99.1
pod	9	27	33.3
total	1023	1411	72.5

package Aion;

use common::sense;

our $VERSION = "2.2";

use Aion::Types qw//;
use Aion::Meta::RequiresAnyFunction;
use Aion::Meta::Feature;
use Aion::Meta::RequiresFeature;
use Aion::Meta::Subroutine;

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

sub export($@);

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

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

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

	if($attr ne '-role') {  # Класс
		export $pkg, qw/extends/;
		*{"${pkg}::new"} = \&initialize;
	} else {	# Роль
		export $pkg, qw/requires req/;
	}

	export $pkg, qw/with has aspect does exactly/;

	# Метаинформация
	$META{$pkg} = {
		order => scalar keys %META,
		require => {},
		feature => {},
		subroutine => {},
		aspect => {
			is        => \&is_aspect,
			isa       => \&isa_aspect,
			coerce    => \&coerce_aspect,
			lazy      => \&lazy_aspect,
			default   => \&default_aspect,
			trigger   => \&trigger_aspect,
			release   => \&release_aspect,
			init_arg  => \&init_arg_aspect,
			accessor  => \&accessor_aspect,
			writer    => \&writer_aspect,
			reader    => \&reader_aspect,
			predicate => \&predicate_aspect,
			clearer   => \&clearer_aspect,
			cleaner   => \&cleaner_aspect,
			eon       => \&eon_aspect,
		}
	};

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

# Удаляет добавленные символы
sub unimport {
	my $pkg = caller;

	undef &{"${pkg}::$_"} for qw/extends with aspect requires req/;

	eval "package $pkg; no 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;
	}
}

# Проверяет, что этот пакет инициализирован Aion
sub is_aion($) {
	my $pkg = shift;
	die "$pkg is'nt class of Aion!" if !exists $META{$pkg};
}

#@category Aspects

# ro, rw, + и -, *
sub is_aspect {
	my ($is, $feature) = @_;
	die "Use is => '{ro|rw|wo|no} {+|-} {*} {?} {!}'" if $is !~ /^(?ro|rw|wo|no)?(?[+-])?(?\*)?(?\??)(?!?)\z/;

	my ($construct, $name) = @$feature{qw/construct name/};

	$construct->getter("die 'Feature $name cannot be get!';") if $+{access} ~~ [qw/wo no/];

	$construct->setter("die 'Feature $name cannot be set!';") if $+{access} ~~ [qw/ro no/];

	$construct->add_trigger("%(weaken)s") if $+{weak};

	$feature->{required} = 1, $construct->not_specified(' else { die "%(init_arg)s required!" }') if $+{require} eq '+';

	$feature->{excessive} = 1, $construct->initer('die "%(init_arg)s excessive!"') if $+{require} eq '-';

	$feature->{make_predicate} = 1 if $+{has};
	$feature->{make_clearer} = 1 if $+{clear};
}

# isa => Type
sub isa_aspect {
	my ($isa, $feature) = @_;
	my ($construct, $name) = @$feature{qw/construct name/};

	$feature->{isa} = Aion::Types::External[$isa];

	$construct->add_release("${\$feature->meta}\{isa}->validate(\$val, 'Get feature $name');") if AION_ISA =~ /ro|rw/;

	$construct->add_preset("${\$feature->meta}\{isa}->validate(\$val, 'Set feature $name');") if AION_ISA =~ /wo|rw/;
}

# coerce => 1
sub coerce_aspect {
	my ($coerce, $feature) = @_;

	return unless $coerce;

	die "coerce: isa not present!" unless $feature->{isa};

	$feature->{construct}->add_preset("\$val = ${\$feature->meta}\{isa}->coerce(\$val);", 1) if AION_ISA =~ /wo|rw/;
}

my $pleroma;

sub pleroma {
	require Aion::Pleroma;
	$pleroma = Aion::Pleroma->new;
	*pleroma = sub { $pleroma };
	$pleroma
}

# eon => $key
sub eon_aspect {
	my ($key, $feature) = @_;

	die "eon is not compatible with default!" if $feature->{opt}{default};

	if($key eq 1) {
		my $isa = $feature->{isa};
		$key = $isa && $isa->{name} eq "Object" && $isa->{args}[0]
			or die "use: has $feature->{name} => (isa => Object[...], eon => 1)";
	}
	elsif($key eq 2) {
		my $isa = $feature->{isa};
		$key = ($isa && $isa->{name} eq "Object" && $isa->{args}[0]
			or die "use: has $feature->{name} => (isa => Object[...], eon => 2)")
		. "#$feature->{name}";

	}

	default_aspect(sub { Aion->pleroma->resolve($key) }, $feature);
}

# lazy => 1|0
sub lazy_aspect {
	my ($lazy, $feature) = @_;

	$feature->{lazy} = $lazy;
}

# default => value
sub default_aspect {
	my ($default, $feature) = @_;

	my $name = $feature->name;
	my $default_is_code = ref $default eq "CODE";

	if($default_is_code) {
		$feature->{builder} = $default;
	} else {
		$feature->{default} = $default;
		$feature->{isa}->validate($default, $name) if $feature->{isa};
	}

	if($feature->{opt}{lazy} // $default_is_code) {
		$feature->{lazy} = 1;

		if ($default_is_code) {
			$feature->construct->add_access("unless(%(has)s) {
				my \$val = ${\$feature->meta}\{builder}->(\$self);
				%(write)s
			}");
		} else {
			$feature->construct->add_access("unless(%(has)s) {
				my \$val = ${\$feature->meta}\{default};
				%(write)s
			}");
		}
	} else {
		if($default_is_code) {
			$feature->{construct}->not_specified(" else {
				my \$val = ${\$feature->meta}\{builder}->(\$self);
				%(write)s
			}");
		} else {
			$feature->{construct}->not_specified(" else {
				my \$val = ${\$feature->meta}\{default};
				%(write)s
			}");
		}

	}
}

# trigger => $sub
sub trigger_aspect {
	my ($trigger, $feature) = @_;

	$feature->{trigger} = $trigger;

	my $construct = $feature->{construct};

	$construct->add_preset("my \@old = %(has)s? %(get)s: ();");
	$construct->add_trigger("${\$feature->meta}\{trigger}->(\$self, \@old);");
}

# release => $sub
sub release_aspect {
	my ($release, $feature) = @_;

	$feature->{release} = $release;

	$feature->{construct}->add_release("${\$feature->meta}\{release}->(\$self, \$val);");
}

# init_arg => $name
sub init_arg_aspect {
	my ($init_arg, $feature) = @_;

	$feature->construct->init_arg($init_arg);
}

# accessor => $name
sub accessor_aspect {
	my ($accessor, $feature) = @_;

	$feature->construct->accessor_name($accessor);
}

# writer => $name
sub writer_aspect {
	my ($writer, $feature) = @_;

	$feature->{make_writer} = 1;
	$feature->construct->writer_name($writer);
}

# reader => $name
sub reader_aspect {
	my ($reader, $feature) = @_;

	$feature->{make_reader} = 1;
	$feature->construct->reader_name($reader);
}

# predicate => $name
sub predicate_aspect {
	my ($predicate, $feature) = @_;

	$feature->{make_predicate} = 1;
	$feature->construct->predicate_name($predicate);
}

# clearer => $name
sub clearer_aspect {
	my ($clearer, $feature) = @_;

	$feature->{make_clearer} = 1;
	$feature->construct->clearer_name($clearer);
}

# cleaner => $sub
sub cleaner_aspect {
	my ($cleaner, $feature) = @_;

	my ($cls, $construct) = @$feature{qw/pkg construct/};

	$feature->{cleaner} = $cleaner;

	$construct->add_cleaner("${\$feature->meta}\{cleaner}->(\$self);");
}

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

	is_aion $pkg;

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

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

		if(my $meta = $Aion::META{$module}) {
			%$FEATURE = (%$FEATURE, %{$meta->{feature}}) ;
			%$ASPECT = (%$ASPECT, %{$meta->{aspect}});
			%$REQUIRE = (%$REQUIRE, %{$meta->{require}});
		}
	}

	my $import_name = $is_with? 'import_with': 'import_extends';
	for my $module (@_) {
		my $import = $module->can($import_name);
		$import->($module, $pkg) if $import;
	}

	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;

	#TODO: добавить проверку на существование
	$Aion::META{$pkg}{require}{$_} = Aion::Meta::RequiresAnyFunction->new(pkg => $pkg, name => $_) for @_;
}

# Требуется свойство
sub req(@) {
	my ($name) = @_;
	my $pkg = caller;

	is_aion $pkg;

	my $meta = $Aion::META{$pkg};

	#TODO: добавить проверку на существование по модулю и сравнить, что не одинаковы, если модули не совпадают
	# die "Feature `$name` already required!" if exists $meta->{require}{$name};

	$meta->{require}{$name} = Aion::Meta::RequiresFeature->new($pkg, @_);
	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;
}

# Ищет именно классы, а не роли
sub exactly {
    my ($self, $class) = @_;
    return '' if Aion::Types::ClassName->exclude($class);
	goto &UNIVERSAL::isa;
}


# Определяет - подключена ли роль
sub does {
	my ($self, $role) = @_;
	return '' if Aion::Types::ClassName->include($role);
	goto &UNIVERSAL::isa;
}

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

	my $pkg = caller;
	is_aion $pkg;

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

	# создаём фичи
	for my $name (ref $property? @$property: $property) {

		die "has: the method $name is already in the package $pkg"
			if $pkg->can($name) && !exists $meta->{feature}{$name};

		my $feature = Aion::Meta::Feature->new($pkg, $name, @_);

		my $require = delete $meta->{require}{$name};
		$require->compare($feature) if $require;

		my $overload = $meta->{feature}{$name};
		$overload->compare($feature) if $overload;

		$feature->mk_property;
		$meta->{feature}{$name} = $feature;
	}
	return;
}

# Инициализатор: закрывает класс и заменяется на конструктор
sub initialize {
	my ($cls) = @_;

	$cls = ref $cls || $cls;
	is_aion $cls;

	my $REQUIRE = $Aion::META{$cls}{require};
	my $FEATURE = $Aion::META{$cls}{feature};
	my $SUBROUTINE = $Aion::META{$cls}{subroutine};
	for my $key (keys %$REQUIRE) {
		my $require = $REQUIRE->{$key};

		if ($require->isa('Aion::Meta::RequiresAnyFunction')) {
			$require->compare($cls->can($key));
		} elsif ($require->isa('Aion::Meta::RequiresFeature')) {
			$require->compare($FEATURE->{$require->name});
		} else {
			$require->compare($SUBROUTINE->{$require->subname});
		}
	}

	%$REQUIRE = ();

	# TODO: очищать класс от вспомогательных функций
	#eval "package $cls; Aion->unimport; 1" or die;

	my $new = << 'END';
package %(cls)s {
	sub new {
		my ($cls, %value) = @_;
		$cls = ref $cls || $cls;
		my $self = bless {}, $cls;

%(initializers)s

		if(scalar keys %value) {
			my @fakekeys = sort keys %value;
			die "@fakekeys is'nt feature!" if @fakekeys == 1;
			local $" = ", ";
			die "@fakekeys is'nt features!"
		}

		return $self;
	}
}
END

    my @destroyers;
	my $initializers = join "", map {
		push @destroyers, $_->{construct}->destroyer if $_->{cleaner};
		$_->{construct}->initializer
	} sort { $a->{order} <=> $b->{order} } values %$FEATURE;

	my %var = (
		cls => $cls,
		initializers => $initializers,
	);

	$new =~ s/%\((\w+)\)s/$var{$1}/ge;

	eval $new;
	die if $@;

	if (@destroyers) {
		my $destroyer = << 'END';
package %(cls)s {
	sub DESTROY {
		my ($self) = @_;

		warn "${\ref $self}#${\Scalar::Util::id $self} destroy in global phase!" if ${^GLOBAL_PHASE} eq 'DESTRUCT';

%(destroyers)s
	}
}
END

		my %var = (
			cls => $cls,
			destroyers => join "", @destroyers,
		);

		$destroyer =~ s/%\((\w+)\)s/$var{$1}/ge;

		eval $destroyer;
		die $@ if $@;
	}

	goto &{"${cls}::new"};
}

1;

__END__