—

              
package Type::Tiny::Enum;
use 5.008001;
use strict;
use warnings;
BEGIN {
        $Type::Tiny::Enum::AUTHORITY = 'cpan:TOBYINK';
        $Type::Tiny::Enum::VERSION   = '2.008000';
}
$Type::Tiny::Enum::VERSION =~ tr/_//d;
sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
use Exporter::Tiny 1.004001 ();
use Type::Tiny ();
our @ISA = qw( Type::Tiny Exporter::Tiny );
__PACKAGE__->_install_overloads(
        q[@{}] => sub { shift->values },
);
sub _exporter_fail {
        my ( $class, $type_name, $values, $globals ) = @_;
        my $caller = $globals->{into};
        my $type = $class->new(
                name      => $type_name,
                values    => [ @$values ],
                coercion  => 1,
        );
        $INC{'Type/Registry.pm'}
                ? 'Type::Registry'->for_class( $caller )->add_type( $type, $type_name )
                : ( $Type::Registry::DELAYED{$caller}{$type_name} = $type )
                unless( ref($caller) or $caller eq '-lexical' or $globals->{'lexical'} );
        return map +( $_->{name} => $_->{code} ), @{ $type->exportables };
}
sub new {
        my $proto = shift;
         
        my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
        _croak
                "Enum type constraints cannot have a parent constraint passed to the constructor"
                if exists $opts{parent};
        _croak
                "Enum type constraints cannot have a constraint coderef passed to the constructor"
                if exists $opts{constraint};
        _croak
                "Enum type constraints cannot have a inlining coderef passed to the constructor"
                if exists $opts{inlined};
        _croak "Need to supply list of values" unless exists $opts{values};
         
        no warnings 'uninitialized';
        $opts{values} = [
                map "$_",
                @{ ref $opts{values} eq 'ARRAY' ? $opts{values} : [ $opts{values} ] }
        ];
         
        my %tmp;
        undef $tmp{$_} for @{ $opts{values} };
        $opts{unique_values} = [ sort keys %tmp ];
         
        my $xs_encoding = _xs_encoding( $opts{unique_values} );
        if ( defined $xs_encoding ) {
                my $xsub = Type::Tiny::XS::get_coderef_for( $xs_encoding );
                $opts{compiled_type_constraint} = $xsub if $xsub;
        }
         
        if ( defined $opts{coercion} and !ref $opts{coercion} and 1 eq $opts{coercion} )
        {
                delete $opts{coercion};
                $opts{_build_coercion} = sub {
                        require Types::Standard;
                        my $c = shift;
                        my $t = $c->type_constraint;
                        $c->add_type_coercions(
                                Types::Standard::Str(),
                                sub { $t->closest_match( @_ ? $_[0] : $_ ) }
                        );
                };
        } #/ if ( defined $opts{coercion...})
         
        return $proto->SUPER::new( %opts );
} #/ sub new
sub _lockdown {
        my ( $self, $callback ) = @_;
        $callback->( $self->{values}, $self->{unique_values} );
}
sub new_union {
        my $proto  = shift;
        my %opts   = ( @_ == 1 ) ? %{ $_[0] } : @_;
        my @types  = @{ delete $opts{type_constraints} };
        my @values = map @$_, @types;
        $proto->new( %opts, values => \@values );
}
sub new_intersection {
        my $proto  = shift;
        my %opts   = ( @_ == 1 ) ? %{ $_[0] } : @_;
        my @types  = @{ delete $opts{type_constraints} };
        my %values; ++$values{$_} for map @$_, @types;
        my @values = sort grep $values{$_}==@types, keys %values;
        $proto->new( %opts, values => \@values );
}
sub values        { $_[0]{values} }
sub unique_values { $_[0]{unique_values} }
sub constraint    { $_[0]{constraint} ||= $_[0]->_build_constraint }
sub _is_null_constraint { 0 }
sub _build_display_name {
        my $self = shift;
        sprintf( "Enum[%s]", join q[,], @{ $self->unique_values } );
}
sub is_word_safe {
        my $self = shift;
        return not grep /\W/, @{ $self->unique_values };
}
sub exportables {
        my ( $self, $base_name ) = @_;
        if ( not $self->is_anon ) {
                $base_name ||= $self->name;
        }
         
        my $exportables = $self->SUPER::exportables( $base_name );
         
        if ( $self->is_word_safe ) {
                require Eval::TypeTiny;
                require B;
                for my $value ( @{ $self->unique_values } ) {
                        push @$exportables, {
                                name => uc( sprintf '%s_%s', $base_name, $value ),
                                tags => [ 'constants' ],
                                code => Eval::TypeTiny::eval_closure(
                                        source      => sprintf( 'sub () { %s }', B::perlstring($value) ),
                                        environment => {},
                                ),
                        };
                }
        }
         
        return $exportables;
}
{
        my $new_xs;
         
        #
        # Note the fallback code for older Type::Tiny::XS cannot be tested as
        # part of the coverage tests because they use the latest Type::Tiny::XS.
        #
         
        sub _xs_encoding {
                my $unique_values = shift;
                 
                return undef unless Type::Tiny::_USE_XS;
                 
                return undef if @$unique_values > 50;    # RT 121957
                 
                $new_xs = eval { Type::Tiny::XS->VERSION( "0.020" ); 1 } ? 1 : 0
                        unless defined $new_xs;
                if ( $new_xs ) {
                        require B;
                        return sprintf(
                                "Enum[%s]",
                                join( ",", map B::perlstring( $_ ), @$unique_values )
                        );
                }
                else {                                   # uncoverable statement
                        return undef if grep /\W/, @$unique_values;                    # uncoverable statement
                        return sprintf( "Enum[%s]", join( ",", @$unique_values ) );    # uncoverable statement
                }    # uncoverable statement
        } #/ sub _xs_encoding
}
{
        my %cached;
         
        sub _build_constraint {
                my $self = shift;
                 
                my $regexp = $self->_regexp;
                return $cached{$regexp} if $cached{$regexp};
                my $coderef = ( $cached{$regexp} = sub { defined and m{\A(?:$regexp)\z} } );
                Scalar::Util::weaken( $cached{$regexp} );
                return $coderef;
        }
}
{
        my %cached;
         
        sub _build_compiled_check {
                my $self   = shift;
                my $regexp = $self->_regexp;
                return $cached{$regexp} if $cached{$regexp};
                my $coderef = ( $cached{$regexp} = $self->SUPER::_build_compiled_check( @_ ) );
                Scalar::Util::weaken( $cached{$regexp} );
                return $coderef;
        }
}
sub _regexp {
        my $self = shift;
        $self->{_regexp} ||= 'Type::Tiny::Enum::_Trie'->handle( $self->unique_values );
}
sub as_regexp {
        my $self = shift;
         
        my $flags = @_ ? $_[0] : '';
        unless ( defined $flags and $flags =~ /^[i]*$/ ) {
                _croak(
                        "Unknown regexp flags: '$flags'; only 'i' currently accepted; stopped" );
        }
         
        my $regexp = $self->_regexp;
        $flags ? qr/\A(?:$regexp)\z/i : qr/\A(?:$regexp)\z/;
} #/ sub as_regexp
sub can_be_inlined {
        !!1;
}
sub inline_check {
        my $self = shift;
         
        my $xsub;
        if ( my $xs_encoding = _xs_encoding( $self->unique_values ) ) {
                $xsub = Type::Tiny::XS::get_subname_for( $xs_encoding );
                return "$xsub\($_[0]\)" if $xsub && !$Type::Tiny::AvoidCallbacks;
        }
         
        my $regexp = $self->_regexp;
        my $code =
                $_[0] eq '$_'
                ? "(defined and !ref and m{\\A(?:$regexp)\\z})"
                : "(defined($_[0]) and !ref($_[0]) and $_[0] =~ m{\\A(?:$regexp)\\z})";
                 
        return "do { $Type::Tiny::SafePackage $code }"
                if $Type::Tiny::AvoidCallbacks;
        return $code;
} #/ sub inline_check
sub _instantiate_moose_type {
        my $self = shift;
        my %opts = @_;
        delete $opts{parent};
        delete $opts{constraint};
        delete $opts{inlined};
        require Moose::Meta::TypeConstraint::Enum;
        return "Moose::Meta::TypeConstraint::Enum"
                ->new( %opts, values => $self->values );
} #/ sub _instantiate_moose_type
sub has_parent {
        !!1;
}
sub parent {
        require Types::Standard;
        Types::Standard::Str();
}
sub validate_explain {
        my $self = shift;
        my ( $value, $varname ) = @_;
        $varname = '$_' unless defined $varname;
         
        return undef if $self->check( $value );
         
        require Type::Utils;
        !defined( $value )
                ? [
                sprintf(
                        '"%s" requires that the value is defined',
                        $self,
                ),
                ]
                : @$self < 13 ? [
                sprintf(
                        '"%s" requires that the value is equal to %s',
                        $self,
                        Type::Utils::english_list( \"or", map B::perlstring( $_ ), @$self ),
                ),
                ]
                : [
                sprintf(
                        '"%s" requires that the value is one of an enumerated list of strings',
                        $self,
                ),
                ];
} #/ sub validate_explain
sub has_sorter {
        !!1;
}
sub _enum_order_hash {
        my $self = shift;
        my %hash;
        my $i = 0;
        for my $value ( @{ $self->values } ) {
                next if exists $hash{$value};
                $hash{$value} = $i++;
        }
        return %hash;
} #/ sub _enum_order_hash
sub sorter {
        my $self = shift;
        my %hash = $self->_enum_order_hash;
        return [
                sub { $_[0] <=> $_[1] },
                sub { exists( $hash{ $_[0] } ) ? $hash{ $_[0] } : 2_100_000_000 },
        ];
}
my $canon;
sub closest_match {
        require Types::Standard;
         
        my ( $self, $given ) = ( shift, @_ );
         
        return unless Types::Standard::is_Str $given;
         
        return $given if $self->check( $given );
         
        $canon ||= eval(
                $] lt '5.016'
                ? q< sub { ( my $var = lc($_[0]) ) =~ s/(^\s+)|(\s+$)//g; $var } >
                : q< sub { CORE::fc($_[0]) =~ s/(^\s+)|(\s+$)//gr; } >
        );
         
        $self->{_lookups} ||= do {
                my %lookups;
                for ( @{ $self->values } ) {
                        my $key = $canon->( $_ );
                        next if exists $lookups{$key};
                        $lookups{$key} = $_;
                }
                \%lookups;
        };
         
        my $cgiven = $canon->( $given );
        return $self->{_lookups}{$cgiven}
                if $self->{_lookups}{$cgiven};
                 
        my $best;
        VALUE: for my $possible ( @{ $self->values } ) {
                my $stem = substr( $possible, 0, length $cgiven );
                if ( $cgiven eq $canon->( $stem ) ) {
                        if ( defined( $best ) and length( $best ) >= length( $possible ) ) {
                                next VALUE;
                        }
                        $best = $possible;
                }
        }
         
        return $best if defined $best;
         
        return $self->values->[$given]
                if Types::Standard::is_Int $given;
                 
        return $given;
} #/ sub closest_match
push @Type::Tiny::CMP, sub {
        my $A = shift->find_constraining_type;
        my $B = shift->find_constraining_type;
        return Type::Tiny::CMP_UNKNOWN
                unless $A->isa( __PACKAGE__ ) && $B->isa( __PACKAGE__ );
                 
        my %seen;
        for my $word ( @{ $A->unique_values } ) {
                $seen{$word} += 1;
        }
        for my $word ( @{ $B->unique_values } ) {
                $seen{$word} += 2;
        }
         
        my $values = join( '', CORE::values %seen );
        if ( $values =~ /^3*$/ ) {
                return Type::Tiny::CMP_EQUIVALENT;
        }
        elsif ( $values !~ /2/ ) {
                return Type::Tiny::CMP_SUPERTYPE;
        }
        elsif ( $values !~ /1/ ) {
                return Type::Tiny::CMP_SUBTYPE;
        }
         
        return Type::Tiny::CMP_UNKNOWN;
};
package    # stolen from Regexp::Trie
        Type::Tiny::Enum::_Trie;
sub new { bless {} => shift }
sub add {
        my $self = shift;
        my $str  = shift;
        my $ref  = $self;
        for my $char ( split //, $str ) {
                $ref->{$char} ||= {};
                $ref = $ref->{$char};
        }
        $ref->{''} = 1;    # { '' => 1 } as terminator
        $self;
} #/ sub add
sub _regexp {
        my $self = shift;
        return if $self->{''} and scalar keys %$self == 1;    # terminator
        my ( @alt, @cc );
        my $q = 0;
        for my $char ( sort keys %$self ) {
                my $qchar = quotemeta $char;
                if ( ref $self->{$char} ) {
                        if ( defined( my $recurse = _regexp( $self->{$char} ) ) ) {
                                push @alt, $qchar . $recurse;
                        }
                        else {
                                push @cc, $qchar;
                        }
                }
                else {
                        $q = 1;
                }
        } #/ for my $char ( sort keys...)
        my $cconly = !@alt;
        @cc and push @alt, @cc == 1 ? $cc[0] : '[' . join( '', @cc ) . ']';
        my $result = @alt == 1 ? $alt[0] : '(?:' . join( '|', @alt ) . ')';
        $q and $result = $cconly ? "$result?" : "(?:$result)?";
        return $result;
} #/ sub _regexp
sub handle {
        my $class = shift;
        my ( $vals ) = @_;
        return '(?!)' unless @$vals;
        my $self = $class->new;
        $self->add( $_ ) for @$vals;
        $self->_regexp;
}
1;
__END__
HideShow 259 lines of Pod
=pod
=encoding utf-8
=head1 NAME
Type::Tiny::Enum - string enum type constraints
=head1 SYNOPSIS
Using via L<Types::Standard>:
  package Horse {
    use Moo;
    use Types::Standard qw( Str Enum );
     
    has name    => ( is => 'ro', isa => Str );
    has status  => ( is => 'ro', isa => Enum[ 'alive', 'dead' ] );
     
    sub neigh {
      my ( $self ) = @_;
      return if $self->status eq 'dead';
      ...;
    }
  }
Using Type::Tiny::Enum's export feature:
  package Horse {
    use Moo;
    use Types::Standard qw( Str );
    use Type::Tiny::Enum Status => [ 'alive', 'dead' ];
     
    has name    => ( is => 'ro', isa => Str );
    has status  => ( is => 'ro', isa => Status, default => STATUS_ALIVE );
     
    sub neigh {
      my ( $self ) = @_;
      return if $self->status eq STATUS_DEAD;
      ...;
    }
  }
Using Type::Tiny::Enum's object-oriented interface:
  package Horse {
    use Moo;
    use Types::Standard qw( Str );
    use Type::Tiny::Enum;
     
    my $Status = Type::Tiny::Enum->new(
      name   => 'Status',
      values => [ 'alive', 'dead' ],
    );
     
    has name    => ( is => 'ro', isa => Str );
    has status  => ( is => 'ro', isa => $Status, default => $Status->[0] );
     
    sub neigh {
      my ( $self ) = @_;
      return if $self->status eq $Status->[0];
      ...;
    }
  }
=head1 STATUS
This module is covered by the
L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">.
=head1 DESCRIPTION
Enum type constraints.
This package inherits from L<Type::Tiny>; see that for most documentation.
Major differences are listed below:
=head2 Constructors
The C<new> constructor from L<Type::Tiny> still works, of course. But there
is also:
=over
=item C<< new_union( type_constraints => \@enums, %opts ) >>
Creates a new enum type constraint which is the union of existing enum
type constraints.
=item C<< new_intersection( type_constraints => \@enums, %opts ) >>
Creates a new enum type constraint which is the intersection of existing enum
type constraints.
=back
=head2 Attributes
=over
=item C<values>
Arrayref of allowable value strings. Non-string values (e.g. objects with
overloading) will be stringified in the constructor.
=item C<constraint>
Unlike Type::Tiny, you I<cannot> pass a constraint coderef to the constructor.
Instead rely on the default.
=item C<inlined>
Unlike Type::Tiny, you I<cannot> pass an inlining coderef to the constructor.
Instead rely on the default.
=item C<parent>
Parent is always B<Types::Standard::Str>, and cannot be passed to the
constructor.
=item C<unique_values>
The list of C<values> but sorted and with duplicates removed. This cannot
be passed to the constructor.
=item C<coercion>
If C<< coercion => 1 >> is passed to the constructor, the type will have a
coercion using the C<closest_match> method.
=back
=head2 Methods
=over
=item C<as_regexp>
Returns the enum as a regexp which strings can be checked against. If you're
checking I<< a lot >> of strings, then using this regexp might be faster than
checking each string against 
  my $enum  = Type::Tiny::Enum->new(...);
  my $check = $enum->compiled_check;
  my $re    = $enum->as_regexp;
   
  # fast
  my @valid_tokens = grep $enum->check($_), @all_tokens;
   
  # faster
  my @valid_tokens = grep $check->($_), @all_tokens;
   
  # fastest
  my @valid_tokens = grep /$re/, @all_tokens;
You can get a case-insensitive regexp using C<< $enum->as_regexp('i') >>.
=item C<closest_match>
Returns the closest match in the enum for a string.
  my $enum = Type::Tiny::Enum->new(
    values => [ qw( foo bar baz quux ) ],
  );
   
  say $enum->closest_match("FO");   # ==> foo
It will try to find an exact match first, fall back to a case-insensitive
match, if it still can't find one, will try to find a head substring match,
and finally, if given an integer, will use that as an index.
  my $enum = Type::Tiny::Enum->new(
    values => [ qw( foo bar baz quux ) ],
  );
   
  say $enum->closest_match(  0 );  # ==> foo
  say $enum->closest_match(  1 );  # ==> bar
  say $enum->closest_match(  2 );  # ==> baz
  say $enum->closest_match( -1 );  # ==> quux
=item C<< is_word_safe >>
Returns true if none of the values in the enumeration contain a non-word
character. Word characters include letters, numbers, and underscores, but
not most punctuation or whitespace.
=back
=head2 Exports
Type::Tiny::Enum can be used as an exporter.
  use Type::Tiny::Enum Status => [ 'dead', 'alive' ];
This will export the following functions into your namespace:
=over
=item C<< Status >>
=item C<< is_Status( $value ) >>
=item C<< assert_Status( $value ) >>
=item C<< to_Status( $value ) >>
=item C<< STATUS_DEAD >>
=item C<< STATUS_ALIVE >>
=back
Multiple enumerations can be exported at once:
  use Type::Tiny::Enum (
    Status    => [ 'dead', 'alive' ],
    TaxStatus => [ 'paid', 'pending' ],
  );
=head2 Overloading
=over
=item *
Arrayrefification calls C<values>.
=back
=head1 BUGS
Please report any bugs to
L<https://github.com/tobyink/p5-type-tiny/issues>.
=head1 SEE ALSO
L<Type::Tiny::Manual>.
L<Type::Tiny>.
L<Moose::Meta::TypeConstraint::Enum>.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2013-2014, 2017-2025 by Toby Inkster.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 DISCLAIMER OF WARRANTIES
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.