File Coverage

File:blib/lib/Params/Validate/Strict.pm
Coverage:86.4%

linestmtbrancondsubtimecode
1package 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
74our @ISA = qw(Exporter);
75our @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
87our $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.
92our $_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
1209sub 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
2267sub 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.
2289sub _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
2310sub _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
2329sub _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
2349sub _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
2375sub _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
2389sub _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
2404sub _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
2423sub _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
2438sub _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
2476sub _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.
2500sub _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.
2511my %_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).
2517sub _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.
2559sub _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
2566sub _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
2582sub _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
28111;
2812