Aion/lib/Aion.pm
package Aion;
use 5.22.0;
no strict; no warnings; no diagnostics;
use common::sense;
our $VERSION = "0.1";
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');
if($attr ne '-role') { # Класс
export $pkg, qw/new extends/;
} else { # Роль
export $pkg, qw/requires/;
}
export $pkg, qw/with upgrade has aspect does clear/;
# Метаинформация
$META{$pkg} = {
feature => {},
aspect => {
is => \&is_aspect,
isa => \&isa_aspect,
coerce => \&coerce_aspect,
default => \&default_aspect,
trigger => \&trigger_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}};
}
# ro, rw, + и -
sub is_aspect {
my ($cls, $name, $is, $construct, $feature) = @_;
die "Use is => '(ro|rw|wo|no)[+-]?[*]?'" if $is !~ /^(ro|rw|wo|no)[+-]?[*]?\z/;
$construct->{get} = "die 'has: $name is $is (not get)'" if $is =~ /^(wo|no)/;
if($is =~ /^(ro|no)/) {
$construct->{set} = "die 'has: $name is $is (not set)'";
}
elsif($is =~ /\*\z/) {
$construct->{ret} = "; Scalar::Util::weaken(\$self->{$name})$construct->{ret}";
}
$feature->{required} = 1 if $is =~ /\+/;
$feature->{excessive} = 1 if $is =~ /-/;
push @{$feature->{init}}, \&_weaken_init if $is =~ /\*\z/;
}
# isa => Type
sub isa_aspect {
my ($cls, $name, $isa, $construct, $feature) = @_;
die "has: $name - isa maybe Aion::Type"
if !UNIVERSAL::isa($isa, 'Aion::Type');
$feature->{isa} = $isa;
$construct->{get} = "\$Aion::META{'$cls'}{feature}{$name}{isa}->validate(do{$construct->{get}}, 'Get feature `$name`')" if ISA =~ /ro|rw/;
$construct->{set} = "\$Aion::META{'$cls'}{feature}{$name}{isa}->validate(\$val, 'Set feature `$name`'); $construct->{set}" if ISA =~ /wo|rw/;
}
# coerce => 1
sub coerce_aspect {
my ($cls, $name, $coerce, $construct, $feature) = @_;
return unless $coerce;
die "coerce: isa not present!" unless $feature->{isa};
$construct->{coerce} = "\$val = \$Aion::META{'$cls'}{feature}{$name}{isa}->coerce(\$val); ";
$construct->{set} = "%(coerce)s$construct->{set}"
}
# default => value
sub default_aspect {
my ($cls, $name, $default, $construct, $feature) = @_;
if(ref $default eq "CODE") {
$feature->{lazy} = 1;
*{"${cls}::${name}__DEFAULT"} = $default;
$construct->{lazy_trigger} //= "";
$construct->{lazy} = "\$self->{$name} = \$self->${name}__DEFAULT%(lazy_trigger)s if !exists \$self->{$name}; ";
$construct->{get} = "%(lazy)s$construct->{get}";
} else {
$feature->{opt}{isa}->validate($default, $name) if $feature->{opt}{isa};
$feature->{default} = $default;
}
}
sub _trigger_init {
my ($self, $feature) = @_;
my $name = "$feature->{name}__TRIGGER";
$self->$name;
}
# trigger => $sub
sub trigger_aspect {
my ($cls, $name, $trigger, $construct, $feature) = @_;
*{"${cls}::${name}__TRIGGER"} = $trigger;
$construct->{set} = "my \$e = exists \$self->{$name}; my \$old = \$self->{$name}; $construct->{set}; \$self->${name}__TRIGGER(\$e? \$old: ())";
$construct->{lazy_trigger} = ", \$self->${name}__TRIGGER";
push @{$feature->{init}}, \&_trigger_init;
}
# Расширяет класс или роль
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');
if(my $meta = $Aion::META{$module}) {
%$FEATURE = (%$FEATURE, %{$meta->{feature}}) ;
%$ASPECT = (%$ASPECT, %{$meta->{aspect}});
}
}
my $import_name = $with? 'import_with': 'import_extends';
for my $module (@_) {
my $import = $module->can($import_name);
$import->($module, $pkg) if $import;
if($with && exists $Aion::META{$module} && (my $requires = $Aion::META{$module}{requires})) {
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;
}
# Определяет - расширен ли класс
sub isa {
my ($self, $class) = @_;
my $pkg = ref $self || $self;
return 1 if $class eq $pkg;
my $meta = $Aion::META{$pkg};
my $extends = $meta->{extends} // return "";
return 1 if $class ~~ $extends;
for my $extender (@$extends) {
return 1 if $extender->isa($class);
}
return "";
}
# Определяет - подключена ли роль
sub does {
my ($self, $role) = @_;
my $pkg = ref $self || $self;
my $meta = $Aion::META{$pkg};
my $does = $meta->{with} // return "";
return 1 if $role ~~ $does;
for my $doeser (@$does) {
return 1 if $doeser->can("does") && $doeser->does($role);
}
return "";
}
# Очищает переменную в объекте, возвращает себя
sub clear {
my $self = shift;
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};
# атрибуты
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 %construct = (
pkg => $pkg,
name => $name,
attr => '',
eval => 'package %(pkg)s {
%(sub)s
}',
sub => 'sub %(name)s%(attr)s {
if(@_>1) {
my ($self, $val) = @_;
%(set)s%(ret)s
} else {
my ($self) = @_;
%(get)s
}
}',
get => '$self->{%(name)s}',
set => '$self->{%(name)s} = $val',
ret => '; $self',
);
my $feature = {
has => [@_],
opt => \%opt,
name => $name,
construct => \%construct,
};
my $ASPECT = $meta->{aspect};
for(my $i=0; $i<@_; $i+=2) {
my ($aspect, $value) = @_[$i, $i+1];
my $aspect_sub = $ASPECT->{$aspect};
die "has: not exists aspect `$aspect`!" if !$aspect_sub;
$aspect_sub->($pkg, $name, $value, \%construct, $feature);
}
my $sub = _resolv($construct{eval}, \%construct);
eval $sub;
die if $@;
$feature->{sub} = $sub;
$meta->{feature}{$name} = $feature;
}
return;
}
sub _resolv {
my ($s, $construct) = @_;
$s =~ s{%\((\w*)\)s}{
die "has: not construct `$1`\!" unless exists $construct->{$1};
_resolv($construct->{$1}, $construct);
}ge;
$s
}
# конструктор
sub new {
my ($self, @errors) = create_from_params(@_);
die join "", "has:\n\n", map "* $_\n", @errors if @errors;
$self
}
# Устанавливает свойства и выдаёт объект и ошибки
sub create_from_params {
my ($cls, %value) = @_;
$cls = ref $cls || $cls;
is_aion $cls;
my $self = bless {}, $cls;
my @init;
my @required;
my @errors;
my $FEATURE = $Aion::META{$cls}{feature};
while(my ($name, $feature) = each %$FEATURE) {
if(exists $value{$name}) {
my $val = delete $value{$name};
if(!$feature->{excessive}) {
$val = $feature->{coerce}->coerce($val) if $feature->{coerce};
push @errors, $feature->{isa}->detail($val, "Feature $name")
if ISA =~ /w/ && $feature->{isa} && !$feature->{isa}->include($val);
$self->{$name} = $val;
push @init, $feature if $feature->{init};
}
else {
push @errors, "Feature $name cannot set in new!";
}
} elsif($feature->{required}) {
push @required, $name;
} elsif(exists $feature->{default}) {
$self->{$name} = $feature->{default};
push @init, $feature if $feature->{init};
}
}
for my $feature (@init) {
for my $init (@{$feature->{init}}) {
$init->($self, $feature);
}
}
do {local $" = ", "; unshift @errors, "Features @required is required!"} if @required > 1;
unshift @errors, "Feature @required is required!" if @required == 1;
my @fakekeys = sort keys %value;
unshift @errors, "@fakekeys is not feature!" if @fakekeys == 1;
do {local $" = ", "; unshift @errors, "@fakekeys is not features!"} if @fakekeys > 1;
return $self, @errors;
}
1;
__END__
=encoding utf-8
=head1 NAME
Aion - a postmodern object system for Perl 5, as C<Moose> and C<Moo>, but with improvements
=head1 VERSION
0.1
=head1 SYNOPSIS
package Calc {
use Aion;
has a => (is => 'ro+', isa => Num);
has b => (is => 'ro+', isa => Num);
has op => (is => 'ro', isa => Enum[qw/+ - * \/ **/], default => '+');
sub result {
my ($self) = @_;
eval "${\ $self->a} ${\ $self->op} ${\ $self->b}"
}
}
Calc->new(a => 1.1, b => 2)->result # => 3.1
=head1 DESCRIPTION
Aion — OOP framework for create classes with B<features>, has B<aspects>, B<roles> and so on.
Properties declared via C<has> are called B<features>.
And C<is>, C<isa>, C<default> and so on in C<has> are called B<aspects>.
In addition to standard aspects, roles can add their own aspects using subroutine C<aspect>.
=head1 SUBROUTINES IN CLASSES AND ROLES
C<use Aion> include in module types from C<Aion::Types> and next subroutines:
=head2 has ($name, %aspects)
Make method for get/set feature (property) of the class.
File lib/Animal.pm:
package Animal;
use Aion;
has type => (is => 'ro+', isa => Str);
has name => (is => 'rw-', isa => Str, default => 'murka');
1;
use lib "lib";
use Animal;
my $cat = Animal->new(type => 'cat');
$cat->type # => cat
$cat->name # => murka
$cat->name("murzik");
$cat->name # => murzik
=head2 with
Add to module roles. It call on each the role method C<import_with>.
File lib/Role/Keys/Stringify.pm:
package Role::Keys::Stringify;
use Aion -role;
sub keysify {
my ($self) = @_;
join ", ", sort keys %$self;
}
1;
File lib/Role/Values/Stringify.pm:
package Role::Values::Stringify;
use Aion -role;
sub valsify {
my ($self) = @_;
join ", ", map $self->{$_}, sort keys %$self;
}
1;
File lib/Class/All/Stringify.pm:
package Class::All::Stringify;
use Aion;
with qw/Role::Keys::Stringify Role::Values::Stringify/;
has [qw/key1 key2/] => (is => 'rw', isa => Str);
1;
use lib "lib";
use Class::All::Stringify;
my $s = Class::All::Stringify->new(key1=>"a", key2=>"b");
$s->keysify # => key1, key2
$s->valsify # => a, b
=head2 isa ($package)
Check C<$package> is the class what extended this class.
package Ex::X { use Aion; }
package Ex::A { use Aion; extends qw/Ex::X/; }
package Ex::B { use Aion; }
package Ex::C { use Aion; extends qw/Ex::A Ex::B/ }
Ex::C->isa("Ex::A") # -> 1
Ex::C->isa("Ex::B") # -> 1
Ex::C->isa("Ex::X") # -> 1
Ex::C->isa("Ex::X1") # -> ""
Ex::A->isa("Ex::X") # -> 1
Ex::A->isa("Ex::A") # -> 1
Ex::X->isa("Ex::X") # -> 1
=head2 does ($package)
Check C<$package> is the role what extended this class.
package Role::X { use Aion -role; }
package Role::A { use Aion; with qw/Role::X/; }
package Role::B { use Aion; }
package Ex::Z { use Aion; with qw/Role::A Role::B/ }
Ex::Z->does("Role::A") # -> 1
Ex::Z->does("Role::B") # -> 1
Ex::Z->does("Role::X") # -> 1
Role::A->does("Role::X") # -> 1
Role::A->does("Role::X1") # -> ""
Ex::Z->does("Ex::Z") # -> ""
=head2 aspect ($aspect => sub { ... })
It add aspect to C<has> in this class or role, and to the classes, who use this role, if it role.
package Example::Earth {
use Aion;
aspect lvalue => sub {
my ($cls, $name, $value, $construct, $feature) = @_;
$construct->{attr} .= ":lvalue";
};
has moon => (is => "rw", lvalue => 1);
}
my $earth = Example::Earth->new;
$earth->moon = "Mars";
$earth->moon # => Mars
Aspect is called every time it is specified in C<has>.
Aspect handler has parameters:
=over
=item * C<$cls> — the package with the C<has>.
=item * C<$name> — the feature name.
=item * C<$value> — the aspect value.
=item * C<$construct> — the hash with code fragments for join to the feature method.
=item * C<$feature> — the hash present feature.
=back
package Example::Mars {
use Aion;
aspect lvalue => sub {
my ($cls, $name, $value, $construct, $feature) = @_;
$construct->{attr} .= ":lvalue";
$cls # => Example::Mars
$name # => moon
$value # -> 1
[sort keys %$construct] # --> [qw/attr eval get name pkg ret set sub/]
[sort keys %$feature] # --> [qw/construct has name opt/]
my $_construct = {
pkg => $cls,
name => $name,
attr => ':lvalue',
eval => 'package %(pkg)s {
%(sub)s
}',
sub => 'sub %(name)s%(attr)s {
if(@_>1) {
my ($self, $val) = @_;
%(set)s%(ret)s
} else {
my ($self) = @_;
%(get)s
}
}',
get => '$self->{%(name)s}',
set => '$self->{%(name)s} = $val',
ret => '; $self',
};
$construct # --> $_construct
my $_feature = {
has => [is => "rw", lvalue => 1],
opt => {
is => "rw",
lvalue => 1,
},
name => $name,
construct => $_construct,
};
$feature # --> $_feature
};
has moon => (is => "rw", lvalue => 1);
}
=head1 SUBROUTINES IN CLASSES
=head2 extends (@superclasses)
Extends package other package. It call on each the package method C<import_extends> if it exists.
package World { use Aion;
our $extended_by_this = 0;
sub import_extends {
my ($class, $extends) = @_;
$extended_by_this ++;
$class # => World
$extends # => Hello
}
}
package Hello { use Aion;
extends qw/World/;
$World::extended_by_this # -> 1
}
Hello->isa("World") # -> 1
=head2 new (%param)
Constructor.
=over
=item * Set C<%param> to features.
=item * Check if param not mapped to feature.
=item * Set default values.
=back
package NewExample { use Aion;
has x => (is => 'ro', isa => Num);
has y => (is => 'ro+', isa => Num);
has z => (is => 'ro-', isa => Num);
}
eval { NewExample->new(f => 5) }; $@ # ~> f is not feature!
eval { NewExample->new(n => 5, r => 6) }; $@ # ~> n, r is not features!
eval { NewExample->new }; $@ # ~> Feature y is required!
eval { NewExample->new(z => 10) }; $@ # ~> Feature z cannot set in new!
my $ex = NewExample->new(y => 8);
eval { $ex->x }; $@ # ~> Get feature `x` must have the type Num. The it is undef
$ex = NewExample->new(x => 10.1, y => 8);
$ex->x # -> 10.1
=head1 SUBROUTINES IN ROLES
=head2 requires (@subroutine_names)
Check who in classes who use the role present the subroutines.
package Role::Alpha { use Aion -role;
sub in {
my ($self, $s) = @_;
$s =~ /[${\ $self->abc }]/
}
requires qw/abc/;
}
eval { package Omega1 { use Aion; with Role::Alpha; } }; $@ # ~> abc requires!
package Omega { use Aion;
with Role::Alpha;
sub abc { "abc" }
}
Omega->new->in("a") # -> 1
=head1 METHODS
=head2 has ($feature)
It check what property is set.
package ExHas { use Aion;
has x => (is => 'rw');
}
my $ex = ExHas->new;
$ex->has("x") # -> ""
$ex->x(10);
$ex->has("x") # -> 1
=head2 clear (@features)
Cleared the features.
package ExClear { use Aion;
has x => (is => 'rw');
has y => (is => 'rw');
}
my $c = ExClear->new(x => 10, y => 12);
$c->has("x") # -> 1
$c->has("y") # -> 1
$c->clear(qw/x y/);
$c->has("x") # -> ""
$c->has("y") # -> ""
=head1 METHODS IN CLASSES
C<use Aion> include in module next methods:
=head2 new (%parameters)
The constructor.
=head1 ASPECTS
C<use Aion> include in module next aspects for use in C<has>:
=head2 is => $permissions
=over
=item * C<ro> — make getter only.
=item * C<wo> — make setter only.
=item * C<rw> — make getter and setter.
=back
Default is C<rw>.
Additional permissions:
=over
=item * C<+> — the feature is required. It is not used with C<->.
=item * C<-> — the feature cannot be set in the constructor. It is not used with C<+>.
=item * C<*> — the value is reference and it maked weaken can be set.
=back
package ExIs { use Aion;
has rw => (is => 'rw');
has ro => (is => 'ro+');
has wo => (is => 'wo-');
}
eval { ExIs->new }; $@ # ~> \* Feature ro is required!
eval { ExIs->new(ro => 10, wo => -10) }; $@ # ~> \* Feature wo cannot set in new!
ExIs->new(ro => 10);
ExIs->new(ro => 10, rw => 20);
ExIs->new(ro => 10)->ro # -> 10
ExIs->new(ro => 10)->wo(30)->has("wo") # -> 1
eval { ExIs->new(ro => 10)->wo }; $@ # ~> has: wo is wo- \(not get\)
ExIs->new(ro => 10)->rw(30)->rw # -> 30
Feature with C<*> don't hold value:
package Node { use Aion;
has parent => (is => "rw*", isa => Maybe[Object["Node"]]);
}
my $root = Node->new;
my $node = Node->new(parent => $root);
$node->parent->parent # -> undef
undef $root;
$node->parent # -> undef
# And by setter:
$node->parent($root = Node->new);
$node->parent->parent # -> undef
undef $root;
$node->parent # -> undef
=head2 isa => $type
Set feature type. It validate feature value
=head2 default => $value
Default value set in constructor, if feature falue not present.
package ExDefault { use Aion;
has x => (is => 'ro', default => 10);
}
ExDefault->new->x # -> 10
ExDefault->new(x => 20)->x # -> 20
If C<$value> is subroutine, then the subroutine is considered a constructor for feature value. This subroutine lazy called where the value get.
my $count = 10;
package ExLazy { use Aion;
has x => (default => sub {
my ($self) = @_;
++$count
});
}
my $ex = ExLazy->new;
$count # -> 10
$ex->x # -> 11
$count # -> 11
$ex->x # -> 11
$count # -> 11
=head2 trigger => $sub
C<$sub> called after the value of the feature is set (in C<new> or in setter).
package ExTrigger { use Aion;
has x => (trigger => sub {
my ($self, $old_value) = @_;
$self->y($old_value + $self->x);
});
has y => ();
}
my $ex = ExTrigger->new(x => 10);
$ex->y # -> 10
$ex->x(20);
$ex->y # -> 30
=head1 ATTRIBUTES
Aion add universal attributes.
=head2 Isa (@signature)
Attribute C<Isa> check the signature the function where it called.
B<WARNING>: use atribute C<Isa> slows down the program.
B<TIP>: use aspect C<isa> on features is more than enough to check the correctness of the object data.
package Anim { use Aion;
sub is_cat : Isa(Object => Str => Bool) {
my ($self, $anim) = @_;
$anim =~ /(cat)/
}
}
my $anim = Anim->new;
$anim->is_cat('cat') # -> 1
$anim->is_cat('dog') # -> ""
eval { Anim->is_cat("cat") }; $@ # ~> Arguments of method `is_cat` must have the type Tuple\[Object, Str\].
eval { my @items = $anim->is_cat("cat") }; $@ # ~> Returns of method `is_cat` must have the type Tuple\[Bool\].
If use name of type in C<@signature>, then call subroutine with this name from current package.
=head1 AUTHOR
Yaroslav O. Kosmina LL<mailto:dart@cpan.org>
=head1 LICENSE
⚖ B<GPLv3>
=head1 COPYRIGHT
The Aion module is copyright © 2023 Yaroslav O. Kosmina. Rusland. All rights reserved.