| File: | blib/lib/Params/Validate/Strict.pm |
| Coverage: | 86.4% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package Params::Validate::Strict; | |||||
| 2 | ||||||
| 3 | 31 31 31 | 2005049 28 388 | use strict; | |||
| 4 | 31 31 31 | 45 21 716 | use warnings; | |||
| 5 | ||||||
| 6 | # TODO: test cases - check 1e20 and -1e20 are accepted as integers | |||||
| 7 | ||||||
| 8 | # TODOs inspired by Params::Smart (see SEE ALSO): | |||||
| 9 | # | |||||
| 10 | # TODO: named_only => 1 rule â marks a parameter as keyword-only; it may not | |||||
| 11 | # be supplied by position even when the schema uses positional mode. Mirrors | |||||
| 12 | # the '+name' sigil in Params::Smart. Useful for flags that would be | |||||
| 13 | # dangerous or ambiguous if accidentally supplied by position (e.g. a boolean | |||||
| 14 | # that happens to sit at the same index as a required string on a different | |||||
| 15 | # call path). | |||||
| 16 | # | |||||
| 17 | # TODO: auto-detect positional vs named calling â allow a single schema to | |||||
| 18 | # accept both f(1, 2, 3) and f(a=>1, b=>2, c=>3) by inspecting @_ at | |||||
| 19 | # runtime and choosing the appropriate mode. Params::Smart's heuristic | |||||
| 20 | # checks whether the first element of @_ is a known parameter name; if so, | |||||
| 21 | # named mode is assumed, otherwise positional. Caveats: the heuristic can | |||||
| 22 | # misfire when a positional value happens to be a string matching a param | |||||
| 23 | # name â callers should be able to pass a hint (e.g. force_named => 1) to | |||||
| 24 | # override. The return value should include a '_named' key (as Params::Smart | |||||
| 25 | # does) so the caller can diagnose which mode was used. | |||||
| 26 | # | |||||
| 27 | # TODO: needs => ['param1', 'param2'] per-parameter dependency shorthand â | |||||
| 28 | # a convenience alternative to the schema-level 'relationships' system. | |||||
| 29 | # Params::Smart uses { name => 'foo', needs => ['bar'] } directly in the | |||||
| 30 | # parameter rule. PVS already has the full dependency system via | |||||
| 31 | # relationships => [{ type => 'dependency', ... }], but a per-parameter | |||||
| 32 | # 'needs' key would be more ergonomic for simple one-to-many dependencies | |||||
| 33 | # without requiring a separate top-level 'relationships' entry. Should be | |||||
| 34 | # desugared to an equivalent dependency relationship before validation runs. | |||||
| 35 | # | |||||
| 36 | # TODO: '_named' diagnostic key in the return hashref â when auto-detect mode | |||||
| 37 | # is active (see above), include a '_named' key in the returned args hashref | |||||
| 38 | # that is true when named-parameter calling was inferred and false when | |||||
| 39 | # positional calling was inferred. Mirrors Params::Smart's behaviour. | |||||
| 40 | # Even without full auto-detect, this key could be set unconditionally | |||||
| 41 | # (true for hashref input, false for arrayref input) to let callers | |||||
| 42 | # identify which mode was actually used. | |||||
| 43 | ||||||
| 44 | # Remaining TODOs from Params::Util gap analysis (see SEE ALSO): | |||||
| 45 | # | |||||
| 46 | # TODO: element_isa => 'ClassName' rule â validates that every element of an | |||||
| 47 | # arrayref parameter is a blessed object that passes ->isa('ClassName'). | |||||
| 48 | # Covers Params::Util's _SET (min => 1) and _SET0 (no min) patterns, which | |||||
| 49 | # are not expressible with the existing element_type => 'object' rule alone | |||||
| 50 | # (that only checks blessedness, not the inheritance chain). Implementation: | |||||
| 51 | # new 'element_isa' rule key processed inside the arrayref branch of the | |||||
| 52 | # rule-dispatch loop, iterating each element and calling ->isa. | |||||
| 53 | # | |||||
| 54 | # TODO: 'can' rule extended to non-object types â three variants needed, | |||||
| 55 | # mirroring _CLASSCAN / _INSTANCECAN / _INVOCANTCAN from Params::Util | |||||
| 56 | # 1.105_001 (unreleased) / Params::SomeUtil (listed but not yet implemented). | |||||
| 57 | # The motivation is to avoid the UNIVERSAL::can pitfall: always call | |||||
| 58 | # $value->can($method) as a method (which respects an overridden can()), | |||||
| 59 | # never UNIVERSAL::can($value, $method) as a function. PVS's existing 'can' | |||||
| 60 | # rule for type => 'object' already calls ->can correctly. The remaining | |||||
| 61 | # two variants to add are: | |||||
| 62 | # - type => 'invocant' + can: value is an object OR class-name string that | |||||
| 63 | # can do the method (_INVOCANTCAN). | |||||
| 64 | # - type => 'string' (class-name) + classcan: string class-name that can | |||||
| 65 | # do the method (_CLASSCAN); symmetric with classisa / classdoes. | |||||
| 66 | ||||||
| 67 | 31 31 31 | 56 26 641 | use Carp; | |||
| 68 | 31 31 31 | 50 29 390 | use Exporter qw(import); # Required for @EXPORT_OK | |||
| 69 | 31 31 31 | 6492 188421 1135 | use Encode qw(decode_utf8); | |||
| 70 | 31 31 31 | 76 334 825 | use List::Util 1.33 qw(all any); # Required for memberof/matches validation | |||
| 71 | 31 31 31 | 5103 111424 1407 | use Readonly::Values::Boolean; | |||
| 72 | 31 31 31 | 88 30 139675 | use Scalar::Util; | |||
| 73 | ||||||
| 74 | our @ISA = qw(Exporter); | |||||
| 75 | our @EXPORT_OK = qw(validate_strict compile_schema); | |||||
| 76 | ||||||
| 77 - 85 | =head1 NAME Params::Validate::Strict - Validates a set of parameters against a schema =head1 VERSION Version 0.41 =cut | |||||
| 86 | ||||||
| 87 | our $VERSION = '0.41'; | |||||
| 88 | ||||||
| 89 | # Recursion depth counter â localised on every entry so it unwinds automatically. | |||||
| 90 | # Protects against mutations (or bugs) that turn the pipe-normalisation guard into | |||||
| 91 | # an infinite loop through the union-type ARRAY handler. | |||||
| 92 | our $_depth = 0; | |||||
| 93 | ||||||
| 94 - 1207 | =head1 SYNOPSIS
my $schema = {
username => { type => 'string', min => 3, max => 50 },
age => { type => 'integer', min => 0, max => 150 },
};
my $input = {
username => 'john_doe',
age => '30', # Will be coerced to integer
};
my $validated_input = validate_strict(schema => $schema, input => $input);
if(defined($validated_input)) {
print "Example 1: Validation successful!\n";
print 'Username: ', $validated_input->{username}, "\n";
print 'Age: ', $validated_input->{age}, "\n"; # It's an integer now
} else {
print "Example 1: Validation failed: $@\n";
}
Upon first reading this may seem overly complex and full of scope creep in a sledgehammer to crack a nut sort of way,
however two use cases make use of the extensive logic that comes with this code
and I have a couple of other reasons for writing it.
=over 4
=item * Black Box Testing
The schema can be plumbed into L<App::Test::Generator> to automatically create a set of black-box test cases.
=item * WAF
The schema can be plumbed into a WAF,
e.g., L<VWF|https://github.com/nigelhorne/VWF/>,
to protect from random user input.
=item * Improved API Documentation
Even if you don't use this module,
the specification syntax can help with documentation.
=item * I like it
I found it fun to write this,
even if nobody else finds it useful,
though I hope you will.
=back
=head1 METHODS
=head2 validate_strict
Validates a set of parameters against a schema.
This function takes two mandatory arguments:
=over 4
=item * C<schema> || C<members>
A reference to a hash that defines the validation rules for each parameter.
The keys of the hash are the parameter names, and the values are either a string representing the parameter type or a reference to a hash containing more detailed rules.
As an alternative the schema may be supplied as an B<arrayref of parameter hashrefs>,
where every element describes one parameter and carries a mandatory
C<name> key:
$schema = [
{ name => 'username', type => 'string', min => 3, max => 50 },
{ name => 'age', type => 'integer', min => 0, max => 150 },
{ name => 'role', type => 'string', optional => 1, default => 'user' },
];
The arrayref form is normalised to the standard hashref form before any further
processing. It is particularly useful when declaration order matters (e.g.
for positional or mixed calling conventions used by some CPAN modules). The
C<name> key is consumed during normalisation and does not appear as a
validation rule.
For some sort of compatibility with L<Data::Processor>,
it is possible to wrap the schema within a hash like this:
$schema = {
description => 'Describe what this schema does',
error_msg => 'An error message',
schema => {
# ... schema goes here
}
}
=item * C<args> || C<input>
A reference to a hash containing the parameters to be validated.
The keys of the hash are the parameter names, and the values are the parameter values.
=back
It takes optional arguments:
=over 4
=item * C<description>
What the schema does,
used in error messages.
=item * C<error_msg>
Overrides the default message when something doesn't validate.
=item * C<unknown_parameter_handler>
This parameter describes what to do when a parameter is given that is not in the schema of valid parameters.
It must be one of C<die>, C<warn>, or C<ignore>.
It defaults to C<die> unless C<carp_on_warn> is given, in which case it defaults to C<warn>.
=item * C<logger>
A logging object that understands messages such as C<error> and C<warn>.
=item * C<custom_types>
A reference to a hash that defines reusable custom types.
Custom types allow you to define validation rules once and reuse them throughout your schema,
making your validation logic more maintainable and readable.
Each custom type is defined as a hash reference containing the same validation rules available for regular parameters
(C<type>, C<min>, C<max>, C<matches>, C<memberof>, C<values>, C<enum>, C<notmemberof>, C<callback>, etc.).
my $custom_types = {
email => {
type => 'string',
matches => qr/^[^@\s]+\@[^@\s]+\.[^@\s]+$/,
error_msg => 'Invalid email address format'
}, phone => {
type => 'string',
matches => qr/^\+?[1-9]\d{1,14}$/,
min => 10,
max => 15
}, percentage => {
type => 'number',
min => 0,
max => 100
}, status => {
type => 'string',
memberof => ['draft', 'published', 'archived']
}
};
my $schema = {
user_email => { type => 'email' },
contact_number => { type => 'phone', optional => 1 },
completion => { type => 'percentage' },
post_status => { type => 'status' }
};
my $validated = validate_strict(
schema => $schema,
input => $input,
custom_types => $custom_types
);
Custom types can be extended or overridden in the schema by specifying additional constraints:
my $schema = {
admin_username => {
type => 'username', # Uses custom type definition
min => 5, # Overrides custom type's min value
max => 15 # Overrides custom type's max value
}
};
Custom types work seamlessly with nested schema, optional parameters, and all other validation features.
=back
The schema can define the following rules for each parameter:
=over 4
=item * C<type>
The data type of the parameter.
Valid types are C<string>, C<integer>, C<number>, C<float>, C<boolean>, C<scalar>, C<scalarref>, C<stringref>, C<hashref>, C<arrayref>, C<object>, C<coderef>, C<regex>, C<handle>, C<arraylike>, C<hashlike>, C<codelike>, C<invocant> and C<void>.
C<scalar> accepts any plain scalar value (string, number, boolean, etc.) but rejects references (arrayrefs, hashrefs, coderefs, objects).
C<scalarref> accepts a reference to a scalar value (e.g. C<\$var>) but rejects plain scalars, arrayrefs, hashrefs, coderefs, and objects.
C<stringref> accepts a reference to a scalar that contains a plain string (e.g. C<\$str>) and rejects plain scalars, references-to-references, arrayrefs, hashrefs, coderefs, and objects.
C<void> asserts that the parameter value is C<undef> (the parameter represents a void return or absent output).
When C<void> is used the schema must contain exactly one parameter.
The C<min>/C<max> constraints apply to the B<length> (in characters) of the referenced string.
All other string rules (C<matches>, C<nomatch>, C<memberof>, etc.) operate on the dereferenced string value.
The validated return value is the dereferenced plain string.
C<regex> accepts a compiled regular expression (C<qr//> object); the value is returned unchanged.
C<handle> accepts a file handle: a glob reference with a defined C<fileno>, an C<IO::Handle> subclass instance, or any value for which C<fileno> returns a defined value.
C<arraylike> accepts an array reference or a blessed object that overloads C<@{}> array dereferencing.
C<hashlike> accepts a hash reference or a blessed object that overloads C<%{}> hash dereferencing.
C<codelike> accepts a code reference or a blessed object that overloads C<&{}> code dereferencing.
C<invocant> accepts either a blessed object instance or a plain string that is a syntactically valid Perl class name (e.g. C<'MyApp::Widget'>).
A type can be an arrayref when a parameter could have different types (e.g. a string or an object).
$schema = {
username => [
{ type => 'string', min => 3, max => 50 }, # Name
{ type => 'integer', 'min' => 1 }, # UID that isn't root
]
};
As a shorthand, C<type> itself may be an arrayref of type name strings (a I<union type>),
or a pipe-separated string, when all other constraints are shared between the alternatives:
$schema = {
data => { type => ['string', 'arrayref'] },
id => { type => 'string|integer', optional => 1 },
};
This is equivalent to the full array-of-rules form but more concise.
Whitespace around the C<|> is ignored, so C<'string | arrayref'> is the same as C<'string|arrayref'>.
Every other key in the rule hash (C<optional>, C<min>, C<max>, C<matches>, etc.)
is inherited by each candidate type and validated independently against it.
Type names are tried left-to-right; the first match wins and its coercion
(e.g. numeric types) is propagated back to the caller.
If the value fails all candidate types, validation croaks with a message
listing the union members.
=item * C<can>
The parameter must be an object that understands the method C<can>.
C<can> can be a simple scalar string of a method name,
or an arrayref of a list of method names, all of which must be supported by the object.
$schema = {
gedcom => { type => object, can => 'get_individual' }
}
=item * C<isa>
The parameter must be an object of type C<isa>.
Requires C<type =E<gt> 'object'>.
=item * C<does>
The parameter must be a blessed object that satisfies the role via C<-E<gt>DOES>.
Requires C<type =E<gt> 'object'>.
handler => { type => 'object', does => 'My::Role::Printable' }
=item * C<classisa>
The parameter must be a string holding a syntactically valid Perl class name
that passes C<-E<gt>isa('Base::Class')>.
The class must already be loaded (its C<@ISA> must be reachable).
Does not accept blessed object references; use C<isa> for those.
backend => { type => 'string', classisa => 'My::Backend::Base' }
=item * C<subclass>
Like C<classisa>, but requires a I<strict> subclass: the value must not equal
the base class name itself.
plugin => { type => 'string', subclass => 'My::Plugin::Base' }
=item * C<classdoes>
Like C<classisa>, but tests C<-E<gt>DOES> (role consumption) instead of C<-E<gt>isa>.
consumer => { type => 'string', classdoes => 'My::Role::Loggable' }
=item * C<driver>
The parameter must be a valid class name that: (1) can be loaded via C<require>,
and (2) passes C<-E<gt>isa('Base::Class')>.
The module is actually loaded as a side effect of validation.
store => { type => 'string', driver => 'Cache::Store' }
=item * C<memberof>
The parameter must be a member of the given arrayref.
status => {
type => 'string',
memberof => ['draft', 'published', 'archived']
}
priority => {
type => 'integer',
memberof => [1, 2, 3, 4, 5]
}
For string types, the comparison is case-sensitive by default. Use the C<case_sensitive>
flag to control this behavior:
# Case-sensitive (default) - must be exact match
code => {
type => 'string',
memberof => ['ABC', 'DEF', 'GHI']
# 'abc' will fail
}
# Case-insensitive - any case accepted
code => {
type => 'string',
memberof => ['ABC', 'DEF', 'GHI'],
case_sensitive => 0
# 'abc', 'Abc', 'ABC' all pass, original case preserved
}
For numeric types (C<integer>, C<number>, C<float>), the comparison uses numeric
equality (C<==> operator):
rating => {
type => 'number',
memberof => [0.5, 1.0, 1.5, 2.0]
}
Note that C<memberof> cannot be combined with C<min> or C<max> constraints as they
serve conflicting purposes - C<memberof> defines an explicit whitelist while C<min>/C<max>
define ranges.
=item * C<enum>
Same as C<memberof>.
=item * C<values>
Same as C<memberof>.
=item * C<notmemberof>
The parameter must not be a member of the given arrayref (blacklist).
This is the inverse of C<memberof>.
username => {
type => 'string',
notmemberof => ['admin', 'root', 'system', 'administrator']
}
port => {
type => 'integer',
notmemberof => [22, 23, 25, 80, 443] # Reserved ports
}
Like C<memberof>, string comparisons are case-sensitive by default but can be controlled
with the C<case_sensitive> flag:
# Case-sensitive (default)
username => {
type => 'string',
notmemberof => ['Admin', 'Root']
# 'admin' would pass, 'Admin' would fail
}
# Case-insensitive
username => {
type => 'string',
notmemberof => ['Admin', 'Root'],
case_sensitive => 0
# 'admin', 'ADMIN', 'Admin' all fail
}
The blacklist is checked after any C<transform> rules are applied, allowing you to
normalize input before checking:
username => {
type => 'string',
transform => sub { lc($_[0]) }, # Normalize to lowercase
notmemberof => ['admin', 'root', 'system']
}
C<notmemberof> can be combined with other validation rules:
username => {
type => 'string',
notmemberof => ['admin', 'root', 'system'],
min => 3,
max => 20,
matches => qr/^[a-z0-9_]+$/
}
=item * C<case_sensitive>
A boolean value indicating whether string comparisons should be case-sensitive.
This flag affects the C<memberof> and C<notmemberof> validation rules.
The default value is C<1> (case-sensitive).
When set to C<0>, string comparisons are performed case-insensitively, allowing values
with different casing to match. The original case of the input value is preserved in
the validated output.
# Case-sensitive (default)
status => {
type => 'string',
memberof => ['Draft', 'Published', 'Archived'] # Input 'draft' will fail - must match exact case
}
# Case-insensitive
status => {
type => 'string',
memberof => ['Draft', 'Published', 'Archived'],
case_sensitive => 0 # Input 'draft', 'DRAFT', or 'DrAfT' will all pass
}
country_code => {
type => 'string',
memberof => ['US', 'UK', 'CA', 'FR'],
case_sensitive => 0 # Accept 'us', 'US', 'Us', etc.
}
This flag has no effect on numeric types (C<integer>, C<number>, C<float>) as numbers
do not have case.
=item * C<min>/C<minimum>
The minimum length (for strings in characters not bytes), value (for numbers) or number of keys (for hashrefs).
=item * C<max>
The maximum length (for strings in characters not bytes), value (for numbers) or number of keys (for hashrefs).
=item * C<matches>
A regular expression that the parameter value must match.
Checks all members of arrayrefs.
=item * C<nomatch>
A regular expression that the parameter value must not match.
Checks all members of arrayrefs.
=item * C<bnf>
An arrayref of BNF grammar lines that defines the set of strings the
parameter value must belong to.
The first rule in the grammar is the start rule; the value must match it
exactly (anchored).
Each element is either a rule definition (C<< <name> ::= ... >>) or a
continuation of the previous rule. Terminals are double-quoted; non-terminals
use angle brackets. Alternatives are separated by C<|>.
$schema = {
na_tel_no => {
type => 'string',
bnf => [
'<telephone-number> ::= <country-code-opt> <area-code> <separator-opt>',
'<central-office-code> <separator-opt> <station-code>',
'<country-code-opt> ::= "" | "+1" | "1"',
'<separator-opt> ::= "" | "-" | " " | "."',
'<area-code> ::= <digit2-9> <digit0-9> <digit0-9>',
'<central-office-code> ::= <digit2-9> <digit0-9> <digit0-9>',
'<station-code> ::= <digit0-9> <digit0-9> <digit0-9> <digit0-9>',
'<digit0-9> ::= "0"|"1"|"2"|"3"|"4"|"5"|"6"|"7"|"8"|"9"',
'<digit2-9> ::= "2"|"3"|"4"|"5"|"6"|"7"|"8"|"9"',
],
},
};
Implemented by L<Params::Validate::Strict::BNF>. Recursive grammars are not
supported.
=item * C<position>
For routines and methods that take positional args,
this integer value defines which position the argument will be in.
If this is set for all arguments,
C<validate_strict> will return a reference to an array, rather than a reference to a hash.
=item * C<slurp>
Valid only in positional-argument schemas (those where every parameter has a
C<position> value). When C<slurp =E<gt> 1> is set, this parameter collects
I<all> remaining positional arguments starting from C<position> into an
arrayref, rather than taking only the single element at that index.
# sub log_message($level, @messages)
my $schema = {
level => { type => 'string', position => 0 },
messages => { type => 'arrayref', position => 1, slurp => 1 },
};
The slurp parameter is implicitly optional: if there are no arguments at or
beyond C<position>, the value is an empty arrayref. Combine with C<min =E<gt>
1> to require at least one element:
messages => { type => 'arrayref', position => 1, slurp => 1, min => 1 }
At most one slurp parameter may be defined per schema, and it must have the
highest C<position> value. The return value at that position is an arrayref.
=item * C<aliases>
An arrayref of alternative input-key names that are also accepted for this
parameter. When any alias is found in the input the parameter is stored
under its canonical schema key; if both the canonical name and an alias are
present the canonical name takes precedence. Aliases are not treated as
unknown parameters regardless of the C<unknown_parameter_handler> setting.
colour => {
type => 'string',
aliases => ['color'],
memberof => ['red', 'green', 'blue'],
}
Only named (hashref) input supports aliases; positional (arrayref) input
ignores them.
=item * C<regex>
Synonym of matches
=item * C<description>
The description of the rule
=item * C<callback>
A code reference to a subroutine that performs custom validation logic.
The subroutine should accept the parameter value, the argument list and the schema as arguments and return true if the value is valid, false otherwise.
Use this to test more complex examples:
my $schema = {
even_number => {
type => 'integer',
callback => sub { $_[0] % 2 == 0 }
};
# Specify the arguments for a routine which has a second, optional argument, which, if given, must be less than or equal to the first
my $schema = {
first => {
type => 'integer'
}, second => {
type => 'integer',
optional => 1,
callback => sub {
my($value, $args) = @_;
# The 'defined' is needed in case 'second' is evaluated before 'first'
return (defined($args->{first}) && $value <= $args->{first}) ? 1 : 0
}
}
};
=item * C<optional>
A boolean value indicating whether the parameter is optional.
If true, the parameter is not required.
If false or omitted, the parameter is required.
It can be a reference to a code snippet that will return true or false,
to determine if the parameter is optional or not.
The code will be called with two arguments: the value of the parameter and hash ref of all parameters:
my $schema = {
optional_field => {
type => 'string',
optional => sub {
my ($value, $all_params) = @_;
return $all_params->{make_optional} ? 1 : 0;
}
},
make_optional => { type => 'boolean' }
};
my $result = validate_strict(schema => $schema, input => { make_optional => 1 });
If the parameter is not optional, it can be passed an undef value, which will not flag an error.
This is by design.
So this will not say that the required parameter 's' is missing:
validate_strict(
schema => { s => { type => 'string' } },
input => { s => undef },
);
=item * C<default>
Populate missing optional parameters with the specified value.
Note that this value is not validated.
username => {
type => 'string',
optional => 1,
default => 'guest'
}
=item * C<element_type>
Extends the validation to individual elements of arrays.
tags => {
type => 'arrayref',
element_type => 'number', # Float means the same
min => 1, # this is the length of the array, not the min value for each of the numbers. For that, add a C<schema> rule
max => 5
}
=item * C<error_msg>
The custom error message to be used in the event of a validation failure.
age => {
type => 'integer',
min => 18,
error_msg => 'You must be at least 18 years old'
}
=item * C<nullable>
Like optional,
though this cannot be a coderef,
only a flag.
=item * C<schema>
You can validate nested hashrefs and arrayrefs using the C<schema> property:
my $schema = {
user => { # 'user' is a hashref
type => 'hashref',
schema => { # Specify what the elements of the hash should be
name => { type => 'string' },
age => { type => 'integer', min => 0 },
hobbies => { # 'hobbies' is an array ref that this user has
type => 'arrayref',
schema => { type => 'string' }, # Validate each hobby
min => 1 # At least one hobby
}
}
}, metadata => {
type => 'hashref',
schema => {
created => { type => 'string' },
tags => {
type => 'arrayref',
schema => {
type => 'string',
matches => qr/^[a-z]+$/ # Or you can say matches => '^[a-z]+$'
}
}
}
}
};
=item * C<validate>
A snippet of code that validates the input.
It's passed the input arguments,
and return a string containing a reason for rejection,
or undef if it's allowed.
my $schema = {
user => {
type => 'string',
validate => sub {
if($_[0]->{'password'} eq 'bar') {
return undef;
}
return 'Invalid password, try again';
}
}, password => {
type => 'string'
}
};
=item * C<transform>
A code reference to a subroutine that transforms/sanitizes the parameter value before validation.
The subroutine should accept the parameter value as an argument and return the transformed value.
The transformation is applied before any validation rules are checked, allowing you to normalize
or clean data before it is validated.
Common use cases include trimming whitespace, normalizing case, formatting phone numbers,
sanitizing user input, and converting between data formats.
# Simple string transformations
username => {
type => 'string',
transform => sub { lc(trim($_[0])) }, # lowercase and trim
matches => qr/^[a-z0-9_]+$/
}
email => {
type => 'string',
transform => sub { lc(trim($_[0])) }, # normalize email
matches => qr/^[^@\s]+\@[^@\s]+\.[^@\s]+$/
}
# Array transformations
tags => {
type => 'arrayref',
transform => sub { [map { lc($_) } @{$_[0]}] }, # lowercase all elements
element_type => 'string'
}
keywords => {
type => 'arrayref',
transform => sub {
my @arr = map { lc(trim($_)) } @{$_[0]};
my %seen;
return [grep { !$seen{$_}++ } @arr]; # remove duplicates
}
}
# Numeric transformations
quantity => {
type => 'integer',
transform => sub { int($_[0] + 0.5) }, # round to nearest integer
min => 1
}
# Sanitization
slug => {
type => 'string',
transform => sub {
my $str = lc(trim($_[0]));
$str =~ s/[^\w\s-]//g; # remove special characters
$str =~ s/\s+/-/g; # replace spaces with hyphens
return $str;
},
matches => qr/^[a-z0-9-]+$/
}
phone => {
type => 'string',
transform => sub {
my $str = $_[0];
$str =~ s/\D//g; # remove all non-digits
return $str;
},
matches => qr/^\d{10}$/
}
The C<transform> function is applied to the value before any validation checks (C<min>/C<minimum>, C<max>,
C<matches>, C<callback>, etc.), ensuring that validation rules are checked against the cleaned data.
Transformations work with all parameter types including nested structures:
user => {
type => 'hashref',
schema => {
name => {
type => 'string',
transform => sub { trim($_[0]) }
}, email => {
type => 'string',
transform => sub { lc(trim($_[0])) }
}
}
}
Transformations can also be defined in custom types for reusability:
my $custom_types = {
email => {
type => 'string',
transform => sub { lc(trim($_[0])) },
matches => qr/^[^@\s]+\@[^@\s]+\.[^@\s]+$/
}
};
Note that the transformed value is what gets returned in the validated result and is what
subsequent validation rules will check against. If a transformation might fail, ensure it
handles edge cases appropriately.
It is the responsibility of the transformer to ensure that the type of the returned value is correct,
since that is what will be validated.
Many validators also allow a code ref to be passed so that you can create your own, conditional validation rule, e.g.:
$schema = {
age => {
type => 'integer',
min => sub {
my ($value, $all_params) = @_;
return $all_params->{country} eq 'US' ? 21 : 18;
}
}
}
=item * C<validator>
A synonym of C<validate>, for compatibility with L<Data::Processor>.
=item * C<cross_validation>
A reference to a hash that defines validation rules that depend on more than one parameter.
Cross-field validations are performed after all individual parameter validations have passed,
allowing you to enforce business logic that requires checking relationships between different fields.
Each cross-validation rule is a key-value pair where the key is a descriptive name for the validation
and the value is a code reference that accepts a hash reference of all validated parameters.
The subroutine should return C<undef> if the validation passes, or an error message string if it fails.
my $schema = {
password => { type => 'string', min => 8 },
password_confirm => { type => 'string' }
};
my $cross_validation = {
passwords_match => sub {
my $params = shift;
return $params->{password} eq $params->{password_confirm}
? undef : "Passwords don't match";
}
};
my $validated = validate_strict(
schema => $schema,
input => $input,
cross_validation => $cross_validation
);
Common use cases include password confirmation, date range validation, numeric comparisons,
and conditional requirements:
# Date range validation
my $cross_validation = {
date_range_valid => sub {
my $params = shift;
return $params->{start_date} le $params->{end_date}
? undef : "Start date must be before or equal to end date";
}
};
# Price range validation
my $cross_validation = {
price_range_valid => sub {
my $params = shift;
return $params->{min_price} <= $params->{max_price}
? undef : "Minimum price must be less than or equal to maximum price";
}
};
# Conditional required field
my $cross_validation = {
address_required_for_delivery => sub {
my $params = shift;
if ($params->{shipping_method} eq 'delivery' && !$params->{delivery_address}) {
return "Delivery address is required when shipping method is 'delivery'";
}
return undef;
}
};
Multiple cross-validations can be defined in the same hash, and they are all checked in order.
If any cross-validation fails, the function will C<croak> with the error message returned by the validation:
my $cross_validation = {
passwords_match => sub {
my $params = shift;
return $params->{password} eq $params->{password_confirm}
? undef : "Passwords don't match";
},
emails_match => sub {
my $params = shift;
return $params->{email} eq $params->{email_confirm}
? undef : "Email addresses don't match";
},
age_matches_birth_year => sub {
my $params = shift;
my $current_year = (localtime)[5] + 1900;
my $calculated_age = $current_year - $params->{birth_year};
return abs($calculated_age - $params->{age}) <= 1
? undef : "Age doesn't match birth year";
}
};
Cross-validations receive the parameters after individual validation and transformation have been applied,
so you can rely on the data being in the correct format and type:
my $schema = {
email => {
type => 'string',
transform => sub { lc($_[0]) } # Lowercased before cross-validation
},
email_confirm => {
type => 'string',
transform => sub { lc($_[0]) }
}
};
my $cross_validation = {
emails_match => sub {
my $params = shift;
# Both emails are already lowercased at this point
return $params->{email} eq $params->{email_confirm}
? undef : "Email addresses don't match";
}
};
Cross-validations can access nested structures and optional fields:
my $cross_validation = {
guardian_required_for_minors => sub {
my $params = shift;
if ($params->{user}{age} < 18 && !$params->{guardian}) {
return "Guardian information required for users under 18";
}
return undef;
}
};
=item * metadata
Fields starting with <_> are generated by L<App::Test::Generator::SchemaExtractor>,
and are currently ignored.
=item * C<semantic>
A hint about the semantic meaning of the parameter value.
Supported values: C<unix_timestamp>, C<identifier>, C<class_name>.
ts => { type => 'integer', semantic => 'unix_timestamp' }
func => { type => 'string', semantic => 'identifier' }
module => { type => 'string', semantic => 'class_name' }
When C<semantic> is C<unix_timestamp>, the value must be a non-negative integer no greater than
C<2147483647> (i.e. a valid 32-bit Unix epoch timestamp).
Values outside this range cause the function to C<croak>.
When C<semantic> is C<identifier>, the value must match C</\A[A-Za-z_]\w*\z/>, a single
valid Perl bareword identifier. Package separators (C<::>) are not permitted; use
C<class_name> for those.
When C<semantic> is C<class_name>, the value must match
C</\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/>, a syntactically valid Perl class name such
as C<'Foo'> or C<'Foo::Bar::Baz'>. The class does not need to be loaded.
Unknown semantic values emit a warning but do not cause an error.
=item * schematic
TODO: gives an idea of what the field will be, e.g. C<filename>.
All cross-validations must pass for the overall validation to succeed.
=item * C<relationships>
A reference to an array that defines validation rules based on relationships between parameters.
Relationship validations are performed after all individual parameter validations have passed,
but before cross-validations.
Each relationship is a hash reference with a C<type> field and additional fields depending on the type:
=over 4
=item * B<mutually_exclusive>
Parameters that cannot be specified together.
relationships => [
{
type => 'mutually_exclusive',
params => ['file', 'content'],
description => 'Cannot specify both file and content'
}
]
=item * B<required_group>
At least one parameter from the group must be specified.
relationships => [
{
type => 'required_group',
params => ['id', 'name'],
logic => 'or',
description => 'Must specify either id or name'
}
]
=item * B<conditional_requirement>
If one parameter is specified, another becomes required.
relationships => [
{
type => 'conditional_requirement',
if => 'async',
then_required => 'callback',
description => 'When async is specified, callback is required'
}
]
=item * B<dependency>
One parameter requires another to be present.
relationships => [
{
type => 'dependency',
param => 'port',
requires => 'host',
description => 'port requires host to be specified'
}
]
=item * B<value_constraint>
Specific value requirements between parameters.
relationships => [
{
type => 'value_constraint',
if => 'ssl',
then => 'port',
operator => '==',
value => 443,
description => 'When ssl is specified, port must equal 443'
}
]
=item * B<value_conditional>
Parameter required when another has a specific value.
relationships => [
{
type => 'value_conditional',
if => 'mode',
equals => 'secure',
then_required => 'key',
description => "When mode equals 'secure', key is required"
}
]
=back
If a parameter is optional and its value is C<undef>,
validation will be skipped for that parameter.
If the validation fails, the function will C<croak> with an error message describing the validation failure.
If the validation is successful, the function will return a reference to a new hash containing the validated and (where applicable) coerced parameters. Integer and number parameters will be coerced to their respective types.
The C<description> field is optional but recommended for clearer error messages.
=back
=head2 Example Usage
my $schema = {
host => { type => 'string' },
port => { type => 'integer' },
ssl => { type => 'boolean' },
file => { type => 'string', optional => 1 },
content => { type => 'string', optional => 1 }
};
my $relationships = [
{
type => 'mutually_exclusive',
params => ['file', 'content']
}, {
type => 'required_group',
params => ['host', 'file']
},
{
type => 'dependency',
param => 'port',
requires => 'host'
},
{
type => 'value_constraint',
if => 'ssl',
then => 'port',
operator => '==',
value => 443
}
];
my $validated = validate_strict(
schema => $schema,
input => $input,
relationships => $relationships
);
=head1 MIGRATION FROM LEGACY VALIDATORS
=head2 From L<Params::Validate>
# Old style
validate(@_, {
name => { type => SCALAR },
age => { type => SCALAR, regex => qr/^\d+$/ }
});
# New style
validate_strict(
schema => { # or "members"
name => 'string',
age => { type => 'integer', min => 0 }
},
args => { @_ }
);
=head2 From L<Type::Params>
# Old style
my ($name, $age) = validate_positional \@_, Str, Int;
# New style - requires converting to named parameters first
my %args = (name => $_[0], age => $_[1]);
my $validated = validate_strict(
schema => { name => 'string', age => 'integer' },
args => \%args
);
=cut | |||||
| 1208 | ||||||
| 1209 | sub validate_strict | |||||
| 1210 | { | |||||
| 1211 | 1984 | 3692062 | local $_depth = $_depth + 1; | |||
| 1212 | 1984 | 2243 | Carp::croak('validate_strict: maximum call depth exceeded â possible infinite recursion in union-type schema') | |||
| 1213 | if $_depth > 20; | |||||
| 1214 | ||||||
| 1215 | 1983 399 | 2752 519 | my %args = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_; | |||
| 1216 | 1983 | 1545 | my $params = \%args; | |||
| 1217 | ||||||
| 1218 | 1983 | 2156 | my $schema = $params->{'schema'} || $params->{'members'}; | |||
| 1219 | 1983 | 2912 | my $args = $params->{'args'} || $params->{'input'}; | |||
| 1220 | 1983 | 1383 | my $logger = $params->{'logger'}; | |||
| 1221 | 1983 | 1299 | my $custom_types = $params->{'custom_types'}; | |||
| 1222 | 1983 | 1409 | my $unknown_parameter_handler = $params->{'unknown_parameter_handler'}; | |||
| 1223 | 1983 | 1761 | if(!defined($unknown_parameter_handler)) { | |||
| 1224 | 1954 | 1550 | if($params->{'carp_on_warn'}) { | |||
| 1225 | 2 | 1 | $unknown_parameter_handler = 'warn'; | |||
| 1226 | } else { | |||||
| 1227 | 1952 | 1396 | $unknown_parameter_handler = 'die'; | |||
| 1228 | } | |||||
| 1229 | } | |||||
| 1230 | ||||||
| 1231 | 1983 | 1631 | return $args if(!defined($schema)); # No schema, allow all arguments | |||
| 1232 | ||||||
| 1233 | # Accept arrayref schema: [{ name=>'param', type=>'...', ... }, ...] | |||||
| 1234 | # Normalise to the standard named-parameter hashref form before further processing. | |||||
| 1235 | 1979 | 1924 | if(ref($schema) eq 'ARRAY') { | |||
| 1236 | 16 | 19 | $schema = _schema_from_arrayref($schema, $logger); | |||
| 1237 | } | |||||
| 1238 | ||||||
| 1239 | # Check if schema and args are references to hashes | |||||
| 1240 | 1973 | 1710 | if(ref($schema) ne 'HASH') { | |||
| 1241 | 3 | 4 | _error($logger, 'validate_strict: schema must be a hash reference'); | |||
| 1242 | } | |||||
| 1243 | ||||||
| 1244 | # Inspired by Data::Processor | |||||
| 1245 | 1970 | 2458 | my $schema_description = $params->{'description'} || 'validate_strict'; | |||
| 1246 | 1970 | 1302 | my $error_msg = $params->{'error_msg'}; | |||
| 1247 | ||||||
| 1248 | 1970 | 1836 | if($schema->{'members'} && ($schema->{'description'} || $schema->{'error_msg'})) { | |||
| 1249 | 8 | 12 | $schema_description = $schema->{'description'}; | |||
| 1250 | 8 | 15 | $error_msg = $schema->{'error_msg'}; | |||
| 1251 | 8 | 8 | $schema = $schema->{'members'}; | |||
| 1252 | # The members value may also be in arrayref form | |||||
| 1253 | 8 | 17 | if(ref($schema) eq 'ARRAY') { | |||
| 1254 | 1 | 1 | $schema = _schema_from_arrayref($schema, $logger); | |||
| 1255 | } | |||||
| 1256 | } | |||||
| 1257 | ||||||
| 1258 | 1970 | 3148 | if(exists($params->{'args'}) && (!defined($args))) { | |||
| 1259 | 2 | 2 | $args = {}; | |||
| 1260 | } elsif((ref($args) ne 'HASH') && (ref($args) ne 'ARRAY')) { | |||||
| 1261 | 2 | 5 | _error($logger, $error_msg || "$schema_description: args must be a hash or array reference"); | |||
| 1262 | } | |||||
| 1263 | ||||||
| 1264 | 1968 | 1742 | if(ref($args) eq 'HASH') { | |||
| 1265 | # Named args: build alias reverse-map first so aliased keys are not | |||||
| 1266 | # treated as unknown parameters. | |||||
| 1267 | 1936 | 1209 | my %_alias_to_canonical; | |||
| 1268 | 1936 1936 | 1150 2079 | foreach my $canonical (keys %{$schema}) { | |||
| 1269 | 2484 | 1701 | my $r = $schema->{$canonical}; | |||
| 1270 | 2484 | 3697 | if(ref($r) eq 'HASH' && ref($r->{'aliases'}) eq 'ARRAY') { | |||
| 1271 | 5 5 | 5 7 | $_alias_to_canonical{$_} = $canonical for @{$r->{'aliases'}}; | |||
| 1272 | } | |||||
| 1273 | } | |||||
| 1274 | ||||||
| 1275 | 1936 1936 | 1467 1662 | foreach my $key (keys %{$args}) { | |||
| 1276 | 2254 | 2283 | if(!exists($schema->{$key}) && !exists($_alias_to_canonical{$key})) { | |||
| 1277 | 33 | 69 | if($unknown_parameter_handler eq 'die') { | |||
| 1278 | 9 | 12 | _error($logger, "$schema_description: Unknown parameter '$key'"); | |||
| 1279 | } elsif($unknown_parameter_handler eq 'warn') { | |||||
| 1280 | 14 | 29 | _warn($logger, "$schema_description: Unknown parameter '$key'"); | |||
| 1281 | 14 | 1108 | next; | |||
| 1282 | } elsif($unknown_parameter_handler eq 'ignore') { | |||||
| 1283 | 6 | 12 | if($logger) { | |||
| 1284 | 1 | 3 | $logger->debug(__PACKAGE__ . ": $schema_description: Unknown parameter '$key'"); | |||
| 1285 | } | |||||
| 1286 | 6 | 12 | next; | |||
| 1287 | } else { | |||||
| 1288 | 4 | 7 | _error($logger, "$schema_description: '$unknown_parameter_handler' unknown_parameter_handler must be one of die, warn, ignore"); | |||
| 1289 | } | |||||
| 1290 | } | |||||
| 1291 | } | |||||
| 1292 | } | |||||
| 1293 | ||||||
| 1294 | # Find out if this routine takes positional arguments | |||||
| 1295 | 1955 | 1415 | my $are_positional_args = -1; | |||
| 1296 | 1955 1955 | 1187 1526 | foreach my $key (keys %{$schema}) { | |||
| 1297 | 1969 | 1653 | if(defined(my $rules = $schema->{$key})) { | |||
| 1298 | 1967 | 1558 | if(ref($rules) eq 'HASH') { | |||
| 1299 | 1927 | 1839 | if($rules->{'slurp'} && !defined($rules->{'position'})) { | |||
| 1300 | 0 | 0 | _error($logger, "::validate_strict: slurp parameter '$key' requires a 'position'"); | |||
| 1301 | } | |||||
| 1302 | 1927 | 1630 | if(!defined($rules->{'position'})) { | |||
| 1303 | 1878 | 1528 | if($are_positional_args == 1) { | |||
| 1304 | 0 | 0 | _error($logger, "::validate_strict: $key is missing position value"); | |||
| 1305 | } | |||||
| 1306 | 1878 | 1159 | $are_positional_args = 0; | |||
| 1307 | 1878 | 1593 | last; | |||
| 1308 | } | |||||
| 1309 | 49 | 50 | $are_positional_args = 1; | |||
| 1310 | } else { | |||||
| 1311 | 40 | 26 | $are_positional_args = 0; | |||
| 1312 | 40 | 38 | last; | |||
| 1313 | } | |||||
| 1314 | } else { | |||||
| 1315 | 2 | 2 | $are_positional_args = 0; | |||
| 1316 | 2 | 2 | last; | |||
| 1317 | } | |||||
| 1318 | } | |||||
| 1319 | ||||||
| 1320 | 1955 | 1430 | my %validated_args; | |||
| 1321 | my %invalid_args; | |||||
| 1322 | 1955 1955 | 1177 1489 | foreach my $key (keys %{$schema}) { | |||
| 1323 | 2446 | 1632 | my $rules = $schema->{$key}; | |||
| 1324 | ||||||
| 1325 | # For named-arg schemas: resolve which input key provides this parameter. | |||||
| 1326 | # If the canonical name is absent, try each alias in order. | |||||
| 1327 | 2446 | 1536 | my $lookup_key = $key; | |||
| 1328 | 2446 | 4342 | if($are_positional_args != 1 && ref($rules) eq 'HASH' | |||
| 1329 | && ref($rules->{'aliases'}) eq 'ARRAY' | |||||
| 1330 | && !exists($args->{$key})) { | |||||
| 1331 | 3 3 | 3 3 | for my $alias (@{$rules->{'aliases'}}) { | |||
| 1332 | 3 | 4 | if(exists($args->{$alias})) { | |||
| 1333 | 2 | 3 | $lookup_key = $alias; | |||
| 1334 | 2 | 1 | last; | |||
| 1335 | } | |||||
| 1336 | } | |||||
| 1337 | } | |||||
| 1338 | ||||||
| 1339 | 2446 | 1490 | my $value; | |||
| 1340 | 2446 | 1803 | if($are_positional_args == 1) { | |||
| 1341 | 48 | 54 | if(ref($args) ne 'ARRAY') { | |||
| 1342 | 0 | 0 | _error($logger, "::validate_strict: position $rules->{position} given for '$key', but args isn't an array"); | |||
| 1343 | } | |||||
| 1344 | 48 | 85 | if(ref($rules) eq 'HASH' && $rules->{'slurp'}) { | |||
| 1345 | 4 | 5 | my $pos = $rules->{'position'}; | |||
| 1346 | 4 4 | 4 5 | $value = [@{$args}[$pos .. $#$args]]; | |||
| 1347 | } else { | |||||
| 1348 | 44 | 63 | $value = $args->[$rules->{'position'}]; | |||
| 1349 | } | |||||
| 1350 | } else { | |||||
| 1351 | 2398 | 1704 | $value = $args->{$lookup_key}; | |||
| 1352 | } | |||||
| 1353 | ||||||
| 1354 | 2445 | 1888 | if(!defined($rules)) { # Allow anything | |||
| 1355 | 2 | 2 | $validated_args{$key} = $value; | |||
| 1356 | 2 | 2 | next; | |||
| 1357 | } | |||||
| 1358 | ||||||
| 1359 | # If rules are a simple type string | |||||
| 1360 | 2443 | 2040 | if(ref($rules) eq '') { | |||
| 1361 | 31 | 30 | $rules = { type => $rules }; | |||
| 1362 | } | |||||
| 1363 | ||||||
| 1364 | 2443 | 1533 | my $is_optional = 0; | |||
| 1365 | ||||||
| 1366 | 2443 | 1456 | my $rule_description = $schema_description; # Can be overridden in each element | |||
| 1367 | 2443 | 1694 | my $param_label = "'$key'"; | |||
| 1368 | ||||||
| 1369 | 2443 | 1972 | if(ref($rules) eq 'HASH') { | |||
| 1370 | 2423 | 1991 | if(exists($rules->{'description'})) { | |||
| 1371 | 9 | 9 | $param_label = "'$key' ($rules->{description})"; | |||
| 1372 | } | |||||
| 1373 | # For stringref: validate and dereference before transform so that | |||||
| 1374 | # transform (and all subsequent rule handlers) see the plain string. | |||||
| 1375 | # Preserve the original ref so optional => CODE receives what the caller passed. | |||||
| 1376 | 2423 | 1531 | my $pre_deref_value = $value; | |||
| 1377 | 2423 | 4821 | my $is_stringref_type = defined($value) && defined($rules->{'type'}) && !ref($rules->{'type'}) && lc($rules->{'type'}) eq 'stringref'; | |||
| 1378 | 2423 | 1865 | if($is_stringref_type) { | |||
| 1379 | 116 | 116 | if(ref($value) ne 'SCALAR') { | |||
| 1380 | 42 | 46 | my $got = ref($value) ? 'a ' . ref($value) . ' reference' : 'a plain scalar'; | |||
| 1381 | 42 | 59 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a string reference, not $got"); | |||
| 1382 | } | |||||
| 1383 | 74 74 | 46 61 | $value = ${$value}; | |||
| 1384 | } | |||||
| 1385 | 2381 | 2127 | if($rules->{'transform'} && defined($value)) { | |||
| 1386 | 90 | 99 | if(ref($rules->{'transform'}) eq 'CODE') { | |||
| 1387 | 87 87 | 65 100 | $value = &{$rules->{'transform'}}($value); | |||
| 1388 | } else { | |||||
| 1389 | 3 | 5 | _error($logger, "$rule_description: transforms must be a code ref"); | |||
| 1390 | } | |||||
| 1391 | } | |||||
| 1392 | 2378 | 5201 | if(exists($rules->{optional})) { | |||
| 1393 | 370 | 348 | if(ref($rules->{'optional'}) eq 'CODE') { | |||
| 1394 | # For stringref the coderef receives the original SCALAR ref (what | |||||
| 1395 | # the caller supplied), not the internally-dereferenced plain string. | |||||
| 1396 | # For all other types the post-transform value is passed, as before. | |||||
| 1397 | 19 | 27 | my $opt_arg = $is_stringref_type ? $pre_deref_value : $value; | |||
| 1398 | 19 19 | 15 25 | $is_optional = &{$rules->{optional}}($opt_arg, $args); | |||
| 1399 | } else { | |||||
| 1400 | 351 | 290 | $is_optional = $rules->{'optional'}; | |||
| 1401 | } | |||||
| 1402 | } elsif($rules->{nullable}) { | |||||
| 1403 | 7 | 10 | $is_optional = $rules->{'nullable'}; | |||
| 1404 | } elsif(defined($rules->{'type'}) && !ref($rules->{'type'}) && lc($rules->{'type'}) eq 'void') { | |||||
| 1405 | 17 | 30 | $is_optional = 1; | |||
| 1406 | } elsif($rules->{'slurp'}) { | |||||
| 1407 | 4 | 3 | $is_optional = 1; | |||
| 1408 | } | |||||
| 1409 | } | |||||
| 1410 | ||||||
| 1411 | # Handle optional parameters | |||||
| 1412 | 2398 | 4353 | if((ref($rules) eq 'HASH') && $is_optional) { | |||
| 1413 | 384 | 242 | my $missing; | |||
| 1414 | 384 | 299 | if($are_positional_args == 1) { | |||
| 1415 | # A slurp parameter is never missing: at worst it yields an empty arrayref. | |||||
| 1416 | 10 | 12 | $missing = $rules->{'slurp'} ? 0 : !defined($args->[$rules->{position}]); | |||
| 1417 | } else { | |||||
| 1418 | 374 | 293 | $missing = !exists($args->{$lookup_key}); | |||
| 1419 | } | |||||
| 1420 | 384 | 390 | if($missing) { | |||
| 1421 | 186 | 169 | if($are_positional_args == 1) { | |||
| 1422 | 5 5 | 7 7 | if(scalar(@{$args}) < $rules->{'position'}) { | |||
| 1423 | # arg array is too short, so it must be missing | |||||
| 1424 | 1 | 3 | _error($logger, "$rule_description: Required parameter $param_label is missing"); | |||
| 1425 | 0 | 0 | next; | |||
| 1426 | } | |||||
| 1427 | } | |||||
| 1428 | 185 | 184 | if(exists($rules->{'default'})) { | |||
| 1429 | # Populate missing optional parameters with the specified output values | |||||
| 1430 | 38 | 97 | $validated_args{$key} //= $rules->{'default'}; | |||
| 1431 | 38 | 40 | next; # default wins; do not fall through to the schema branch | |||
| 1432 | } | |||||
| 1433 | ||||||
| 1434 | 147 | 135 | if($rules->{'schema'}) { | |||
| 1435 | 6 | 9 | $value = _apply_nested_defaults({}, $rules->{'schema'}); | |||
| 1436 | 6 6 | 5 11 | next unless scalar(%{$value}); | |||
| 1437 | # The nested schema has a default value | |||||
| 1438 | } else { | |||||
| 1439 | 141 | 140 | next; # optional and missing | |||
| 1440 | } | |||||
| 1441 | } | |||||
| 1442 | } elsif((ref($args) eq 'HASH') && !exists($args->{$lookup_key})) { | |||||
| 1443 | # The parameter is required | |||||
| 1444 | # Use exists rather than defined, so that an undefined value can be passed, but the key is there | |||||
| 1445 | 22 | 38 | _error($logger, "$rule_description: Required parameter $param_label is missing"); | |||
| 1446 | } | |||||
| 1447 | ||||||
| 1448 | # Normalise union type shorthand: { type => ['string', 'integer'], ... } | |||||
| 1449 | # or pipe-separated string { type => 'string|integer' } | |||||
| 1450 | # into the array-of-rules form that the ARRAY handler below already supports. | |||||
| 1451 | # Each candidate type inherits all other constraints from the parent rule | |||||
| 1452 | # (min, max, matches, optional, etc.) so they are each fully validated. | |||||
| 1453 | # Must run after optional/transform handling above but before rule dispatch below. | |||||
| 1454 | 2192 | 4858 | if(ref($rules) eq 'HASH' && !ref($rules->{'type'}) && defined($rules->{'type'}) && $rules->{'type'} =~ /\|/) { | |||
| 1455 | 6 | 24 | $rules = { %$rules, type => [ split /\s*\|\s*/, $rules->{'type'} ] }; | |||
| 1456 | } | |||||
| 1457 | 2192 | 2779 | if(ref($rules) eq 'HASH' && ref($rules->{'type'}) eq 'ARRAY') { | |||
| 1458 | 66 66 | 58 77 | my %base = %{$rules}; | |||
| 1459 | 66 66 | 54 90 | my @type_list = @{delete $base{'type'}}; | |||
| 1460 | 66 | 70 | if(!@type_list) { | |||
| 1461 | 2 | 3 | _error($logger, "$rule_description: Parameter $param_label: union type list must not be empty"); | |||
| 1462 | } | |||||
| 1463 | # Expand into one full rule hash per candidate type | |||||
| 1464 | 64 127 | 49 170 | $rules = [ map { { %base, type => $_ } } @type_list ]; | |||
| 1465 | } | |||||
| 1466 | ||||||
| 1467 | # Validate based on rules | |||||
| 1468 | 2190 | 1836 | if(ref($rules) eq 'HASH') { | |||
| 1469 | 2106 | 3302 | if(defined(my $min = $rules->{'min'} // $rules->{'minimum'}) && defined(my $max = $rules->{'max'})) { | |||
| 1470 | 151 | 156 | if($min > $max) { | |||
| 1471 | 7 | 14 | _error($logger, "validate_strict($key): min must be <= max ($min > $max)"); | |||
| 1472 | } | |||||
| 1473 | } | |||||
| 1474 | ||||||
| 1475 | # memberof and its synonym enum cannot be combined with min or max | |||||
| 1476 | 2099 | 3399 | if($rules->{'memberof'} || $rules->{'enum'} || $rules->{'values'}) { | |||
| 1477 | 131 | 233 | if(defined(my $min = $rules->{'min'} // $rules->{'minimum'})) { | |||
| 1478 | 8 | 17 | _error($logger, "validate_strict($key): min ($min) makes no sense with memberof/enum/values"); | |||
| 1479 | } | |||||
| 1480 | 123 | 147 | if(defined(my $max = $rules->{'max'})) { | |||
| 1481 | 5 | 8 | _error($logger, "validate_strict($key): max ($max) makes no sense with memberof/enum/values"); | |||
| 1482 | } | |||||
| 1483 | } | |||||
| 1484 | ||||||
| 1485 | 2086 3826 | 2079 3537 | foreach my $rule_name ('type', grep { $_ ne 'type' } keys %$rules) { | |||
| 1486 | 3682 | 2701 | my $rule_value = $rules->{$rule_name}; | |||
| 1487 | ||||||
| 1488 | 3682 | 3488 | if((ref($rule_value) eq 'CODE') | |||
| 1489 | && ($rule_name ne 'validate') | |||||
| 1490 | && ($rule_name ne 'callback') | |||||
| 1491 | && ($rule_name ne 'validator') | |||||
| 1492 | && ($rule_name ne 'transform') # already applied before this loop | |||||
| 1493 | && ($rule_name ne 'optional')) { # already applied before this loop | |||||
| 1494 | 16 16 | 10 17 | $rule_value = &{$rule_value}($value, $args); | |||
| 1495 | } | |||||
| 1496 | ||||||
| 1497 | # Better OOP, the routine has been given an object rather than a scalar | |||||
| 1498 | 3682 | 3830 | if(Scalar::Util::blessed($rule_value) && $rule_value->can('as_string')) { | |||
| 1499 | 2 | 2 | $rule_value = $rule_value->as_string(); | |||
| 1500 | } | |||||
| 1501 | ||||||
| 1502 | 3682 | 7513 | if($rule_name eq 'type') { | |||
| 1503 | 2086 | 1455 | my $type = lc($rule_value); | |||
| 1504 | ||||||
| 1505 | 2086 | 5472 | if(($type eq 'string') || ($type eq 'str')) { | |||
| 1506 | 872 | 676 | if(ref($value)) { | |||
| 1507 | 31 | 46 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a string"); | |||
| 1508 | } | |||||
| 1509 | 841 | 855 | unless((ref($value) eq '') || (defined($value) && length($value))) { # Allow undef for optional strings | |||
| 1510 | 0 | 0 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a string"); | |||
| 1511 | } | |||||
| 1512 | } elsif(($type eq 'integer') || ($type eq 'int')) { | |||||
| 1513 | 325 | 275 | if(!defined($value)) { | |||
| 1514 | 3 | 4 | next; # Skip if number is undefined | |||
| 1515 | } | |||||
| 1516 | 322 | 847 | if(!Scalar::Util::looks_like_number($value) || ($value - $value) != 0 || $value != int($value)) { | |||
| 1517 | 33 | 63 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) must be an integer"); | |||
| 1518 | } | |||||
| 1519 | 289 | 261 | $value = int($value); # Coerce to integer | |||
| 1520 | } elsif(($type eq 'number') || ($type eq 'float') || ($type eq 'num') || ($type eq 'double')) { | |||||
| 1521 | 95 | 103 | if(!defined($value)) { | |||
| 1522 | 2 | 2 | next; # Skip if number is undefined | |||
| 1523 | } | |||||
| 1524 | 93 | 138 | if(!Scalar::Util::looks_like_number($value)) { | |||
| 1525 | 5 | 11 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a number"); | |||
| 1526 | } | |||||
| 1527 | # $value = eval $value; # Coerce to number (be careful with eval) | |||||
| 1528 | 88 | 136 | $value = 0 + $value; # Numeric coercion | |||
| 1529 | } elsif($type eq 'arrayref') { | |||||
| 1530 | 208 | 200 | if(!defined($value)) { | |||
| 1531 | 3 | 18 | next; # Skip if arrayref is undefined | |||
| 1532 | } | |||||
| 1533 | 205 | 250 | if(ref($value) ne 'ARRAY') { | |||
| 1534 | 22 | 44 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be an arrayref, not " . ref($value)); | |||
| 1535 | } | |||||
| 1536 | } elsif($type eq 'hashref') { | |||||
| 1537 | 88 | 76 | if(!defined($value)) { | |||
| 1538 | 3 | 4 | next; # Skip if hashref is undefined | |||
| 1539 | } | |||||
| 1540 | 85 | 131 | if(ref($value) ne 'HASH') { | |||
| 1541 | 5 | 10 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be an hashref"); | |||
| 1542 | } | |||||
| 1543 | } elsif($type eq 'scalar') { | |||||
| 1544 | 118 | 108 | if(!defined($value)) { | |||
| 1545 | 3 | 3 | next; # Skip if undefined | |||
| 1546 | } | |||||
| 1547 | 115 | 121 | if(ref($value)) { | |||
| 1548 | 47 | 73 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a scalar, not a " . ref($value) . ' reference'); | |||
| 1549 | } | |||||
| 1550 | } elsif($type eq 'scalarref') { | |||||
| 1551 | 71 | 66 | if(!defined($value)) { | |||
| 1552 | 2 | 3 | next; # Skip if undefined | |||
| 1553 | } | |||||
| 1554 | 69 | 83 | if(ref($value) ne 'SCALAR') { | |||
| 1555 | 41 | 48 | my $got = ref($value) ? 'a ' . ref($value) . ' reference' : 'a plain scalar'; | |||
| 1556 | 41 | 50 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a scalar reference, not $got"); | |||
| 1557 | } | |||||
| 1558 | } elsif($type eq 'stringref') { | |||||
| 1559 | 76 | 98 | if(!defined($value)) { | |||
| 1560 | 2 | 2 | next; # Skip if undefined | |||
| 1561 | } | |||||
| 1562 | # The early-deref block validated the SCALAR ref and set $value to the | |||||
| 1563 | # plain string. If transform subsequently returned a reference, reject it. | |||||
| 1564 | 74 | 85 | if(ref($value)) { | |||
| 1565 | 2 | 5 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label stringref transform must return a plain string, not a " . ref($value) . ' reference'); | |||
| 1566 | } | |||||
| 1567 | } elsif($type eq 'void') { | |||||
| 1568 | 16 16 | 12 18 | if(scalar(keys %{$schema}) != 1) { | |||
| 1569 | 2 | 4 | _error($logger, "$rule_description: type 'void' requires exactly one parameter in the schema"); | |||
| 1570 | } | |||||
| 1571 | 14 | 17 | if(defined($value)) { | |||
| 1572 | 11 | 13 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be undef (void type accepts no value)"); | |||
| 1573 | } | |||||
| 1574 | } elsif(($type eq 'boolean') || ($type eq 'bool')) { | |||||
| 1575 | 67 | 64 | if(!defined($value)) { | |||
| 1576 | 2 | 3 | next; # Skip if bool is undefined | |||
| 1577 | } | |||||
| 1578 | 65 | 158 | if(defined(my $b = $Readonly::Values::Boolean::booleans{$value})) { | |||
| 1579 | 58 | 286 | $value = $b; | |||
| 1580 | } else { | |||||
| 1581 | 7 | 33 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) must be a boolean"); | |||
| 1582 | } | |||||
| 1583 | } elsif($type eq 'coderef') { | |||||
| 1584 | 10 | 14 | if(!defined($value)) { | |||
| 1585 | 1 | 1 | next; # Skip if code is undefined | |||
| 1586 | } | |||||
| 1587 | 9 | 19 | if(ref($value) ne 'CODE') { | |||
| 1588 | 3 | 11 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a coderef, not a ref to " . ref($value)); | |||
| 1589 | } | |||||
| 1590 | } elsif($type eq 'regex') { | |||||
| 1591 | 3 | 4 | if(!defined($value)) { | |||
| 1592 | 1 | 1 | next; | |||
| 1593 | } | |||||
| 1594 | 2 | 4 | if(ref($value) ne 'Regexp') { | |||
| 1595 | 1 | 4 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a compiled regex (qr//)" . | |||
| 1596 | (ref($value) ? ", not a " . ref($value) . " reference" : ", not a plain scalar")); | |||||
| 1597 | } | |||||
| 1598 | } elsif($type eq 'handle') { | |||||
| 1599 | 3 | 3 | if(!defined($value)) { | |||
| 1600 | 1 | 2 | next; | |||
| 1601 | } | |||||
| 1602 | 2 | 17 | my $is_handle = 0; | |||
| 1603 | 2 | 13 | if(ref($value) eq 'GLOB' && defined(fileno($value))) { | |||
| 1604 | 1 | 1 | $is_handle = 1; | |||
| 1605 | } elsif(Scalar::Util::blessed($value) && $value->isa('IO::Handle')) { | |||||
| 1606 | 0 | 0 | $is_handle = 1; | |||
| 1607 | } else { | |||||
| 1608 | 1 1 | 1 4 | $is_handle = defined(eval { fileno($value) }); | |||
| 1609 | } | |||||
| 1610 | 2 | 3 | unless($is_handle) { | |||
| 1611 | 1 | 3 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a file handle"); | |||
| 1612 | } | |||||
| 1613 | } elsif($type eq 'arraylike') { | |||||
| 1614 | 2 | 3 | if(!defined($value)) { | |||
| 1615 | 0 | 0 | next; | |||
| 1616 | } | |||||
| 1617 | 2 | 5 | unless(ref($value) eq 'ARRAY' || (Scalar::Util::blessed($value) && overload::Method($value, '@{}'))) { | |||
| 1618 | 1 | 12 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be an array reference or array-like object"); | |||
| 1619 | } | |||||
| 1620 | } elsif($type eq 'hashlike') { | |||||
| 1621 | 2 | 3 | if(!defined($value)) { | |||
| 1622 | 0 | 0 | next; | |||
| 1623 | } | |||||
| 1624 | 2 | 6 | unless(ref($value) eq 'HASH' || (Scalar::Util::blessed($value) && overload::Method($value, '%{}'))) { | |||
| 1625 | 1 | 2 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a hash reference or hash-like object"); | |||
| 1626 | } | |||||
| 1627 | } elsif($type eq 'codelike') { | |||||
| 1628 | 2 | 1 | if(!defined($value)) { | |||
| 1629 | 0 | 0 | next; | |||
| 1630 | } | |||||
| 1631 | 2 | 7 | unless(ref($value) eq 'CODE' || (Scalar::Util::blessed($value) && overload::Method($value, '&{}'))) { | |||
| 1632 | 1 | 3 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a code reference or code-like object"); | |||
| 1633 | } | |||||
| 1634 | } elsif($type eq 'invocant') { | |||||
| 1635 | 3 | 4 | if(!defined($value)) { | |||
| 1636 | 0 | 0 | next; | |||
| 1637 | } | |||||
| 1638 | 3 | 11 | unless(Scalar::Util::blessed($value) || (!ref($value) && $value =~ /\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/)) { | |||
| 1639 | 1 | 2 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be a blessed object or a class name"); | |||
| 1640 | } | |||||
| 1641 | } elsif($type eq 'object') { | |||||
| 1642 | 62 | 81 | if(!defined($value)) { | |||
| 1643 | 1 | 1 | next; # Skip if object is undefined | |||
| 1644 | } | |||||
| 1645 | 61 | 122 | if(!Scalar::Util::blessed($value)) { | |||
| 1646 | 4 | 9 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must be an object"); | |||
| 1647 | } | |||||
| 1648 | } elsif(my $custom_type = $custom_types->{$type}) { | |||||
| 1649 | 60 | 58 | if($custom_type->{'transform'}) { | |||
| 1650 | # The custom type has a transform embedded within it | |||||
| 1651 | 9 | 10 | if(ref($custom_type->{'transform'}) eq 'CODE') { | |||
| 1652 | 8 8 | 6 11 | $value = &{$custom_type->{'transform'}}($value); | |||
| 1653 | } else { | |||||
| 1654 | 1 | 2 | _error($logger, "$rule_description: transforms must be a code ref"); | |||
| 1655 | } | |||||
| 1656 | } | |||||
| 1657 | 59 | 344 | validate_strict({ input => { $key => $value }, schema => { $key => $custom_type }, custom_types => $custom_types }); | |||
| 1658 | } else { | |||||
| 1659 | 3 | 11 | _error($logger, "$rule_description: Unknown type '$type'"); | |||
| 1660 | } | |||||
| 1661 | } elsif(($rule_name eq 'min') || ($rule_name eq 'minimum')) { | |||||
| 1662 | 430 | 454 | if(!defined($rules->{'type'})) { | |||
| 1663 | 0 | 0 | _error($logger, "$rule_description: Don't know type of $param_label to determine its minimum value $rule_value"); | |||
| 1664 | } | |||||
| 1665 | 430 | 376 | my $type = lc($rules->{'type'}); | |||
| 1666 | 430 | 780 | if(exists($custom_types->{$type}->{'min'}) || exists($custom_types->{$type}->{minimum})) { | |||
| 1667 | 3 | 6 | $rule_value = $custom_types->{$type}->{'min'} // $custom_types->{$type}->{minimum}; | |||
| 1668 | 3 | 3 | $type = $custom_types->{$type}->{'type'}; | |||
| 1669 | } | |||||
| 1670 | 430 | 1038 | if(($type eq 'string') || ($type eq 'str') || ($type eq 'stringref')) { | |||
| 1671 | 154 | 151 | if($rule_value < 0) { | |||
| 1672 | 3 | 6 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label has meaningless minimum value that is less than zero"); | |||
| 1673 | } | |||||
| 1674 | 151 | 154 | if(!defined($value)) { | |||
| 1675 | 3 | 6 | if($rule_value > 0 && !$is_optional) { | |||
| 1676 | 1 | 5 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label is undefined, but must be at least $rule_value character" . ($rule_value == 1 ? '' : 's')); | |||
| 1677 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1678 | } | |||||
| 1679 | 2 | 1 | next; | |||
| 1680 | } | |||||
| 1681 | 148 | 149 | if(defined(my $len = _number_of_characters($value))) { | |||
| 1682 | 148 | 200 | if($len < $rule_value) { | |||
| 1683 | 40 | 85 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label too short, ($len characters), must be at least $rule_value characters"); | |||
| 1684 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1685 | } | |||||
| 1686 | } else { | |||||
| 1687 | 0 | 0 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label can't be decoded"); | |||
| 1688 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1689 | } | |||||
| 1690 | } elsif($type eq 'arrayref') { | |||||
| 1691 | 104 | 101 | if(!defined($value)) { | |||
| 1692 | 1 | 2 | if($rule_value > 0 && !$is_optional) { | |||
| 1693 | 1 | 9 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label is undefined, but must have at least $rule_value member" . ($rule_value > 1 ? 's' : '')); | |||
| 1694 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1695 | } | |||||
| 1696 | 0 | 0 | next; | |||
| 1697 | } | |||||
| 1698 | 103 103 | 76 138 | if(scalar(@{$value}) < $rule_value) { | |||
| 1699 | 13 | 51 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must have at least $rule_value member" . (($rule_value > 1) ? 's' : '')); | |||
| 1700 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1701 | } | |||||
| 1702 | } elsif($type eq 'hashref') { | |||||
| 1703 | 16 | 33 | if(!defined($value)) { | |||
| 1704 | 1 | 3 | if($rule_value > 0 && !$is_optional) { | |||
| 1705 | 1 | 2 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label is undefined, but must contain at least $rule_value keys"); | |||
| 1706 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1707 | } | |||||
| 1708 | 0 | 0 | next; | |||
| 1709 | } | |||||
| 1710 | 15 15 | 13 25 | if(scalar(keys(%{$value})) < $rule_value) { | |||
| 1711 | 8 | 23 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must contain at least $rule_value keys"); | |||
| 1712 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1713 | } | |||||
| 1714 | } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) { | |||||
| 1715 | 153 | 143 | if(!defined($value)) { | |||
| 1716 | 1 | 3 | if($rule_value > 0 && !$is_optional) { | |||
| 1717 | 1 | 3 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label is undefined, but must be at least $rule_value"); | |||
| 1718 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1719 | } | |||||
| 1720 | 0 | 0 | next; | |||
| 1721 | } | |||||
| 1722 | 152 | 150 | if(Scalar::Util::looks_like_number($value)) { | |||
| 1723 | 152 | 199 | if($value < $rule_value) { | |||
| 1724 | 40 | 127 | if($rules->{'error_msg'}) { | |||
| 1725 | 7 | 15 | _error($logger, $rules->{'error_msg'}); | |||
| 1726 | } elsif(($type eq 'integer') && ($value == 0)) { | |||||
| 1727 | 3 | 7 | _error($logger, "$rule_description: Parameter $param_label ($value) must be a positive number"); | |||
| 1728 | } elsif(($type eq 'integer') && ($value == 1)) { | |||||
| 1729 | 0 | 0 | _error($logger, "$rule_description: Parameter $param_label ($value) must be a positive, non-zero number"); | |||
| 1730 | } else { | |||||
| 1731 | 30 | 65 | _error($logger, "$rule_description: Parameter $param_label ($value) must be at least $rule_value"); | |||
| 1732 | } | |||||
| 1733 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1734 | 0 | 0 | next; | |||
| 1735 | } | |||||
| 1736 | } else { | |||||
| 1737 | 0 | 0 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) must be a number"); | |||
| 1738 | 0 | 0 | next; | |||
| 1739 | } | |||||
| 1740 | } else { | |||||
| 1741 | 3 | 8 | _error($logger, "$rule_description: Parameter $param_label of type '$type' has meaningless min value $rule_value"); | |||
| 1742 | } | |||||
| 1743 | } elsif($rule_name eq 'max') { | |||||
| 1744 | 198 | 219 | if(!defined($rules->{'type'})) { | |||
| 1745 | 0 | 0 | _error($logger, "$rule_description: Don't know type of $param_label to determine its maximum value $rule_value"); | |||
| 1746 | } | |||||
| 1747 | 198 | 161 | my $type = lc($rules->{'type'}); | |||
| 1748 | 198 | 250 | if(exists($custom_types->{$type}->{'max'})) { | |||
| 1749 | 4 | 4 | $rule_value = $custom_types->{$type}->{'max'}; | |||
| 1750 | 4 | 4 | $type = $custom_types->{$type}->{'type'}; | |||
| 1751 | } | |||||
| 1752 | 198 | 535 | if(($type eq 'string') || ($type eq 'str') || ($type eq 'stringref')) { | |||
| 1753 | 95 | 80 | if(!defined($value)) { | |||
| 1754 | 0 | 0 | next; # Skip if string is undefined | |||
| 1755 | } | |||||
| 1756 | 95 | 132 | if(defined(my $len = _number_of_characters($value))) { | |||
| 1757 | 95 | 128 | if($len > $rule_value) { | |||
| 1758 | 30 | 65 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label too long, ($len characters), must be no longer than $rule_value"); | |||
| 1759 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1760 | } | |||||
| 1761 | } else { | |||||
| 1762 | 0 | 0 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label can't be decoded"); | |||
| 1763 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1764 | } | |||||
| 1765 | } elsif($type eq 'arrayref') { | |||||
| 1766 | 22 | 23 | if(!defined($value)) { | |||
| 1767 | 0 | 0 | next; # Skip if string is undefined | |||
| 1768 | } | |||||
| 1769 | 22 22 | 15 36 | if(scalar(@{$value}) > $rule_value) { | |||
| 1770 | 9 | 25 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must contain no more than $rule_value items"); | |||
| 1771 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1772 | } | |||||
| 1773 | } elsif($type eq 'hashref') { | |||||
| 1774 | 14 | 17 | if(!defined($value)) { | |||
| 1775 | 0 | 0 | next; # Skip if hash is undefined | |||
| 1776 | } | |||||
| 1777 | 14 14 | 9 22 | if(scalar(keys(%{$value})) > $rule_value) { | |||
| 1778 | 8 | 17 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label must contain no more than $rule_value keys"); | |||
| 1779 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1780 | } | |||||
| 1781 | } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) { | |||||
| 1782 | 64 | 65 | if(!defined($value)) { | |||
| 1783 | 0 | 0 | next; # Skip if hash is undefined | |||
| 1784 | } | |||||
| 1785 | 64 | 77 | if(Scalar::Util::looks_like_number($value)) { | |||
| 1786 | 64 | 75 | if($value > $rule_value) { | |||
| 1787 | 17 | 71 | if($rules->{'error_msg'}) { | |||
| 1788 | 0 | 0 | _error($logger, $rules->{'error_msg'}); | |||
| 1789 | } elsif(($type eq 'integer') && ($value == 0)) { | |||||
| 1790 | 0 | 0 | _error($logger, "$rule_description: Parameter $param_label ($value) must be a negative number"); | |||
| 1791 | } elsif(($type eq 'integer') && ($value == -1)) { | |||||
| 1792 | 0 | 0 | _error($logger, "$rule_description: Parameter $param_label ($value) must be a negative, non-zero number"); | |||
| 1793 | } else { | |||||
| 1794 | 17 | 36 | _error($logger, "$rule_description: Parameter $param_label ($value) must be no more than $rule_value"); | |||
| 1795 | } | |||||
| 1796 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1797 | 0 | 0 | next; | |||
| 1798 | } | |||||
| 1799 | } else { | |||||
| 1800 | 0 | 0 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) must be a number"); | |||
| 1801 | 0 | 0 | next; | |||
| 1802 | } | |||||
| 1803 | } else { | |||||
| 1804 | 3 | 7 | _error($logger, "$rule_description: Parameter $param_label of type '$type' has meaningless max value $rule_value"); | |||
| 1805 | } | |||||
| 1806 | } elsif(($rule_name eq 'matches') || ($rule_name eq 'regex')) { | |||||
| 1807 | 124 | 136 | if(!defined($value)) { | |||
| 1808 | 1 | 1 | next; # Skip if string is undefined | |||
| 1809 | } | |||||
| 1810 | 123 | 98 | eval { | |||
| 1811 | 123 | 217 | my $re = (ref($rule_value) eq 'Regexp') ? $rule_value : qr/\Q$rule_value\E/; | |||
| 1812 | 123 | 488 | if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) { | |||
| 1813 | # all{} short-circuits on first failure and allocates no temp array | |||||
| 1814 | 5 11 5 | 9 35 12 | unless(all { $_ =~ $re } @{$value}) { | |||
| 1815 | 2 2 | 3 6 | _rule_error($logger, $rules, "$rule_description: All members of parameter $param_label [", join(', ', @{$value}), "] must match pattern '$rule_value'"); | |||
| 1816 | } | |||||
| 1817 | } elsif($value !~ $re) { | |||||
| 1818 | 34 | 97 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) must match pattern '$re'"); | |||
| 1819 | } | |||||
| 1820 | 87 | 98 | 1; | |||
| 1821 | }; | |||||
| 1822 | 123 | 8929 | if($@) { | |||
| 1823 | 36 | 96 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label regex '$rule_value' error: $@"); | |||
| 1824 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1825 | } | |||||
| 1826 | } elsif($rule_name eq 'nomatch') { | |||||
| 1827 | 26 | 31 | if(!defined($value)) { | |||
| 1828 | 0 | 0 | next; # Skip if string is undefined | |||
| 1829 | } | |||||
| 1830 | # Compile string patterns with \Q...\E so metacharacters are | |||||
| 1831 | # treated as literals, matching the behaviour of 'matches'. | |||||
| 1832 | 26 | 61 | my $re = (ref($rule_value) eq 'Regexp') ? $rule_value : qr/\Q$rule_value\E/; | |||
| 1833 | 26 | 22 | eval { | |||
| 1834 | 26 | 100 | if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) { | |||
| 1835 | # any{} short-circuits on first match and allocates no temp array | |||||
| 1836 | 5 13 5 | 9 24 10 | if(any { $_ =~ $re } @{$value}) { | |||
| 1837 | 2 2 | 3 8 | _rule_error($logger, $rules, "$rule_description: No member of parameter $param_label [", join(', ', @{$value}), "] must match pattern '$rule_value'"); | |||
| 1838 | } | |||||
| 1839 | } elsif($value =~ $re) { | |||||
| 1840 | 10 | 33 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) must not match pattern '$rule_value'"); | |||
| 1841 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1842 | } | |||||
| 1843 | 14 | 16 | 1; | |||
| 1844 | }; | |||||
| 1845 | 26 | 3022 | if($@) { | |||
| 1846 | 12 | 35 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label regex '$rule_value' error: $@"); | |||
| 1847 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1848 | } | |||||
| 1849 | } elsif($rule_name eq 'bnf') { | |||||
| 1850 | 25 | 40 | if(!defined($value)) { | |||
| 1851 | 3 | 4 | next; # Skip if value is undefined | |||
| 1852 | } | |||||
| 1853 | 22 | 25 | if(ref($rule_value) ne 'ARRAY') { | |||
| 1854 | 3 | 5 | _error($logger, "$rule_description: Parameter $param_label 'bnf' rule must be an arrayref of grammar lines"); | |||
| 1855 | } | |||||
| 1856 | 19 | 43 | require Params::Validate::Strict::BNF; | |||
| 1857 | 19 | 27 | my $matcher = Params::Validate::Strict::BNF::bnf_to_matcher($rule_value); | |||
| 1858 | 15 | 18 | unless($matcher->($value)) { | |||
| 1859 | 8 | 17 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) does not match the BNF grammar"); | |||
| 1860 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1861 | } | |||||
| 1862 | } elsif(($rule_name eq 'memberof') || ($rule_name eq 'enum') || ($rule_name eq 'values')) { | |||||
| 1863 | 118 | 105 | if(!defined($value)) { | |||
| 1864 | 0 | 0 | next; # Skip if string is undefined | |||
| 1865 | } | |||||
| 1866 | 118 | 145 | if(ref($rule_value) eq 'ARRAY') { | |||
| 1867 | 116 | 209 | unless(_value_in_list($value, $rule_value, $rules->{'type'} // '', $rules->{'case_sensitive'})) { | |||
| 1868 | 42 42 | 63 94 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) must be one of ", join(', ', @{$rule_value})); | |||
| 1869 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1870 | } | |||||
| 1871 | } else { | |||||
| 1872 | 2 | 4 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label rule ($rule_value) must be an array reference"); | |||
| 1873 | } | |||||
| 1874 | } elsif($rule_name eq 'notmemberof') { | |||||
| 1875 | 50 | 45 | if(!defined($value)) { | |||
| 1876 | 0 | 0 | next; # Skip if string is undefined | |||
| 1877 | } | |||||
| 1878 | 50 | 53 | if(ref($rule_value) eq 'ARRAY') { | |||
| 1879 | 49 | 98 | if(_value_in_list($value, $rule_value, $rules->{'type'} // '', $rules->{'case_sensitive'})) { | |||
| 1880 | 27 27 | 50 59 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label ($value) must not be one of ", join(', ', @{$rule_value})); | |||
| 1881 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1882 | } | |||||
| 1883 | } else { | |||||
| 1884 | 1 | 2 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label rule ($rule_value) must be an array reference"); | |||
| 1885 | } | |||||
| 1886 | } elsif($rule_name eq 'isa') { | |||||
| 1887 | 23 | 28 | if(!defined($value)) { | |||
| 1888 | 0 | 0 | next; # Skip if object not given | |||
| 1889 | } | |||||
| 1890 | 23 | 40 | if($rules->{'type'} eq 'object') { | |||
| 1891 | 20 | 90 | if(!$value->isa($rule_value)) { | |||
| 1892 | 6 | 23 | _error($logger, "$rule_description: Parameter $param_label must be a '$rule_value' object got a " . (ref($value) ? ref($value) : $value) . ' object instead'); | |||
| 1893 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1894 | } | |||||
| 1895 | } else { | |||||
| 1896 | 3 | 6 | _error($logger, "$rule_description: Parameter $param_label has meaningless isa value $rule_value"); | |||
| 1897 | } | |||||
| 1898 | } elsif($rule_name eq 'can') { | |||||
| 1899 | 38 | 45 | if(!defined($value)) { | |||
| 1900 | 0 | 0 | next; # Skip if object not given | |||
| 1901 | } | |||||
| 1902 | 38 | 47 | if($rules->{'type'} eq 'object') { | |||
| 1903 | 35 | 75 | if(ref($rule_value) eq 'ARRAY') { | |||
| 1904 | # List of methods | |||||
| 1905 | 15 15 | 11 17 | foreach my $method(@{$rule_value}) { | |||
| 1906 | 29 | 64 | if(!$value->can($method)) { | |||
| 1907 | 6 | 12 | _error($logger, "$rule_description: Parameter $param_label must be an object that understands the $method method"); | |||
| 1908 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1909 | } | |||||
| 1910 | } | |||||
| 1911 | } elsif(!ref($rule_value)) { | |||||
| 1912 | 19 | 78 | if(!$value->can($rule_value)) { | |||
| 1913 | 8 | 22 | _error($logger, "$rule_description: Parameter $param_label must be an object that understands the $rule_value method"); | |||
| 1914 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1915 | } | |||||
| 1916 | } else { | |||||
| 1917 | 1 | 1 | _error($logger, "$rule_description: 'can' rule for Parameter $param_label must be either a scalar or an arrayref"); | |||
| 1918 | } | |||||
| 1919 | } else { | |||||
| 1920 | 3 | 9 | _error($logger, "$rule_description: Parameter $param_label has meaningless can value '$rule_value' for parameter type $rules->{type}"); | |||
| 1921 | } | |||||
| 1922 | } elsif($rule_name eq 'does') { | |||||
| 1923 | 3 | 4 | if(!defined($value)) { | |||
| 1924 | 0 | 0 | next; # Skip if object not given | |||
| 1925 | } | |||||
| 1926 | 3 | 4 | if($rules->{'type'} eq 'object') { | |||
| 1927 | 2 | 10 | unless(Scalar::Util::blessed($value) && $value->DOES($rule_value)) { | |||
| 1928 | 1 | 3 | _error($logger, "$rule_description: Parameter $param_label must be an object that does '$rule_value'"); | |||
| 1929 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1930 | } | |||||
| 1931 | } else { | |||||
| 1932 | 1 | 3 | _error($logger, "$rule_description: Parameter $param_label has meaningless does value '$rule_value' for parameter type $rules->{type}"); | |||
| 1933 | } | |||||
| 1934 | } elsif($rule_name eq 'classisa') { | |||||
| 1935 | 3 | 4 | if(!defined($value)) { | |||
| 1936 | 1 | 1 | next; | |||
| 1937 | } | |||||
| 1938 | 2 | 19 | unless(!ref($value) && $value =~ /\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/ && $value->isa($rule_value)) { | |||
| 1939 | 1 | 3 | _error($logger, "$rule_description: Parameter $param_label ($value) must be a class that isa '$rule_value'"); | |||
| 1940 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1941 | } | |||||
| 1942 | } elsif($rule_name eq 'subclass') { | |||||
| 1943 | 2 | 3 | if(!defined($value)) { | |||
| 1944 | 0 | 0 | next; | |||
| 1945 | } | |||||
| 1946 | 2 | 12 | unless(!ref($value) && $value =~ /\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/ | |||
| 1947 | && $value ne $rule_value && $value->isa($rule_value)) { | |||||
| 1948 | 1 | 2 | _error($logger, "$rule_description: Parameter $param_label ($value) must be a strict subclass of '$rule_value'"); | |||
| 1949 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1950 | } | |||||
| 1951 | } elsif($rule_name eq 'classdoes') { | |||||
| 1952 | 2 | 3 | if(!defined($value)) { | |||
| 1953 | 0 | 0 | next; | |||
| 1954 | } | |||||
| 1955 | 2 | 20 | unless(!ref($value) && $value =~ /\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/ && $value->DOES($rule_value)) { | |||
| 1956 | 1 | 3 | _error($logger, "$rule_description: Parameter $param_label ($value) must be a class that does '$rule_value'"); | |||
| 1957 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1958 | } | |||||
| 1959 | } elsif($rule_name eq 'driver') { | |||||
| 1960 | 3 | 4 | if(!defined($value)) { | |||
| 1961 | 0 | 0 | next; | |||
| 1962 | } | |||||
| 1963 | 3 | 12 | unless(!ref($value) && $value =~ /\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/) { | |||
| 1964 | 1 | 3 | _error($logger, "$rule_description: Parameter $param_label must be a valid class name"); | |||
| 1965 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1966 | 0 | 0 | next; | |||
| 1967 | } | |||||
| 1968 | 2 | 5 | (my $file = $value) =~ s{::}{/}g; | |||
| 1969 | 2 | 3 | $file .= '.pm'; | |||
| 1970 | 2 2 | 1 7 | eval { require $file }; | |||
| 1971 | 2 | 3 | if($@) { | |||
| 1972 | 0 | 0 | _error($logger, "$rule_description: Parameter $param_label ($value) could not be loaded: $@"); | |||
| 1973 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1974 | 0 | 0 | next; | |||
| 1975 | } | |||||
| 1976 | 2 | 10 | unless($value->isa($rule_value)) { | |||
| 1977 | 1 | 2 | _error($logger, "$rule_description: Parameter $param_label ($value) must be a class that isa '$rule_value'"); | |||
| 1978 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 1979 | } | |||||
| 1980 | } elsif($rule_name eq 'element_type') { | |||||
| 1981 | 44 | 81 | if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) { | |||
| 1982 | 41 | 36 | my $type = $rule_value; | |||
| 1983 | 41 | 35 | my $custom_type = $custom_types->{$rule_value}; | |||
| 1984 | 41 | 51 | if($custom_type && $custom_type->{'type'}) { | |||
| 1985 | 4 | 5 | $type = $custom_type->{'type'}; | |||
| 1986 | } | |||||
| 1987 | 41 41 | 27 45 | foreach my $member(@{$value}) { | |||
| 1988 | 98 | 85 | if($custom_type && $custom_type->{'transform'}) { | |||
| 1989 | # The custom type has a transform embedded within it | |||||
| 1990 | 5 | 8 | if(ref($custom_type->{'transform'}) eq 'CODE') { | |||
| 1991 | 4 4 | 2 4 | $member = &{$custom_type->{'transform'}}($member); | |||
| 1992 | } else { | |||||
| 1993 | 1 | 1 | _error($logger, "$rule_description: transforms must be a code ref"); | |||
| 1994 | } | |||||
| 1995 | } | |||||
| 1996 | 97 | 139 | if(($type eq 'string') || ($type eq 'Str')) { | |||
| 1997 | 41 | 49 | if(ref($member)) { | |||
| 1998 | 2 | 5 | _rule_error($logger, $rules, "$param_label can only contain strings"); | |||
| 1999 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2000 | } | |||||
| 2001 | } elsif($type eq 'integer') { | |||||
| 2002 | 44 | 106 | if(ref($member) || ($member =~ /\D/)) { | |||
| 2003 | 6 | 12 | _rule_error($logger, $rules, "$param_label can only contain integers (found $member)"); | |||
| 2004 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2005 | } | |||||
| 2006 | } elsif(($type eq 'number') || ($rule_value eq 'float')) { | |||||
| 2007 | 11 | 58 | if(ref($member) || ($member !~ /^[-+]?(?:\d+(?:\.\d*)?|\.\d+)$/)) { | |||
| 2008 | 2 | 4 | _rule_error($logger, $rules, "$param_label can only contain numbers (found $member)"); | |||
| 2009 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2010 | } | |||||
| 2011 | } elsif($type eq 'object') { | |||||
| 2012 | 0 | 0 | if(!Scalar::Util::blessed($member)) { | |||
| 2013 | 0 | 0 | _rule_error($logger, $rules, "$param_label can only contain objects (found $member)"); | |||
| 2014 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2015 | } | |||||
| 2016 | } else { | |||||
| 2017 | 1 | 2 | _error($logger, "BUG: Add $type to element_type list"); | |||
| 2018 | } | |||||
| 2019 | } | |||||
| 2020 | } else { | |||||
| 2021 | 3 | 5 | _error($logger, "$rule_description: Parameter $param_label has meaningless element_type value $rule_value"); | |||
| 2022 | } | |||||
| 2023 | } elsif($rule_name eq 'optional') { | |||||
| 2024 | # Already handled at the beginning of the loop | |||||
| 2025 | } elsif($rule_name eq 'nullable') { | |||||
| 2026 | # Already handled at the beginning of the loop (same as optional) | |||||
| 2027 | } elsif($rule_name eq 'default') { | |||||
| 2028 | # Handled earlier | |||||
| 2029 | } elsif($rule_name eq 'error_msg') { | |||||
| 2030 | # Handled inline | |||||
| 2031 | } elsif($rule_name eq 'transform') { | |||||
| 2032 | # Handled before the loop | |||||
| 2033 | } elsif($rule_name eq 'case_sensitive') { | |||||
| 2034 | # Handled inline | |||||
| 2035 | } elsif($rule_name eq 'description') { | |||||
| 2036 | # A la, Data::Processor | |||||
| 2037 | } elsif($rule_name =~ /^_/) { | |||||
| 2038 | # Ignore internal/metadata fields from schema extraction | |||||
| 2039 | } elsif($rule_name eq 'semantic') { | |||||
| 2040 | 17 | 24 | if($rule_value eq 'unix_timestamp') { | |||
| 2041 | 9 | 20 | if($value < 0 || $value > 2147483647) { | |||
| 2042 | 4 | 6 | _error($logger, "Invalid Unix timestamp: $value"); | |||
| 2043 | } | |||||
| 2044 | } elsif($rule_value eq 'identifier') { | |||||
| 2045 | 3 | 49 | if(defined($value) && $value !~ /\A[A-Za-z_]\w*\z/) { | |||
| 2046 | 2 | 4 | _error($logger, "Invalid Perl identifier: $value"); | |||
| 2047 | } | |||||
| 2048 | } elsif($rule_value eq 'class_name') { | |||||
| 2049 | 3 | 9 | if(defined($value) && $value !~ /\A[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/) { | |||
| 2050 | 1 | 2 | _error($logger, "Invalid Perl class name: $value"); | |||
| 2051 | } | |||||
| 2052 | } else { | |||||
| 2053 | 2 | 5 | _warn($logger, "semantic type $rule_value is not yet supported"); | |||
| 2054 | } | |||||
| 2055 | } elsif($rule_name eq 'schema') { | |||||
| 2056 | # Nested schema Run the given schema against each element of the array | |||||
| 2057 | 69 | 130 | if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) { | |||
| 2058 | 18 | 18 | if(ref($value) eq 'ARRAY') { | |||
| 2059 | 18 18 | 17 20 | foreach my $member(@{$value}) { | |||
| 2060 | # Distinguish two schema forms: | |||||
| 2061 | # (a) Rule hash â has a top-level 'type' key, e.g. { type=>'string', matches=>qr/.../ } | |||||
| 2062 | # => validate each element against that rule directly. | |||||
| 2063 | # (b) Field-schema hash â keys are field names whose values are rule hashes, | |||||
| 2064 | # e.g. { name=>{type=>'string'}, age=>{type=>'integer'} } | |||||
| 2065 | # => validate each hashref element against the field schema directly. | |||||
| 2066 | 29 | 43 | my $is_field_schema = (ref($rule_value) eq 'HASH') && !exists($rule_value->{'type'}); | |||
| 2067 | 29 | 34 | my %inner = (custom_types => $custom_types); | |||
| 2068 | 29 | 25 | if($is_field_schema) { | |||
| 2069 | 7 | 5 | $inner{input} = $member; | |||
| 2070 | 7 | 6 | $inner{schema} = $rule_value; | |||
| 2071 | } else { | |||||
| 2072 | 22 | 22 | $inner{input} = { $key => $member }; | |||
| 2073 | 22 | 28 | $inner{schema} = { $key => $rule_value }; | |||
| 2074 | } | |||||
| 2075 | 29 | 73 | if(!validate_strict(\%inner)) { | |||
| 2076 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2077 | } | |||||
| 2078 | } | |||||
| 2079 | } elsif(defined($value)) { # Allow undef for optional values | |||||
| 2080 | 0 | 0 | _error($logger, "$rule_description: nested schema: Parameter '$value' must be an arrayref"); | |||
| 2081 | } | |||||
| 2082 | } elsif($rules->{'type'} eq 'hashref') { | |||||
| 2083 | 50 | 53 | if(ref($rule_value) eq 'HASH') { | |||
| 2084 | # Apply nested defaults before validation | |||||
| 2085 | 50 | 57 | my $nested_with_defaults = _apply_nested_defaults($value, $rule_value); | |||
| 2086 | 50 50 | 34 52 | if(scalar keys(%{$nested_with_defaults})) { | |||
| 2087 | 48 | 299 | if(my $new_args = validate_strict({ input => $nested_with_defaults, schema => $rule_value, custom_types => $custom_types })) { | |||
| 2088 | 34 | 59 | $value = $new_args; | |||
| 2089 | } else { | |||||
| 2090 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2091 | } | |||||
| 2092 | } | |||||
| 2093 | } else { | |||||
| 2094 | 0 | 0 | _error($logger, "$rule_description: nested schema: Parameter '$value' must be an hashref"); | |||
| 2095 | } | |||||
| 2096 | } else { | |||||
| 2097 | 1 | 2 | _error($logger, "$rule_description: Parameter $param_label: 'schema' only supports arrayref and hashref, not $rules->{type}"); | |||
| 2098 | } | |||||
| 2099 | } elsif(($rule_name eq 'validate') || ($rule_name eq 'validator')) { | |||||
| 2100 | 15 | 20 | if(ref($rule_value) eq 'CODE') { | |||
| 2101 | 13 13 | 10 20 | if(my $error = &{$rule_value}($args)) { | |||
| 2102 | 5 | 19 | _error($logger, "$rule_description: $param_label not valid: $error"); | |||
| 2103 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2104 | } | |||||
| 2105 | } else { | |||||
| 2106 | # _error($logger, "$rule_description: Parameter $param_label: 'validate' only supports coderef, not $value"); | |||||
| 2107 | 2 | 4 | _error($logger, "$rule_description: Parameter $param_label: 'validate' only supports coderef, not " . ref($rule_value) // $rule_value); | |||
| 2108 | } | |||||
| 2109 | } elsif ($rule_name eq 'callback') { | |||||
| 2110 | # Custom validation code | |||||
| 2111 | 50 | 64 | unless (defined &$rule_value) { | |||
| 2112 | 1 | 2 | _error($logger, "$rule_description: callback for $param_label must be a code reference"); | |||
| 2113 | } | |||||
| 2114 | 49 | 68 | my $res = $rule_value->($value, $args, $schema); | |||
| 2115 | 47 | 130 | unless ($res) { | |||
| 2116 | 18 | 40 | _rule_error($logger, $rules, "$rule_description: Parameter $param_label failed custom validation"); | |||
| 2117 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2118 | } | |||||
| 2119 | } elsif($rule_name eq 'position') { | |||||
| 2120 | 38 | 61 | if($rule_value < 0) { | |||
| 2121 | 0 | 0 | _error($logger, "$rule_description: Parameter $param_label: 'position' must be a positive integer, not $value"); | |||
| 2122 | } | |||||
| 2123 | 38 | 65 | if($rule_value =~ /\D/) { | |||
| 2124 | 1 | 2 | _error($logger, "$rule_description: Parameter $param_label: 'position' must be a positive integer"); | |||
| 2125 | } | |||||
| 2126 | } elsif($rule_name eq 'slurp') { | |||||
| 2127 | 3 | 8 | if($rule_value && $are_positional_args != 1) { | |||
| 2128 | 0 | 0 | _error($logger, "$rule_description: Parameter $param_label: 'slurp' is only valid in positional-argument schemas (all parameters need a 'position')"); | |||
| 2129 | } | |||||
| 2130 | # Pre-processed: value was already collected as arrayref of remaining positional args | |||||
| 2131 | } elsif($rule_name eq 'aliases') { | |||||
| 2132 | # Pre-processed: alternative input-key names resolved during value fetch | |||||
| 2133 | } else { | |||||
| 2134 | 2 | 5 | _error($logger, "$rule_description: Unknown rule '$rule_name'"); | |||
| 2135 | } | |||||
| 2136 | } | |||||
| 2137 | } elsif(ref($rules) eq 'ARRAY') { | |||||
| 2138 | 82 82 | 55 77 | if(scalar(@{$rules})) { | |||
| 2139 | # An argument can be one of several different types. | |||||
| 2140 | # This path handles both explicit array-of-rules schemas and the | |||||
| 2141 | # normalised form of union type shorthand (type => ['a', 'b', ...]). | |||||
| 2142 | 80 | 57 | my $rc = 0; | |||
| 2143 | 80 | 68 | my @types; | |||
| 2144 | 80 80 | 55 71 | foreach my $rule(@{$rules}) { | |||
| 2145 | 128 | 139 | if(ref($rule) ne 'HASH') { | |||
| 2146 | 1 | 2 | _error($logger, "$rule_description: Parameter $param_label rules must be a hash reference"); | |||
| 2147 | } | |||||
| 2148 | 127 | 131 | if(!defined($rule->{'type'})) { | |||
| 2149 | 0 | 0 | _error($logger, "$rule_description: Parameter $param_label is missing a type in an alternative"); | |||
| 2150 | } | |||||
| 2151 | 127 | 135 | push @types, $rule->{'type'}; | |||
| 2152 | 127 | 75 | my $result; | |||
| 2153 | 127 | 92 | eval { | |||
| 2154 | 127 | 398 | $result = validate_strict({ input => { $key => $value }, schema => { $key => $rule }, logger => undef, custom_types => $custom_types }); | |||
| 2155 | }; | |||||
| 2156 | 127 | 15352 | if(!$@) { | |||
| 2157 | # Capture coercion performed by the successful sub-validation | |||||
| 2158 | # (e.g. integer/number coercion) so the outer scope sees it. | |||||
| 2159 | 56 | 74 | $value = $result->{$key} if(defined($result)); | |||
| 2160 | 56 | 38 | $rc = 1; | |||
| 2161 | 56 | 73 | last; | |||
| 2162 | } | |||||
| 2163 | } | |||||
| 2164 | 79 | 114 | if(!$rc) { | |||
| 2165 | 23 | 50 | _error($logger, "$rule_description: Parameter $param_label must be one of " . join(', ', @types)); | |||
| 2166 | 0 | 0 | $invalid_args{$key} = 1; | |||
| 2167 | } | |||||
| 2168 | } else { | |||||
| 2169 | 2 | 3 | _error($logger, "$rule_description: Parameter $param_label schema is empty arrayref"); | |||
| 2170 | } | |||||
| 2171 | } elsif(ref($rules)) { | |||||
| 2172 | 2 | 4 | _error($logger, 'rules must be a hash reference or string'); | |||
| 2173 | } | |||||
| 2174 | ||||||
| 2175 | 1477 | 2207 | $validated_args{$key} = $value; | |||
| 2176 | } | |||||
| 2177 | ||||||
| 2178 | # Validate parameter relationships | |||||
| 2179 | 1171 | 1301 | if (my $relationships = $params->{'relationships'}) { | |||
| 2180 | 56 | 66 | _validate_relationships(\%validated_args, $relationships, $logger, $schema_description); | |||
| 2181 | } | |||||
| 2182 | ||||||
| 2183 | 1145 | 965 | if(my $cross_validation = $params->{'cross_validation'}) { | |||
| 2184 | 56 56 | 35 54 | foreach my $validator_name(keys %{$cross_validation}) { | |||
| 2185 | 63 | 62 | my $validator = $cross_validation->{$validator_name}; | |||
| 2186 | 63 | 98 | if((!ref($validator)) || (ref($validator) ne 'CODE')) { | |||
| 2187 | 2 | 4 | _error($logger, "$schema_description: cross_validation $validator is not a code snippet"); | |||
| 2188 | 0 | 0 | next; | |||
| 2189 | } | |||||
| 2190 | 61 61 | 45 67 | if(my $error = &{$validator}(\%validated_args, $validator)) { | |||
| 2191 | 25 | 90 | _error($logger, $error); | |||
| 2192 | # We have no idea which parameters are still valid, so let's invalidate them all | |||||
| 2193 | 0 | 0 | return; | |||
| 2194 | } | |||||
| 2195 | } | |||||
| 2196 | } | |||||
| 2197 | ||||||
| 2198 | 1117 | 995 | foreach my $key(keys %invalid_args) { | |||
| 2199 | 0 | 0 | delete $validated_args{$key}; | |||
| 2200 | } | |||||
| 2201 | ||||||
| 2202 | 1117 | 931 | if($are_positional_args == 1) { | |||
| 2203 | 24 | 18 | my @rc; | |||
| 2204 | 24 24 | 18 25 | foreach my $key (keys %{$schema}) { | |||
| 2205 | # Use exists() rather than if(my $value = ...) so that falsy but | |||||
| 2206 | # valid coerced values (integer 0, empty string, undef from an | |||||
| 2207 | # absent optional) are not silently dropped from the return array. | |||||
| 2208 | 40 | 40 | if(exists $validated_args{$key}) { | |||
| 2209 | 38 | 34 | my $value = delete $validated_args{$key}; | |||
| 2210 | 38 | 33 | my $position = $schema->{$key}->{'position'}; | |||
| 2211 | 38 | 40 | if(defined($rc[$position])) { | |||
| 2212 | 2 | 4 | _error($logger, "$schema_description: $key: position $position appears twice"); | |||
| 2213 | } | |||||
| 2214 | 36 | 35 | $rc[$position] = $value; | |||
| 2215 | } | |||||
| 2216 | } | |||||
| 2217 | 22 | 52 | return \@rc; | |||
| 2218 | } | |||||
| 2219 | 1093 | 2196 | return \%validated_args; | |||
| 2220 | } | |||||
| 2221 | ||||||
| 2222 - 2265 | =head2 compile_schema my $validator = compile_schema(\%schema); my $result = $validator->(\%input); # with optional keyword args my $validator = compile_schema(\%schema, description => 'User registration', custom_types => \%types, unknown_parameter_handler => 'warn', ); Pre-captures a schema (and any optional keyword arguments accepted by C<validate_strict>) into a reusable validator closure. Calling the returned coderef is equivalent to: validate_strict(schema => \%schema, input => \%input, %opts); but avoids the overhead of argument parsing on every call - useful when the same schema is applied repeatedly in a hot path. =head3 Arguments =over 4 =item * C<\%schema> (required) The validation schema as a hashref or arrayref, identical to the C<schema> argument of C<validate_strict>. =item * C<%opts> (optional) Any keyword arguments accepted by C<validate_strict> other than C<schema> and C<input>: C<description>, C<custom_types>, C<unknown_parameter_handler>, C<logger>, C<relationships>, C<cross_validation>, etc. =back =head3 Returns A code reference C<sub ($input) -E<gt> \%validated>. =cut | |||||
| 2266 | ||||||
| 2267 | sub compile_schema | |||||
| 2268 | { | |||||
| 2269 | 5 | 6110 | my ($schema, %opts) = @_; | |||
| 2270 | 5 | 10 | unless(ref($schema) eq 'HASH' || ref($schema) eq 'ARRAY') { | |||
| 2271 | 1 | 4 | Carp::croak('compile_schema: schema must be a hash or array reference'); | |||
| 2272 | } | |||||
| 2273 | return sub { | |||||
| 2274 | 4 | 409 | my $input = shift; | |||
| 2275 | 4 | 5 | return validate_strict(schema => $schema, input => $input, %opts); | |||
| 2276 | 4 | 7 | }; | |||
| 2277 | } | |||||
| 2278 | ||||||
| 2279 | # _schema_from_arrayref($arrayref, $logger) | |||||
| 2280 | # | |||||
| 2281 | # Normalise an arrayref schema: | |||||
| 2282 | # [ { name => 'param', type => 'string', ... }, ... ] | |||||
| 2283 | # to the standard named-parameter hashref form: | |||||
| 2284 | # { param => { type => 'string', ... }, ... } | |||||
| 2285 | # | |||||
| 2286 | # The 'name' key is consumed during conversion and does not become a rule. | |||||
| 2287 | # Croaks if any element is not a hashref, is missing 'name', or if a name | |||||
| 2288 | # appears more than once. | |||||
| 2289 | sub _schema_from_arrayref | |||||
| 2290 | { | |||||
| 2291 | 17 | 14 | my ($arrayref, $logger) = @_; | |||
| 2292 | ||||||
| 2293 | 17 | 13 | my %schema; | |||
| 2294 | 17 17 | 12 18 | foreach my $spec (@{$arrayref}) { | |||
| 2295 | 23 | 25 | _error($logger, "validate_strict: each arrayref schema element must be a hashref") | |||
| 2296 | unless ref($spec) eq 'HASH'; | |||||
| 2297 | _error($logger, "validate_strict: arrayref schema element must have a 'name' key") | |||||
| 2298 | 21 | 23 | unless exists($spec->{'name'}); | |||
| 2299 | 19 19 | 12 40 | my %rule = %{$spec}; | |||
| 2300 | 19 | 19 | my $name = delete $rule{'name'}; | |||
| 2301 | _error($logger, "validate_strict: duplicate parameter '$name' in arrayref schema") | |||||
| 2302 | 19 | 18 | if exists($schema{$name}); | |||
| 2303 | 17 | 23 | $schema{$name} = \%rule; | |||
| 2304 | } | |||||
| 2305 | 11 | 11 | return \%schema; | |||
| 2306 | } | |||||
| 2307 | ||||||
| 2308 | # Return number of visible characters not number of bytes | |||||
| 2309 | # Ensure string is decoded into Perl characters | |||||
| 2310 | sub _number_of_characters | |||||
| 2311 | { | |||||
| 2312 | 251 | 76669 | my $value = $_[0]; | |||
| 2313 | ||||||
| 2314 | 251 | 222 | return if(!defined($value)); | |||
| 2315 | ||||||
| 2316 | 250 | 720 | if($value !~ /[^[:ascii:]]/) { | |||
| 2317 | 187 | 241 | return length($value); | |||
| 2318 | } | |||||
| 2319 | # Decode only if it's not already a Perl character string | |||||
| 2320 | 63 | 146 | $value = decode_utf8($value) unless utf8::is_utf8($value); | |||
| 2321 | ||||||
| 2322 | # Count grapheme clusters (visible characters). | |||||
| 2323 | # \X matches one extended grapheme cluster; Perl's Unicode tables are kept | |||||
| 2324 | # current with each release, correctly handling ZWJ sequences and emoji | |||||
| 2325 | # modifier sequences that Unicode::GCString 2013.10 could not. | |||||
| 2326 | 63 | 256 | return scalar(() = $value =~ /\X/g); | |||
| 2327 | } | |||||
| 2328 | ||||||
| 2329 | sub _apply_nested_defaults { | |||||
| 2330 | 70 | 7040 | my ($input, $schema) = @_; | |||
| 2331 | 70 | 91 | my %result = %$input; | |||
| 2332 | ||||||
| 2333 | 70 | 82 | foreach my $key (keys %$schema) { | |||
| 2334 | 151 | 104 | my $rules = $schema->{$key}; | |||
| 2335 | ||||||
| 2336 | 151 | 223 | if (ref $rules eq 'HASH' && exists $rules->{default} && !exists $result{$key}) { | |||
| 2337 | 11 | 25 | $result{$key} //= $rules->{default}; | |||
| 2338 | } | |||||
| 2339 | ||||||
| 2340 | # Recursively handle nested schema | |||||
| 2341 | 151 | 248 | if((ref $rules eq 'HASH') && $rules->{schema} && (ref $result{$key} eq 'HASH')) { | |||
| 2342 | 10 | 16 | $result{$key} = _apply_nested_defaults($result{$key}, $rules->{schema}); | |||
| 2343 | } | |||||
| 2344 | } | |||||
| 2345 | ||||||
| 2346 | 70 | 74 | return \%result; | |||
| 2347 | } | |||||
| 2348 | ||||||
| 2349 | sub _validate_relationships { | |||||
| 2350 | 56 | 80 | my ($validated_args, $relationships, $logger, $description) = @_; | |||
| 2351 | ||||||
| 2352 | 56 | 62 | return unless ref($relationships) eq 'ARRAY'; | |||
| 2353 | ||||||
| 2354 | 56 | 50 | foreach my $rel (@$relationships) { | |||
| 2355 | 56 | 66 | my $type = $rel->{type} or next; | |||
| 2356 | ||||||
| 2357 | 56 | 109 | if ($type eq 'mutually_exclusive') { | |||
| 2358 | 8 | 20 | _validate_mutually_exclusive($validated_args, $rel, $logger, $description); | |||
| 2359 | } elsif ($type eq 'required_group') { | |||||
| 2360 | 7 | 27 | _validate_required_group($validated_args, $rel, $logger, $description); | |||
| 2361 | } elsif ($type eq 'conditional_requirement') { | |||||
| 2362 | 9 | 14 | _validate_conditional_requirement($validated_args, $rel, $logger, $description); | |||
| 2363 | } elsif ($type eq 'dependency') { | |||||
| 2364 | 7 | 34 | _validate_dependency($validated_args, $rel, $logger, $description); | |||
| 2365 | } elsif ($type eq 'value_constraint') { | |||||
| 2366 | 17 | 24 | _validate_value_constraint($validated_args, $rel, $logger, $description); | |||
| 2367 | } elsif ($type eq 'value_conditional') { | |||||
| 2368 | 7 | 11 | _validate_value_conditional($validated_args, $rel, $logger, $description); | |||
| 2369 | } else { | |||||
| 2370 | 1 | 2 | _error($logger, "Unknown relationship type $type"); | |||
| 2371 | } | |||||
| 2372 | } | |||||
| 2373 | } | |||||
| 2374 | ||||||
| 2375 | sub _validate_mutually_exclusive { | |||||
| 2376 | 12 | 6856 | my ($args, $rel, $logger, $description) = @_; | |||
| 2377 | ||||||
| 2378 | 12 12 | 11 22 | my @params = @{$rel->{params} || []}; | |||
| 2379 | 12 | 17 | return unless @params >= 2; | |||
| 2380 | ||||||
| 2381 | 12 24 | 14 24 | my @present = grep { _param_defined($args, $_) } @params; | |||
| 2382 | ||||||
| 2383 | 12 | 21 | if (@present > 1) { | |||
| 2384 | 6 | 19 | my $msg = $rel->{description} || 'Cannot specify both ' . join(' and ', @present); | |||
| 2385 | 6 | 11 | _error($logger, "$description: $msg"); | |||
| 2386 | } | |||||
| 2387 | } | |||||
| 2388 | ||||||
| 2389 | sub _validate_required_group { | |||||
| 2390 | 9 | 3044 | my ($args, $rel, $logger, $description) = @_; | |||
| 2391 | ||||||
| 2392 | 9 9 | 11 20 | my @params = @{$rel->{params} || []}; | |||
| 2393 | 9 | 13 | return unless @params >= 2; | |||
| 2394 | ||||||
| 2395 | 8 16 | 11 18 | my @present = grep { _param_defined($args, $_) } @params; | |||
| 2396 | ||||||
| 2397 | 8 | 20 | if (@present == 0) { | |||
| 2398 | my $msg = $rel->{description} || | |||||
| 2399 | 4 | 20 | 'Must specify at least one of: ' . join(', ', @params); | |||
| 2400 | 4 | 9 | _error($logger, "$description: $msg"); | |||
| 2401 | } | |||||
| 2402 | } | |||||
| 2403 | ||||||
| 2404 | sub _validate_conditional_requirement { | |||||
| 2405 | 13 | 5530 | my ($args, $rel, $logger, $description) = @_; | |||
| 2406 | ||||||
| 2407 | 13 | 20 | my $if_param = $rel->{if} or return; | |||
| 2408 | 12 | 19 | my $then_param = $rel->{then_required} or return; | |||
| 2409 | ||||||
| 2410 | # If the condition parameter is present and defined | |||||
| 2411 | 11 | 13 | if (_param_defined($args, $if_param)) { | |||
| 2412 | # Check if it's truthy (for booleans and general values) | |||||
| 2413 | 9 | 16 | if ($args->{$if_param}) { | |||
| 2414 | # Then the required parameter must also be present | |||||
| 2415 | 7 | 7 | unless (_param_defined($args, $then_param)) { | |||
| 2416 | 3 | 11 | my $msg = $rel->{description} || "When $if_param is specified, $then_param is required"; | |||
| 2417 | 3 | 6 | _error($logger, "$description: $msg"); | |||
| 2418 | } | |||||
| 2419 | } | |||||
| 2420 | } | |||||
| 2421 | } | |||||
| 2422 | ||||||
| 2423 | sub _validate_dependency { | |||||
| 2424 | 10 | 3480 | my ($args, $rel, $logger, $description) = @_; | |||
| 2425 | ||||||
| 2426 | 10 | 37 | my $param = $rel->{param} or return; | |||
| 2427 | 9 | 14 | my $requires = $rel->{requires} or return; | |||
| 2428 | ||||||
| 2429 | # If param is present, requires must also be present | |||||
| 2430 | 9 | 17 | if (_param_defined($args, $param)) { | |||
| 2431 | 6 | 8 | unless (_param_defined($args, $requires)) { | |||
| 2432 | 4 | 10 | my $msg = $rel->{description} || "$param requires $requires to be specified"; | |||
| 2433 | 4 | 9 | _error($logger, "$description: $msg"); | |||
| 2434 | } | |||||
| 2435 | } | |||||
| 2436 | } | |||||
| 2437 | ||||||
| 2438 | sub _validate_value_constraint { | |||||
| 2439 | 32 | 7542 | my ($args, $rel, $logger, $description) = @_; | |||
| 2440 | ||||||
| 2441 | 32 | 40 | my $if_param = $rel->{if} or return; | |||
| 2442 | 32 | 33 | my $then_param = $rel->{then} or return; | |||
| 2443 | 32 | 29 | my $operator = $rel->{operator} or return; | |||
| 2444 | 32 | 32 | my $value = $rel->{value}; | |||
| 2445 | 32 | 30 | return unless defined $value; | |||
| 2446 | ||||||
| 2447 | # If the condition parameter is present and truthy | |||||
| 2448 | 32 | 31 | if (_param_defined($args, $if_param) && $args->{$if_param}) { | |||
| 2449 | # Check if the then parameter exists | |||||
| 2450 | 29 | 26 | if (_param_defined($args, $then_param)) { | |||
| 2451 | 29 | 22 | my $actual = $args->{$then_param}; | |||
| 2452 | 29 | 20 | my $valid = 0; | |||
| 2453 | ||||||
| 2454 | 29 | 55 | if ($operator eq '==') { | |||
| 2455 | 8 | 15 | $valid = ($actual == $value); | |||
| 2456 | } elsif ($operator eq '!=') { | |||||
| 2457 | 4 | 4 | $valid = ($actual != $value); | |||
| 2458 | } elsif ($operator eq '<') { | |||||
| 2459 | 4 | 3 | $valid = ($actual < $value); | |||
| 2460 | } elsif ($operator eq '<=') { | |||||
| 2461 | 4 | 3 | $valid = ($actual <= $value); | |||
| 2462 | } elsif ($operator eq '>') { | |||||
| 2463 | 4 | 5 | $valid = ($actual > $value); | |||
| 2464 | } elsif ($operator eq '>=') { | |||||
| 2465 | 4 | 4 | $valid = ($actual >= $value); | |||
| 2466 | } | |||||
| 2467 | ||||||
| 2468 | 29 | 41 | unless ($valid) { | |||
| 2469 | 17 | 39 | my $msg = $rel->{description} || "When $if_param is specified, $then_param must be $operator $value (got $actual)"; | |||
| 2470 | 17 | 21 | _error($logger, "$description: $msg"); | |||
| 2471 | } | |||||
| 2472 | } | |||||
| 2473 | } | |||||
| 2474 | } | |||||
| 2475 | ||||||
| 2476 | sub _validate_value_conditional { | |||||
| 2477 | 11 | 4834 | my ($args, $rel, $logger, $description) = @_; | |||
| 2478 | ||||||
| 2479 | 11 | 16 | my $if_param = $rel->{if} or return; | |||
| 2480 | 11 | 9 | my $equals = $rel->{equals}; | |||
| 2481 | 11 | 16 | my $then_param = $rel->{then_required} or return; | |||
| 2482 | 11 | 14 | return unless defined $equals; | |||
| 2483 | ||||||
| 2484 | # If the parameter has the specific value | |||||
| 2485 | 11 | 14 | if (_param_defined($args, $if_param)) { | |||
| 2486 | 9 | 32 | if ($args->{$if_param} eq $equals) { | |||
| 2487 | # Then the required parameter must be present | |||||
| 2488 | 6 | 5 | unless (_param_defined($args, $then_param)) { | |||
| 2489 | my $msg = $rel->{description} || | |||||
| 2490 | 4 | 13 | "When $if_param equals '$equals', $then_param is required"; | |||
| 2491 | 4 | 7 | _error($logger, "$description: $msg"); | |||
| 2492 | } | |||||
| 2493 | } | |||||
| 2494 | } | |||||
| 2495 | } | |||||
| 2496 | ||||||
| 2497 | # Emit either the rule's custom error_msg or the supplied default message. | |||||
| 2498 | # Accepts a list for @default_parts so callers can pass join() fragments | |||||
| 2499 | # without pre-allocating a concatenated string. | |||||
| 2500 | sub _rule_error | |||||
| 2501 | { | |||||
| 2502 | 578 | 619 | my ($logger, $rules, @default_parts) = @_; | |||
| 2503 | 578 | 1112 | _error($logger, $rules->{'error_msg'} || join('', @default_parts)); | |||
| 2504 | } | |||||
| 2505 | ||||||
| 2506 | # Package-level cache: maps "refaddr(list):mode" -> [weak_list_ref, lookup_hash]. | |||||
| 2507 | # Each entry holds a WEAK reference to the original list arrayref alongside the | |||||
| 2508 | # compiled lookup hash. When the list goes out of scope and is freed, the weak | |||||
| 2509 | # reference becomes undef; the next access detects the stale entry and rebuilds, | |||||
| 2510 | # preventing false cache hits after address reuse. | |||||
| 2511 | my %_pvs_memberof_cache; | |||||
| 2512 | ||||||
| 2513 | # Return true if $value is present in $list, respecting numeric vs string | |||||
| 2514 | # comparison and the case_sensitive flag. Used by both memberof and notmemberof. | |||||
| 2515 | # On the first call for a given ($list, mode) pair the lookup hash is built | |||||
| 2516 | # (O(k)); subsequent calls with the same live list object are O(1). | |||||
| 2517 | sub _value_in_list | |||||
| 2518 | { | |||||
| 2519 | 165 | 212 | my ($value, $list, $type, $case_sensitive) = @_; | |||
| 2520 | 165 | 318 | my $is_numeric = ($type eq 'integer') || ($type eq 'number') || ($type eq 'float'); | |||
| 2521 | 165 | 266 | my $is_icase = !$is_numeric && defined($case_sensitive) && !$case_sensitive; | |||
| 2522 | ||||||
| 2523 | # Key combines address and comparison mode so the same list object can be | |||||
| 2524 | # cached under multiple modes without collision. | |||||
| 2525 | 165 | 281 | my $ckey = Scalar::Util::refaddr($list) . ($is_numeric ? 'n' : $is_icase ? 'i' : 's'); | |||
| 2526 | 165 | 139 | my $entry = $_pvs_memberof_cache{$ckey}; | |||
| 2527 | ||||||
| 2528 | # Stale check: if the weak ref is dead the list was freed and its address | |||||
| 2529 | # may have been reused by a different list â discard the cached hash. | |||||
| 2530 | 165 | 231 | if(defined($entry) && !defined($entry->[0])) { | |||
| 2531 | 0 | 0 | delete $_pvs_memberof_cache{$ckey}; | |||
| 2532 | 0 | 0 | $entry = undef; | |||
| 2533 | } | |||||
| 2534 | ||||||
| 2535 | 165 | 154 | unless(defined $entry) { | |||
| 2536 | 121 | 79 | my $lookup; | |||
| 2537 | 121 | 120 | if($is_numeric) { | |||
| 2538 | # Normalise to numeric value so "1" and "1.0" hash identically. | |||||
| 2539 | 22 82 22 | 23 116 19 | $lookup = { map { ($_ + 0) => 1 } @{$list} }; | |||
| 2540 | } elsif($is_icase) { | |||||
| 2541 | 14 32 14 | 11 43 15 | $lookup = { map { lc($_) => 1 } @{$list} }; | |||
| 2542 | } else { | |||||
| 2543 | 85 292 85 | 49 317 75 | $lookup = { map { $_ => 1 } @{$list} }; | |||
| 2544 | } | |||||
| 2545 | # Store [weak_ref_to_list, lookup_hash] â weak ref does not prevent GC. | |||||
| 2546 | 121 | 133 | my $weak = $list; | |||
| 2547 | 121 | 161 | Scalar::Util::weaken($weak); | |||
| 2548 | 121 | 159 | $_pvs_memberof_cache{$ckey} = [$weak, $lookup]; | |||
| 2549 | 121 | 117 | $entry = $_pvs_memberof_cache{$ckey}; | |||
| 2550 | } | |||||
| 2551 | ||||||
| 2552 | 165 | 116 | my $lookup = $entry->[1]; | |||
| 2553 | return $is_numeric ? exists($lookup->{$value + 0}) | |||||
| 2554 | : $is_icase ? exists($lookup->{lc($value)}) | |||||
| 2555 | 165 | 357 | : exists($lookup->{$value}); | |||
| 2556 | } | |||||
| 2557 | ||||||
| 2558 | # Return true when $args->{$param} is both present (exists) and defined. | |||||
| 2559 | sub _param_defined | |||||
| 2560 | { | |||||
| 2561 | 151 | 113 | my ($args, $param) = @_; | |||
| 2562 | 151 | 321 | return exists($args->{$param}) && defined($args->{$param}); | |||
| 2563 | } | |||||
| 2564 | ||||||
| 2565 | # Helper to log error or croak | |||||
| 2566 | sub _error | |||||
| 2567 | { | |||||
| 2568 | 859 | 4252 | my $logger = shift; | |||
| 2569 | 859 | 825 | my $message = join('', @_); | |||
| 2570 | # Strip ASCII control characters to prevent log-injection / CRLF attacks | |||||
| 2571 | # when user-supplied values appear in the message. | |||||
| 2572 | 859 | 1114 | $message =~ s/[[:cntrl:]]/ /g; | |||
| 2573 | ||||||
| 2574 | 859 | 971 | my @call_details = caller(0); | |||
| 2575 | 859 | 12123 | if($logger) { | |||
| 2576 | 21 | 42 | $logger->error(__PACKAGE__, ' line ', $call_details[2], ": $message"); | |||
| 2577 | } | |||||
| 2578 | 859 | 4219 | croak(__PACKAGE__, ' line ', $call_details[2], ": $message"); | |||
| 2579 | } | |||||
| 2580 | ||||||
| 2581 | # Helper to log warning or carp | |||||
| 2582 | sub _warn | |||||
| 2583 | { | |||||
| 2584 | 18 | 4510 | my $logger = shift; | |||
| 2585 | 18 | 26 | my $message = join('', @_); | |||
| 2586 | # Strip ASCII control characters to prevent log-injection / CRLF attacks. | |||||
| 2587 | 18 | 21 | $message =~ s/[[:cntrl:]]/ /g; | |||
| 2588 | ||||||
| 2589 | 18 | 45 | if($logger) { | |||
| 2590 | 7 | 16 | $logger->warn(__PACKAGE__, ": $message"); | |||
| 2591 | } else { | |||||
| 2592 | 11 | 63 | carp(__PACKAGE__, ": $message"); | |||
| 2593 | } | |||||
| 2594 | } | |||||
| 2595 | ||||||
| 2596 - 2809 | =head1 AUTHOR
Nigel Horne, C<< <njh at nigelhorne.com> >>
=encoding utf-8
=head1 FORMAL SPECIFICATION
[PARAM_NAME, VALUE, TYPE_NAME, CONSTRAINT_VALUE]
ValidationRule ::= SimpleType | ComplexRule | UnionType
SimpleType ::= string | integer | number | float | boolean | scalar
| scalarref | stringref | arrayref | hashref | coderef
| object | void | regex | handle
| arraylike | hashlike | codelike | invocant
UnionType ::= seq SimpleType -- at least two members; written as type => ['a', 'b']
ComplexRule == [
type: SimpleType | UnionType;
min: ââ;
max: ââ;
optional: ð¹;
matches: REGEX;
regex: REGEX;
nomatch: REGEX;
memberof: seq VALUE;
enum: seq VALUE;
values: seq VALUE;
notmemberof: seq VALUE;
callback: FUNCTION;
isa: TYPE_NAME;
does: ROLE_NAME;
can: METHOD_NAME | seq METHOD_NAME;
classisa: TYPE_NAME;
subclass: TYPE_NAME;
classdoes: ROLE_NAME;
driver: TYPE_NAME;
semantic: 'unix_timestamp' | 'identifier' | 'class_name';
aliases: seq PARAM_NAME;
slurp: ð¹;
position: ââ;
default: VALUE;
transform: FUNCTION;
error_msg: STRING
]
Schema == PARAM_NAME ⸠ValidationRule
Arguments == PARAM_NAME ⸠VALUE
ValidatedResult == PARAM_NAME ⸠VALUE
â rule: ComplexRule â¢
rule.min ⤠rule.max â§
¬((rule.memberof ⨠rule.enum ⨠rule.values) â§ rule.min) â§
¬((rule.memberof ⨠rule.enum ⨠rule.values) â§ rule.max) â§
¬(rule.notmemberof â§ rule.min) â§
¬(rule.notmemberof ⧠rule.max)
â schema: Schema; args: Arguments â¢
dom(validate_strict(schema, args)) â dom(schema) ⪠dom(args)
validate_strict: Schema à Arguments â ValidatedResult
â schema: Schema; args: Arguments â¢
let result == validate_strict(schema, args) â¢
(â name: dom(schema) â© dom(args) â¢
name â dom(result) â
type_matches(result(name), schema(name))) â§
(â name: dom(schema) â¢
¬optional(schema(name)) â name â dom(args))
type_matches: VALUE Ã ValidationRule â ð¹
=head1 EXAMPLE
use Params::Get;
use Params::Validate::Strict;
sub where_am_i
{
my $params = Params::Validate::Strict::validate_strict({
args => Params::Get::get_params(undef, \@_),
description => 'Print a string of latitude and longitude',
error_msg => 'Latitude is a number between +/- 90, longitude is a number between +/- 180',
members => {
'latitude' => {
type => 'number',
min => -90,
max => 90
}, 'longitude' => {
type => 'number',
min => -180,
max => 180
}
}
});
print 'You are at ', $params->{'latitude'}, ', ', $params->{'longitude'}, "\n";
}
where_am_i({ latitude => 3.14, longitude => -155 });
=head1 BUGS
=head1 SECURITY
=head2 Taint mode
This module does B<not> untaint its return values.
When running under Perl's taint mode (C<-T>), any value that was derived from
tainted external input (C<$ENV{}>, C<STDIN>, etc.) will remain tainted in the
validated result, even if the module accepted it.
Callers that require untainted values must perform their own regex capture after
validation, for example:
my $validated = validate_strict(%args);
my ($safe_name) = ($validated->{name} =~ /\A([\w\s]+)\z/);
=head2 User-supplied regex patterns
The C<matches> rule accepts pre-compiled C<qr//> objects supplied by the caller.
A pathologically constructed pattern (e.g. C<qr/(a+)+b/>) can cause catastrophic
backtracking and peg a CPU core when matched against a hostile input value.
Use possessive quantifiers (C<++>) or atomic groups (C<< (?>...) >>) in any
C<matches> pattern that will be applied to untrusted data.
=head2 Error message content
Error and warning messages produced by this module may include the parameter
value supplied by the caller.
The module strips ASCII control characters (including CR and LF) from all
messages before passing them to the logger or croaking, to prevent log-injection
and HTTP response-splitting attacks.
Callers should nevertheless apply their own output encoding before including any
validated value in an HTTP response, HTML page, or structured log entry.
=head1 SEE ALSO
=over 4
=item * L<Test Dashboard|https://nigelhorne.github.io/Params-Validate-Strict/coverage/>
=item * L<Data::Processor>
=item * L<Params::Get>
=item * L<Params::Smart>
This is where the ideas for C<aliases>, C<slurp> and C<compile_schema> came from.
=item * L<Params::Util>
This is where the ideas for C<regex>, C<handle>, C<arraylike>, C<hashlike>, C<codelike>, C<invocant> came from.
=item * L<Params::SomeUtil>
A maintained fork of L<Params::Util> 1.07 with bug fixes. The same type-predicate ideas apply.
=item * L<Params::Validate>
=item * L<Return::Set>
=item * L<App::Test::Generator>
=back
=head1 SUPPORT
This module is provided as-is without any warranty.
Please report any bugs or feature requests to C<bug-params-validate-strict at rt.cpan.org>,
or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Validate-Strict>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
You can find documentation for this module with the perldoc command.
perldoc Params::Validate::Strict
You can also look for information at:
=over 4
=item * MetaCPAN
L<https://metacpan.org/dist/Params-Validate-Strict>
=item * RT: CPAN's request tracker
L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Params-Validate-Strict>
=item * CPAN Testers' Matrix
L<http://matrix.cpantesters.org/?dist=Params-Validate-Strict>
=item * CPAN Testers Dependencies
L<http://deps.cpantesters.org/?module=Params::Validate::Strict>
=back
=head1 LICENSE AND COPYRIGHT
Copyright 2025-2026 Nigel Horne.
This program is released under the following licence: GPL2.
If you use it,
please let me know.
=cut | |||||
| 2810 | ||||||
| 2811 | 1; | |||||
| 2812 | ||||||