File Coverage

lib/Types/Standard/CycleTuple.pm
Criterion Covered Total %
statement 106 108 99.0
branch 37 44 84.0
condition 3 3 100.0
subroutine 17 17 100.0
pod n/a
total 163 172 95.3


line stmt bran cond sub pod time code
1             # INTERNAL MODULE: guts for CycleTuple type from Types::Standard.
2              
3             package Types::Standard::CycleTuple;
4              
5 4     4   108 use 5.008001;
  4         19  
6 4     4   36 use strict;
  4         14  
  4         92  
7 4     4   40 use warnings;
  4         16  
  4         219  
8              
9             BEGIN {
10 4     4   13 $Types::Standard::CycleTuple::AUTHORITY = 'cpan:TOBYINK';
11 4         173 $Types::Standard::CycleTuple::VERSION = '2.004000';
12             }
13              
14             $Types::Standard::CycleTuple::VERSION =~ tr/_//d;
15              
16 4     4   35 use Type::Tiny ();
  4         7  
  4         113  
17 4     4   44 use Types::Standard ();
  4         10  
  4         104  
18 4     4   24 use Types::TypeTiny ();
  4         11  
  4         409  
19              
20 6     6   55 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  6         36  
21              
22             my $_Optional = Types::Standard::Optional;
23             my $_arr = Types::Standard::ArrayRef;
24             my $_Slurpy = Types::Standard::Slurpy;
25              
26 4     4   31 no warnings;
  4         7  
  4         5426  
27              
28             my $cycleuniq = 0;
29              
30             sub __constraint_generator {
31             my @params = map {
32 13     13   38 my $param = $_;
  27         42  
33 27 100       440 Types::TypeTiny::is_TypeTiny( $param )
34             or _croak(
35             "Parameters to CycleTuple[...] expected to be type constraints; got $param" );
36 26         76 $param;
37             } @_;
38 12         25 my $count = @params;
39 12         43 my $tuple = Types::Standard::Tuple()->of( @params );
40            
41 12 100       55 _croak( "Parameters to CycleTuple[...] cannot be optional" )
42             if grep !!$_->is_strictly_a_type_of( $_Optional ), @params;
43 9 100       45 _croak( "Parameters to CycleTuple[...] cannot be slurpy" )
44             if grep !!$_->is_strictly_a_type_of( $_Slurpy ), @params;
45            
46             sub {
47 74     74   123 my $value = shift;
48 74 50       175 return unless $_arr->check( $value );
49 74 100       373 return if @$value % $count;
50 33         56 my $i = 0;
51 33         80 while ( $i < $#$value ) {
52 40         115 my $tmp = [ @$value[ $i .. $i + $count - 1 ] ];
53 40 100       140 return unless $tuple->check( $tmp );
54 37         254 $i += $count;
55             }
56 30         84 !!1;
57             }
58 7         57 } #/ sub __constraint_generator
59              
60             sub __inline_generator {
61             my @params = map {
62 7     7   24 my $param = $_;
  19         28  
63 19 50       275 Types::TypeTiny::is_TypeTiny( $param )
64             or _croak(
65             "Parameter to CycleTuple[`a] expected to be a type constraint; got $param" );
66 19         78 $param;
67             } @_;
68 7         24 my $count = @params;
69 7         27 my $tuple = Types::Standard::Tuple()->of( @params );
70            
71 7 100       29 return unless $tuple->can_be_inlined;
72            
73             sub {
74 69     69   136 $cycleuniq++;
75            
76 69         95 my $v = $_[1];
77 69         150 my @checks = $_arr->inline_check( $v );
78 69 100       511 push @checks, sprintf(
79             'not(@%s %% %d)',
80             ( $v =~ /\A\$[a-z0-9_]+\z/i ? $v : "{$v}" ),
81             $count,
82             );
83             push @checks, sprintf(
84             'do { my $cyclecount%d = 0; my $cycleok%d = 1; while ($cyclecount%d < $#{%s}) { my $cycletmp%d = [@{%s}[$cyclecount%d .. $cyclecount%d+%d]]; unless (%s) { $cycleok%d = 0; last; }; $cyclecount%d += %d; }; $cycleok%d; }',
85             $cycleuniq,
86             $cycleuniq,
87             $cycleuniq,
88             $v,
89             $cycleuniq,
90             $v,
91             $cycleuniq,
92             $cycleuniq,
93             $count - 1,
94             $tuple->inline_check( "\$cycletmp$cycleuniq" ),
95             $cycleuniq,
96             $cycleuniq,
97             $count,
98             $cycleuniq,
99 69 50       144 ) if grep { $_->inline_check( '$xyz' ) ne '(!!1)' } @params;
  203         803  
100 69         344 join( ' && ', @checks );
101             }
102 5         73 } #/ sub __inline_generator
103              
104             sub __deep_explanation {
105 3     3   11 my ( $type, $value, $varname ) = @_;
106            
107             my @constraints =
108 3         8 map Types::TypeTiny::to_TypeTiny( $_ ), @{ $type->parameters };
  3         9  
109            
110 3 100       13 if ( @$value % @constraints ) {
111             return [
112 1         8 sprintf(
113             '"%s" expects a multiple of %d values in the array', $type,
114             scalar( @constraints )
115             ),
116             sprintf( '%d values found', scalar( @$value ) ),
117             ];
118             }
119            
120 2         22 for my $i ( 0 .. $#$value ) {
121 4         12 my $constraint = $constraints[ $i % @constraints ];
122 4 100       12 next if $constraint->check( $value->[$i] );
123            
124             return [
125             sprintf(
126             '"%s" constrains value at index %d of array with "%s"', $type, $i, $constraint
127             ),
128             @{
129 2         16 $constraint->validate_explain(
  2         21  
130             $value->[$i], sprintf( '%s->[%s]', $varname, $i )
131             )
132             },
133             ];
134             } #/ for my $i ( 0 .. $#$value)
135            
136             # This should never happen...
137 0         0 return; # uncoverable statement
138             } #/ sub __deep_explanation
139              
140             my $label_counter = 0;
141              
142             sub __coercion_generator {
143 5     5   27 my ( $parent, $child, @tuple ) = @_;
144            
145 5         9 my $child_coercions_exist = 0;
146 5         6 my $all_inlinable = 1;
147 5         16 for my $tc ( @tuple ) {
148 14 100       42 $all_inlinable = 0 if !$tc->can_be_inlined;
149 14 100 100     52 $all_inlinable = 0 if $tc->has_coercion && !$tc->coercion->can_be_inlined;
150 14 100       37 $child_coercions_exist++ if $tc->has_coercion;
151             }
152            
153 5 50       19 return unless $child_coercions_exist;
154 5         18 my $C = "Type::Coercion"->new( type_constraint => $child );
155            
156 5 100       28 if ( $all_inlinable ) {
157             $C->add_type_coercions(
158             $parent => Types::Standard::Stringable {
159 2     2   10 my $label = sprintf( "CTUPLELABEL%d", ++$label_counter );
160 2         54 my $label2 = sprintf( "CTUPLEINNER%d", $label_counter );
161 2         6 my @code;
162 2         8 push @code, 'do { my ($orig, $return_orig, $tmp, @new) = ($_, 0);';
163 2         7 push @code, "$label: {";
164 2         15 push @code,
165             sprintf(
166             '(($return_orig = 1), last %s) if scalar(@$orig) %% %d != 0;', $label,
167             scalar @tuple
168             );
169 2         8 push @code, sprintf( 'my $%s = 0; while ($%s < @$orig) {', $label2, $label2 );
170 2         9 for my $i ( 0 .. $#tuple ) {
171 5         13 my $ct = $tuple[$i];
172 5         16 my $ct_coerce = $ct->has_coercion;
173            
174 5 100       39 push @code, sprintf(
175             'do { $tmp = %s; (%s) ? ($new[$%s + %d]=$tmp) : (($return_orig=1), last %s) };',
176             $ct_coerce
177             ? $ct->coercion->inline_coercion( "\$orig->[\$$label2 + $i]" )
178             : "\$orig->[\$$label2 + $i]",
179             $ct->inline_check( '$tmp' ),
180             $label2,
181             $i,
182             $label,
183             );
184             } #/ for my $i ( 0 .. $#tuple)
185 2         11 push @code, sprintf( '$%s += %d;', $label2, scalar( @tuple ) );
186 2         7 push @code, '}';
187 2         15 push @code, '}';
188 2         8 push @code, '$return_orig ? $orig : \\@new';
189 2         5 push @code, '}';
190 2         36 "@code";
191             }
192 2         30 );
193             } #/ if ( $all_inlinable )
194            
195             else {
196             $C->add_type_coercions(
197             $parent => sub {
198 3 50   3   58 my $value = @_ ? $_[0] : $_;
199            
200 3 50       11 if ( scalar( @$value ) % scalar( @tuple ) != 0 ) {
201 0         0 return $value;
202             }
203            
204 3         8 my @new;
205 3         9 for my $i ( 0 .. $#$value ) {
206 18         31 my $ct = $tuple[ $i % @tuple ];
207 18 100       38 my $x = $ct->has_coercion ? $ct->coerce( $value->[$i] ) : $value->[$i];
208            
209 18 50       79 return $value unless $ct->check( $x );
210            
211 18         51 $new[$i] = $x;
212             }
213            
214 3         32 return \@new;
215             },
216 3         61 );
217             } #/ else [ if ( $all_inlinable ) ]
218            
219 5         26 return $C;
220             } #/ sub __coercion_generator
221              
222             1;