File Coverage

blib/lib/Type/Params/Signature.pm
Criterion Covered Total %
statement 433 446 97.0
branch 201 224 89.7
condition 90 119 75.6
subroutine 69 71 97.1
pod 0 37 0.0
total 793 897 88.4


line stmt bran cond sub pod time code
1             # INTERNAL MODULE: OO backend for Type::Params signatures.
2              
3             package Type::Params::Signature;
4              
5 52     52   1891 use 5.008001;
  52         232  
6 52     52   310 use strict;
  52         209  
  52         1213  
7 52     52   275 use warnings;
  52         116  
  52         2556  
8              
9             BEGIN {
10 52 50   52   2062 if ( $] < 5.010 ) { require Devel::TypeTiny::Perl58Compat }
  0         0  
11             }
12              
13             BEGIN {
14 52     52   184 $Type::Params::Signature::AUTHORITY = 'cpan:TOBYINK';
15 52         2070 $Type::Params::Signature::VERSION = '2.003_000';
16             }
17              
18             $Type::Params::Signature::VERSION =~ tr/_//d;
19              
20 52     52   603 use B ();
  52         149  
  52         1210  
21 52     52   24275 use Eval::TypeTiny::CodeAccumulator;
  52         151  
  52         1953  
22 52     52   401 use Types::Standard qw( -is -types -assert );
  52         141  
  52         787  
23 52     52   7896 use Types::TypeTiny qw( -is -types to_TypeTiny );
  52         160  
  52         483  
24 52     52   124679 use Type::Params::Parameter;
  52         181  
  52         27914  
25              
26             sub _croak {
27 13     13   67 require Error::TypeTiny;
28 13         60 return Error::TypeTiny::croak( pop );
29             }
30              
31             sub _new_parameter {
32 715     715   1143 shift;
33 715         2345 'Type::Params::Parameter'->new( @_ );
34             }
35              
36             sub _new_code_accumulator {
37 314     314   1487 shift;
38 314         1871 'Eval::TypeTiny::CodeAccumulator'->new( @_ );
39             }
40              
41             sub new {
42 290     290 0 555 my $class = shift;
43 290 50       1552 my %self = @_ == 1 ? %{$_[0]} : @_;
  0         0  
44 290         655 my $self = bless \%self, $class;
45 290   50     1117 $self->{parameters} ||= [];
46 290   50     1545 $self->{class_prefix} ||= 'Type::Params::OO::Klass';
47 290         927 $self->BUILD;
48 283         875 return $self;
49             }
50              
51             {
52             my $klass_id;
53             my %klass_cache;
54             sub BUILD {
55 290     290 0 507 my $self = shift;
56              
57 290 100 100     936 if ( $self->{named_to_list} and not ref $self->{named_to_list} ) {
58 9         26 $self->{named_to_list} = [ map $_->name, @{ $self->{parameters} } ];
  9         45  
59             }
60              
61 290 50       839 if ( delete $self->{rationalize_slurpies} ) {
62 290         914 $self->_rationalize_slurpies;
63             }
64              
65 285 100       877 if ( $self->{method} ) {
66 29         69 my $type = $self->{method};
67             $type =
68             is_Int($type) ? Defined :
69 29 0       194 is_Str($type) ? do { require Type::Utils; Type::Utils::dwim_type( $type, $self->{package} ? ( for => $self->{package} ) : () ) } :
  0 50       0  
  0 100       0  
70             to_TypeTiny( $type );
71 29   50     124 unshift @{ $self->{head} ||= [] }, $self->_new_parameter(
  29         231  
72             name => 'invocant',
73             type => $type,
74             );
75             }
76              
77 285 100 100     1531 if ( defined $self->{bless} and $self->{bless} eq 1 and not $self->{named_to_list} ) {
      100        
78 30         95 my $klass_key = $self->_klass_key;
79 30   66     1588 $self->{bless} = ( $klass_cache{$klass_key} ||= sprintf( '%s%d', $self->{class_prefix}, ++$klass_id ) );
80 30 50       103 $self->{oo_trace} = 1 unless exists $self->{oo_trace};
81 30         98 $self->make_class;
82             }
83 283 100       6973 if ( is_ArrayRef $self->{class} ) {
84 8         32 $self->{constructor} = $self->{class}->[1];
85 8         19 $self->{class} = $self->{class}->[0];
86             }
87             }
88             }
89              
90             sub _klass_key {
91 30     30   94 my $self = shift;
92              
93 30         51 my @parameters = @{ $self->parameters };
  30         87  
94 30 100       91 if ( $self->has_slurpy ) {
95 1         6 push @parameters, $self->slurpy;
96             }
97              
98 52     52   533 no warnings 'uninitialized';
  52         165  
  52         286657  
99             join(
100             '|',
101             map sprintf( '%s*%s*%s', $_->name, $_->getter, $_->predicate ),
102 30         163 sort { $a->{name} cmp $b->{name} } @parameters
  44         185  
103             );
104             }
105              
106             sub _rationalize_slurpies {
107 290     290   519 my $self = shift;
108              
109 290         803 my $parameters = $self->parameters;
110              
111 290 100       768 if ( $self->is_named ) {
    100          
112 155         297 my ( @slurpy, @rest );
113              
114 155         323 for my $parameter ( @$parameters ) {
115 381 100       1122 if ( $parameter->type->is_strictly_a_type_of( Slurpy ) ) {
    100          
116 26         97 push @slurpy, $parameter;
117             }
118             elsif ( $parameter->{slurpy} ) {
119 1         4 $parameter->{type} = Slurpy[ $parameter->type ];
120 1         9 push @slurpy, $parameter;
121             }
122             else {
123 354         976 push @rest, $parameter;
124             }
125             }
126              
127 155 100       661 if ( @slurpy == 1 ) {
    100          
128 25         82 my $constraint = $slurpy[0]->type;
129 25 100 66     93 if ( $constraint->type_parameter && $constraint->type_parameter->{uniq} == Any->{uniq} or $constraint->my_slurp_into eq 'HASH' ) {
      100        
130 24         85 $self->{slurpy} = $slurpy[0];
131 24         87 @$parameters = @rest;
132             }
133             else {
134 1         5 $self->_croak( 'Signatures with named parameters can only have slurpy parameters which are a subtype of HashRef' );
135             }
136             }
137             elsif ( @slurpy ) {
138 1         4 $self->_croak( 'Found multiple slurpy parameters! There can be only one' );
139             }
140             }
141             elsif ( @$parameters ) {
142 133 100       506 if ( $parameters->[-1]->type->is_strictly_a_type_of( Slurpy ) ) {
    100          
143 40         173 $self->{slurpy} = pop @$parameters;
144             }
145             elsif ( $parameters->[-1]{slurpy} ) {
146 6         18 $self->{slurpy} = pop @$parameters;
147 6         25 $self->{slurpy}{type} = Slurpy[ $self->{slurpy}{type} ];
148             }
149              
150 133         423 for my $parameter ( @$parameters ) {
151 184 100 66     682 if ( $parameter->type->is_strictly_a_type_of( Slurpy ) or $parameter->{slurpy} ) {
152 3         13 $self->_croak( 'Parameter following slurpy parameter' );
153             }
154             }
155             }
156              
157 285 100 100     1489 if ( $self->{slurpy} and $self->{slurpy}->has_default ) {
158 1         6 require Carp;
159 1         4 our @CARP_NOT = ( __PACKAGE__, 'Type::Params' );
160 1         263 Carp::carp( "Warning: the default for the slurpy parameter will be ignored, continuing anyway" );
161 1         14 delete $self->{slurpy}{default};
162             }
163             }
164              
165             sub _parameters_from_list {
166 329     329   1364 my ( $class, $style, $list, %opts ) = @_;
167 329         570 my @return;
168 329         627 my $is_named = ( $style eq 'named' );
169              
170 329         884 while ( @$list ) {
171 686         1162 my ( $type, %param_opts );
172 686 100       1430 if ( $is_named ) {
173 381         1117 $param_opts{name} = assert_Str( shift( @$list ) );
174             }
175 686 100 66     3810 if ( is_HashRef $list->[0] and exists $list->[0]{slurpy} and not is_Bool $list->[0]{slurpy} ) {
      33        
176 2         6 my %new_opts = %{ shift( @$list ) };
  2         9  
177 2         7 $type = delete $new_opts{slurpy};
178 2         9 %param_opts = ( %param_opts, %new_opts, slurpy => 1 );
179             }
180             else {
181 684         1208 $type = shift( @$list );
182             }
183 686 100       2142 if ( is_HashRef( $list->[0] ) ) {
184 60 100 100     242 unless ( exists $list->[0]{slurpy} and not is_Bool $list->[0]{slurpy} ) {
185 58         117 %param_opts = ( %param_opts, %{ +shift( @$list ) } );
  58         217  
186             }
187             }
188             $param_opts{type} =
189 4         12 is_Int($type) ? ( $type ? Any : do { $param_opts{optional} = !!1; Any; } ) :
  4         15  
190 686 100       3373 is_Str($type) ? do { require Type::Utils; Type::Utils::dwim_type( $type, $opts{package} ? ( for => $opts{package} ) : () ) } :
  0 0       0  
  0 50       0  
    100          
191             to_TypeTiny( $type );
192 686         2261 my $parameter = $class->_new_parameter( %param_opts );
193 686         2350 push @return, $parameter;
194             }
195              
196 329         1318 return \@return;
197             }
198              
199             sub new_from_compile {
200 290     290 0 704 my $class = shift;
201 290         496 my $style = shift;
202 290         659 my $is_named = ( $style eq 'named' );
203              
204 290         552 my %opts = ();
205 290   66     2273 while ( is_HashRef $_[0] and not exists $_[0]{slurpy} ) {
206 382         820 %opts = ( %opts, %{ +shift } );
  382         2520  
207             }
208              
209 290         758 for my $pos ( qw/ head tail / ) {
210 580 100       1650 next unless defined $opts{$pos};
211 39 100       121 if ( is_Int( $opts{$pos} ) ) {
212 6         23 $opts{$pos} = [ ( Any ) x $opts{$pos} ];
213             }
214 39         157 $opts{$pos} = $class->_parameters_from_list( positional => $opts{$pos}, %opts );
215             }
216              
217 290         832 my $list = [ @_ ];
218 290         688 $opts{is_named} = $is_named;
219 290         1237 $opts{parameters} = $class->_parameters_from_list( $style => $list, %opts );
220              
221 290         1270 my $self = $class->new( %opts, rationalize_slurpies => 1 );
222 283         2254 return $self;
223             }
224              
225             sub new_from_v2api {
226 312     312 0 816 my ( $class, $opts ) = @_;
227              
228 312   100     1424 my $positional = delete( $opts->{positional} ) || delete( $opts->{pos} );
229 312         669 my $named = delete( $opts->{named} );
230 312   100     1336 my $multiple = delete( $opts->{multiple} ) || delete( $opts->{multi} );
231              
232 312 100 100     1509 $class->_croak( "Signature must be positional, named, or multiple" )
      100        
233             unless $positional || $named || $multiple;
234              
235 310 100       839 if ( $multiple ) {
236 19 100       90 $multiple = [] unless is_ArrayRef $multiple;
237 19 100       51 unshift @$multiple, { positional => $positional } if $positional;
238 19 100       43 unshift @$multiple, { named => $named } if $named;
239 19         2101 require Type::Params::Alternatives;
240 19         131 return 'Type::Params::Alternatives'->new(
241             base_options => $opts,
242             alternatives => $multiple,
243             sig_class => $class,
244             );
245             }
246              
247 291         678 my ( $sig_kind, $args ) = ( pos => $positional );
248 291 100       735 if ( $named ) {
249 156 100       418 $opts->{bless} = 1 unless exists $opts->{bless};
250 156         318 ( $sig_kind, $args ) = ( named => $named );
251 156 100       397 $class->_croak( "Signature cannot have both positional and named arguments" )
252             if $positional;
253             }
254              
255 289         940 return $class->new_from_compile( $sig_kind, $opts, @$args );
256             }
257              
258 307     307 0 1118 sub package { $_[0]{package} }
259 307     307 0 2242 sub subname { $_[0]{subname} }
260 301     301 0 1268 sub description { $_[0]{description} } sub has_description { exists $_[0]{description} }
  0     0 0 0  
261 301     301 0 979 sub method { $_[0]{method} }
262 1379     1379 0 3918 sub head { $_[0]{head} } sub has_head { exists $_[0]{head} }
  339     339 0 2466  
263 1195     1195 0 3263 sub tail { $_[0]{tail} } sub has_tail { exists $_[0]{tail} }
  64     64 0 131  
264 1     1 0 293 sub parameters { $_[0]{parameters} } sub has_parameters { exists $_[0]{parameters} }
  1054     1054 0 3082  
265 707     707 0 2275 sub slurpy { $_[0]{slurpy} } sub has_slurpy { exists $_[0]{slurpy} }
  221     221 0 737  
266 1708     1708 0 9522 sub on_die { $_[0]{on_die} } sub has_on_die { exists $_[0]{on_die} }
  6     6 0 23  
267 1102     1102 0 3116 sub strictness { $_[0]{strictness} } sub has_strictness { exists $_[0]{strictness} }
  706     706 0 3177  
268 581     581 0 2587 sub goto_next { $_[0]{goto_next} }
269 1936     1936 0 6775 sub is_named { $_[0]{is_named} }
270 509     509 0 1921 sub bless { $_[0]{bless} }
271 163     163 0 500 sub class { $_[0]{class} }
272 24     24 0 110 sub constructor { $_[0]{constructor} }
273 180     180 0 817 sub named_to_list { $_[0]{named_to_list} }
274 44     44 0 167 sub oo_trace { $_[0]{oo_trace} }
275              
276 42 100   42 0 269 sub method_invocant { $_[0]{method_invocant} = defined( $_[0]{method_invocant} ) ? $_[0]{method_invocant} : 'undef' }
277              
278             sub can_shortcut {
279             return $_[0]{can_shortcut}
280 448 100   448 0 1516 if exists $_[0]{can_shortcut};
281             $_[0]{can_shortcut} = !(
282             $_[0]->slurpy or
283 150   100     422 grep $_->might_supply_new_value, @{ $_[0]->parameters }
284             );
285             }
286              
287             sub coderef {
288 301   66 301 0 1443 $_[0]{coderef} ||= $_[0]->_build_coderef;
289             }
290              
291             sub _build_coderef {
292 301     301   568 my $self = shift;
293 301   66     868 my $coderef = $self->_new_code_accumulator(
294             description => $self->description
295             || sprintf( q{parameter validation for '%s::%s'}, $self->package || '', $self->subname || '__ANON__' )
296             );
297              
298 301         1418 $self->_coderef_start( $coderef );
299 299 100       734 $self->_coderef_head( $coderef ) if $self->has_head;
300 299 100       845 $self->_coderef_tail( $coderef ) if $self->has_tail;
301 299         1096 $self->_coderef_parameters( $coderef );
302 298 100       904 if ( $self->has_slurpy ) {
    100          
303 69         267 $self->_coderef_slurpy( $coderef );
304             }
305             elsif ( $self->is_named ) {
306 126         369 $self->_coderef_extra_names( $coderef );
307             }
308 298         1167 $self->_coderef_end( $coderef );
309              
310 298         1176 return $coderef;
311             }
312              
313             sub _coderef_start {
314 301     301   705 my ( $self, $coderef ) = ( shift, @_ );
315              
316 301         1371 $coderef->add_line( 'sub {' );
317 301         679 $coderef->{indent} .= "\t";
318              
319 301 100       1049 if ( my $next = $self->goto_next ) {
320 33 100       133 if ( is_CodeLike $next ) {
321 32         108 $coderef->add_variable( '$__NEXT__', \$next );
322             }
323             else {
324 1         5 $coderef->add_line( 'my $__NEXT__ = shift;' );
325 1         8 $coderef->add_gap;
326             }
327             }
328              
329 301 100       847 if ( $self->method ) {
330             # Passed to parameter defaults
331 38         95 $self->{method_invocant} = '$__INVOCANT__';
332 38         95 $coderef->add_line( sprintf 'my %s = $_[0];', $self->method_invocant );
333 38         123 $coderef->add_gap;
334             }
335              
336 301         1375 $self->_coderef_start_extra( $coderef );
337              
338 300         507 my $extravars = '';
339 300 100       703 if ( $self->has_head ) {
340 51         113 $extravars .= ', @head';
341             }
342 300 100       801 if ( $self->has_tail ) {
343 16         32 $extravars .= ', @tail';
344             }
345              
346 300 100       808 if ( $self->is_named ) {
    100          
347 150         514 $coderef->add_line( "my ( \%out, \%in, \%tmp, \$tmp, \$dtmp$extravars );" );
348             }
349             elsif ( $self->can_shortcut ) {
350 85         418 $coderef->add_line( "my ( \%tmp, \$tmp$extravars );" );
351             }
352             else {
353 65         311 $coderef->add_line( "my ( \@out, \%tmp, \$tmp, \$dtmp$extravars );" );
354             }
355              
356 300 100       911 if ( $self->has_on_die ) {
357 6         20 $coderef->add_variable( '$__ON_DIE__', \ $self->on_die );
358             }
359              
360 300         1158 $coderef->add_gap;
361              
362 300         1024 $self->_coderef_check_count( $coderef );
363              
364 299         1024 $coderef->add_gap;
365              
366 299         643 $self;
367             }
368              
369       282     sub _coderef_start_extra {}
370              
371             sub _coderef_check_count {
372 282     282   637 my ( $self, $coderef ) = ( shift, @_ );
373              
374 282         524 my $strictness_test = '';
375 282 100 100     728 if ( defined $self->strictness and $self->strictness eq 1 ) {
    100          
    100          
376 1         2 $strictness_test = '';
377             }
378             elsif ( $self->strictness ) {
379 3         4 $strictness_test = sprintf '( not %s ) or ', $self->strictness;
380             }
381             elsif ( $self->has_strictness ) {
382 1         3 return $self;
383             }
384              
385 281         587 my $headtail = 0;
386 281 100       592 $headtail += @{ $self->head } if $self->has_head;
  51         112  
387 281 100       686 $headtail += @{ $self->tail } if $self->has_tail;
  16         39  
388              
389 281         777 my $is_named = $self->is_named;
390 281         525 my $min_args = 0;
391 281         483 my $max_args = 0;
392 281         461 my $seen_optional = 0;
393 281         420 for my $parameter ( @{ $self->parameters } ) {
  281         683  
394 529 100       1429 if ( $parameter->optional ) {
395 117         1761 ++$seen_optional;
396 117         256 ++$max_args;
397             }
398             else {
399 412 100 100     17676 $seen_optional and !$is_named and $self->_croak(
400             'Non-Optional parameter following Optional parameter',
401             );
402 411         647 ++$max_args;
403 411         787 ++$min_args;
404             }
405             }
406              
407 280 100       862 undef $max_args if $self->has_slurpy;
408              
409             # Note: code related to $max_args_if_hash is currently commented out
410             # because it handles this badly:
411             #
412             # my %opts = ( x => 1, y => 1 );
413             # your_func( %opts, y => 2 ); # override y
414             #
415              
416 280 100       743 if ( $is_named ) {
417 150         321 my $args_if_hashref = $headtail + 1;
418 150 100       223 my $hashref_index = @{ $self->head || [] };
  150         509  
419 150         344 my $arity_if_hash = $headtail % 2;
420 150         357 my $min_args_if_hash = $headtail + ( 2 * $min_args );
421             #my $max_args_if_hash = defined( $max_args )
422             # ? ( $headtail + ( 2 * $max_args ) )
423             # : undef;
424              
425 150         920 require List::Util;
426 150         721 $self->{min_args} = List::Util::min( $args_if_hashref, $min_args_if_hash );
427             #if ( defined $max_args_if_hash ) {
428             # $self->{max_args} = List::Util::max( $args_if_hashref, $max_args_if_hash );
429             #}
430              
431 150         275 my $extra_conditions = '';
432             #if ( defined $max_args_if_hash and $min_args_if_hash==$max_args_if_hash ) {
433             # $extra_conditions .= " && \@_ == $min_args_if_hash"
434             #}
435             #else {
436 150 100       455 $extra_conditions .= " && \@_ >= $min_args_if_hash"
437             if $min_args_if_hash;
438             # $extra_conditions .= " && \@_ <= $max_args_if_hash"
439             # if defined $max_args_if_hash;
440             #}
441              
442 150         547 $coderef->add_line( $strictness_test . sprintf(
443             "\@_ == %d && %s\n\tor \@_ %% 2 == %d%s\n\tor %s;",
444             $args_if_hashref,
445             HashRef->inline_check( sprintf '$_[%d]', $hashref_index ),
446             $arity_if_hash,
447             $extra_conditions,
448             $self->_make_count_fail(
449             coderef => $coderef,
450             got => 'scalar( @_ )',
451             ),
452             ) );
453             }
454             else {
455 130         279 $min_args += $headtail;
456 130 100       391 $max_args += $headtail if defined $max_args;
457              
458 130         331 $self->{min_args} = $min_args;
459 130         305 $self->{max_args} = $max_args;
460              
461 130 100 100     733 if ( defined $max_args and $min_args == $max_args ) {
    100 100        
462 67         296 $coderef->add_line( $strictness_test . sprintf(
463             "\@_ == %d\n\tor %s;",
464             $min_args,
465             $self->_make_count_fail(
466             coderef => $coderef,
467             minimum => $min_args,
468             maximum => $max_args,
469             got => 'scalar( @_ )',
470             ),
471             ) );
472             }
473             elsif ( $min_args and defined $max_args ) {
474 10         46 $coderef->add_line( $strictness_test . sprintf(
475             "\@_ >= %d && \@_ <= %d\n\tor %s;",
476             $min_args,
477             $max_args,
478             $self->_make_count_fail(
479             coderef => $coderef,
480             minimum => $min_args,
481             maximum => $max_args,
482             got => 'scalar( @_ )',
483             ),
484             ) );
485             }
486             else {
487 53   100     444 $coderef->add_line( $strictness_test . sprintf(
      100        
488             "\@_ >= %d\n\tor %s;",
489             $min_args || 0,
490             $self->_make_count_fail(
491             coderef => $coderef,
492             minimum => $min_args || 0,
493             got => 'scalar( @_ )',
494             ),
495             ) );
496             }
497             }
498             }
499              
500             sub _coderef_head {
501 51     51   143 my ( $self, $coderef ) = ( shift, @_ );
502 51 50       101 $self->has_head or return;
503              
504 51         100 my $size = @{ $self->head };
  51         124  
505 51         245 $coderef->add_line( sprintf(
506             '@head = splice( @_, 0, %d );',
507             $size,
508             ) );
509              
510 51         176 $coderef->add_gap;
511              
512 51         107 my $i = 0;
513 51         134 for my $parameter ( @{ $self->head } ) {
  51         137  
514 59         451 $parameter->_make_code(
515             signature => $self,
516             coderef => $coderef,
517             input_slot => sprintf( '$head[%d]', $i ),
518             input_var => '@head',
519             output_slot => sprintf( '$head[%d]', $i ),
520             output_var => undef,
521             index => $i,
522             type => 'head',
523             display_var => sprintf( '$_[%d]', $i ),
524             );
525 59         181 ++$i;
526             }
527              
528 51         94 $self;
529             }
530              
531             sub _coderef_tail {
532 16     16   38 my ( $self, $coderef ) = ( shift, @_ );
533 16 50       35 $self->has_tail or return;
534              
535 16         32 my $size = @{ $self->tail };
  16         34  
536 16         90 $coderef->add_line( sprintf(
537             '@tail = splice( @_, -%d );',
538             $size,
539             ) );
540              
541 16         41 $coderef->add_gap;
542              
543 16         40 my $i = 0;
544 16         28 my $n = @{ $self->tail };
  16         36  
545 16         32 for my $parameter ( @{ $self->tail } ) {
  16         36  
546 42         249 $parameter->_make_code(
547             signature => $self,
548             coderef => $coderef,
549             input_slot => sprintf( '$tail[%d]', $i ),
550             input_var => '@tail',
551             output_slot => sprintf( '$tail[%d]', $i ),
552             output_var => undef,
553             index => $i,
554             type => 'tail',
555             display_var => sprintf( '$_[-%d]', $n - $i ),
556             );
557 42         106 ++$i;
558             }
559              
560 16         33 $self;
561             }
562              
563             sub _coderef_parameters {
564 299     299   755 my ( $self, $coderef ) = ( shift, @_ );
565              
566 299 100       725 if ( $self->is_named ) {
567              
568 150         459 $coderef->add_line( sprintf(
569             '%%in = ( @_ == 1 and %s ) ? %%{ $_[0] } : @_;',
570             HashRef->inline_check( '$_[0]' ),
571             ) );
572              
573 150         505 $coderef->add_gap;
574              
575 150         272 for my $parameter ( @{ $self->parameters } ) {
  150         353  
576 350         1032 my $qname = B::perlstring( $parameter->name );
577 350         1554 $parameter->_make_code(
578             signature => $self,
579             coderef => $coderef,
580             is_named => 1,
581             input_slot => sprintf( '$in{%s}', $qname ),
582             output_slot => sprintf( '$out{%s}', $qname ),
583             display_var => sprintf( '$_{%s}', $qname ),
584             key => $parameter->name,
585             type => 'named_arg',
586             );
587             }
588             }
589             else {
590 149         373 my $can_shortcut = $self->can_shortcut;
591 149 100       387 my $head_size = $self->has_head ? @{ $self->head } : 0;
  32         75  
592              
593 149         289 my $i = 0;
594 149         240 for my $parameter ( @{ $self->parameters } ) {
  149         529  
595 179 100       1482 $parameter->_make_code(
    100          
596             signature => $self,
597             coderef => $coderef,
598             is_named => 0,
599             input_slot => sprintf( '$_[%d]', $i ),
600             input_var => '@_',
601             output_slot => ( $can_shortcut ? undef : sprintf( '$_[%d]', $i ) ),
602             output_var => ( $can_shortcut ? undef : '@out' ),
603             index => $i,
604             display_var => sprintf( '$_[%d]', $i + $head_size ),
605             );
606 178         461 ++$i;
607             }
608             }
609             }
610              
611             sub _coderef_slurpy {
612 69     69   185 my ( $self, $coderef ) = ( shift, @_ );
613 69 50       181 return unless $self->has_slurpy;
614              
615 69         185 my $parameter = $self->slurpy;
616 69         213 my $constraint = $parameter->type;
617 69         610 my $slurp_into = $constraint->my_slurp_into;
618 69         511 my $real_type = $constraint->my_unslurpy;
619              
620 69 100 66     1875 if ( $self->is_named ) {
    100          
    100          
621 24         96 $coderef->add_line( 'my $SLURPY = \\%in;' );
622             }
623             elsif ( $real_type and $real_type->{uniq} == Any->{uniq} ) {
624              
625             $coderef->add_line( sprintf(
626             'my $SLURPY = [ @_[ %d .. $#_ ] ];',
627 1         6 scalar( @{ $self->parameters } ),
  1         3  
628             ) );
629             }
630             elsif ( $slurp_into eq 'HASH' ) {
631              
632 29         240 my $index = scalar( @{ $self->parameters } );
  29         85  
633 29   33     135 $coderef->add_line( sprintf(
634             'my $SLURPY = ( $#_ == %d and ( %s ) ) ? { %%{ $_[%d] } } : ( ( $#_ - %d ) %% 2 ) ? { @_[ %d .. $#_ ] } : %s;',
635             $index,
636             HashRef->inline_check("\$_[$index]"),
637             $index,
638             $index,
639             $index,
640             $self->_make_general_fail(
641             coderef => $coderef,
642             message => sprintf(
643             qq{sprintf( "Odd number of elements in %%s", %s )},
644             B::perlstring( ( $real_type or $constraint )->display_name ),
645             ),
646             ),
647             ) );
648             }
649             else {
650            
651             $coderef->add_line( sprintf(
652             'my $SLURPY = [ @_[ %d .. $#_ ] ];',
653 15         110 scalar( @{ $self->parameters } ),
  15         49  
654             ) );
655             }
656              
657 69         326 $coderef->add_gap;
658              
659 69 100       310 $parameter->_make_code(
660             signature => $self,
661             coderef => $coderef,
662             input_slot => '$SLURPY',
663             display_var => '$SLURPY',
664             index => 0,
665             $self->is_named
666             ? ( output_slot => sprintf( '$out{%s}', B::perlstring( $parameter->name ) ) )
667             : ( output_var => '@out' )
668             );
669             }
670              
671             sub _coderef_extra_names {
672 126     126   288 my ( $self, $coderef ) = ( shift, @_ );
673              
674 126 50 33     285 return $self if $self->has_strictness && ! $self->strictness;
675              
676 126         7916 require Type::Utils;
677 126         293 my $english_list = 'Type::Utils::english_list';
678 126 100       361 if ( $Type::Tiny::AvoidCallbacks ) {
679 8         15 $english_list = 'join q{, } => ';
680             }
681              
682 126         413 $coderef->add_line( '# Unrecognized parameters' );
683 126 50 33     634 $coderef->add_line( sprintf(
684             '%s if %skeys %%in;',
685             $self->_make_general_fail(
686             coderef => $coderef,
687             message => "sprintf( q{Unrecognized parameter%s: %s}, keys( %in ) > 1 ? q{s} : q{}, $english_list( sort keys %in ) )",
688             ),
689             defined( $self->strictness ) && $self->strictness ne 1
690             ? sprintf( '%s && ', $self->strictness )
691             : ''
692             ) );
693 126         344 $coderef->add_gap;
694             }
695              
696             sub _coderef_end {
697 298     298   717 my ( $self, $coderef ) = ( shift, @_ );
698              
699 298 100 100     728 if ( $self->bless and $self->oo_trace ) {
700 28         76 my $package = $self->package;
701 28         68 my $subname = $self->subname;
702 28 50 33     129 if ( defined $package and defined $subname ) {
703 28         244 $coderef->add_line( sprintf(
704             '$out{"~~caller"} = %s;',
705             B::perlstring( "$package\::$subname" ),
706             ) );
707 28         78 $coderef->add_gap;
708             }
709             }
710              
711 298         988 $self->_coderef_end_extra( $coderef );
712 298         842 $coderef->add_line( $self->_make_return_expression( is_early => 0 ) . ';' );
713 298         1956 $coderef->{indent} =~ s/\t$//;
714 298         1040 $coderef->add_line( '}' );
715              
716 298         499 $self;
717             }
718              
719       280     sub _coderef_end_extra {}
720              
721             sub _make_return_list {
722 299     299   507 my $self = shift;
723              
724 299         472 my @return_list;
725 299 100       657 if ( $self->has_head ) {
726 51         109 push @return_list, '@head';
727             }
728              
729 299 100       806 if ( not $self->is_named ) {
    100          
    100          
    100          
730 149 100       441 push @return_list, $self->can_shortcut ? '@_' : '@out';
731             }
732             elsif ( $self->named_to_list ) {
733             push @return_list, map(
734             sprintf( '$out{%s}', B::perlstring( $_ ) ),
735 11         18 @{ $self->named_to_list },
  11         21  
736             );
737             }
738             elsif ( $self->class ) {
739 24   100     54 push @return_list, sprintf(
740             '%s->%s( \%%out )',
741             B::perlstring( $self->class ),
742             $self->constructor || 'new',
743             );
744             }
745             elsif ( $self->bless ) {
746 36         85 push @return_list, sprintf(
747             'bless( \%%out, %s )',
748             B::perlstring( $self->bless ),
749             );
750             }
751             else {
752 79         160 push @return_list, '\%out';
753             }
754              
755 299 100       820 if ( $self->has_tail ) {
756 16         39 push @return_list, '@tail';
757             }
758              
759 299         942 return @return_list;
760             }
761              
762             sub _make_return_expression {
763 317     317   927 my ( $self, %args ) = @_;
764              
765 317         830 my $list = join q{, }, $self->_make_return_list;
766              
767 317 100 66     755 if ( $self->goto_next ) {
    100          
768 33 100       172 if ( $list eq '@_' ) {
769 7         39 return sprintf 'goto( $__NEXT__ )';
770             }
771             else {
772 26         203 return sprintf 'do { @_ = ( %s ); goto $__NEXT__ }',
773             $list;
774             }
775             }
776             elsif ( $args{is_early} or not exists $args{is_early} ) {
777 19         103 return sprintf 'return( %s )', $list;
778             }
779             else {
780 265         1685 return sprintf '( %s )', $list;
781             }
782             }
783              
784             sub _make_general_fail {
785 445     445   1461 my ( $self, %args ) = ( shift, @_ );
786              
787             return sprintf(
788             $self->has_on_die
789             ? q{return( "Error::TypeTiny"->throw_cb( $__ON_DIE__, message => %s ) )}
790             : q{"Error::TypeTiny"->throw( message => %s )},
791             $args{message},
792 445 100       975 );
793             }
794              
795             sub _make_constraint_fail {
796 683     683   3375 my ( $self, %args ) = ( shift, @_ );
797              
798             return sprintf(
799             $self->has_on_die
800             ? q{return( Type::Tiny::_failed_check( %d, %s, %s, varname => %s, on_die => $__ON_DIE__ ) )}
801             : q{Type::Tiny::_failed_check( %d, %s, %s, varname => %s )},
802             $args{constraint}{uniq},
803             B::perlstring( $args{constraint}->display_name ),
804             $args{varname},
805 683 100 33     1848 B::perlstring( $args{display_var} || $args{varname} ),
806             );
807             }
808              
809             sub _make_count_fail {
810 280     280   1238 my ( $self, %args ) = ( shift, @_ );
811              
812 280         587 my @counts;
813 280 50       781 if ( $args{got} ) {
814             push @counts, sprintf(
815             'got => %s',
816             $args{got},
817 280         1009 );
818             }
819 280         648 for my $c ( qw/ minimum maximum / ) {
820 560 100       2576 is_Int( $args{$c} ) or next;
821             push @counts, sprintf(
822             '%s => %s',
823             $c,
824 207         1336 $args{$c},
825             );
826             }
827              
828 280 100       804 return sprintf(
829             $self->has_on_die
830             ? q{return( "Error::TypeTiny::WrongNumberOfParameters"->throw_cb( $__ON_DIE__, %s ) )}
831             : q{"Error::TypeTiny::WrongNumberOfParameters"->throw( %s )},
832             join( q{, }, @counts ),
833             );
834             }
835              
836             sub class_attributes {
837 43     43 0 77 my $self = shift;
838 43   66     187 $self->{class_attributes} ||= $self->_build_class_attributes;
839             }
840              
841             sub _build_class_attributes {
842 30     30   69 my $self = shift;
843 30         60 my %predicates;
844             my %getters;
845              
846 30         56 my @parameters = @{ $self->parameters };
  30         91  
847 30 100       94 if ( $self->has_slurpy ) {
848 1         3 push @parameters, $self->slurpy;
849             }
850              
851 30         86 for my $parameter ( @parameters ) {
852              
853 63         187 my $name = $parameter->name;
854 63 100       149 if ( my $predicate = $parameter->predicate ) {
855 20 50       96 $predicate =~ /^[^0-9\W]\w*$/
856             or $self->_croak( "Bad accessor name: \"$predicate\"" );
857 20         53 $predicates{$predicate} = $name;
858             }
859 63 50       148 if ( my $getter = $parameter->getter ) {
860 63 100       289 $getter =~ /^[^0-9\W]\w*$/
861             or $self->_croak( "Bad accessor name: \"$getter\"" );
862 61         207 $getters{$getter} = $name;
863             }
864             }
865              
866             return {
867 28         191 exists_predicates => \%predicates,
868             getters => \%getters,
869             };
870             }
871              
872             sub make_class {
873 30     30 0 68 my $self = shift;
874            
875 30   50     179 my $env = uc( $ENV{PERL_TYPE_PARAMS_XS} || 'XS' );
876 30 50 33     153 if ( $env eq 'PP' or $ENV{PERL_ONLY} ) {
877 0         0 $self->make_class_pp;
878             }
879              
880 30         74 $self->make_class_xs;
881             }
882              
883             sub make_class_xs {
884 30     30 0 51 my $self = shift;
885              
886 30 50       65 eval {
887 30         4836 require Class::XSAccessor;
888 30         20857 'Class::XSAccessor'->VERSION( '1.17' );
889 30         179 1;
890             } or return $self->make_class_pp;
891              
892 30         95 my $attr = $self->class_attributes;
893              
894 28         102 'Class::XSAccessor'->import(
895             class => $self->bless,
896             replace => 1,
897             %$attr,
898             );
899             }
900              
901             sub make_class_pp {
902 0     0 0 0 my $self = shift;
903              
904 0         0 my $code = $self->make_class_pp_code;
905 0         0 do {
906 0         0 local $@;
907 0 0       0 eval( $code ) or die( $@ );
908             };
909             }
910              
911             sub make_class_pp_code {
912 48     48 0 96 my $self = shift;
913              
914 48 100 66     108 return ''
      100        
915             unless $self->is_named && $self->bless && !$self->named_to_list;
916              
917 13         46 my $coderef = $self->_new_code_accumulator;
918 13         47 my $attr = $self->class_attributes;
919              
920 13         44 $coderef->add_line( '{' );
921 13         32 $coderef->{indent} = "\t";
922 13         84 $coderef->add_line( sprintf( 'package %s;', $self->bless ) );
923 13         47 $coderef->add_line( 'use strict;' );
924 13         60 $coderef->add_line( 'no warnings;' );
925              
926 13         21 for my $function ( sort keys %{ $attr->{getters} } ) {
  13         87  
927 28         52 my $slot = $attr->{getters}{$function};
928 28         127 $coderef->add_line( sprintf(
929             'sub %s { $_[0]{%s} }',
930             $function,
931             B::perlstring( $slot ),
932             ) );
933             }
934              
935 13         34 for my $function ( sort keys %{ $attr->{exists_predicates} } ) {
  13         46  
936 12         21 my $slot = $attr->{exists_predicates}{$function};
937 12         56 $coderef->add_line( sprintf(
938             'sub %s { exists $_[0]{%s} }',
939             $function,
940             B::perlstring( $slot ),
941             ) );
942             }
943            
944 13         56 $coderef->add_line( '1;' );
945 13         28 $coderef->{indent} = "";
946 13         46 $coderef->add_line( '}' );
947              
948 13         32 return $coderef->code;
949             }
950              
951             sub return_wanted {
952 291     291 0 586 my $self = shift;
953 291         1193 my $coderef = $self->coderef;
954              
955 288 100       1356 if ( $self->{want_source} ) {
    100          
    100          
956 7         30 return $coderef->code;
957             }
958             elsif ( $self->{want_object} ) { # undocumented for now
959 1         8 return $self;
960             }
961             elsif ( $self->{want_details} ) {
962             return {
963             min_args => $self->{min_args},
964             max_args => $self->{max_args},
965             environment => $coderef->{env},
966 52         167 source => $coderef->code,
967             closure => $coderef->compile,
968             named => $self->is_named,
969             class_definition => $self->make_class_pp_code,
970             };
971             }
972              
973 228         808 return $coderef->compile;
974             }
975              
976             1;