File Coverage

blib/lib/Type/Tiny/Enum.pm
Criterion Covered Total %
statement 203 222 92.3
branch 80 110 72.7
condition 27 41 65.8
subroutine 42 44 95.4
pod 17 17 100.0
total 369 434 85.4


line stmt bran cond sub pod time code
1             package Type::Tiny::Enum;
2              
3 33     23   72390 use 5.008001;
  23         96  
4 23     23   142 use strict;
  23         58  
  23         510  
5 23     23   125 use warnings;
  23         66  
  23         1066  
6              
7             BEGIN {
8 23     23   75 $Type::Tiny::Enum::AUTHORITY = 'cpan:TOBYINK';
9 23         1884 $Type::Tiny::Enum::VERSION = '2.004000';
10             }
11              
12             $Type::Tiny::Enum::VERSION =~ tr/_//d;
13              
14 5     5   27 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  5         24  
15              
16 23     23   1555 use Exporter::Tiny 1.004001 ();
  23         9340  
  23         502  
17 23     23   1468 use Type::Tiny ();
  23         61  
  23         7087  
18             our @ISA = qw( Type::Tiny Exporter::Tiny );
19              
20             __PACKAGE__->_install_overloads(
21 10     10   40 q[@{}] => sub { shift->values },
22             );
23              
24             sub _exporter_fail {
25 1     1   180 my ( $class, $type_name, $values, $globals ) = @_;
26 1         2 my $caller = $globals->{into};
27 1         4 my $type = $class->new(
28             name => $type_name,
29             values => [ @$values ],
30             coercion => 1,
31             );
32             $INC{'Type/Registry.pm'}
33             ? 'Type::Registry'->for_class( $caller )->add_type( $type, $type_name )
34             : ( $Type::Registry::DELAYED{$caller}{$type_name} = $type )
35 1 100 33     15 unless( ref($caller) or $caller eq '-lexical' or $globals->{'lexical'} );
    50 33        
36 1         3 return map +( $_->{name} => $_->{code} ), @{ $type->exportables };
  1         3  
37             }
38              
39             sub new {
40 51     51 1 299 my $proto = shift;
41            
42 51 50       253 my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
  0         0  
43             _croak
44             "Enum type constraints cannot have a parent constraint passed to the constructor"
45 51 100       175 if exists $opts{parent};
46             _croak
47             "Enum type constraints cannot have a constraint coderef passed to the constructor"
48 50 100       140 if exists $opts{constraint};
49             _croak
50             "Enum type constraints cannot have a inlining coderef passed to the constructor"
51 49 100       128 if exists $opts{inlined};
52 48 100       137 _croak "Need to supply list of values" unless exists $opts{values};
53            
54 23     23   201 no warnings 'uninitialized';
  23         64  
  23         71006  
55             $opts{values} = [
56             map "$_",
57 47 50       85 @{ ref $opts{values} eq 'ARRAY' ? $opts{values} : [ $opts{values} ] }
  47         340  
58             ];
59            
60 47         129 my %tmp;
61 47         81 undef $tmp{$_} for @{ $opts{values} };
  47         239  
62 47         289 $opts{unique_values} = [ sort keys %tmp ];
63            
64 47         152 my $xs_encoding = _xs_encoding( $opts{unique_values} );
65 47 50       214 if ( defined $xs_encoding ) {
66 47         207 my $xsub = Type::Tiny::XS::get_coderef_for( $xs_encoding );
67 47 50       2532 $opts{compiled_type_constraint} = $xsub if $xsub;
68             }
69            
70 47 100 100     209 if ( defined $opts{coercion} and !ref $opts{coercion} and 1 eq $opts{coercion} )
      66        
71             {
72 2         7 delete $opts{coercion};
73             $opts{_build_coercion} = sub {
74 2     2   11 require Types::Standard;
75 2         10 my $c = shift;
76 2         9 my $t = $c->type_constraint;
77             $c->add_type_coercions(
78             Types::Standard::Str(),
79 9 50       105 sub { $t->closest_match( @_ ? $_[0] : $_ ) }
80 2         8 );
81 2         13 };
82             } #/ if ( defined $opts{coercion...})
83            
84 47         459 return $proto->SUPER::new( %opts );
85             } #/ sub new
86              
87             sub _lockdown {
88 47     47   132 my ( $self, $callback ) = @_;
89 47         187 $callback->( $self->{values}, $self->{unique_values} );
90             }
91              
92             sub new_union {
93 1     1 1 3 my $proto = shift;
94 1 50       4 my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
  0         0  
95 1         2 my @types = @{ delete $opts{type_constraints} };
  1         3  
96 1         5 my @values = map @$_, @types;
97 1         5 $proto->new( %opts, values => \@values );
98             }
99              
100             sub new_intersection {
101 1     1 1 2 my $proto = shift;
102 1 50       4 my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
  0         0  
103 1         3 my @types = @{ delete $opts{type_constraints} };
  1         3  
104 1         3 my %values; ++$values{$_} for map @$_, @types;
  1         5  
105 1         10 my @values = sort grep $values{$_}==@types, keys %values;
106 1         7 $proto->new( %opts, values => \@values );
107             }
108              
109 28     28 1 692 sub values { $_[0]{values} }
110 381     381 1 1461 sub unique_values { $_[0]{unique_values} }
111 35   66 35 1 198 sub constraint { $_[0]{constraint} ||= $_[0]->_build_constraint }
112              
113 95     95   218 sub _is_null_constraint { 0 }
114              
115             sub _build_display_name {
116 16     16   47 my $self = shift;
117 16         31 sprintf( "Enum[%s]", join q[,], @{ $self->unique_values } );
  16         43  
118             }
119              
120             sub is_word_safe {
121 7     7 1 15 my $self = shift;
122 7         14 return not grep /\W/, @{ $self->unique_values };
  7         19  
123             }
124              
125             sub exportables {
126 7     7 1 24 my ( $self, $base_name ) = @_;
127 7 50       23 if ( not $self->is_anon ) {
128 7   33     45 $base_name ||= $self->name;
129             }
130            
131 7         42 my $exportables = $self->SUPER::exportables( $base_name );
132            
133 7 100       27 if ( $self->is_word_safe ) {
134 6         36 require Eval::TypeTiny;
135 6         24 require B;
136 6         22 for my $value ( @{ $self->unique_values } ) {
  6         20  
137 20         173 push @$exportables, {
138             name => uc( sprintf '%s_%s', $base_name, $value ),
139             tags => [ 'constants' ],
140             code => Eval::TypeTiny::eval_closure(
141             source => sprintf( 'sub () { %s }', B::perlstring($value) ),
142             environment => {},
143             ),
144             };
145             }
146             }
147            
148 7         48 return $exportables;
149             }
150              
151             {
152             my $new_xs;
153            
154             #
155             # Note the fallback code for older Type::Tiny::XS cannot be tested as
156             # part of the coverage tests because they use the latest Type::Tiny::XS.
157             #
158            
159             sub _xs_encoding {
160 359     359   482 my $unique_values = shift;
161            
162 359         638 return undef unless Type::Tiny::_USE_XS;
163            
164 359 50       904 return undef if @$unique_values > 50; # RT 121957
165            
166 359 50       726 $new_xs = eval { Type::Tiny::XS->VERSION( "0.020" ); 1 } ? 1 : 0
  22 100       331  
  22         120  
167             unless defined $new_xs;
168 359 50       661 if ( $new_xs ) {
169 359         1411 require B;
170 359         3476 return sprintf(
171             "Enum[%s]",
172             join( ",", map B::perlstring( $_ ), @$unique_values )
173             );
174             }
175             else { # uncoverable statement
176 0 0       0 return undef if grep /\W/, @$unique_values; # uncoverable statement
177 0         0 return sprintf( "Enum[%s]", join( ",", @$unique_values ) ); # uncoverable statement
178             } # uncoverable statement
179             } #/ sub _xs_encoding
180             }
181              
182             {
183             my %cached;
184            
185             sub _build_constraint {
186 5     5   9 my $self = shift;
187            
188 5         15 my $regexp = $self->_regexp;
189 5 100       24 return $cached{$regexp} if $cached{$regexp};
190 4 50   29   24 my $coderef = ( $cached{$regexp} = sub { defined and m{\A(?:$regexp)\z} } );
  20         323  
191 4         28 Scalar::Util::weaken( $cached{$regexp} );
192 3         13 return $coderef;
193             }
194             }
195              
196             {
197             my %cached;
198            
199             sub _build_compiled_check {
200 0     0   0 my $self = shift;
201 0         0 my $regexp = $self->_regexp;
202 0 0       0 return $cached{$regexp} if $cached{$regexp};
203 0         0 my $coderef = ( $cached{$regexp} = $self->SUPER::_build_compiled_check( @_ ) );
204 0         0 Scalar::Util::weaken( $cached{$regexp} );
205 0         0 return $coderef;
206             }
207             }
208              
209             sub _regexp {
210 62     62   97 my $self = shift;
211 62   66     218 $self->{_regexp} ||= 'Type::Tiny::Enum::_Trie'->handle( $self->unique_values );
212             }
213              
214             sub as_regexp {
215 3     3 1 1771 my $self = shift;
216            
217 3 100       11 my $flags = @_ ? $_[0] : '';
218 3 100 66     24 unless ( defined $flags and $flags =~ /^[i]*$/ ) {
219 1         10 _croak(
220             "Unknown regexp flags: '$flags'; only 'i' currently accepted; stopped" );
221             }
222            
223 2         7 my $regexp = $self->_regexp;
224 2 100       110 $flags ? qr/\A(?:$regexp)\z/i : qr/\A(?:$regexp)\z/;
225             } #/ sub as_regexp
226              
227             sub can_be_inlined {
228 256     256 1 1418 !!1;
229             }
230              
231             sub inline_check {
232 312     312 1 470 my $self = shift;
233            
234 312         363 my $xsub;
235 312 50       612 if ( my $xs_encoding = _xs_encoding( $self->unique_values ) ) {
236 312         834 $xsub = Type::Tiny::XS::get_subname_for( $xs_encoding );
237 312 100 66     6139 return "$xsub\($_[0]\)" if $xsub && !$Type::Tiny::AvoidCallbacks;
238             }
239            
240 55         174 my $regexp = $self->_regexp;
241 55 50       251 my $code =
242             $_[0] eq '$_'
243             ? "(defined and !ref and m{\\A(?:$regexp)\\z})"
244             : "(defined($_[0]) and !ref($_[0]) and $_[0] =~ m{\\A(?:$regexp)\\z})";
245            
246 55 50       2503 return "do { $Type::Tiny::SafePackage $code }"
247             if $Type::Tiny::AvoidCallbacks;
248 0         0 return $code;
249             } #/ sub inline_check
250              
251             sub _instantiate_moose_type {
252 0     0   0 my $self = shift;
253 0         0 my %opts = @_;
254 0         0 delete $opts{parent};
255 0         0 delete $opts{constraint};
256 0         0 delete $opts{inlined};
257 0         0 require Moose::Meta::TypeConstraint::Enum;
258 0         0 return "Moose::Meta::TypeConstraint::Enum"
259             ->new( %opts, values => $self->values );
260             } #/ sub _instantiate_moose_type
261              
262             sub has_parent {
263 108     108 1 300 !!1;
264             }
265              
266             sub parent {
267 179     179 1 3681 require Types::Standard;
268 179         450 Types::Standard::Str();
269             }
270              
271             sub validate_explain {
272 1     1 1 2 my $self = shift;
273 1         3 my ( $value, $varname ) = @_;
274 1 50       3 $varname = '$_' unless defined $varname;
275            
276 1 50       8 return undef if $self->check( $value );
277            
278 1         6 require Type::Utils;
279 1 50       6 !defined( $value )
    50          
280             ? [
281             sprintf(
282             '"%s" requires that the value is defined',
283             $self,
284             ),
285             ]
286             : @$self < 13 ? [
287             sprintf(
288             '"%s" requires that the value is equal to %s',
289             $self,
290             Type::Utils::english_list( \"or", map B::perlstring( $_ ), @$self ),
291             ),
292             ]
293             : [
294             sprintf(
295             '"%s" requires that the value is one of an enumerated list of strings',
296             $self,
297             ),
298             ];
299             } #/ sub validate_explain
300              
301             sub has_sorter {
302 2     2 1 16 !!1;
303             }
304              
305             sub _enum_order_hash {
306 2     2   4 my $self = shift;
307 2         4 my %hash;
308 2         5 my $i = 0;
309 2         4 for my $value ( @{ $self->values } ) {
  2         24  
310 7 100       16 next if exists $hash{$value};
311 6         15 $hash{$value} = $i++;
312             }
313 2         13 return %hash;
314             } #/ sub _enum_order_hash
315              
316             sub sorter {
317 2     2 1 5 my $self = shift;
318 2         7 my %hash = $self->_enum_order_hash;
319             return [
320 15     15   238 sub { $_[0] <=> $_[1] },
321 9 100   9   83 sub { exists( $hash{ $_[0] } ) ? $hash{ $_[0] } : 2_100_000_000 },
322 2         31 ];
323             }
324              
325             my $canon;
326              
327             sub closest_match {
328 9     9 1 47 require Types::Standard;
329            
330 9         22 my ( $self, $given ) = ( shift, @_ );
331            
332 9 50       23 return unless Types::Standard::is_Str $given;
333            
334 9 50       28 return $given if $self->check( $given );
335            
336 9 50 66     154 $canon ||= eval(
337             $] lt '5.016'
338             ? q< sub { ( my $var = lc($_[0]) ) =~ s/(^\s+)|(\s+$)//g; $var } >
339             : q< sub { CORE::fc($_[0]) =~ s/(^\s+)|(\s+$)//gr; } >
340             );
341            
342 9   66     29 $self->{_lookups} ||= do {
343 1         3 my %lookups;
344 1         4 for ( @{ $self->values } ) {
  1         4  
345 3         55 my $key = $canon->( $_ );
346 3 50       17 next if exists $lookups{$key};
347 3         9 $lookups{$key} = $_;
348             }
349 1         8 \%lookups;
350             };
351            
352 9         209 my $cgiven = $canon->( $given );
353             return $self->{_lookups}{$cgiven}
354 9 100       47 if $self->{_lookups}{$cgiven};
355            
356 7         11 my $best;
357 7         11 VALUE: for my $possible ( @{ $self->values } ) {
  7         19  
358 21         46 my $stem = substr( $possible, 0, length $cgiven );
359 21 100       353 if ( $cgiven eq $canon->( $stem ) ) {
360 3 100 66     18 if ( defined( $best ) and length( $best ) >= length( $possible ) ) {
361 1         5 next VALUE;
362             }
363 2         9 $best = $possible;
364             }
365             }
366            
367 7 100       33 return $best if defined $best;
368            
369 5 100       22 return $self->values->[$given]
370             if Types::Standard::is_Int $given;
371            
372 1         7 return $given;
373             } #/ sub closest_match
374              
375             push @Type::Tiny::CMP, sub {
376             my $A = shift->find_constraining_type;
377             my $B = shift->find_constraining_type;
378             return Type::Tiny::CMP_UNKNOWN
379             unless $A->isa( __PACKAGE__ ) && $B->isa( __PACKAGE__ );
380            
381             my %seen;
382             for my $word ( @{ $A->unique_values } ) {
383             $seen{$word} += 1;
384             }
385             for my $word ( @{ $B->unique_values } ) {
386             $seen{$word} += 2;
387             }
388            
389             my $values = join( '', CORE::values %seen );
390             if ( $values =~ /^3*$/ ) {
391             return Type::Tiny::CMP_EQUIVALENT;
392             }
393             elsif ( $values !~ /2/ ) {
394             return Type::Tiny::CMP_SUPERTYPE;
395             }
396             elsif ( $values !~ /1/ ) {
397             return Type::Tiny::CMP_SUBTYPE;
398             }
399            
400             return Type::Tiny::CMP_UNKNOWN;
401             };
402              
403             package # stolen from Regexp::Trie
404             Type::Tiny::Enum::_Trie;
405 8     8   28 sub new { bless {} => shift }
406              
407             sub add {
408 22     22   39 my $self = shift;
409 22         29 my $str = shift;
410 22         42 my $ref = $self;
411 22         65 for my $char ( split //, $str ) {
412 65   100     515 $ref->{$char} ||= {};
413 65         252 $ref = $ref->{$char};
414             }
415 22         60 $ref->{''} = 1; # { '' => 1 } as terminator
416 22         53 $self;
417             } #/ sub add
418              
419             sub _regexp {
420 65     65   89 my $self = shift;
421 65 100 100     252 return if $self->{''} and scalar keys %$self == 1; # terminator
422 45         60 my ( @alt, @cc );
423 45         57 my $q = 0;
424 45         138 for my $char ( sort keys %$self ) {
425 59         110 my $qchar = quotemeta $char;
426 59 100       121 if ( ref $self->{$char} ) {
427 57 100       168 if ( defined( my $recurse = _regexp( $self->{$char} ) ) ) {
428 37         93 push @alt, $qchar . $recurse;
429             }
430             else {
431 20         59 push @cc, $qchar;
432             }
433             }
434             else {
435 2         6 $q = 1;
436             }
437             } #/ for my $char ( sort keys...)
438 45         83 my $cconly = !@alt;
439 45 100       134 @cc and push @alt, @cc == 1 ? $cc[0] : '[' . join( '', @cc ) . ']';
    100          
440 45 100       136 my $result = @alt == 1 ? $alt[0] : '(?:' . join( '|', @alt ) . ')';
441 45 50       117 $q and $result = $cconly ? "$result?" : "(?:$result)?";
    100          
442 45         199 return $result;
443             } #/ sub _regexp
444              
445             sub handle {
446 8     8   19 my $class = shift;
447 8         31 my ( $vals ) = @_;
448 8 50       29 return '(?!)' unless @$vals;
449 8         27 my $self = $class->new;
450 8         39 $self->add( $_ ) for @$vals;
451 8         48 $self->_regexp;
452             }
453              
454             1;
455              
456             __END__