File Coverage

blib/lib/Type/Params/Parameter.pm
Criterion Covered Total %
statement 154 156 98.7
branch 82 86 95.3
condition 46 54 85.1
subroutine 27 27 100.0
pod 0 17 0.0
total 309 340 90.8


line stmt bran cond sub pod time code
1             # INTERNAL MODULE: a parameter within a Type::Params::Signature.
2              
3             package Type::Params::Parameter;
4              
5 52     52   1295 use 5.008001;
  52         212  
6 52     52   306 use strict;
  52         117  
  52         1205  
7 52     52   314 use warnings;
  52         122  
  52         2610  
8              
9             BEGIN {
10 52 50   52   2053 if ( $] < 5.010 ) { require Devel::TypeTiny::Perl58Compat }
  0         0  
11             }
12              
13             BEGIN {
14 52     52   183 $Type::Params::Parameter::AUTHORITY = 'cpan:TOBYINK';
15 52         1790 $Type::Params::Parameter::VERSION = '2.004000';
16             }
17              
18             $Type::Params::Parameter::VERSION =~ tr/_//d;
19              
20 52     52   322 use Types::Standard qw( -is -types );
  52         129  
  52         428  
21              
22             sub _croak {
23 1     1   7 require Carp;
24 1         206 Carp::croak( pop );
25             }
26              
27             sub new {
28 715     715 0 1202 my $class = shift;
29              
30 715 50       2338 my %self = @_ == 1 ? %{$_[0]} : @_;
  0         0  
31 715   100     3306 $self{alias} ||= [];
32 715 100 66     2863 if ( defined $self{alias} and not ref $self{alias} ) {
33 7         27 $self{alias} = [ $self{alias} ];
34             }
35              
36 715         2031 bless \%self, $class;
37             }
38              
39 3     3 0 12 sub name { $_[0]{name} } sub has_name { exists $_[0]{name} }
  1580     1580 0 7042  
40 3     3 0 12 sub type { $_[0]{type} } sub has_type { exists $_[0]{type} }
  2308     2308 0 6507  
41 17     17 0 30 sub default { $_[0]{default} } sub has_default { exists $_[0]{default} }
  1608     1608 0 5636  
42 8     8 0 63 sub alias { $_[0]{alias} } sub has_alias { @{ $_[0]{alias} } }
  350     350 0 579  
  350         1309  
43 699     699 0 2515 sub strictness { $_[0]{strictness} } sub has_strictness { exists $_[0]{strictness} }
  1     1 0 3  
44              
45 851     851 0 2178 sub should_clone { $_[0]{clone} }
46              
47             sub coerce {
48             exists( $_[0]{coerce} )
49             ? $_[0]{coerce}
50 142 50   142 0 465 : ( $_[0]{coerce} = $_[0]->type->has_coercion )
51             }
52              
53             sub optional {
54             exists( $_[0]{optional} )
55             ? $_[0]{optional}
56 1963 100   1963 0 5303 : do {
57             $_[0]{optional} = $_[0]->has_default || grep(
58             $_->{uniq} == Optional->{uniq},
59 688   100     1523 $_[0]->type->parents,
60             );
61             }
62             }
63              
64             sub getter {
65             exists( $_[0]{getter} )
66             ? $_[0]{getter}
67             : ( $_[0]{getter} = $_[0]{name} )
68 126 100   126 0 461 }
69              
70             sub predicate {
71             exists( $_[0]{predicate} )
72             ? $_[0]{predicate}
73 126 100   126 0 437 : ( $_[0]{predicate} = ( $_[0]->optional ? 'has_' . $_[0]{name} : undef ) )
    100          
74             }
75              
76             sub might_supply_new_value {
77 152 100 100 152 0 417 $_[0]->has_default or $_[0]->coerce or $_[0]->should_clone;
78             }
79              
80             sub _code_for_default {
81 17     17   39 my ( $self, $signature, $coderef ) = @_;
82 17         42 my $default = $self->default;
83              
84 17 100       79 if ( is_CodeRef $default ) {
85             my $default_varname = $coderef->add_variable(
86             '$default_for_' . $self->{vartail},
87 4         26 \$default,
88             );
89 4         14 return sprintf( '%s->( %s )', $default_varname, $signature->method_invocant );
90             }
91 13 100       45 if ( is_Undef $default ) {
92 2         10 return 'undef';
93             }
94 11 100       33 if ( is_Str $default ) {
95 5         40 return B::perlstring( $default );
96             }
97 6 100       16 if ( is_HashRef $default ) {
98 2         13 return '{}';
99             }
100 4 100       15 if ( is_ArrayRef $default ) {
101 2         13 return '[]';
102             }
103 2 100       9 if ( is_ScalarRef $default ) {
104 1         5 return $$default;
105             }
106              
107 1         5 $self->_croak( 'Default expected to be undef, string, coderef, or empty arrayref/hashref' );
108             }
109              
110             sub _maybe_clone {
111 19     19   43 my ( $self, $varname ) = @_;
112              
113 19 100       53 if ( $self->should_clone ) {
114 2         14 return sprintf( 'Storable::dclone( %s )', $varname );
115             }
116 17         53 return $varname;
117             }
118              
119             sub _make_code {
120 699     699   3910 my ( $self, %args ) = ( shift, @_ );
121              
122 699   100     2763 my $type = $args{type} || 'arg';
123 699         1306 my $signature = $args{signature};
124 699         1149 my $coderef = $args{coderef};
125 699         1140 my $varname = $args{input_slot};
126 699         1211 my $index = $args{index};
127 699         1559 my $constraint = $self->type;
128 699         1613 my $is_optional = $self->optional;
129             my $really_optional =
130             $is_optional
131             && $constraint->parent
132             && $constraint->parent->{uniq} eq Optional->{uniq}
133 699   66     6668 && $constraint->type_parameter;
134              
135 699         1438 my $strictness;
136 699 100       1548 if ( $self->has_strictness ) {
    100          
137 1         5 $strictness = \ $self->strictness;
138             }
139             elsif ( $signature->has_strictness ) {
140 9         32 $strictness = \ $signature->strictness;
141             }
142              
143 699         1411 my ( $vartail, $exists_check );
144 699 100       1514 if ( $args{is_named} ) {
145 350         623 my $bit = $args{key};
146 350 50       917 $bit =~ s/([_\W])/$1 eq '_' ? '__' : sprintf('_%x', ord($1))/ge;
  2         10  
147 350         774 $vartail = $type . '_' . $bit;
148 350         1009 $exists_check = sprintf 'exists( %s )', $args{input_slot};
149             }
150             else {
151 349   100     1764 ( my $input_count_varname = $args{input_var} || '' ) =~ s/\@/\$\#/;
152 349         931 $vartail = $type . '_' . $index;
153 349         1127 $exists_check = sprintf '%s >= %d', $input_count_varname, $index;
154             }
155              
156 699         1197 my $block_needs_ending = 0;
157 699         1557 my $needs_clone = $self->should_clone;
158 699         1085 my $in_big_optional_block = 0;
159              
160 699 100 66     1756 if ( $needs_clone and not $signature->{loaded_Storable} ) {
161 2         7 $coderef->add_line( 'use Storable ();' );
162 2         5 $coderef->add_gap;
163 2         5 $signature->{loaded_Storable} = 1;
164             }
165              
166             $coderef->add_line( sprintf(
167             '# Parameter %s (type: %s)',
168             $self->name || $args{input_slot},
169 699   66     1595 $constraint->display_name,
170             ) );
171              
172 699 100 100     2469 if ( $args{is_named} and $self->has_alias ) {
173             $coderef->add_line( sprintf(
174             'for my $alias ( %s ) {',
175 8         28 join( q{, }, map B::perlstring($_), @{ $self->alias } ),
  8         29  
176             ) );
177 8         39 $coderef->increase_indent;
178 8         24 $coderef->add_line( 'exists $in{$alias} or next;' );
179 8         34 $coderef->add_line( sprintf(
180             'if ( %s ) {',
181             $exists_check,
182             ) );
183 8         32 $coderef->increase_indent;
184             $coderef->add_line( sprintf(
185             '%s;',
186             $signature->_make_general_fail(
187             coderef => $coderef,
188 8   33     28 message => q{sprintf( 'Superfluous alias "%s" for argument "%s"', $alias, } . B::perlstring( $self->name || $args{input_slot} ) . q{ )},
189             ),
190             ) );
191 8         35 $coderef->decrease_indent;
192 8         26 $coderef->add_line( '}' );
193 8         29 $coderef->add_line( 'else {' );
194 8         26 $coderef->increase_indent;
195 8         34 $coderef->add_line( sprintf(
196             '%s = delete( $in{$alias} );',
197             $varname,
198             ) );
199 8         26 $coderef->decrease_indent;
200 8         27 $coderef->add_line( '}' );
201 8         20 $coderef->decrease_indent;
202 8         17 $coderef->add_line( '}' );
203             }
204              
205 699 100       1627 if ( $self->has_default ) {
    100          
    100          
206 17         39 $self->{vartail} = $vartail; # hack
207 17         44 $coderef->add_line( sprintf(
208             '$dtmp = %s ? %s : %s;',
209             $exists_check,
210             $self->_maybe_clone( $varname ),
211             $self->_code_for_default( $signature, $coderef ),
212             ) );
213 16         30 $varname = '$dtmp';
214 16         27 $needs_clone = 0;
215             }
216             elsif ( $self->optional ) {
217 99 100       244 if ( $args{is_named} ) {
218 80         347 $coderef->add_line( sprintf(
219             'if ( %s ) {',
220             $exists_check,
221             ) );
222 80         168 $coderef->{indent} .= "\t";
223 80         157 ++$block_needs_ending;
224 80         162 ++$in_big_optional_block;
225             }
226             else {
227 19         56 $coderef->add_line( sprintf(
228             "%s\n\tor %s;",
229             $exists_check,
230             $signature->_make_return_expression( is_early => 1 ),
231             ) );
232             }
233             }
234             elsif ( $args{is_named} ) {
235 264         1141 $coderef->add_line( sprintf(
236             "%s\n\tor %s;",
237             $exists_check,
238             $signature->_make_general_fail(
239             coderef => $coderef,
240             message => "'Missing required parameter: $args{key}'",
241             ),
242             ) );
243             }
244              
245 698 100       1736 if ( $needs_clone ) {
246 2         6 $coderef->add_line( sprintf(
247             '$dtmp = %s;',
248             $self->_maybe_clone( $varname ),
249             ) );
250 2         5 $varname = '$dtmp';
251 2         4 $needs_clone = 0;
252             }
253              
254 698 100 100     2336 if ( $constraint->has_coercion and $constraint->coercion->can_be_inlined ) {
    100          
255 84 100       383 $coderef->add_line( sprintf(
256             '$tmp%s = %s;',
257             ( $is_optional ? '{x}' : '' ),
258             $constraint->coercion->inline_coercion( $varname )
259             ) );
260 84 100       335 $varname = '$tmp' . ( $is_optional ? '{x}' : '' );
261             }
262             elsif ( $constraint->has_coercion ) {
263 83         344 my $coercion_varname = $coderef->add_variable(
264             '$coercion_for_' . $vartail,
265             \ $constraint->coercion->compiled_coercion,
266             );
267 83 100       613 $coderef->add_line( sprintf(
268             '$tmp%s = &%s( %s );',
269             ( $is_optional ? '{x}' : '' ),
270             $coercion_varname,
271             $varname,
272             ) );
273 83 100       263 $varname = '$tmp' . ( $is_optional ? '{x}' : '' );
274             }
275              
276 698         2631 undef $Type::Tiny::ALL_TYPES{ $constraint->{uniq} };
277 698         1465 $Type::Tiny::ALL_TYPES{ $constraint->{uniq} } = $constraint;
278              
279 698         1185 my $strictness_test = '';
280 698 100 100     3016 if ( $strictness and $$strictness eq 1 ) {
    100 100        
281 3         6 $strictness_test = '';
282             }
283             elsif ( $strictness and $$strictness ) {
284 5         18 $strictness_test = sprintf "( not %s )\n\tor ", $$strictness;
285             }
286              
287 698 100 100     3153 if ( $strictness and not $$strictness ) {
    100          
    100          
288 2         8 $coderef->add_line( '1; # ... nothing to do' );
289             }
290             elsif ( $constraint->{uniq} == Any->{uniq} ) {
291 13         75 $coderef->add_line( '1; # ... nothing to do' );
292             }
293             elsif ( $constraint->can_be_inlined ) {
294             $coderef->add_line( $strictness_test . sprintf(
295             "%s\n\tor %s;",
296             ( $really_optional or $constraint )->inline_check( $varname ),
297             $signature->_make_constraint_fail(
298             coderef => $coderef,
299             parameter => $self,
300             constraint => $constraint,
301             varname => $varname,
302             display_var => $args{display_var},
303 622   66     2562 ),
304             ) );
305             }
306             else {
307 61   66     312 my $compiled_check_varname = $coderef->add_variable(
308             '$check_for_' . $vartail,
309             \ ( ( $really_optional or $constraint )->compiled_check ),
310             );
311             $coderef->add_line( $strictness_test . sprintf(
312             "&%s( %s )\n\tor %s;",
313             $compiled_check_varname,
314             $varname,
315             $signature->_make_constraint_fail(
316             coderef => $coderef,
317             parameter => $self,
318             constraint => $constraint,
319             varname => $varname,
320             display_var => $args{display_var},
321 61         293 ),
322             ) );
323             }
324              
325 698 100 100     3682 if ( $args{output_var} ) {
    100          
326             $coderef->add_line( sprintf(
327             'push( %s, %s );',
328             $args{output_var},
329 104         423 $varname,
330             ) );
331             }
332             elsif ( $args{output_slot} and $args{output_slot} ne $varname ) {
333 390 100 100     1849 if ( !$in_big_optional_block and $varname =~ /\{/ ) {
334             $coderef->add_line( sprintf(
335             '%s = %s if exists( %s );',
336             $args{output_slot},
337 204         879 $varname,
338             $varname,
339             ) );
340             }
341             else {
342             $coderef->add_line( sprintf(
343             '%s = %s;',
344             $args{output_slot},
345 186         788 $varname,
346             ) );
347             }
348             }
349              
350 698 100       1769 if ( $args{is_named} ) {
351             $coderef->add_line( sprintf(
352             'delete( %s );',
353             $args{input_slot},
354 350         1182 ) );
355             }
356              
357 698 100       1663 if ( $block_needs_ending ) {
358 80         421 $coderef->{indent} =~ s/\s$//;
359 80         291 $coderef->add_line( '}' );
360             }
361              
362 698         2125 $coderef->add_gap;
363              
364 698         3117 $self;
365             }
366              
367             1;