view release on metacpan or  search on metacpan

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

    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 {
	my ($cls, $value) = @_;
	my $case = $cls->tryFromValue($value);
    die "Did not case with value `$value`!" unless defined $case;
	$case
}

# Получить case по значению
sub tryFromValue {
	my ($cls, $value) = @_;
	my ($case) = grep { $_->{value} ~~ $value } $cls->cases;
	$case
}

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