File Coverage

blib/lib/Data/Enum.pm

Criterion	Covered	Total	%
statement	75	75	100.0
branch	12	12	100.0
condition			n/a
subroutine	19	19	100.0
pod	1	1	100.0
total	107	107	100.0

package Data::Enum;

# ABSTRACT: immutable enumeration classes

use v5.10;

use strict;
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 overload ();

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

our $VERSION = 'v0.2.6';



sub new {
    my $this = shift;

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

    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 = "Data::Enum::" . $Counter++;

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

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

    my $_make_predicate = sub {
        my ($value) = @_;
        return "is_" . $value;
    };

    $base->add_symbol(
        '&new',
        sub {
            my ( $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 } );

    my $match = sub {
        my ( $self, $arg ) = @_;
        return blessed($arg)
            ? refaddr($arg) == refaddr($self)
            : $arg eq $$self;
    };

    $base->add_symbol( '&MATCH', $match );

    $name->overload::OVERLOAD(
        q{""} => sub { my ($self) = @_; return $$self; },
        q{eq} => $match,
        q{ne} => sub {
            my ( $self, $arg ) = @_;
            return blessed($arg)
              ? refaddr($arg) != refaddr($self)
              : $arg ne $$self;
        },
    );

    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',  [$name] );
        $subtype->add_symbol( '&' . $predicate, \&TRUE );
    }

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


1;

__END__