File Coverage

blib/lib/Class/Type/Enum.pm

Criterion	Covered	Total	%
statement	106	109	97.2
branch	21	26	80.7
condition	3	6	50.0
subroutine	32	32	100.0
pod	16	16	100.0
total	178	189	94.1

package Class::Type::Enum;
# ABSTRACT: Build Enum-like classes
$Class::Type::Enum::VERSION = '0.013';

use strict;
use warnings;

use Carp qw(croak);
use Class::Method::Modifiers qw(install_modifier);
use List::Util 1.33;
use Scalar::Util qw(blessed);

use namespace::clean;

use overload (
  '""'     => 'stringify',
  'cmp'    => 'cmp',
  '0+'     => 'numify',
  fallback => 1,
);



sub import {
  my ($class, %params) = @_;

  # import is inherited, but we don't want to do all this to everything that
  # uses a subclass of Class::Type::Enum.
  return unless $class eq __PACKAGE__;
  # If there's a use case for it, we can still allow extending CTE subclasses.

  my $target = caller;

  my %values;

  if (ref $params{values} eq 'ARRAY') {
    my $i = 0;
    %values = map { $_ => $i++ } @{$params{values}};
  }
  elsif (ref $params{values} eq 'HASH') {
    %values = %{$params{values}};
  }
  else {
    croak "Enum values must be provided either as an array or hash ref.";
  }

  ## the bits that are installed into the target class, plus @ISA
  {
    no strict 'refs';
    push @{"${target}::ISA"}, $class;
  }
  install_modifier $target, 'fresh', sym_to_ord => sub { \%values };
  install_modifier $target, 'fresh', ord_to_sym => sub { +{ reverse(%values) } };

  install_modifier $target, 'fresh', values => sub {
    my $ord = $_[0]->sym_to_ord;
    [ sort { $ord->{$a} <=> $ord->{$b} } keys %values ];
  };

  for my $value (keys %values) {
    install_modifier $target, 'fresh', "is_$value" => sub { $_[0]->is($value) };
  }
}



sub new {
  my ($class, $value) = @_;

  (blessed($class) || $class)->inflate_symbol($value);
}


sub inflate_symbol {
  my ($class, $symbol) = @_;

  my $ord = $class->sym_to_ord->{$symbol};

  croak "Value [$symbol] is not valid for enum $class"
    unless defined $ord;

  bless \$ord, $class;
}


sub inflate_ordinal {
  my ($class, $ord) = @_;

  croak "Ordinal [$ord] is not valid for enum $class"
    unless exists $class->ord_to_sym->{$ord};

  bless \$ord, $class;
}


sub list_is_methods {
  my ($class) = @_;

  map "is_$_", @{$class->values};
}


sub type_constraint {
  my ($class) = @_;

  require Type::Tiny::Class;
  require Types::Standard;
  Type::Tiny::Class->new(class => blessed($class) || $class)
    ->plus_constructors(Types::Standard::Str(), 'inflate_symbol');
}


sub test_symbol {
  my ($class, $value) = @_;

  exists($class->sym_to_ord->{$value})
}


sub test_ordinal {
  my ($class, $value) = @_;

  exists($class->ord_to_sym->{$value})
}


sub coerce_symbol {
  my ($class, $value) = @_;
  return $value if eval { $value->isa($class) };

  $class->inflate_symbol($value);
}


sub coerce_ordinal {
  my ($class, $value) = @_;
  return $value if eval { $value->isa($class) };

  $class->inflate_ordinal($value);
}


sub coerce_any {
  my ($class, $value) = @_;
  return $value if eval { $value->isa($class) };

  for my $method (qw( inflate_ordinal inflate_symbol )) {
    my $enum = eval { $class->$method($value) };
    return $enum if $enum;
  }
  croak "Could not coerce invalid value [$value] into $class";
}



sub is {
  my ($self, $value) = @_;
  my $ord = $self->sym_to_ord->{$value};

  croak "Value [$value] is not valid for enum " . blessed($self)
    unless defined $ord;

  $$self == $ord;
}



sub stringify {
  my ($self) = @_;
  $self->ord_to_sym->{$$self};
}


sub numify {
  my ($self) = @_;
  $$self;
}


sub cmp {
  my ($self, $other, $reversed) = @_;
  return -1 * $self->cmp($other) if $reversed;

  return $$self <=> $other if blessed($other);

  my $ord = $self->sym_to_ord->{$other};
  croak "Cannot compare to invalid symbol [$other] for " . blessed($self)
    unless defined $ord;

  return $$self <=> $ord;
}


sub any {
  my ($self, @cases) = @_;

  List::Util::any { $self->is($_) } @cases;
}


sub none {
  my ($self, @cases) = @_;

  List::Util::none { $self->is($_) } @cases;
}



1;

__END__