view release on metacpan or  search on metacpan

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

use Aion -role;

# Импорт
sub import {
	my $pkg = caller;
	*{"${pkg}::issa"} = \&issa if $pkg->can('issa') != \&issa;
	*{"${pkg}::case"} = \&case if $pkg->can('case') != \&case;
	eval "package $pkg; use Aion -role; with 'Aion::Enum'; 1" or die
}

sub unimport {
	my $pkg = caller;
	undef &{"${pkg}::issa"};
	undef &{"${pkg}::case"};
	eval "package $pkg; no Aion; 1" or die
}

#@category Свойства
has name  => (is => 'ro');
has value => (is => 'ro');
has stash => (is => 'ro');
has alias => (is => 'ro', default => sub {
    my ($self) = @_;
    $self->_alias->{$self->{name}};
});

#@category Управленцы

# Создать перечисление
sub case(@) {
	my ($name, $value, $stash) = @_;
	
	die "The case name must by 1+ simbol!" unless length $name;
	
	my $pkg = caller;
	my $meta = $Aion::META{$pkg};
	my $issa = $meta->{issa};
	my $enum = $meta->{enum} //= [];
	
	$issa->{name}->validate($name, "$name name") if $issa->{name};
	$issa->{value}->validate($value, "$name value") if $issa->{value};
	$issa->{stash}->validate($stash, "$name stash") if $issa->{stash};
	$issa->{alias}->validate($pkg->_alias->{$name}, "$name alias") if $issa->{alias};
	
	my $case = bless {
        name => $name,
        defined($value)? (value => $value): (),
        defined($stash)? (stash => $stash): (),
    }, $pkg;

    push @$enum, $case;

    constant->import("${pkg}::$name", $case);

    return;
}

# Задаёт типы для value и stash
sub issa(@) {
	my $pkg = caller;
	my ($nameisa, $valueisa, $stashisa, $aliasisa) = map { ref $_ eq '' ? eval "package $pkg; $_" || die : $_ } @_;
	$Aion::META{$pkg}{issa} = {
		name => $nameisa,
		value => $valueisa,
		stash => $stashisa,
		alias => $aliasisa,
	};
	return;
}

#@category Перечисления

# Перечисления
sub cases {
	my ($cls) = @_;
	@{$Aion::META{ref $cls || $cls}{enum}}
}

# Имена
sub names {
	my ($cls) = @_;
	map $_->{name}, $cls->cases
}

# Значения
sub values {
	my ($cls) = @_;
	map $_->{value}, $cls->cases
}

# Дополнения
sub stashes {
	my ($cls) = @_;
	map $_->{stash}, $cls->cases
}

# Псевдонимы
sub aliases {
	my ($cls) = @_;
	map $_->alias, $cls->cases
}

my %ALIAS;
sub _alias {
	my ($cls) = @_;
	$cls = ref $cls || $cls;
	my $alias_ref = $ALIAS{$cls};
	
	return $alias_ref if $alias_ref;
	
	my $alias_ref = $ALIAS{$cls} = {};

    my $path = $INC{($cls =~ s!::!/!gr) . ".pm"};
    die "$cls not loaded!" unless $path;
    open my $f, "<:utf8", $path or die "$path: $!";
    my $alias;
    my $id = '[a-zA-Z_]\w*';
    while(<$f>) {
        $alias = $1 if /^# (\S.*?)\s*$/;

        do {
            $alias_ref->{$+{id}} = $alias;
            undef $alias;
        } if /^case \s+ (
                (?<id>$id)
            | '(?<id>$id)'
            | "(?<id>$id)"
            | q[wq]? (?:
                \{ (?<id>$id) \}
                | \[ (?<id>$id) \]
                | \( (?<id>$id) \)
                | < (?<id>$id) >
                | ([~!\@#$%^&*-+=\\\/|]) (?<id>$id) \2
            )
        )/x;
    }
    close $f;
    
    $alias_ref
}

#@category Конструкторы

# Получить case по имени c исключением
sub fromName {
	my ($cls, $name) = @_;
	my $case = $cls->tryFromName($name);
    die "Did not case with name `$name`!" unless defined $case;
	$case
}

# Получить case по имени
sub tryFromName {
	my ($cls, $name) = @_;
	my ($case) = grep { $_->{name} ~~ $name } $cls->cases;
	$case
}

# Получить case по значению c исключением
sub fromValue {