← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:05 2021

Filename/usr/local/lib/perl5/site_perl/Params/ValidationCompiler/Compiler.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@10Params::ValidationCompiler::Compiler::BEGIN@10
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@11Params::ValidationCompiler::Compiler::BEGIN@11
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@12Params::ValidationCompiler::Compiler::BEGIN@12
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@13Params::ValidationCompiler::Compiler::BEGIN@13
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@14Params::ValidationCompiler::Compiler::BEGIN@14
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@18Params::ValidationCompiler::Compiler::BEGIN@18
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@3Params::ValidationCompiler::Compiler::BEGIN@3
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@4Params::ValidationCompiler::Compiler::BEGIN@4
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@8Params::ValidationCompiler::Compiler::BEGIN@8
0000s0sParams::ValidationCompiler::Compiler::::BEGIN@9Params::ValidationCompiler::Compiler::BEGIN@9
0000s0sParams::ValidationCompiler::Compiler::::CORE:sortParams::ValidationCompiler::Compiler::CORE:sort (opcode)
0000s0sParams::ValidationCompiler::Compiler::::HAS_CXSAParams::ValidationCompiler::Compiler::HAS_CXSA
0000s0sParams::ValidationCompiler::Compiler::::HAS_SUB_UTILParams::ValidationCompiler::Compiler::HAS_SUB_UTIL
0000s0sParams::ValidationCompiler::Compiler::::__ANON__Params::ValidationCompiler::Compiler::__ANON__ (xsub)
0000s0sParams::ValidationCompiler::Compiler::::__ANON__[:34]Params::ValidationCompiler::Compiler::__ANON__[:34]
0000s0sParams::ValidationCompiler::Compiler::::_add_check_for_extra_hash_param_typesParams::ValidationCompiler::Compiler::_add_check_for_extra_hash_param_types
0000s0sParams::ValidationCompiler::Compiler::::_add_check_for_extra_hash_paramsParams::ValidationCompiler::Compiler::_add_check_for_extra_hash_params
0000s0sParams::ValidationCompiler::Compiler::::_add_check_for_extra_positional_param_typesParams::ValidationCompiler::Compiler::_add_check_for_extra_positional_param_types
0000s0sParams::ValidationCompiler::Compiler::::_add_check_for_extra_positional_paramsParams::ValidationCompiler::Compiler::_add_check_for_extra_positional_params
0000s0sParams::ValidationCompiler::Compiler::::_add_check_for_required_named_paramParams::ValidationCompiler::Compiler::_add_check_for_required_named_param
0000s0sParams::ValidationCompiler::Compiler::::_add_check_for_required_positional_paramsParams::ValidationCompiler::Compiler::_add_check_for_required_positional_params
0000s0sParams::ValidationCompiler::Compiler::::_add_moose_checkParams::ValidationCompiler::Compiler::_add_moose_check
0000s0sParams::ValidationCompiler::Compiler::::_add_named_default_assignmentParams::ValidationCompiler::Compiler::_add_named_default_assignment
0000s0sParams::ValidationCompiler::Compiler::::_add_positional_default_assignmentParams::ValidationCompiler::Compiler::_add_positional_default_assignment
0000s0sParams::ValidationCompiler::Compiler::::_add_return_named_args_objectParams::ValidationCompiler::Compiler::_add_return_named_args_object
0000s0sParams::ValidationCompiler::Compiler::::_add_shared_default_assignmentParams::ValidationCompiler::Compiler::_add_shared_default_assignment
0000s0sParams::ValidationCompiler::Compiler::::_add_specio_checkParams::ValidationCompiler::Compiler::_add_specio_check
0000s0sParams::ValidationCompiler::Compiler::::_add_to_environmentParams::ValidationCompiler::Compiler::_add_to_environment
0000s0sParams::ValidationCompiler::Compiler::::_add_type_checkParams::ValidationCompiler::Compiler::_add_type_check
0000s0sParams::ValidationCompiler::Compiler::::_add_type_tiny_checkParams::ValidationCompiler::Compiler::_add_type_tiny_check
0000s0sParams::ValidationCompiler::Compiler::::_any_type_has_coercionParams::ValidationCompiler::Compiler::_any_type_has_coercion
0000s0sParams::ValidationCompiler::Compiler::::_callerParams::ValidationCompiler::Compiler::_caller
0000s0sParams::ValidationCompiler::Compiler::::_compileParams::ValidationCompiler::Compiler::_compile
0000s0sParams::ValidationCompiler::Compiler::::_compile_named_args_checkParams::ValidationCompiler::Compiler::_compile_named_args_check
0000s0sParams::ValidationCompiler::Compiler::::_compile_named_args_check_bodyParams::ValidationCompiler::Compiler::_compile_named_args_check_body
0000s0sParams::ValidationCompiler::Compiler::::_compile_named_args_list_checkParams::ValidationCompiler::Compiler::_compile_named_args_list_check
0000s0sParams::ValidationCompiler::Compiler::::_compile_positional_args_checkParams::ValidationCompiler::Compiler::_compile_positional_args_check
0000s0sParams::ValidationCompiler::Compiler::::_create_cxsa_return_classParams::ValidationCompiler::Compiler::_create_cxsa_return_class
0000s0sParams::ValidationCompiler::Compiler::::_create_pp_return_classParams::ValidationCompiler::Compiler::_create_pp_return_class
0000s0sParams::ValidationCompiler::Compiler::::_describeParams::ValidationCompiler::Compiler::_describe
0000s0sParams::ValidationCompiler::Compiler::::_envParams::ValidationCompiler::Compiler::_env
0000s0sParams::ValidationCompiler::Compiler::::_has_callerParams::ValidationCompiler::Compiler::_has_caller
0000s0sParams::ValidationCompiler::Compiler::::_has_nameParams::ValidationCompiler::Compiler::_has_name
0000s0sParams::ValidationCompiler::Compiler::::_inlineable_nameParams::ValidationCompiler::Compiler::_inlineable_name
0000s0sParams::ValidationCompiler::Compiler::::_munge_and_check_positional_paramsParams::ValidationCompiler::Compiler::_munge_and_check_positional_params
0000s0sParams::ValidationCompiler::Compiler::::_name_is_optionalParams::ValidationCompiler::Compiler::_name_is_optional
0000s0sParams::ValidationCompiler::Compiler::::_set_named_args_hashParams::ValidationCompiler::Compiler::_set_named_args_hash
0000s0sParams::ValidationCompiler::Compiler::::_sourceParams::ValidationCompiler::Compiler::_source
0000s0sParams::ValidationCompiler::Compiler::::_type_checkParams::ValidationCompiler::Compiler::_type_check
0000s0sParams::ValidationCompiler::Compiler::::_typesParams::ValidationCompiler::Compiler::_types
0000s0sParams::ValidationCompiler::Compiler::::_validate_param_specParams::ValidationCompiler::Compiler::_validate_param_spec
0000s0sParams::ValidationCompiler::Compiler::::nameParams::ValidationCompiler::Compiler::name
0000s0sParams::ValidationCompiler::Compiler::::named_to_listParams::ValidationCompiler::Compiler::named_to_list
0000s0sParams::ValidationCompiler::Compiler::::newParams::ValidationCompiler::Compiler::new
0000s0sParams::ValidationCompiler::Compiler::::paramsParams::ValidationCompiler::Compiler::params
0000s0sParams::ValidationCompiler::Compiler::::return_objectParams::ValidationCompiler::Compiler::return_object
0000s0sParams::ValidationCompiler::Compiler::::slurpyParams::ValidationCompiler::Compiler::slurpy
0000s0sParams::ValidationCompiler::Compiler::::sourceParams::ValidationCompiler::Compiler::source
0000s0sParams::ValidationCompiler::Compiler::::subrefParams::ValidationCompiler::Compiler::subref
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Params::ValidationCompiler::Compiler;
2
3use strict;
4use warnings;
5
6our $VERSION = '0.30';
7
8use Carp qw( croak );
9use Eval::Closure qw( eval_closure );
10use List::Util 1.29 qw( pairkeys pairvalues );
11use Params::ValidationCompiler::Exceptions;
12use Scalar::Util qw( blessed looks_like_number reftype );
13use overload ();
14use B qw( perlstring );
15
16our @CARP_NOT = ( 'Params::ValidationCompiler', __PACKAGE__ );
17
18BEGIN {
19 ## no critic (Variables::RequireInitializationForLocalVars)
20 local $@;
21 my $has_sub_util = eval {
22 require Sub::Util;
23 Sub::Util->VERSION(1.40);
24 Sub::Util->import('set_subname');
25 1;
26 };
27
28 sub HAS_SUB_UTIL () {$has_sub_util}
29
30 unless ($has_sub_util) {
31 *set_subname = sub {
32 croak
33 'Cannot name a generated validation subroutine. Please install Sub::Util.';
34 };
35 }
36
37 my $has_cxsa = eval {
38 require Class::XSAccessor;
39 1;
40 };
41
42 sub HAS_CXSA {$has_cxsa}
43}
44
45my %known
46 = map { $_ => 1 }
47 qw( debug name name_is_optional named_to_list params return_object slurpy );
48
49# I'd rather use Moo here but I want to make things relatively high on the
50# CPAN river like DateTime use this distro, so reducing deps is important.
51sub new {
52 my $class = shift;
53 my %p = @_;
54
55 unless ( exists $p{params} ) {
56 croak
57 q{You must provide a "params" parameter when creating a parameter validator};
58 }
59
60 if ( ref $p{params} eq 'HASH' ) {
61 croak q{The "params" hashref must contain at least one key-value pair}
62 unless %{ $p{params} };
63
64 croak
65 q{"named_to_list" must be used with arrayref params containing key-value pairs}
66 if $p{named_to_list};
67
68 $class->_validate_param_spec($_) for values %{ $p{params} };
69 }
70 elsif ( ref $p{params} eq 'ARRAY' ) {
71 croak q{The "params" arrayref must contain at least one element}
72 unless @{ $p{params} };
73
74 croak q{You can only use "return_object" with named params}
75 if $p{return_object};
76
77 my @specs
78 = $p{named_to_list}
79 ? pairvalues @{ $p{params} }
80 : @{ $p{params} };
81
82 $class->_validate_param_spec($_) for @specs;
83 }
84 else {
85 my $type = _describe( $p{params} );
86 croak
87 qq{The "params" parameter when creating a parameter validator must be a hashref or arrayref, you passed $type};
88 }
89
90 if ( $p{named_to_list} && $p{slurpy} ) {
91 croak q{You cannot use "named_to_list" and "slurpy" together};
92 }
93
94 if ( exists $p{name} && ( !defined $p{name} || ref $p{name} ) ) {
95 my $type = _describe( $p{name} );
96 croak
97 qq{The "name" parameter when creating a parameter validator must be a scalar, you passed $type};
98 }
99
100 if ( $p{return_object} && $p{slurpy} ) {
101 croak q{You cannot use "return_object" and "slurpy" together};
102 }
103
104 my @unknown = sort grep { !$known{$_} } keys %p;
105 if (@unknown) {
106 croak
107 "You passed unknown parameters when creating a parameter validator: [@unknown]";
108 }
109
110 my $self = bless \%p, $class;
111
112 $self->{_source} = [];
113 $self->{_env} = {};
114
115 return $self;
116}
117
118sub _describe {
119 my $thing = shift;
120
121 if ( !defined $thing ) {
122 return 'an undef';
123 }
124 elsif ( my $class = blessed $thing ) {
125 my $article = $class =~ /^[aeiou]/i ? 'an' : 'a';
126 return "$article $class object";
127 }
128 elsif ( ref $thing ) {
129 my $ref = lc ref $thing;
130 my $article = $ref =~ /^[aeiou]/i ? 'an' : 'a';
131 return "$article $ref" . 'ref';
132 }
133
134 return 'a scalar';
135}
136
137{
138 my %known_keys = (
139 default => 1,
140 getter => 1,
141 optional => 1,
142 predicate => 1,
143 type => 1,
144 );
145
146 sub _validate_param_spec {
147 shift;
148 my $spec = shift;
149
150 my $ref = ref $spec;
151 return unless $ref;
152
153 croak
154 "Specifications must be a scalar or hashref, but received a $ref"
155 unless $ref eq 'HASH';
156
157 my @unknown = sort grep { !$known_keys{$_} } keys %{$spec};
158 if (@unknown) {
159 croak "Specification contains unknown keys: [@unknown]";
160 }
161 }
162}
163
164sub name { $_[0]->{name} }
165sub _has_name { exists $_[0]->{name} }
166
167sub _name_is_optional { $_[0]->{name_is_optional} }
168
169# I have no idea why critic thinks _caller isn't used.
170
171## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
172sub _caller { $_[0]->{caller} }
173## use critic
174sub _has_caller { exists $_[0]->{caller} }
175
176sub params { $_[0]->{params} }
177
178sub slurpy { $_[0]->{slurpy} }
179
180sub _source { $_[0]->{_source} }
181
182sub _env { $_[0]->{_env} }
183
184sub named_to_list { $_[0]->{named_to_list} }
185
186sub return_object { $_[0]->{return_object} }
187
188sub _inlineable_name {
189 return defined $_[0]->{name}
190 ? $_[0]->{name}
191 : 'an un-named validation subroutine';
192}
193
194sub _any_type_has_coercion {
195 my $self = shift;
196
197 return $self->{_has_coercion} if exists $self->{_has_coercion};
198
199 for my $type ( $self->_types ) {
200
201 # Specio
202 if ( $type->can('has_coercions') && $type->has_coercions ) {
203 return $self->{_has_coercion} = 1;
204 }
205
206 # Moose and Type::Tiny
207 elsif ( $type->can('has_coercion') && $type->has_coercion ) {
208 return $self->{_has_coercion} = 1;
209 }
210 }
211
212 return $self->{_has_coercion} = 0;
213}
214
215sub _types {
216 my $self = shift;
217
218 my @types;
219 if ( ref $self->params eq 'HASH' ) {
220 @types = map { $_->{type} || () }
221 grep { ref $_ } values %{ $self->params };
222 }
223 elsif ( ref $self->params eq 'ARRAY' ) {
224 if ( $self->named_to_list ) {
225 my %p = @{ $self->params };
226 @types = map { $_->{type} || () } grep { ref $_ } values %p;
227 }
228 else {
229 @types
230 = map { $_->{type} || () } grep { ref $_ } @{ $self->params };
231 }
232 }
233
234 push @types, $self->slurpy if $self->slurpy && ref $self->slurpy;
235
236 return @types;
237}
238
239sub subref {
240 my $self = shift;
241
242 $self->_compile;
243
244 local $ENV{EVAL_CLOSURE_PRINT_SOURCE} = 1 if $self->{debug};
245 my $sub = eval_closure(
246 source => 'sub { ' . ( join "\n", @{ $self->_source } ) . ' };',
247 environment => $self->_env,
248 );
249
250 if ( $self->_has_name ) {
251 my $caller = $self->_has_caller ? $self->_caller : caller(1);
252 my $name = join '::', $caller, $self->name;
253
254 return $sub if $self->_name_is_optional && !HAS_SUB_UTIL;
255 set_subname( $name, $sub );
256 }
257
258 return $sub;
259}
260
261sub source {
262 my $self = shift;
263
264 $self->_compile;
265 return (
266 ( join "\n", @{ $self->_source } ),
267 $self->_env,
268 );
269}
270
271sub _compile {
272 my $self = shift;
273
274 if ( ref $self->params eq 'HASH' ) {
275 $self->_compile_named_args_check;
276 }
277 elsif ( ref $self->params eq 'ARRAY' ) {
278 if ( $self->named_to_list ) {
279 $self->_compile_named_args_list_check;
280 }
281 else {
282 $self->_compile_positional_args_check;
283 }
284 }
285}
286
287sub _compile_named_args_check {
288 my $self = shift;
289
290 $self->_compile_named_args_check_body( $self->params );
291
292 if ( $self->return_object ) {
293 push @{ $self->_source }, $self->_add_return_named_args_object;
294 }
295 else {
296 push @{ $self->_source }, 'return %args;';
297 }
298
299 return;
300}
301
302{
303 my $class_id = 0;
304
305 sub _add_return_named_args_object {
306 my $self = shift;
307
308 my $params = $self->params;
309 my %getters;
310 my %predicates;
311 for my $p ( keys %{$params} ) {
312 $getters{
313 ref $params->{$p} && exists $params->{$p}{getter}
314 ? $params->{$p}{getter}
315 : $p
316 } = $p;
317 $predicates{ $params->{$p}{predicate} } = $p
318 if ref $params->{$p} && exists $params->{$p}{predicate};
319 }
320
321 my $use_cxsa = HAS_CXSA && !$ENV{TEST_NAMED_ARGS_OBJECT_WITHOUT_CXSA};
322 my $class = sprintf(
323 '%s::OO::Args%d::%s',
324 __PACKAGE__,
325 $class_id++,
326 $use_cxsa ? 'XS' : 'PP',
327 );
328
329 if ($use_cxsa) {
330 $self->_create_cxsa_return_class(
331 $class,
332 \%getters,
333 \%predicates,
334 );
335 }
336 else {
337 $self->_create_pp_return_class( $class, \%getters, \%predicates );
338 }
339
340 return sprintf( 'bless \%%args, %s', perlstring($class) );
341 }
342}
343
344sub _create_cxsa_return_class {
345 my $self = shift;
346 my $class = shift;
347 my $getters = shift;
348 my $predicates = shift;
349
350 Class::XSAccessor->import(
351 redefine => 1,
352 class => $class,
353 getters => $getters,
354 exists_predicates => $predicates,
355 );
356
357 return;
358}
359
360sub _create_pp_return_class {
361 my $self = shift;
362 my $class = shift;
363 my $getters = shift;
364 my $predicates = shift;
365
366 my @source = sprintf( 'package %s;', $class );
367 for my $sub ( keys %{$getters} ) {
368 push @source,
369 sprintf(
370 'sub %s { return $_[0]->{%s} }', $sub,
371 perlstring( $getters->{$sub} )
372 );
373 }
374 for my $sub ( keys %{$predicates} ) {
375 push @source,
376 sprintf(
377 'sub %s { return exists $_[0]->{%s} }', $sub,
378 perlstring( $predicates->{$sub} )
379 );
380 }
381 push @source, q{1;};
382 ## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
383 eval join q{}, @source
384 or die $@;
385
386 return;
387}
388
389sub _compile_named_args_list_check {
390 my $self = shift;
391
392 $self->_compile_named_args_check_body( { @{ $self->params } } );
393
394 my @keys = map { perlstring($_) } pairkeys @{ $self->params };
395
396 # If we don't handle the one-key case specially we end up getting a
397 # warning like "Scalar value @args{"bar"} better written as $args{"bar"}
398 # at ..."
399 if ( @keys == 1 ) {
400 push @{ $self->_source }, "return \$args{$keys[0]};";
401 }
402 else {
403 my $keys_str = join q{, }, @keys;
404 push @{ $self->_source }, "return \@args{$keys_str};";
405 }
406
407 return;
408}
409
410sub _compile_named_args_check_body {
411 my $self = shift;
412 my $params = shift;
413
414 push @{ $self->_source }, $self->_set_named_args_hash;
415
416 for my $name ( sort keys %{$params} ) {
417 my $spec = $params->{$name};
418 $spec = { optional => !$spec } unless ref $spec;
419
420 my $qname = perlstring($name);
421 my $access = "\$args{$qname}";
422
423 # We check exists $spec->{optional} so as not to blow up on a
424 # restricted hash.
425 $self->_add_check_for_required_named_param( $access, $name )
426 unless ( exists $spec->{optional} && $spec->{optional} )
427 || exists $spec->{default};
428
429 $self->_add_named_default_assignment(
430 $access,
431 $name,
432 $spec->{default}
433 ) if exists $spec->{default};
434
435 # Same issue with restricted hashes here.
436 $self->_add_type_check( $access, $name, $spec )
437 if exists $spec->{type} && $spec->{type};
438 }
439
440 if ( $self->slurpy ) {
441 $self->_add_check_for_extra_hash_param_types( $self->slurpy, $params )
442 if ref $self->slurpy;
443 }
444 else {
445 $self->_add_check_for_extra_hash_params($params);
446 }
447
448 return;
449}
450
451sub _set_named_args_hash {
452 my $self = shift;
453
454 push @{ $self->_source },
455 sprintf( <<'EOF', ( $self->_inlineable_name ) x 4 );
456my %%args;
457if ( @_ %% 2 == 0 ) {
458 %%args = @_;
459}
460elsif ( @_ == 1 ) {
461 if ( ref $_[0] ) {
462 if ( Scalar::Util::blessed( $_[0] ) ) {
463 if ( overload::Overloaded( $_[0] )
464 && defined overload::Method( $_[0], '%%{}' ) ) {
465
466 %%args = %%{ $_[0] };
467 }
468 else {
469 Params::ValidationCompiler::Exception::BadArguments->throw(
470 message =>
471 'Expected a hash or hash reference but a single object argument was passed to %s',
472 show_trace => 1,
473 );
474 }
475 }
476 elsif ( ref $_[0] eq 'HASH' ) {
477 %%args = %%{ $_[0] };
478 }
479 else {
480 Params::ValidationCompiler::Exception::BadArguments->throw(
481 message =>
482 'Expected a hash or hash reference but a single '
483 . ( ref $_[0] )
484 . ' reference argument was passed to %s',
485 show_trace => 1,
486 );
487 }
488 }
489 else {
490 Params::ValidationCompiler::Exception::BadArguments->throw(
491 message =>
492 'Expected a hash or hash reference but a single non-reference argument was passed to %s',
493 show_trace => 1,
494 );
495 }
496}
497else {
498 Params::ValidationCompiler::Exception::BadArguments->throw(
499 message =>
500 'Expected a hash or hash reference but an odd number of arguments was passed to %s',
501 show_trace => 1,
502 );
503}
504EOF
505
506 return;
507}
508
509sub _add_check_for_required_named_param {
510 my $self = shift;
511 my $access = shift;
512 my $name = shift;
513
514 my $qname = perlstring($name);
515 push @{ $self->_source },
516 sprintf( <<'EOF', $access, $qname, $self->_inlineable_name, $qname );
517exists %s
518 or Params::ValidationCompiler::Exception::Named::Required->throw(
519 message => %s . ' is a required parameter for %s',
520 parameter => %s,
521 show_trace => 1,
522 );
523EOF
524
525 return;
526}
527
528sub _add_check_for_extra_hash_param_types {
529 my $self = shift;
530 my $type = shift;
531 my $params = shift;
532
533 $self->_env->{'%known'}
534 = { map { $_ => 1 } keys %{$params} };
535
536 # We need to set the name argument to something that won't conflict with
537 # names someone would actually use for a parameter.
538 my $check = join q{}, $self->_type_check(
539 '$args{$key}',
540 '__PCC extra parameters__',
541 $type,
542 );
543 push @{ $self->_source }, sprintf( <<'EOF', $check );
544for my $key ( grep { !$known{$_} } keys %%args ) {
545 %s;
546}
547EOF
548
549 return;
550}
551
552sub _add_check_for_extra_hash_params {
553 my $self = shift;
554 my $params = shift;
555
556 $self->_env->{'%known'}
557 = { map { $_ => 1 } keys %{$params} };
558 push @{ $self->_source }, sprintf( <<'EOF', $self->_inlineable_name );
559my @extra = grep { !$known{$_} } keys %%args;
560if (@extra) {
561 my $u = join ', ', sort @extra;
562 Params::ValidationCompiler::Exception::Named::Extra->throw(
563 message => "Found extra parameters passed to %s: [$u]",
564 parameters => \@extra,
565 show_trace => 1,
566 );
567}
568EOF
569
570 return;
571}
572
573sub _compile_positional_args_check {
574 my $self = shift;
575
576 my @specs = $self->_munge_and_check_positional_params;
577
578 my $first_optional_idx = -1;
579 for my $i ( 0 .. $#specs ) {
580 next unless $specs[$i]{optional} || exists $specs[$i]{default};
581 $first_optional_idx = $i;
582 last;
583 }
584
585 # If optional params start anywhere after the first parameter spec then we
586 # must require at least one param. If there are no optional params then
587 # they're all required.
588 $self->_add_check_for_required_positional_params(
589 $first_optional_idx == -1
590 ? ( scalar @specs )
591 : $first_optional_idx
592 ) if $first_optional_idx != 0;
593
594 $self->_add_check_for_extra_positional_params( scalar @specs )
595 unless $self->slurpy;
596
597 my $access_var = '$_';
598 my $return_var = '@_';
599 if ( $self->_any_type_has_coercion ) {
600 push @{ $self->_source }, 'my @copy = @_;';
601 $access_var = '$copy';
602 $return_var = '@copy';
603 }
604
605 for my $i ( 0 .. $#specs ) {
606 my $spec = $specs[$i];
607
608 my $name = "Parameter $i";
609 my $access = sprintf( '%s[%i]', $access_var, $i );
610
611 $self->_add_positional_default_assignment(
612 $i,
613 $access,
614 $name,
615 $spec->{default}
616 ) if exists $spec->{default};
617
618 $self->_add_type_check( $access, $name, $spec )
619 if $spec->{type};
620 }
621
622 if ( ref $self->slurpy ) {
623 $self->_add_check_for_extra_positional_param_types(
624 scalar @specs,
625 $self->slurpy,
626 $access_var,
627 );
628 }
629
630 push @{ $self->_source }, sprintf( 'return %s;', $return_var );
631
632 return;
633}
634
635sub _munge_and_check_positional_params {
636 my $self = shift;
637
638 my @specs;
639 my $in_optional = 0;
640
641 for my $spec ( @{ $self->params } ) {
642 $spec = ref $spec ? $spec : { optional => !$spec };
643 if ( $spec->{optional} || exists $spec->{default} ) {
644 $in_optional = 1;
645 }
646 elsif ($in_optional) {
647 croak
648 'Parameter list contains an optional parameter followed by a required parameter.';
649 }
650
651 push @specs, $spec;
652 }
653
654 return @specs;
655}
656
657sub _add_check_for_required_positional_params {
658 my $self = shift;
659 my $min = shift;
660
661 push @{ $self->_source },
662 sprintf( <<'EOF', ($min) x 2, $self->_inlineable_name, $min );
663if ( @_ < %d ) {
664 my $got = scalar @_;
665 my $got_n = @_ == 1 ? 'parameter' : 'parameters';
666 Params::ValidationCompiler::Exception::Positional::Required->throw(
667 message => "Got $got $got_n but expected at least %d for %s",
668 minimum => %d,
669 got => scalar @_,
670 show_trace => 1,
671 );
672}
673EOF
674
675 return;
676}
677
678sub _add_check_for_extra_positional_param_types {
679 my $self = shift;
680 my $max = shift;
681 my $type = shift;
682 my $access_var = shift;
683
684 # We need to set the name argument to something that won't conflict with
685 # names someone would actually use for a parameter.
686 my $check = join q{}, $self->_type_check(
687 sprintf( '%s[$i]', $access_var ),
688 '__PCC extra parameters__',
689 $type,
690 );
691 push @{ $self->_source }, sprintf( <<'EOF', $max, $max, $check );
692if ( @_ > %d ) {
693 for my $i ( %d .. $#_ ) {
694 %s;
695 }
696}
697EOF
698
699 return;
700}
701
702sub _add_check_for_extra_positional_params {
703 my $self = shift;
704 my $max = shift;
705
706 push @{ $self->_source },
707 sprintf( <<'EOF', ($max) x 2, $self->_inlineable_name, $max );
708if ( @_ > %d ) {
709 my $extra = @_ - %d;
710 my $extra_n = $extra == 1 ? 'parameter' : 'parameters';
711 Params::ValidationCompiler::Exception::Positional::Extra->throw(
712 message => "Got $extra extra $extra_n for %s",
713 maximum => %d,
714 got => scalar @_,
715 show_trace => 1,
716 );
717}
718EOF
719
720 return;
721}
722
723sub _add_positional_default_assignment {
724 my $self = shift;
725 my $position = shift;
726 my $access = shift;
727 my $name = shift;
728 my $default = shift;
729
730 push @{ $self->_source }, "if ( \$#_ < $position ) {";
731 $self->_add_shared_default_assignment( $access, $name, $default );
732 push @{ $self->_source }, '}';
733
734 return;
735}
736
737sub _add_named_default_assignment {
738 my $self = shift;
739 my $access = shift;
740 my $name = shift;
741 my $default = shift;
742
743 my $qname = perlstring($name);
744 push @{ $self->_source }, "unless ( exists \$args{$qname} ) {";
745 $self->_add_shared_default_assignment( $access, $name, $default );
746 push @{ $self->_source }, '}';
747
748 return;
749}
750
751sub _add_shared_default_assignment {
752 my $self = shift;
753 my $access = shift;
754 my $name = shift;
755 my $default = shift;
756
757 my $qname = perlstring($name);
758
759 croak 'Default must be either a plain scalar or a subroutine reference'
760 if ref $default && reftype($default) ne 'CODE';
761
762 if ( ref $default ) {
763 push @{ $self->_source }, "$access = \$defaults{$qname}->();";
764 $self->_env->{'%defaults'}{$name} = $default;
765 }
766 else {
767 if ( defined $default ) {
768 if ( looks_like_number($default) ) {
769 push @{ $self->_source }, "$access = $default;";
770 }
771 else {
772 push @{ $self->_source },
773 "$access = " . perlstring($default) . ';';
774 }
775 }
776 else {
777 push @{ $self->_source }, "$access = undef;";
778 }
779 }
780
781 return;
782}
783
784sub _add_type_check {
785 my $self = shift;
786 my $access = shift;
787 my $name = shift;
788 my $spec = shift;
789
790 my $type = $spec->{type};
791 croak "Passed a type that is not an object for $name: $type"
792 unless blessed $type;
793
794 push @{ $self->_source }, sprintf( 'if ( exists %s ) {', $access )
795 if $spec->{optional};
796
797 push @{ $self->_source },
798 $self->_type_check( $access, $name, $spec->{type} );
799
800 push @{ $self->_source }, '}'
801 if $spec->{optional};
802
803 return;
804}
805
806sub _type_check {
807 my $self = shift;
808 my $access = shift;
809 my $name = shift;
810 my $type = shift;
811
812 # Specio
813 return $type->can('can_inline_coercion_and_check')
814 ? $self->_add_specio_check( $access, $name, $type )
815
816 # Type::Tiny
817 : $type->can('inline_assert')
818 ? $self->_add_type_tiny_check( $access, $name, $type )
819
820 # Moose
821 : $type->can('can_be_inlined')
822 ? $self->_add_moose_check( $access, $name, $type )
823 : croak 'Unknown type object ' . ref $type;
824}
825
826# From reading through the Type::Tiny source, I can't see any cases where a
827# Type::Tiny type or coercion needs to provide any environment variables to
828# compile with.
829sub _add_type_tiny_check {
830 my $self = shift;
831 my $access = shift;
832 my $name = shift;
833 my $type = shift;
834
835 my $qname = perlstring($name);
836
837 my @source;
838 if ( $type->has_coercion ) {
839 my $coercion = $type->coercion;
840 if ( $coercion->can_be_inlined ) {
841 push @source,
842 "$access = " . $coercion->inline_coercion($access) . ';';
843 }
844 else {
845 $self->_env->{'%tt_coercions'}{$name}
846 = $coercion->compiled_coercion;
847 push @source,
848 sprintf(
849 '%s = $tt_coercions{%s}->( %s );',
850 $access, $qname, $access,
851 );
852 }
853 }
854
855 if ( $type->can_be_inlined ) {
856 push @source,
857 $type->inline_assert($access);
858 }
859 else {
860 push @source,
861 sprintf(
862 '$types{%s}->assert_valid( %s );',
863 $qname, $access,
864 );
865 $self->_env->{'%types'}{$name} = $type;
866 }
867
868 return @source;
869}
870
871sub _add_specio_check {
872 my $self = shift;
873 my $access = shift;
874 my $name = shift;
875 my $type = shift;
876
877 my $qname = perlstring($name);
878
879 my @source;
880
881 if ( $type->can_inline_coercion_and_check ) {
882 if ( $type->has_coercions ) {
883 my ( $source, $env ) = $type->inline_coercion_and_check($access);
884 push @source, sprintf( '%s = %s;', $access, $source );
885 $self->_add_to_environment(
886 sprintf(
887 'The inline_coercion_and_check for %s ',
888 $type->_description
889 ),
890 $env,
891 );
892 }
893 else {
894 my ( $source, $env ) = $type->inline_assert($access);
895 push @source, $source . ';';
896 $self->_add_to_environment(
897 sprintf(
898 'The inline_assert for %s ',
899 $type->_description
900 ),
901 $env,
902 );
903 }
904 }
905 else {
906 my @coercions = $type->coercions;
907 $self->_env->{'%specio_coercions'}{$name} = \@coercions;
908 for my $i ( 0 .. $#coercions ) {
909 my $c = $coercions[$i];
910 if ( $c->can_be_inlined ) {
911 push @source,
912 sprintf(
913 '%s = %s if %s;',
914 $access,
915 $c->inline_coercion($access),
916 $c->from->inline_check($access)
917 );
918 $self->_add_to_environment(
919 sprintf(
920 'The inline_coercion for %s ',
921 $c->_description
922 ),
923
924 # This should really be public in Specio
925 $c->_inline_environment,
926 );
927 }
928 else {
929 push @source,
930 sprintf(
931 '%s = $specio_coercions{%s}[%s]->coerce(%s) if $specio_coercions{%s}[%s]->from->value_is_valid(%s);',
932 $access,
933 $qname,
934 $i,
935 $access,
936 $qname,
937 $i,
938 $access
939 );
940 }
941 }
942
943 push @source,
944 sprintf(
945 '$types{%s}->validate_or_die(%s);',
946 $qname, $access,
947 );
948
949 $self->_env->{'%types'}{$name} = $type;
950 }
951
952 return @source;
953}
954
955sub _add_moose_check {
956 my $self = shift;
957 my $access = shift;
958 my $name = shift;
959 my $type = shift;
960
961 my $qname = perlstring($name);
962
963 my @source;
964
965 if ( $type->has_coercion ) {
966 $self->_env->{'%moose_coercions'}{$name} = $type->coercion;
967 push @source,
968 sprintf(
969 '%s = $moose_coercions{%s}->coerce( %s );',
970 $access, $qname, $access,
971 );
972 }
973
974 $self->_env->{'%types'}{$name} = $type;
975
976 my $code = <<'EOF';
977if ( !%s ) {
978 my $type = $types{%s};
979 my $param = %s;
980 my $value = %s;
981 my $msg = $param . q{ failed with: } . $type->get_message($value);
982 die
983 Params::ValidationCompiler::Exception::ValidationFailedForMooseTypeConstraint
984 ->new(
985 message => $msg,
986 parameter => $param,
987 value => $value,
988 type => $type,
989 );
990}
991EOF
992
993 my $check
994 = $type->can_be_inlined
995 ? $type->_inline_check($access)
996 : sprintf( '$types{%s}->check( %s )', $qname, $access );
997
998 push @source, sprintf(
999 $code,
1000 $check,
1001 $qname,
1002 $qname,
1003 $access,
1004 );
1005
1006 if ( $type->can_be_inlined ) {
1007 $self->_add_to_environment(
1008 sprintf( 'The %s type', $type->name ),
1009 $type->inline_environment,
1010 );
1011 }
1012
1013 return @source;
1014}
1015
1016sub _add_to_environment {
1017 my $self = shift;
1018 my $what = shift;
1019 my $new_env = shift;
1020
1021 my $env = $self->_env;
1022 for my $key ( keys %{$new_env} ) {
1023 if ( exists $env->{$key} ) {
1024 croak sprintf(
1025 '%s has an inline environment variable named %s'
1026 . ' that conflicts with a variable already in the environment',
1027 $what, $key
1028 );
1029 }
1030 $self->_env->{$key} = $new_env->{$key};
1031 }
1032}
1033
10341;
1035
1036# ABSTRACT: Object that implements the check subroutine compilation
1037
1038__END__