1080 lines
27 KiB
Perl
1080 lines
27 KiB
Perl
package Params::ValidationCompiler::Compiler;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
our $VERSION = '0.30';
|
|
|
|
use Carp qw( croak );
|
|
use Eval::Closure qw( eval_closure );
|
|
use List::Util 1.29 qw( pairkeys pairvalues );
|
|
use Params::ValidationCompiler::Exceptions;
|
|
use Scalar::Util qw( blessed looks_like_number reftype );
|
|
use overload ();
|
|
use B qw( perlstring );
|
|
|
|
our @CARP_NOT = ( 'Params::ValidationCompiler', __PACKAGE__ );
|
|
|
|
BEGIN {
|
|
## no critic (Variables::RequireInitializationForLocalVars)
|
|
local $@;
|
|
my $has_sub_util = eval {
|
|
require Sub::Util;
|
|
Sub::Util->VERSION(1.40);
|
|
Sub::Util->import('set_subname');
|
|
1;
|
|
};
|
|
|
|
sub HAS_SUB_UTIL () {$has_sub_util}
|
|
|
|
unless ($has_sub_util) {
|
|
*set_subname = sub {
|
|
croak
|
|
'Cannot name a generated validation subroutine. Please install Sub::Util.';
|
|
};
|
|
}
|
|
|
|
my $has_cxsa = eval {
|
|
require Class::XSAccessor;
|
|
1;
|
|
};
|
|
|
|
sub HAS_CXSA {$has_cxsa}
|
|
}
|
|
|
|
my %known
|
|
= map { $_ => 1 }
|
|
qw( debug name name_is_optional named_to_list params return_object slurpy );
|
|
|
|
# I'd rather use Moo here but I want to make things relatively high on the
|
|
# CPAN river like DateTime use this distro, so reducing deps is important.
|
|
sub new {
|
|
my $class = shift;
|
|
my %p = @_;
|
|
|
|
unless ( exists $p{params} ) {
|
|
croak
|
|
q{You must provide a "params" parameter when creating a parameter validator};
|
|
}
|
|
|
|
if ( ref $p{params} eq 'HASH' ) {
|
|
croak q{The "params" hashref must contain at least one key-value pair}
|
|
unless %{ $p{params} };
|
|
|
|
croak
|
|
q{"named_to_list" must be used with arrayref params containing key-value pairs}
|
|
if $p{named_to_list};
|
|
|
|
$class->_validate_param_spec($_) for values %{ $p{params} };
|
|
}
|
|
elsif ( ref $p{params} eq 'ARRAY' ) {
|
|
croak q{The "params" arrayref must contain at least one element}
|
|
unless @{ $p{params} };
|
|
|
|
croak q{You can only use "return_object" with named params}
|
|
if $p{return_object};
|
|
|
|
my @specs
|
|
= $p{named_to_list}
|
|
? pairvalues @{ $p{params} }
|
|
: @{ $p{params} };
|
|
|
|
$class->_validate_param_spec($_) for @specs;
|
|
}
|
|
else {
|
|
my $type = _describe( $p{params} );
|
|
croak
|
|
qq{The "params" parameter when creating a parameter validator must be a hashref or arrayref, you passed $type};
|
|
}
|
|
|
|
if ( $p{named_to_list} && $p{slurpy} ) {
|
|
croak q{You cannot use "named_to_list" and "slurpy" together};
|
|
}
|
|
|
|
if ( exists $p{name} && ( !defined $p{name} || ref $p{name} ) ) {
|
|
my $type = _describe( $p{name} );
|
|
croak
|
|
qq{The "name" parameter when creating a parameter validator must be a scalar, you passed $type};
|
|
}
|
|
|
|
if ( $p{return_object} && $p{slurpy} ) {
|
|
croak q{You cannot use "return_object" and "slurpy" together};
|
|
}
|
|
|
|
my @unknown = sort grep { !$known{$_} } keys %p;
|
|
if (@unknown) {
|
|
croak
|
|
"You passed unknown parameters when creating a parameter validator: [@unknown]";
|
|
}
|
|
|
|
my $self = bless \%p, $class;
|
|
|
|
$self->{_source} = [];
|
|
$self->{_env} = {};
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub _describe {
|
|
my $thing = shift;
|
|
|
|
if ( !defined $thing ) {
|
|
return 'an undef';
|
|
}
|
|
elsif ( my $class = blessed $thing ) {
|
|
my $article = $class =~ /^[aeiou]/i ? 'an' : 'a';
|
|
return "$article $class object";
|
|
}
|
|
elsif ( ref $thing ) {
|
|
my $ref = lc ref $thing;
|
|
my $article = $ref =~ /^[aeiou]/i ? 'an' : 'a';
|
|
return "$article $ref" . 'ref';
|
|
}
|
|
|
|
return 'a scalar';
|
|
}
|
|
|
|
{
|
|
my %known_keys = (
|
|
default => 1,
|
|
getter => 1,
|
|
optional => 1,
|
|
predicate => 1,
|
|
type => 1,
|
|
);
|
|
|
|
sub _validate_param_spec {
|
|
shift;
|
|
my $spec = shift;
|
|
|
|
my $ref = ref $spec;
|
|
return unless $ref;
|
|
|
|
croak
|
|
"Specifications must be a scalar or hashref, but received a $ref"
|
|
unless $ref eq 'HASH';
|
|
|
|
my @unknown = sort grep { !$known_keys{$_} } keys %{$spec};
|
|
if (@unknown) {
|
|
croak "Specification contains unknown keys: [@unknown]";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub name { $_[0]->{name} }
|
|
sub _has_name { exists $_[0]->{name} }
|
|
|
|
sub _name_is_optional { $_[0]->{name_is_optional} }
|
|
|
|
# I have no idea why critic thinks _caller isn't used.
|
|
|
|
## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
|
|
sub _caller { $_[0]->{caller} }
|
|
## use critic
|
|
sub _has_caller { exists $_[0]->{caller} }
|
|
|
|
sub params { $_[0]->{params} }
|
|
|
|
sub slurpy { $_[0]->{slurpy} }
|
|
|
|
sub _source { $_[0]->{_source} }
|
|
|
|
sub _env { $_[0]->{_env} }
|
|
|
|
sub named_to_list { $_[0]->{named_to_list} }
|
|
|
|
sub return_object { $_[0]->{return_object} }
|
|
|
|
sub _inlineable_name {
|
|
return defined $_[0]->{name}
|
|
? $_[0]->{name}
|
|
: 'an un-named validation subroutine';
|
|
}
|
|
|
|
sub _any_type_has_coercion {
|
|
my $self = shift;
|
|
|
|
return $self->{_has_coercion} if exists $self->{_has_coercion};
|
|
|
|
for my $type ( $self->_types ) {
|
|
|
|
# Specio
|
|
if ( $type->can('has_coercions') && $type->has_coercions ) {
|
|
return $self->{_has_coercion} = 1;
|
|
}
|
|
|
|
# Moose and Type::Tiny
|
|
elsif ( $type->can('has_coercion') && $type->has_coercion ) {
|
|
return $self->{_has_coercion} = 1;
|
|
}
|
|
}
|
|
|
|
return $self->{_has_coercion} = 0;
|
|
}
|
|
|
|
sub _types {
|
|
my $self = shift;
|
|
|
|
my @types;
|
|
if ( ref $self->params eq 'HASH' ) {
|
|
@types = map { $_->{type} || () }
|
|
grep { ref $_ } values %{ $self->params };
|
|
}
|
|
elsif ( ref $self->params eq 'ARRAY' ) {
|
|
if ( $self->named_to_list ) {
|
|
my %p = @{ $self->params };
|
|
@types = map { $_->{type} || () } grep { ref $_ } values %p;
|
|
}
|
|
else {
|
|
@types
|
|
= map { $_->{type} || () } grep { ref $_ } @{ $self->params };
|
|
}
|
|
}
|
|
|
|
push @types, $self->slurpy if $self->slurpy && ref $self->slurpy;
|
|
|
|
return @types;
|
|
}
|
|
|
|
sub subref {
|
|
my $self = shift;
|
|
|
|
$self->_compile;
|
|
|
|
local $ENV{EVAL_CLOSURE_PRINT_SOURCE} = 1 if $self->{debug};
|
|
my $sub = eval_closure(
|
|
source => 'sub { ' . ( join "\n", @{ $self->_source } ) . ' };',
|
|
environment => $self->_env,
|
|
);
|
|
|
|
if ( $self->_has_name ) {
|
|
my $caller = $self->_has_caller ? $self->_caller : caller(1);
|
|
my $name = join '::', $caller, $self->name;
|
|
|
|
return $sub if $self->_name_is_optional && !HAS_SUB_UTIL;
|
|
set_subname( $name, $sub );
|
|
}
|
|
|
|
return $sub;
|
|
}
|
|
|
|
sub source {
|
|
my $self = shift;
|
|
|
|
$self->_compile;
|
|
return (
|
|
( join "\n", @{ $self->_source } ),
|
|
$self->_env,
|
|
);
|
|
}
|
|
|
|
sub _compile {
|
|
my $self = shift;
|
|
|
|
if ( ref $self->params eq 'HASH' ) {
|
|
$self->_compile_named_args_check;
|
|
}
|
|
elsif ( ref $self->params eq 'ARRAY' ) {
|
|
if ( $self->named_to_list ) {
|
|
$self->_compile_named_args_list_check;
|
|
}
|
|
else {
|
|
$self->_compile_positional_args_check;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub _compile_named_args_check {
|
|
my $self = shift;
|
|
|
|
$self->_compile_named_args_check_body( $self->params );
|
|
|
|
if ( $self->return_object ) {
|
|
push @{ $self->_source }, $self->_add_return_named_args_object;
|
|
}
|
|
else {
|
|
push @{ $self->_source }, 'return %args;';
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
{
|
|
my $class_id = 0;
|
|
|
|
sub _add_return_named_args_object {
|
|
my $self = shift;
|
|
|
|
my $params = $self->params;
|
|
my %getters;
|
|
my %predicates;
|
|
for my $p ( keys %{$params} ) {
|
|
$getters{
|
|
ref $params->{$p} && exists $params->{$p}{getter}
|
|
? $params->{$p}{getter}
|
|
: $p
|
|
} = $p;
|
|
$predicates{ $params->{$p}{predicate} } = $p
|
|
if ref $params->{$p} && exists $params->{$p}{predicate};
|
|
}
|
|
|
|
my $use_cxsa = HAS_CXSA && !$ENV{TEST_NAMED_ARGS_OBJECT_WITHOUT_CXSA};
|
|
my $class = sprintf(
|
|
'%s::OO::Args%d::%s',
|
|
__PACKAGE__,
|
|
$class_id++,
|
|
$use_cxsa ? 'XS' : 'PP',
|
|
);
|
|
|
|
if ($use_cxsa) {
|
|
$self->_create_cxsa_return_class(
|
|
$class,
|
|
\%getters,
|
|
\%predicates,
|
|
);
|
|
}
|
|
else {
|
|
$self->_create_pp_return_class( $class, \%getters, \%predicates );
|
|
}
|
|
|
|
return sprintf( 'bless \%%args, %s', perlstring($class) );
|
|
}
|
|
}
|
|
|
|
sub _create_cxsa_return_class {
|
|
my $self = shift;
|
|
my $class = shift;
|
|
my $getters = shift;
|
|
my $predicates = shift;
|
|
|
|
Class::XSAccessor->import(
|
|
redefine => 1,
|
|
class => $class,
|
|
getters => $getters,
|
|
exists_predicates => $predicates,
|
|
);
|
|
|
|
return;
|
|
}
|
|
|
|
sub _create_pp_return_class {
|
|
my $self = shift;
|
|
my $class = shift;
|
|
my $getters = shift;
|
|
my $predicates = shift;
|
|
|
|
my @source = sprintf( 'package %s;', $class );
|
|
for my $sub ( keys %{$getters} ) {
|
|
push @source,
|
|
sprintf(
|
|
'sub %s { return $_[0]->{%s} }', $sub,
|
|
perlstring( $getters->{$sub} )
|
|
);
|
|
}
|
|
for my $sub ( keys %{$predicates} ) {
|
|
push @source,
|
|
sprintf(
|
|
'sub %s { return exists $_[0]->{%s} }', $sub,
|
|
perlstring( $predicates->{$sub} )
|
|
);
|
|
}
|
|
push @source, q{1;};
|
|
## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
|
|
eval join q{}, @source
|
|
or die $@;
|
|
|
|
return;
|
|
}
|
|
|
|
sub _compile_named_args_list_check {
|
|
my $self = shift;
|
|
|
|
$self->_compile_named_args_check_body( { @{ $self->params } } );
|
|
|
|
my @keys = map { perlstring($_) } pairkeys @{ $self->params };
|
|
|
|
# If we don't handle the one-key case specially we end up getting a
|
|
# warning like "Scalar value @args{"bar"} better written as $args{"bar"}
|
|
# at ..."
|
|
if ( @keys == 1 ) {
|
|
push @{ $self->_source }, "return \$args{$keys[0]};";
|
|
}
|
|
else {
|
|
my $keys_str = join q{, }, @keys;
|
|
push @{ $self->_source }, "return \@args{$keys_str};";
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub _compile_named_args_check_body {
|
|
my $self = shift;
|
|
my $params = shift;
|
|
|
|
push @{ $self->_source }, $self->_set_named_args_hash;
|
|
|
|
for my $name ( sort keys %{$params} ) {
|
|
my $spec = $params->{$name};
|
|
$spec = { optional => !$spec } unless ref $spec;
|
|
|
|
my $qname = perlstring($name);
|
|
my $access = "\$args{$qname}";
|
|
|
|
# We check exists $spec->{optional} so as not to blow up on a
|
|
# restricted hash.
|
|
$self->_add_check_for_required_named_param( $access, $name )
|
|
unless ( exists $spec->{optional} && $spec->{optional} )
|
|
|| exists $spec->{default};
|
|
|
|
$self->_add_named_default_assignment(
|
|
$access,
|
|
$name,
|
|
$spec->{default}
|
|
) if exists $spec->{default};
|
|
|
|
# Same issue with restricted hashes here.
|
|
$self->_add_type_check( $access, $name, $spec )
|
|
if exists $spec->{type} && $spec->{type};
|
|
}
|
|
|
|
if ( $self->slurpy ) {
|
|
$self->_add_check_for_extra_hash_param_types( $self->slurpy, $params )
|
|
if ref $self->slurpy;
|
|
}
|
|
else {
|
|
$self->_add_check_for_extra_hash_params($params);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub _set_named_args_hash {
|
|
my $self = shift;
|
|
|
|
push @{ $self->_source },
|
|
sprintf( <<'EOF', ( $self->_inlineable_name ) x 4 );
|
|
my %%args;
|
|
if ( @_ %% 2 == 0 ) {
|
|
%%args = @_;
|
|
}
|
|
elsif ( @_ == 1 ) {
|
|
if ( ref $_[0] ) {
|
|
if ( Scalar::Util::blessed( $_[0] ) ) {
|
|
if ( overload::Overloaded( $_[0] )
|
|
&& defined overload::Method( $_[0], '%%{}' ) ) {
|
|
|
|
%%args = %%{ $_[0] };
|
|
}
|
|
else {
|
|
Params::ValidationCompiler::Exception::BadArguments->throw(
|
|
message =>
|
|
'Expected a hash or hash reference but a single object argument was passed to %s',
|
|
show_trace => 1,
|
|
);
|
|
}
|
|
}
|
|
elsif ( ref $_[0] eq 'HASH' ) {
|
|
%%args = %%{ $_[0] };
|
|
}
|
|
else {
|
|
Params::ValidationCompiler::Exception::BadArguments->throw(
|
|
message =>
|
|
'Expected a hash or hash reference but a single '
|
|
. ( ref $_[0] )
|
|
. ' reference argument was passed to %s',
|
|
show_trace => 1,
|
|
);
|
|
}
|
|
}
|
|
else {
|
|
Params::ValidationCompiler::Exception::BadArguments->throw(
|
|
message =>
|
|
'Expected a hash or hash reference but a single non-reference argument was passed to %s',
|
|
show_trace => 1,
|
|
);
|
|
}
|
|
}
|
|
else {
|
|
Params::ValidationCompiler::Exception::BadArguments->throw(
|
|
message =>
|
|
'Expected a hash or hash reference but an odd number of arguments was passed to %s',
|
|
show_trace => 1,
|
|
);
|
|
}
|
|
EOF
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_check_for_required_named_param {
|
|
my $self = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
|
|
my $qname = perlstring($name);
|
|
push @{ $self->_source },
|
|
sprintf( <<'EOF', $access, $qname, $self->_inlineable_name, $qname );
|
|
exists %s
|
|
or Params::ValidationCompiler::Exception::Named::Required->throw(
|
|
message => %s . ' is a required parameter for %s',
|
|
parameter => %s,
|
|
show_trace => 1,
|
|
);
|
|
EOF
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_check_for_extra_hash_param_types {
|
|
my $self = shift;
|
|
my $type = shift;
|
|
my $params = shift;
|
|
|
|
$self->_env->{'%known'}
|
|
= { map { $_ => 1 } keys %{$params} };
|
|
|
|
# We need to set the name argument to something that won't conflict with
|
|
# names someone would actually use for a parameter.
|
|
my $check = join q{}, $self->_type_check(
|
|
'$args{$key}',
|
|
'__PCC extra parameters__',
|
|
$type,
|
|
);
|
|
push @{ $self->_source }, sprintf( <<'EOF', $check );
|
|
for my $key ( grep { !$known{$_} } keys %%args ) {
|
|
%s;
|
|
}
|
|
EOF
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_check_for_extra_hash_params {
|
|
my $self = shift;
|
|
my $params = shift;
|
|
|
|
$self->_env->{'%known'}
|
|
= { map { $_ => 1 } keys %{$params} };
|
|
push @{ $self->_source }, sprintf( <<'EOF', $self->_inlineable_name );
|
|
my @extra = grep { !$known{$_} } keys %%args;
|
|
if (@extra) {
|
|
my $u = join ', ', sort @extra;
|
|
Params::ValidationCompiler::Exception::Named::Extra->throw(
|
|
message => "Found extra parameters passed to %s: [$u]",
|
|
parameters => \@extra,
|
|
show_trace => 1,
|
|
);
|
|
}
|
|
EOF
|
|
|
|
return;
|
|
}
|
|
|
|
sub _compile_positional_args_check {
|
|
my $self = shift;
|
|
|
|
my @specs = $self->_munge_and_check_positional_params;
|
|
|
|
my $first_optional_idx = -1;
|
|
for my $i ( 0 .. $#specs ) {
|
|
next unless $specs[$i]{optional} || exists $specs[$i]{default};
|
|
$first_optional_idx = $i;
|
|
last;
|
|
}
|
|
|
|
# If optional params start anywhere after the first parameter spec then we
|
|
# must require at least one param. If there are no optional params then
|
|
# they're all required.
|
|
$self->_add_check_for_required_positional_params(
|
|
$first_optional_idx == -1
|
|
? ( scalar @specs )
|
|
: $first_optional_idx
|
|
) if $first_optional_idx != 0;
|
|
|
|
$self->_add_check_for_extra_positional_params( scalar @specs )
|
|
unless $self->slurpy;
|
|
|
|
my $access_var = '$_';
|
|
my $return_var = '@_';
|
|
if ( $self->_any_type_has_coercion ) {
|
|
push @{ $self->_source }, 'my @copy = @_;';
|
|
$access_var = '$copy';
|
|
$return_var = '@copy';
|
|
}
|
|
|
|
for my $i ( 0 .. $#specs ) {
|
|
my $spec = $specs[$i];
|
|
|
|
my $name = "Parameter $i";
|
|
my $access = sprintf( '%s[%i]', $access_var, $i );
|
|
|
|
$self->_add_positional_default_assignment(
|
|
$i,
|
|
$access,
|
|
$name,
|
|
$spec->{default}
|
|
) if exists $spec->{default};
|
|
|
|
$self->_add_type_check( $access, $name, $spec )
|
|
if $spec->{type};
|
|
}
|
|
|
|
if ( ref $self->slurpy ) {
|
|
$self->_add_check_for_extra_positional_param_types(
|
|
scalar @specs,
|
|
$self->slurpy,
|
|
$access_var,
|
|
);
|
|
}
|
|
|
|
push @{ $self->_source }, sprintf( 'return %s;', $return_var );
|
|
|
|
return;
|
|
}
|
|
|
|
sub _munge_and_check_positional_params {
|
|
my $self = shift;
|
|
|
|
my @specs;
|
|
my $in_optional = 0;
|
|
|
|
for my $spec ( @{ $self->params } ) {
|
|
$spec = ref $spec ? $spec : { optional => !$spec };
|
|
if ( $spec->{optional} || exists $spec->{default} ) {
|
|
$in_optional = 1;
|
|
}
|
|
elsif ($in_optional) {
|
|
croak
|
|
'Parameter list contains an optional parameter followed by a required parameter.';
|
|
}
|
|
|
|
push @specs, $spec;
|
|
}
|
|
|
|
return @specs;
|
|
}
|
|
|
|
sub _add_check_for_required_positional_params {
|
|
my $self = shift;
|
|
my $min = shift;
|
|
|
|
push @{ $self->_source },
|
|
sprintf( <<'EOF', ($min) x 2, $self->_inlineable_name, $min );
|
|
if ( @_ < %d ) {
|
|
my $got = scalar @_;
|
|
my $got_n = @_ == 1 ? 'parameter' : 'parameters';
|
|
Params::ValidationCompiler::Exception::Positional::Required->throw(
|
|
message => "Got $got $got_n but expected at least %d for %s",
|
|
minimum => %d,
|
|
got => scalar @_,
|
|
show_trace => 1,
|
|
);
|
|
}
|
|
EOF
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_check_for_extra_positional_param_types {
|
|
my $self = shift;
|
|
my $max = shift;
|
|
my $type = shift;
|
|
my $access_var = shift;
|
|
|
|
# We need to set the name argument to something that won't conflict with
|
|
# names someone would actually use for a parameter.
|
|
my $check = join q{}, $self->_type_check(
|
|
sprintf( '%s[$i]', $access_var ),
|
|
'__PCC extra parameters__',
|
|
$type,
|
|
);
|
|
push @{ $self->_source }, sprintf( <<'EOF', $max, $max, $check );
|
|
if ( @_ > %d ) {
|
|
for my $i ( %d .. $#_ ) {
|
|
%s;
|
|
}
|
|
}
|
|
EOF
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_check_for_extra_positional_params {
|
|
my $self = shift;
|
|
my $max = shift;
|
|
|
|
push @{ $self->_source },
|
|
sprintf( <<'EOF', ($max) x 2, $self->_inlineable_name, $max );
|
|
if ( @_ > %d ) {
|
|
my $extra = @_ - %d;
|
|
my $extra_n = $extra == 1 ? 'parameter' : 'parameters';
|
|
Params::ValidationCompiler::Exception::Positional::Extra->throw(
|
|
message => "Got $extra extra $extra_n for %s",
|
|
maximum => %d,
|
|
got => scalar @_,
|
|
show_trace => 1,
|
|
);
|
|
}
|
|
EOF
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_positional_default_assignment {
|
|
my $self = shift;
|
|
my $position = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
my $default = shift;
|
|
|
|
push @{ $self->_source }, "if ( \$#_ < $position ) {";
|
|
$self->_add_shared_default_assignment( $access, $name, $default );
|
|
push @{ $self->_source }, '}';
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_named_default_assignment {
|
|
my $self = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
my $default = shift;
|
|
|
|
my $qname = perlstring($name);
|
|
push @{ $self->_source }, "unless ( exists \$args{$qname} ) {";
|
|
$self->_add_shared_default_assignment( $access, $name, $default );
|
|
push @{ $self->_source }, '}';
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_shared_default_assignment {
|
|
my $self = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
my $default = shift;
|
|
|
|
my $qname = perlstring($name);
|
|
|
|
croak 'Default must be either a plain scalar or a subroutine reference'
|
|
if ref $default && reftype($default) ne 'CODE';
|
|
|
|
if ( ref $default ) {
|
|
push @{ $self->_source }, "$access = \$defaults{$qname}->();";
|
|
$self->_env->{'%defaults'}{$name} = $default;
|
|
}
|
|
else {
|
|
if ( defined $default ) {
|
|
if ( looks_like_number($default) ) {
|
|
push @{ $self->_source }, "$access = $default;";
|
|
}
|
|
else {
|
|
push @{ $self->_source },
|
|
"$access = " . perlstring($default) . ';';
|
|
}
|
|
}
|
|
else {
|
|
push @{ $self->_source }, "$access = undef;";
|
|
}
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub _add_type_check {
|
|
my $self = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
my $spec = shift;
|
|
|
|
my $type = $spec->{type};
|
|
croak "Passed a type that is not an object for $name: $type"
|
|
unless blessed $type;
|
|
|
|
push @{ $self->_source }, sprintf( 'if ( exists %s ) {', $access )
|
|
if $spec->{optional};
|
|
|
|
push @{ $self->_source },
|
|
$self->_type_check( $access, $name, $spec->{type} );
|
|
|
|
push @{ $self->_source }, '}'
|
|
if $spec->{optional};
|
|
|
|
return;
|
|
}
|
|
|
|
sub _type_check {
|
|
my $self = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
my $type = shift;
|
|
|
|
# Specio
|
|
return $type->can('can_inline_coercion_and_check')
|
|
? $self->_add_specio_check( $access, $name, $type )
|
|
|
|
# Type::Tiny
|
|
: $type->can('inline_assert')
|
|
? $self->_add_type_tiny_check( $access, $name, $type )
|
|
|
|
# Moose
|
|
: $type->can('can_be_inlined')
|
|
? $self->_add_moose_check( $access, $name, $type )
|
|
: croak 'Unknown type object ' . ref $type;
|
|
}
|
|
|
|
# From reading through the Type::Tiny source, I can't see any cases where a
|
|
# Type::Tiny type or coercion needs to provide any environment variables to
|
|
# compile with.
|
|
sub _add_type_tiny_check {
|
|
my $self = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
my $type = shift;
|
|
|
|
my $qname = perlstring($name);
|
|
|
|
my @source;
|
|
if ( $type->has_coercion ) {
|
|
my $coercion = $type->coercion;
|
|
if ( $coercion->can_be_inlined ) {
|
|
push @source,
|
|
"$access = " . $coercion->inline_coercion($access) . ';';
|
|
}
|
|
else {
|
|
$self->_env->{'%tt_coercions'}{$name}
|
|
= $coercion->compiled_coercion;
|
|
push @source,
|
|
sprintf(
|
|
'%s = $tt_coercions{%s}->( %s );',
|
|
$access, $qname, $access,
|
|
);
|
|
}
|
|
}
|
|
|
|
if ( $type->can_be_inlined ) {
|
|
push @source,
|
|
$type->inline_assert($access);
|
|
}
|
|
else {
|
|
push @source,
|
|
sprintf(
|
|
'$types{%s}->assert_valid( %s );',
|
|
$qname, $access,
|
|
);
|
|
$self->_env->{'%types'}{$name} = $type;
|
|
}
|
|
|
|
return @source;
|
|
}
|
|
|
|
sub _add_specio_check {
|
|
my $self = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
my $type = shift;
|
|
|
|
my $qname = perlstring($name);
|
|
|
|
my @source;
|
|
|
|
if ( $type->can_inline_coercion_and_check ) {
|
|
if ( $type->has_coercions ) {
|
|
my ( $source, $env ) = $type->inline_coercion_and_check($access);
|
|
push @source, sprintf( '%s = %s;', $access, $source );
|
|
$self->_add_to_environment(
|
|
sprintf(
|
|
'The inline_coercion_and_check for %s ',
|
|
$type->_description
|
|
),
|
|
$env,
|
|
);
|
|
}
|
|
else {
|
|
my ( $source, $env ) = $type->inline_assert($access);
|
|
push @source, $source . ';';
|
|
$self->_add_to_environment(
|
|
sprintf(
|
|
'The inline_assert for %s ',
|
|
$type->_description
|
|
),
|
|
$env,
|
|
);
|
|
}
|
|
}
|
|
else {
|
|
my @coercions = $type->coercions;
|
|
$self->_env->{'%specio_coercions'}{$name} = \@coercions;
|
|
for my $i ( 0 .. $#coercions ) {
|
|
my $c = $coercions[$i];
|
|
if ( $c->can_be_inlined ) {
|
|
push @source,
|
|
sprintf(
|
|
'%s = %s if %s;',
|
|
$access,
|
|
$c->inline_coercion($access),
|
|
$c->from->inline_check($access)
|
|
);
|
|
$self->_add_to_environment(
|
|
sprintf(
|
|
'The inline_coercion for %s ',
|
|
$c->_description
|
|
),
|
|
|
|
# This should really be public in Specio
|
|
$c->_inline_environment,
|
|
);
|
|
}
|
|
else {
|
|
push @source,
|
|
sprintf(
|
|
'%s = $specio_coercions{%s}[%s]->coerce(%s) if $specio_coercions{%s}[%s]->from->value_is_valid(%s);',
|
|
$access,
|
|
$qname,
|
|
$i,
|
|
$access,
|
|
$qname,
|
|
$i,
|
|
$access
|
|
);
|
|
}
|
|
}
|
|
|
|
push @source,
|
|
sprintf(
|
|
'$types{%s}->validate_or_die(%s);',
|
|
$qname, $access,
|
|
);
|
|
|
|
$self->_env->{'%types'}{$name} = $type;
|
|
}
|
|
|
|
return @source;
|
|
}
|
|
|
|
sub _add_moose_check {
|
|
my $self = shift;
|
|
my $access = shift;
|
|
my $name = shift;
|
|
my $type = shift;
|
|
|
|
my $qname = perlstring($name);
|
|
|
|
my @source;
|
|
|
|
if ( $type->has_coercion ) {
|
|
$self->_env->{'%moose_coercions'}{$name} = $type->coercion;
|
|
push @source,
|
|
sprintf(
|
|
'%s = $moose_coercions{%s}->coerce( %s );',
|
|
$access, $qname, $access,
|
|
);
|
|
}
|
|
|
|
$self->_env->{'%types'}{$name} = $type;
|
|
|
|
my $code = <<'EOF';
|
|
if ( !%s ) {
|
|
my $type = $types{%s};
|
|
my $param = %s;
|
|
my $value = %s;
|
|
my $msg = $param . q{ failed with: } . $type->get_message($value);
|
|
die
|
|
Params::ValidationCompiler::Exception::ValidationFailedForMooseTypeConstraint
|
|
->new(
|
|
message => $msg,
|
|
parameter => $param,
|
|
value => $value,
|
|
type => $type,
|
|
);
|
|
}
|
|
EOF
|
|
|
|
my $check
|
|
= $type->can_be_inlined
|
|
? $type->_inline_check($access)
|
|
: sprintf( '$types{%s}->check( %s )', $qname, $access );
|
|
|
|
push @source, sprintf(
|
|
$code,
|
|
$check,
|
|
$qname,
|
|
$qname,
|
|
$access,
|
|
);
|
|
|
|
if ( $type->can_be_inlined ) {
|
|
$self->_add_to_environment(
|
|
sprintf( 'The %s type', $type->name ),
|
|
$type->inline_environment,
|
|
);
|
|
}
|
|
|
|
return @source;
|
|
}
|
|
|
|
sub _add_to_environment {
|
|
my $self = shift;
|
|
my $what = shift;
|
|
my $new_env = shift;
|
|
|
|
my $env = $self->_env;
|
|
for my $key ( keys %{$new_env} ) {
|
|
if ( exists $env->{$key} ) {
|
|
croak sprintf(
|
|
'%s has an inline environment variable named %s'
|
|
. ' that conflicts with a variable already in the environment',
|
|
$what, $key
|
|
);
|
|
}
|
|
$self->_env->{$key} = $new_env->{$key};
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
# ABSTRACT: Object that implements the check subroutine compilation
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
Params::ValidationCompiler::Compiler - Object that implements the check subroutine compilation
|
|
|
|
=head1 VERSION
|
|
|
|
version 0.30
|
|
|
|
=for Pod::Coverage .*
|
|
|
|
=head1 SUPPORT
|
|
|
|
Bugs may be submitted at L<https://github.com/houseabsolute/Params-ValidationCompiler/issues>.
|
|
|
|
I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
|
|
|
|
=head1 SOURCE
|
|
|
|
The source code repository for Params-ValidationCompiler can be found at L<https://github.com/houseabsolute/Params-ValidationCompiler>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Dave Rolsky <autarch@urth.org>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
This software is Copyright (c) 2016 - 2018 by Dave Rolsky.
|
|
|
|
This is free software, licensed under:
|
|
|
|
The Artistic License 2.0 (GPL Compatible)
|
|
|
|
The full text of the license can be found in the
|
|
F<LICENSE> file included with this distribution.
|
|
|
|
=cut
|