File Coverage

blib/lib/Data/Enum.pm

Criterion	Covered	Total	%
statement	69	69	100.0
branch	6	6	100.0
condition			n/a
subroutine	21	21	100.0
pod	2	2	100.0
total	98	98	100.0

package Data::Enum;

# ABSTRACT: immutable enumeration classes

use v5.20;
use warnings;

use Package::Stash;
use List::Util 1.45 qw/ any uniqstr /;
use Scalar::Util qw/ blessed refaddr /;

# RECOMMEND PREREQ: Package::Stash::XS

use experimental qw/ lexical_subs postderef signatures /;

use overload
  q{""} => \&as_string,
  q{eq} => \&MATCH,
  q{ne} => \&_NOT_MATCH;

use constant TRUE  => 1;
use constant FALSE => 0;

our $VERSION = 'v0.6.0';


sub new ( $this, @args ) {

    my $opts   = ref( $args[0] ) eq "HASH" ? shift @args : {};
    my $prefix = $opts->{prefix} // "is_";

    my @values = uniqstr( sort map { "$_" } @args );

    die "has no values" unless @values;

    die "values must be alphanumeric" if any { /\W/ } @values;

    my $key = join chr(28), @values;

    state %Cache;
    state $Counter = 1;

    if ( my $name = $Cache{$key} ) {
        return $name;
    }

    my $name = $opts->{name} || ( __PACKAGE__ . "::" . $Counter++ );

    my $base = Package::Stash->new($name);

    my sub _make_symbol($value) {
        my $self    = bless \$value, "${name}::${value}";
        Internals::SvREADONLY( $value, 1 );
        return $self;
    };

    my sub _make_predicate($value) {
        return $prefix . $value;
    };

    $base->add_symbol(
        '&new',
        sub( $class, $value ) {
            state $symbols = {
                map { $_ => _make_symbol($_) } @values
            };
            exists $symbols->{"$value"} or die "invalid value: '$value'";
            return $symbols->{"$value"};
        }
    );

    $base->add_symbol( '&values', sub($) { return @values } );

    $base->add_symbol(
        '&predicates',
        sub($) {
            return map { _make_predicate($_) } @values;
        }
    );

    $base->add_symbol( '&prefix', sub($) { $prefix } );

    for my $value (@values) {
        my $predicate = _make_predicate($value);
        $base->add_symbol( '&' . $predicate, \&FALSE );
        my $elem    = "${name}::${value}";
        my $subtype = Package::Stash->new($elem);
        $subtype->add_symbol( '@ISA', [ __PACKAGE__, $name ] );
        for my $other (@values) {
            $subtype->add_symbol( '&' . _make_predicate($other), $other eq $value ? \&TRUE : \&FALSE );
        }
    }

    return $Cache{$key} = $name;
}

sub _NOT_MATCH( $self, $arg, @ ) {
    return blessed($arg)
      ? refaddr($arg) != refaddr($self)
      : $arg ne $self->$*; # as_string
}


sub MATCH( $self, $arg, @ ) {
    return blessed($arg)
      ? refaddr($arg) == refaddr($self)
      : $arg eq $self->$*; # as_string
}


sub as_string($self, @) {
    return $self->$*;
}


1;

__END__