File Coverage

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

linestmtbrancondsubtimecode
1package Params::Validate::Strict;
2
3# FIXME: {max} doesn't play ball with non-ascii strings
4# TODO: better use of the description parameter in error messages
5# FIXME: ensure paramaters such as min => 1 length constraint applies to all values. In this case, undef should not pass through without a croak.
6# TODO: As well as type => [ 'string', 'arrayref' ], allow type => 'string|arrayref'
7# TODO: Allow a BNF definition of a string
8# e.g.
9#       schema => {
10#               na_tel_no => {
11#                       type => 'string',
12#                       bnf => [
13#                               '<telephone-number> ::= <country-code-opt> <area-code> <separator-opt>',
14#                               '<central-office-code> <separator-opt> <station-code>',
15#
16#                               '<country-code-opt> ::= "" | "+1" | "1"',
17#
18#                               '<separator-opt> ::= "" | "-" | " " | "."',
19#
20#                               '<area-code> ::= <digit2-9> <digit0-9> <digit0-9>',
21#
22#                               '<central-office-code> ::= <digit2-9> <digit0-9> <digit0-9>',
23#
24#                               '<station-code> ::= <digit0-9> <digit0-9> <digit0-9> <digit0-9>',
25#
26#                               '<digit0-9> ::= "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9"',
27#
28#                               '<digit2-9> ::= "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9"',
29#                       ]
30#               }
31#       }
32
33
29
29
29
1490142
20
248
use strict;
34
29
29
29
35
16
373
use warnings;
35
36
29
29
29
33
24
489
use Carp;
37
29
29
29
36
21
270
use Exporter qw(import);        # Required for @EXPORT_OK
38
29
29
29
5105
140878
913
use Encode qw(decode_utf8);
39
29
29
29
61
286
682
use List::Util 1.33 qw(all any);        # Required for memberof/matches validation
40
29
29
29
3985
84471
1227
use Readonly::Values::Boolean;
41
29
29
29
77
29
331
use Scalar::Util;
42
29
29
29
3967
128727
74995
use Unicode::GCString;
43
44our @ISA = qw(Exporter);
45our @EXPORT_OK = qw(validate_strict);
46
47 - 55
=head1 NAME

Params::Validate::Strict - Validates a set of parameters against a schema

=head1 VERSION

Version 0.39

=cut
56
57our $VERSION = '0.39';
58
59 - 1047
=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> 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.

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>)
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.
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>.

=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<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<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.
Currently only C<unix_timestamp> is supported.

  ts => { type => 'integer', semantic => 'unix_timestamp' }

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>.

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
1048
1049sub validate_strict
1050{
1051
1772
273
2693788
296
        my %args = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
1052
1772
1094
        my $params = \%args;
1053
1054
1772
1595
        my $schema = $params->{'schema'} || $params->{'members'};
1055
1772
2067
        my $args = $params->{'args'} || $params->{'input'};
1056
1772
1107
        my $logger = $params->{'logger'};
1057
1772
979
        my $custom_types = $params->{'custom_types'};
1058
1772
1016
        my $unknown_parameter_handler = $params->{'unknown_parameter_handler'};
1059
1772
1277
        if(!defined($unknown_parameter_handler)) {
1060
1745
1157
                if($params->{'carp_on_warn'}) {
1061
2
0
                        $unknown_parameter_handler = 'warn';
1062                } else {
1063
1743
990
                        $unknown_parameter_handler = 'die';
1064                }
1065        }
1066
1067
1772
1238
        return $args if(!defined($schema));     # No schema, allow all arguments
1068
1069        # Accept arrayref schema: [{ name=>'param', type=>'...', ... }, ...]
1070        # Normalise to the standard named-parameter hashref form before further processing.
1071
1768
1308
        if(ref($schema) eq 'ARRAY') {
1072
16
16
                $schema = _schema_from_arrayref($schema, $logger);
1073        }
1074
1075        # Check if schema and args are references to hashes
1076
1762
1271
        if(ref($schema) ne 'HASH') {
1077
3
3
                _error($logger, 'validate_strict: schema must be a hash reference');
1078        }
1079
1080        # Inspired by Data::Processor
1081
1759
1746
        my $schema_description = $params->{'description'} || 'validate_strict';
1082
1759
991
        my $error_msg = $params->{'error_msg'};
1083
1084
1759
1296
        if($schema->{'members'} && ($schema->{'description'} || $schema->{'error_msg'})) {
1085
8
6
                $schema_description = $schema->{'description'};
1086
8
9
                $error_msg = $schema->{'error_msg'};
1087
8
6
                $schema = $schema->{'members'};
1088                # The members value may also be in arrayref form
1089
8
10
                if(ref($schema) eq 'ARRAY') {
1090
1
2
                        $schema = _schema_from_arrayref($schema, $logger);
1091                }
1092        }
1093
1094
1759
2229
        if(exists($params->{'args'}) && (!defined($args))) {
1095
2
1
                $args = {};
1096        } elsif((ref($args) ne 'HASH') && (ref($args) ne 'ARRAY')) {
1097
2
9
                _error($logger, $error_msg || "$schema_description: args must be a hash or array reference");
1098        }
1099
1100
1757
1264
        if(ref($args) eq 'HASH') {
1101                # Named args
1102
1729
1729
886
1378
                foreach my $key (keys %{$args}) {
1103
2051
1564
                        if(!exists($schema->{$key})) {
1104
32
47
                                if($unknown_parameter_handler eq 'die') {
1105
9
14
                                        _error($logger, "$schema_description: Unknown parameter '$key'");
1106                                } elsif($unknown_parameter_handler eq 'warn') {
1107
14
31
                                        _warn($logger, "$schema_description: Unknown parameter '$key'");
1108
14
848
                                        next;
1109                                } elsif($unknown_parameter_handler eq 'ignore') {
1110
5
6
                                        if($logger) {
1111
1
3
                                                $logger->debug(__PACKAGE__ . ": $schema_description: Unknown parameter '$key'");
1112                                        }
1113
5
10
                                        next;
1114                                } else {
1115
4
8
                                        _error($logger, "$schema_description: '$unknown_parameter_handler' unknown_parameter_handler must be one of die, warn, ignore");
1116                                }
1117                        }
1118                }
1119        }
1120
1121        # Find out if this routine takes positional arguments
1122
1744
1045
        my $are_positional_args = -1;
1123
1744
1744
836
1192
        foreach my $key (keys %{$schema}) {
1124
1754
1197
                if(defined(my $rules = $schema->{$key})) {
1125
1752
1164
                        if(ref($rules) eq 'HASH') {
1126
1715
1209
                                if(!defined($rules->{'position'})) {
1127
1674
1084
                                        if($are_positional_args == 1) {
1128
0
0
                                                _error($logger, "::validate_strict: $key is missing position value");
1129                                        }
1130
1674
876
                                        $are_positional_args = 0;
1131
1674
1096
                                        last;
1132                                }
1133
41
40
                                $are_positional_args = 1;
1134                        } else {
1135
37
39
                                $are_positional_args = 0;
1136
37
27
                                last;
1137                        }
1138                } else {
1139
2
2
                        $are_positional_args = 0;
1140
2
1
                        last;
1141                }
1142        }
1143
1144
1744
997
        my %validated_args;
1145        my %invalid_args;
1146
1744
1744
861
1086
        foreach my $key (keys %{$schema}) {
1147
2219
1171
                my $rules = $schema->{$key};
1148
2219
1041
                my $value;
1149
2219
1251
                if($are_positional_args == 1) {
1150
40
37
                        if(ref($args) ne 'ARRAY') {
1151
0
0
                                _error($logger, "::validate_strict: position $rules->{position} given for '$key', but args isn't an array");
1152                        }
1153
40
54
                        $value = $args->[$rules->{'position'}];
1154                } else {
1155
2179
1222
                        $value = $args->{$key};
1156                }
1157
1158
2218
1355
                if(!defined($rules)) {  # Allow anything
1159
2
3
                        $validated_args{$key} = $value;
1160
2
2
                        next;
1161                }
1162
1163                # If rules are a simple type string
1164
2216
1463
                if(ref($rules) eq '') {
1165
30
21
                        $rules = { type => $rules };
1166                }
1167
1168
2216
1077
                my $is_optional = 0;
1169
1170
2216
1056
                my $rule_description = $schema_description;     # Can be overridden in each element
1171
1172
2216
1454
                if(ref($rules) eq 'HASH') {
1173
2196
1418
                        if(exists($rules->{'description'})) {
1174
9
6
                                $rule_description = $rules->{'description'};
1175                        }
1176                        # For stringref: validate and dereference before transform so that
1177                        # transform (and all subsequent rule handlers) see the plain string.
1178                        # Preserve the original ref so optional => CODE receives what the caller passed.
1179
2196
1113
                        my $pre_deref_value = $value;
1180
2196
3547
                        my $is_stringref_type = defined($value) && defined($rules->{'type'}) && !ref($rules->{'type'}) && lc($rules->{'type'}) eq 'stringref';
1181
2196
1364
                        if($is_stringref_type) {
1182
116
90
                                if(ref($value) ne 'SCALAR') {
1183
42
42
                                        my $got = ref($value) ? 'a ' . ref($value) . ' reference' : 'a plain scalar';
1184
42
47
                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be a string reference, not $got");
1185                                }
1186
74
74
34
54
                                $value = ${$value};
1187                        }
1188
2154
1577
                        if($rules->{'transform'} && defined($value)) {
1189
90
104
                                if(ref($rules->{'transform'}) eq 'CODE') {
1190
87
87
54
87
                                        $value = &{$rules->{'transform'}}($value);
1191                                } else {
1192
3
5
                                        _error($logger, "$rule_description: transforms must be a code ref");
1193                                }
1194                        }
1195
2151
3481
                        if(exists($rules->{optional})) {
1196
354
290
                                if(ref($rules->{'optional'}) eq 'CODE') {
1197                                        # For stringref the coderef receives the original SCALAR ref (what
1198                                        # the caller supplied), not the internally-dereferenced plain string.
1199                                        # For all other types the post-transform value is passed, as before.
1200
19
22
                                        my $opt_arg = $is_stringref_type ? $pre_deref_value : $value;
1201
19
19
15
19
                                        $is_optional = &{$rules->{optional}}($opt_arg, $args);
1202                                } else {
1203
335
214
                                        $is_optional = $rules->{'optional'};
1204                                }
1205                        } elsif($rules->{nullable}) {
1206
7
7
                                $is_optional = $rules->{'nullable'};
1207                        } elsif(defined($rules->{'type'}) && !ref($rules->{'type'}) && lc($rules->{'type'}) eq 'void') {
1208
17
8
                                $is_optional = 1;
1209                        }
1210                }
1211
1212                # Handle optional parameters
1213
2171
3058
                if((ref($rules) eq 'HASH') && $is_optional) {
1214                        my $missing = ($are_positional_args == 1)
1215                                ? !defined($args->[$rules->{position}])
1216
363
290
                                : !exists($args->{$key});
1217
363
290
                        if($missing) {
1218
181
150
                                if($are_positional_args == 1) {
1219
5
5
4
11
                                        if(scalar(@{$args}) < $rules->{'position'}) {
1220                                                # arg array is too short, so it must be missing
1221
1
3
                                                _error($logger, "$rule_description: Required parameter '$key' is missing");
1222
0
0
                                                next;
1223                                        }
1224                                }
1225
180
164
                                if(exists($rules->{'default'})) {
1226                                        # Populate missing optional parameters with the specified output values
1227
37
39
                                        $validated_args{$key} = $rules->{'default'};
1228
37
38
                                        next;   # default wins; do not fall through to the schema branch
1229                                }
1230
1231
143
118
                                if($rules->{'schema'}) {
1232
6
11
                                        $value = _apply_nested_defaults({}, $rules->{'schema'});
1233
6
6
5
10
                                        next unless scalar(%{$value});
1234                                        # The nested schema has a default value
1235                                } else {
1236
137
107
                                        next;   # optional and missing
1237                                }
1238                        }
1239                } elsif((ref($args) eq 'HASH') && !exists($args->{$key})) {
1240                        # The parameter is required
1241                        # Use exists rather than defined, so that an undefined value can be passed, but the key is there
1242
21
35
                        _error($logger, "$rule_description: Required parameter '$key' is missing");
1243                }
1244
1245                # Normalise union type shorthand: { type => ['string', 'integer'], ... }
1246                # into the array-of-rules form that the ARRAY handler below already supports.
1247                # Each candidate type inherits all other constraints from the parent rule
1248                # (min, max, matches, optional, etc.) so they are each fully validated.
1249                # Must run after optional/transform handling above but before rule dispatch below.
1250
1971
1995
                if(ref($rules) eq 'HASH' && ref($rules->{'type'}) eq 'ARRAY') {
1251
60
60
34
54
                        my %base = %{$rules};
1252
60
60
42
58
                        my @type_list = @{delete $base{'type'}};
1253
60
55
                        if(!@type_list) {
1254
2
3
                                _error($logger, "$rule_description: Parameter '$key': union type list must not be empty");
1255                        }
1256                        # Expand into one full rule hash per candidate type
1257
58
115
44
115
                        $rules = [ map { { %base, type => $_ } } @type_list ];
1258                }
1259
1260                # Validate based on rules
1261
1969
1211
                if(ref($rules) eq 'HASH') {
1262
1891
2364
                        if(defined(my $min = $rules->{'min'} // $rules->{'minimum'}) && defined(my $max = $rules->{'max'})) {
1263
148
138
                                if($min > $max) {
1264
7
14
                                        _error($logger, "validate_strict($key): min must be <= max ($min > $max)");
1265                                }
1266                        }
1267
1268                        # memberof and its synonym enum cannot be combined with min or max
1269
1884
2389
                        if($rules->{'memberof'} || $rules->{'enum'} || $rules->{'values'}) {
1270
132
208
                                if(defined(my $min = $rules->{'min'} // $rules->{'minimum'})) {
1271
8
12
                                        _error($logger, "validate_strict($key): min ($min) makes no sense with memberof/enum/values");
1272                                }
1273
124
133
                                if(defined(my $max = $rules->{'max'})) {
1274
5
7
                                        _error($logger, "validate_strict($key): max ($max) makes no sense with memberof/enum/values");
1275                                }
1276                        }
1277
1278
1871
3411
1530
2366
                        foreach my $rule_name ('type', grep { $_ ne 'type' } keys %$rules) {
1279
3270
1876
                                my $rule_value = $rules->{$rule_name};
1280
1281
3270
2527
                                if((ref($rule_value) eq 'CODE')
1282                                        && ($rule_name ne 'validate')
1283                                        && ($rule_name ne 'callback')
1284                                        && ($rule_name ne 'validator')
1285                                        && ($rule_name ne 'transform')  # already applied before this loop
1286                                        && ($rule_name ne 'optional')) {        # already applied before this loop
1287
16
16
6
16
                                        $rule_value = &{$rule_value}($value, $args);
1288                                }
1289
1290                                # Better OOP, the routine has been given an object rather than a scalar
1291
3270
2675
                                if(Scalar::Util::blessed($rule_value) && $rule_value->can('as_string')) {
1292
2
3
                                        $rule_value = $rule_value->as_string();
1293                                }
1294
1295
3270
5145
                                if($rule_name eq 'type') {
1296
1871
1051
                                        my $type = lc($rule_value);
1297
1298
1871
3912
                                        if(($type eq 'string') || ($type eq 'str')) {
1299
766
503
                                                if(ref($value)) {
1300
29
38
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be a string");
1301                                                }
1302
737
620
                                                unless((ref($value) eq '') || (defined($value) && length($value))) {    # Allow undef for optional strings
1303
0
0
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be a string");
1304                                                }
1305                                        } elsif(($type eq 'integer') || ($type eq 'int')) {
1306
319
226
                                                if(!defined($value)) {
1307
2
2
                                                        next;   # Skip if number is undefined
1308                                                }
1309
317
722
                                                if(!Scalar::Util::looks_like_number($value) || ($value - $value) != 0 || $value != int($value)) {
1310
33
56
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' ($value) must be an integer");
1311                                                }
1312
284
192
                                                $value = int($value); # Coerce to integer
1313                                        } elsif(($type eq 'number') || ($type eq 'float') || ($type eq 'num') || ($type eq 'double')) {
1314
95
82
                                                if(!defined($value)) {
1315
2
2
                                                        next;   # Skip if number is undefined
1316                                                }
1317
93
106
                                                if(!Scalar::Util::looks_like_number($value)) {
1318
5
11
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be a number");
1319                                                }
1320                                                # $value = eval $value; # Coerce to number (be careful with eval)
1321
88
129
                                                $value = 0 + $value;    # Numeric coercion
1322                                        } elsif($type eq 'arrayref') {
1323
122
100
                                                if(!defined($value)) {
1324
2
2
                                                        next;   # Skip if arrayref is undefined
1325                                                }
1326
120
142
                                                if(ref($value) ne 'ARRAY') {
1327
16
27
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1328                                                }
1329                                        } elsif($type eq 'hashref') {
1330
87
82
                                                if(!defined($value)) {
1331
2
2
                                                        next;   # Skip if hashref is undefined
1332                                                }
1333
85
88
                                                if(ref($value) ne 'HASH') {
1334
5
9
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be an hashref");
1335                                                }
1336                                        } elsif($type eq 'scalar') {
1337
118
92
                                                if(!defined($value)) {
1338
3
3
                                                        next;   # Skip if undefined
1339                                                }
1340
115
114
                                                if(ref($value)) {
1341
47
61
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be a scalar, not a " . ref($value) . ' reference');
1342                                                }
1343                                        } elsif($type eq 'scalarref') {
1344
71
60
                                                if(!defined($value)) {
1345
2
3
                                                        next;   # Skip if undefined
1346                                                }
1347
69
68
                                                if(ref($value) ne 'SCALAR') {
1348
41
48
                                                        my $got = ref($value) ? 'a ' . ref($value) . ' reference' : 'a plain scalar';
1349
41
45
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be a scalar reference, not $got");
1350                                                }
1351                                        } elsif($type eq 'stringref') {
1352
76
64
                                                if(!defined($value)) {
1353
2
2
                                                        next;   # Skip if undefined
1354                                                }
1355                                                # The early-deref block validated the SCALAR ref and set $value to the
1356                                                # plain string.  If transform subsequently returned a reference, reject it.
1357
74
67
                                                if(ref($value)) {
1358
2
3
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' stringref transform must return a plain string, not a " . ref($value) . ' reference');
1359                                                }
1360                                        } elsif($type eq 'void') {
1361
16
16
8
19
                                                if(scalar(keys %{$schema}) != 1) {
1362
2
3
                                                        _error($logger, "$rule_description: type 'void' requires exactly one parameter in the schema");
1363                                                }
1364
14
13
                                                if(defined($value)) {
1365
11
13
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be undef (void type accepts no value)");
1366                                                }
1367                                        } elsif(($type eq 'boolean') || ($type eq 'bool')) {
1368
67
51
                                                if(!defined($value)) {
1369
2
3
                                                        next;   # Skip if bool is undefined
1370                                                }
1371
65
137
                                                if(defined(my $b = $Readonly::Values::Boolean::booleans{$value})) {
1372
58
214
                                                        $value = $b;
1373                                                } else {
1374
7
27
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' ($value) must be a boolean");
1375                                                }
1376                                        } elsif($type eq 'coderef') {
1377
10
13
                                                if(!defined($value)) {
1378
1
0
                                                        next;   # Skip if code is undefined
1379                                                }
1380
9
15
                                                if(ref($value) ne 'CODE') {
1381
3
6
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be a coderef, not a ref to " . ref($value));
1382                                                }
1383                                        } elsif($type eq 'object') {
1384
60
49
                                                if(!defined($value)) {
1385
1
1
                                                        next;   # Skip if object is undefined
1386                                                }
1387
59
88
                                                if(!Scalar::Util::blessed($value)) {
1388
4
8
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must be an object");
1389                                                }
1390                                        } elsif(my $custom_type = $custom_types->{$type}) {
1391
61
57
                                                if($custom_type->{'transform'}) {
1392                                                        # The custom type has a transform embedded within it
1393
9
17
                                                        if(ref($custom_type->{'transform'}) eq 'CODE') {
1394
8
8
6
12
                                                                $value = &{$custom_type->{'transform'}}($value);
1395                                                        } else {
1396
1
2
                                                                _error($logger, "$rule_description: transforms must be a code ref");
1397                                                        }
1398                                                }
1399
60
307
                                                validate_strict({ input => { $key => $value }, schema => { $key => $custom_type }, custom_types => $custom_types });
1400                                        } else {
1401
3
17
                                                _error($logger, "$rule_description: Unknown type '$type'");
1402                                        }
1403                                } elsif(($rule_name eq 'min') || ($rule_name eq 'minimum')) {
1404
332
280
                                        if(!defined($rules->{'type'})) {
1405
0
0
                                                _error($logger, "$rule_description: Don't know type of '$key' to determine its minimum value $rule_value");
1406                                        }
1407
332
227
                                        my $type = lc($rules->{'type'});
1408
332
517
                                        if(exists($custom_types->{$type}->{'min'}) || exists($custom_types->{$type}->{minimum})) {
1409
3
4
                                                $rule_value = $custom_types->{$type}->{'min'} // $custom_types->{$type}->{minimum};
1410
3
3
                                                $type = $custom_types->{$type}->{'type'};
1411                                        }
1412
332
737
                                        if(($type eq 'string') || ($type eq 'str') || ($type eq 'stringref')) {
1413
126
123
                                                if($rule_value < 0) {
1414
3
7
                                                        _rule_error($logger, $rules, "$rule_description: String parameter '$key' has meaningless minimum value that is less than zero");
1415                                                }
1416
123
124
                                                if(!defined($value)) {
1417
0
0
                                                        next;   # Skip if string is undefined
1418                                                }
1419
123
115
                                                if(defined(my $len = _number_of_characters($value))) {
1420
123
236
                                                        if($len < $rule_value) {
1421
32
58
                                                                _rule_error($logger, $rules, "$rule_description: String parameter '$key' too short, ($len characters), must be at least $rule_value characters");
1422
0
0
                                                                $invalid_args{$key} = 1;
1423                                                        }
1424                                                } else {
1425
0
0
                                                        _rule_error($logger, $rules, "$rule_description: '$key' can't be decoded");
1426
0
0
                                                        $invalid_args{$key} = 1;
1427                                                }
1428                                        } elsif($type eq 'arrayref') {
1429
32
32
                                                if(!defined($value)) {
1430
0
0
                                                        next;   # Skip if array is undefined
1431                                                }
1432
32
32
25
43
                                                if(scalar(@{$value}) < $rule_value) {
1433
9
26
                                                _rule_error($logger, $rules, "$rule_description: Parameter '$key' must have at least $rule_value member" . (($rule_value > 1) ? 's' : ''));
1434
0
0
                                                $invalid_args{$key} = 1;
1435                                        }
1436                                        } elsif($type eq 'hashref') {
1437
16
17
                                                if(!defined($value)) {
1438
0
0
                                                        next;   # Skip if hash is undefined
1439                                                }
1440
16
16
10
34
                                                if(scalar(keys(%{$value})) < $rule_value) {
1441
8
20
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must contain at least $rule_value keys");
1442
0
0
                                                        $invalid_args{$key} = 1;
1443                                                }
1444                                        } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
1445
155
110
                                                if(!defined($value)) {
1446
0
0
                                                        next;   # Skip if hash is undefined
1447                                                }
1448
155
140
                                                if(Scalar::Util::looks_like_number($value)) {
1449
155
156
                                                        if($value < $rule_value) {
1450
39
122
                                                                if($rules->{'error_msg'}) {
1451
7
12
                                                                        _error($logger, $rules->{'error_msg'});
1452                                                                } elsif(($type eq 'integer') && ($value == 0)) {
1453
3
6
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be a positive number");
1454                                                                } elsif(($type eq 'integer') && ($value == 1)) {
1455
0
0
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be a positive, non-zero number");
1456                                                                } else {
1457
29
56
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be at least $rule_value");
1458                                                                }
1459
0
0
                                                                $invalid_args{$key} = 1;
1460
0
0
                                                                next;
1461                                                        }
1462                                                } else {
1463
0
0
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' ($value) must be a number");
1464
0
0
                                                        next;
1465                                                }
1466                                        } else {
1467
3
6
                                                _error($logger, "$rule_description: Parameter '$key' of type '$type' has meaningless min value $rule_value");
1468                                        }
1469                                } elsif($rule_name eq 'max') {
1470
176
161
                                        if(!defined($rules->{'type'})) {
1471
0
0
                                                _error($logger, "$rule_description: Don't know type of '$key' to determine its maximum value $rule_value");
1472                                        }
1473
176
147
                                        my $type = lc($rules->{'type'});
1474
176
179
                                        if(exists($custom_types->{$type}->{'max'})) {
1475
4
3
                                                $rule_value = $custom_types->{$type}->{'max'};
1476
4
12
                                                $type = $custom_types->{$type}->{'type'};
1477                                        }
1478
176
450
                                        if(($type eq 'string') || ($type eq 'str') || ($type eq 'stringref')) {
1479
73
62
                                                if(!defined($value)) {
1480
0
0
                                                        next;   # Skip if string is undefined
1481                                                }
1482
73
71
                                                if(defined(my $len = _number_of_characters($value))) {
1483
73
164
                                                        if($len > $rule_value) {
1484
22
47
                                                                _rule_error($logger, $rules, "$rule_description: String parameter '$key' too long, ($len characters), must be no longer than $rule_value");
1485
0
0
                                                                $invalid_args{$key} = 1;
1486                                                        }
1487                                                } else {
1488
0
0
                                                        _rule_error($logger, $rules, "$rule_description: '$key' can't be decoded");
1489
0
0
                                                        $invalid_args{$key} = 1;
1490                                                }
1491                                        } elsif($type eq 'arrayref') {
1492
20
18
                                                if(!defined($value)) {
1493
0
0
                                                        next;   # Skip if string is undefined
1494                                                }
1495
20
20
13
26
                                                if(scalar(@{$value}) > $rule_value) {
1496
9
15
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must contain no more than $rule_value items");
1497
0
0
                                                        $invalid_args{$key} = 1;
1498                                                }
1499                                        } elsif($type eq 'hashref') {
1500
15
13
                                                if(!defined($value)) {
1501
0
0
                                                        next;   # Skip if hash is undefined
1502                                                }
1503
15
15
19
19
                                                if(scalar(keys(%{$value})) > $rule_value) {
1504
8
14
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' must contain no more than $rule_value keys");
1505
0
0
                                                        $invalid_args{$key} = 1;
1506                                                }
1507                                        } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
1508
65
73
                                                if(!defined($value)) {
1509
0
0
                                                        next;   # Skip if hash is undefined
1510                                                }
1511
65
70
                                                if(Scalar::Util::looks_like_number($value)) {
1512
65
77
                                                        if($value > $rule_value) {
1513
17
65
                                                                if($rules->{'error_msg'}) {
1514
0
0
                                                                        _error($logger, $rules->{'error_msg'});
1515                                                                } elsif(($type eq 'integer') && ($value == 0)) {
1516
0
0
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be a negative number");
1517                                                                } elsif(($type eq 'integer') && ($value == -1)) {
1518
0
0
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be a negative, non-zero number");
1519                                                                } else {
1520
17
32
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be no more than $rule_value");
1521                                                                }
1522
0
0
                                                                $invalid_args{$key} = 1;
1523
0
0
                                                                next;
1524                                                        }
1525                                                } else {
1526
0
0
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' ($value) must be a number");
1527
0
0
                                                        next;
1528                                                }
1529                                        } else {
1530
3
6
                                                _error($logger, "$rule_description: Parameter '$key' of type '$type' has meaningless max value $rule_value");
1531                                        }
1532                                } elsif(($rule_name eq 'matches') || ($rule_name eq 'regex')) {
1533
126
117
                                        if(!defined($value)) {
1534
1
2
                                                next;   # Skip if string is undefined
1535                                        }
1536
125
87
                                        eval {
1537
125
182
                                                my $re = (ref($rule_value) eq 'Regexp') ? $rule_value : qr/\Q$rule_value\E/;
1538
125
422
                                                if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1539                                                        # all{} short-circuits on first failure and allocates no temp array
1540
5
11
5
11
27
10
                                                        unless(all { $_ =~ $re } @{$value}) {
1541
2
2
4
7
                                                                _rule_error($logger, $rules, "$rule_description: All members of parameter '$key' [", join(', ', @{$value}), "] must match pattern '$rule_value'");
1542                                                        }
1543                                                } elsif($value !~ $re) {
1544
35
97
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' ($value) must match pattern '$re'");
1545                                                }
1546
88
74
                                                1;
1547                                        };
1548
125
7146
                                        if($@) {
1549
37
90
                                                _rule_error($logger, $rules, "$rule_description: Parameter '$key' regex '$rule_value' error: $@");
1550
0
0
                                                $invalid_args{$key} = 1;
1551                                        }
1552                                } elsif($rule_name eq 'nomatch') {
1553
26
44
                                        if(!defined($value)) {
1554
0
0
                                                next;   # Skip if string is undefined
1555                                        }
1556                                        # Compile string patterns with \Q...\E so metacharacters are
1557                                        # treated as literals, matching the behaviour of 'matches'.
1558
26
29
                                        my $re = (ref($rule_value) eq 'Regexp') ? $rule_value : qr/\Q$rule_value\E/;
1559
26
22
                                        eval {
1560
26
85
                                                if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1561                                                        # any{} short-circuits on first match and allocates no temp array
1562
5
13
5
8
21
8
                                                        if(any { $_ =~ $re } @{$value}) {
1563
2
2
3
6
                                                                _rule_error($logger, $rules, "$rule_description: No member of parameter '$key' [", join(', ', @{$value}), "] must match pattern '$rule_value'");
1564                                                        }
1565                                                } elsif($value =~ $re) {
1566
10
35
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' ($value) must not match pattern '$rule_value'");
1567
0
0
                                                        $invalid_args{$key} = 1;
1568                                                }
1569
14
16
                                                1;
1570                                        };
1571
26
2262
                                        if($@) {
1572
12
27
                                                _rule_error($logger, $rules, "$rule_description: Parameter '$key' regex '$rule_value' error: $@");
1573
0
0
                                                $invalid_args{$key} = 1;
1574                                        }
1575                                } elsif(($rule_name eq 'memberof') || ($rule_name eq 'enum') || ($rule_name eq 'values')) {
1576
118
103
                                        if(!defined($value)) {
1577
0
0
                                                next;   # Skip if string is undefined
1578                                        }
1579
118
107
                                        if(ref($rule_value) eq 'ARRAY') {
1580
116
204
                                                unless(_value_in_list($value, $rule_value, $rules->{'type'} // '', $rules->{'case_sensitive'})) {
1581
42
42
51
83
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' ($value) must be one of ", join(', ', @{$rule_value}));
1582
0
0
                                                        $invalid_args{$key} = 1;
1583                                                }
1584                                        } else {
1585
2
5
                                                _rule_error($logger, $rules, "$rule_description: Parameter '$key' rule ($rule_value) must be an array reference");
1586                                        }
1587                                } elsif($rule_name eq 'notmemberof') {
1588
50
39
                                        if(!defined($value)) {
1589
0
0
                                                next;   # Skip if string is undefined
1590                                        }
1591
50
45
                                        if(ref($rule_value) eq 'ARRAY') {
1592
49
77
                                                if(_value_in_list($value, $rule_value, $rules->{'type'} // '', $rules->{'case_sensitive'})) {
1593
27
27
32
47
                                                        _rule_error($logger, $rules, "$rule_description: Parameter '$key' ($value) must not be one of ", join(', ', @{$rule_value}));
1594
0
0
                                                        $invalid_args{$key} = 1;
1595                                                }
1596                                        } else {
1597
1
2
                                                _rule_error($logger, $rules, "$rule_description: Parameter '$key' rule ($rule_value) must be an array reference");
1598                                        }
1599                                } elsif($rule_name eq 'isa') {
1600
23
28
                                        if(!defined($value)) {
1601
0
0
                                                next;   # Skip if object not given
1602                                        }
1603
23
23
                                        if($rules->{'type'} eq 'object') {
1604
20
70
                                                if(!$value->isa($rule_value)) {
1605
6
38
                                                        _error($logger, "$rule_description: Parameter '$key' must be a '$rule_value' object got a " . (ref($value) ? ref($value) : $value) . ' object instead');
1606
0
0
                                                        $invalid_args{$key} = 1;
1607                                                }
1608                                        } else {
1609
3
6
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless isa value $rule_value");
1610                                        }
1611                                } elsif($rule_name eq 'can') {
1612
38
35
                                        if(!defined($value)) {
1613
0
0
                                                next;   # Skip if object not given
1614                                        }
1615
38
39
                                        if($rules->{'type'} eq 'object') {
1616
35
58
                                                if(ref($rule_value) eq 'ARRAY') {
1617                                                        # List of methods
1618
15
15
9
16
                                                        foreach my $method(@{$rule_value}) {
1619
29
52
                                                                if(!$value->can($method)) {
1620
6
15
                                                                        _error($logger, "$rule_description: Parameter '$key' must be an object that understands the $method method");
1621
0
0
                                                                        $invalid_args{$key} = 1;
1622                                                                }
1623                                                        }
1624                                                } elsif(!ref($rule_value)) {
1625
19
71
                                                        if(!$value->can($rule_value)) {
1626
8
15
                                                                _error($logger, "$rule_description: Parameter '$key' must be an object that understands the $rule_value method");
1627
0
0
                                                                $invalid_args{$key} = 1;
1628                                                        }
1629                                                } else {
1630
1
2
                                                        _error($logger, "$rule_description: 'can' rule for Parameter '$key must be either a scalar or an arrayref");
1631                                                }
1632                                        } else {
1633
3
5
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless can value '$rule_value' for parameter type $rules->{type}");
1634                                        }
1635                                } elsif($rule_name eq 'element_type') {
1636
45
91
                                        if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1637
42
26
                                                my $type = $rule_value;
1638
42
32
                                                my $custom_type = $custom_types->{$rule_value};
1639
42
51
                                                if($custom_type && $custom_type->{'type'}) {
1640
4
5
                                                        $type = $custom_type->{'type'};
1641                                                }
1642
42
42
30
35
                                                foreach my $member(@{$value}) {
1643
103
83
                                                        if($custom_type && $custom_type->{'transform'}) {
1644                                                                # The custom type has a transform embedded within it
1645
5
6
                                                                if(ref($custom_type->{'transform'}) eq 'CODE') {
1646
4
4
3
5
                                                                        $member = &{$custom_type->{'transform'}}($member);
1647                                                                } else {
1648
1
3
                                                                        _error($logger, "$rule_description: transforms must be a code ref");
1649                                                                }
1650                                                        }
1651
102
126
                                                        if(($type eq 'string') || ($type eq 'Str')) {
1652
41
37
                                                                if(ref($member)) {
1653
2
4
                                                                        _rule_error($logger, $rules, "$key can only contain strings");
1654
0
0
                                                                        $invalid_args{$key} = 1;
1655                                                                }
1656                                                        } elsif($type eq 'integer') {
1657
46
77
                                                                if(ref($member) || ($member =~ /\D/)) {
1658
7
14
                                                                        _rule_error($logger, $rules, "$key can only contain integers (found $member)");
1659
0
0
                                                                        $invalid_args{$key} = 1;
1660                                                                }
1661                                                        } elsif(($type eq 'number') || ($rule_value eq 'float')) {
1662
14
40
                                                                if(ref($member) || ($member !~ /^[-+]?(?:\d+(?:\.\d*)?|\.\d+)$/)) {
1663
2
5
                                                                        _rule_error($logger, $rules, "$key can only contain numbers (found $member)");
1664
0
0
                                                                        $invalid_args{$key} = 1;
1665                                                                }
1666                                                        } elsif($type eq 'object') {
1667
0
0
                                                                if(!Scalar::Util::blessed($member)) {
1668
0
0
                                                                        _rule_error($logger, $rules, "$key can only contain objects (found $member)");
1669
0
0
                                                                        $invalid_args{$key} = 1;
1670                                                                }
1671                                                        } else {
1672
1
1
                                                                _error($logger, "BUG: Add $type to element_type list");
1673                                                        }
1674                                                }
1675                                        } else {
1676
3
5
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless element_type value $rule_value");
1677                                        }
1678                                } elsif($rule_name eq 'optional') {
1679                                        # Already handled at the beginning of the loop
1680                                } elsif($rule_name eq 'nullable') {
1681                                        # Already handled at the beginning of the loop (same as optional)
1682                                } elsif($rule_name eq 'default') {
1683                                        # Handled earlier
1684                                } elsif($rule_name eq 'error_msg') {
1685                                        # Handled inline
1686                                } elsif($rule_name eq 'transform') {
1687                                        # Handled before the loop
1688                                } elsif($rule_name eq 'case_sensitive') {
1689                                        # Handled inline
1690                                } elsif($rule_name eq 'description') {
1691                                        # A la, Data::Processor
1692                                } elsif($rule_name =~ /^_/) {
1693                                        # Ignore internal/metadata fields from schema extraction
1694                                } elsif($rule_name eq 'semantic') {
1695
11
11
                                        if($rule_value eq 'unix_timestamp') {
1696
9
15
                                                if($value < 0 || $value > 2147483647) {
1697
4
4
                                                        _error($logger, "Invalid Unix timestamp: $value");
1698                                                }
1699                                        } else {
1700
2
4
                                                _warn($logger, "semantic type $rule_value is not yet supported");
1701                                        }
1702                                } elsif($rule_name eq 'schema') {
1703                                        # Nested schema Run the given schema against each element of the array
1704
67
114
                                        if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1705
16
28
                                                if(ref($value) eq 'ARRAY') {
1706
16
16
7
21
                                                        foreach my $member(@{$value}) {
1707                                                                # Distinguish two schema forms:
1708                                                                # (a) Rule hash   â€” has a top-level 'type' key, e.g. { type=>'string', matches=>qr/.../ }
1709                                                                #     â†’ validate each element against that rule directly.
1710                                                                # (b) Field-schema hash — keys are field names whose values are rule hashes,
1711                                                                #     e.g. { name=>{type=>'string'}, age=>{type=>'integer'} }
1712                                                                #     â†’ validate each hashref element against the field schema directly.
1713
26
38
                                                                my $is_field_schema = (ref($rule_value) eq 'HASH') && !exists($rule_value->{'type'});
1714
26
22
                                                                my %inner = (custom_types => $custom_types);
1715
26
26
                                                                if($is_field_schema) {
1716
7
5
                                                                        $inner{input}  = $member;
1717
7
6
                                                                        $inner{schema} = $rule_value;
1718                                                                } else {
1719
19
16
                                                                        $inner{input}  = { $key => $member };
1720
19
27
                                                                        $inner{schema} = { $key => $rule_value };
1721                                                                }
1722
26
71
                                                                if(!validate_strict(\%inner)) {
1723
0
0
                                                                        $invalid_args{$key} = 1;
1724                                                                }
1725                                                        }
1726                                                } elsif(defined($value)) {      # Allow undef for optional values
1727
0
0
                                                        _error($logger, "$rule_description: nested schema: Parameter '$value' must be an arrayref");
1728                                                }
1729                                        } elsif($rules->{'type'} eq 'hashref') {
1730
50
58
                                                if(ref($rule_value) eq 'HASH') {
1731                                                        # Apply nested defaults before validation
1732
50
56
                                                        my $nested_with_defaults = _apply_nested_defaults($value, $rule_value);
1733
50
50
27
56
                                                        if(scalar keys(%{$nested_with_defaults})) {
1734
48
240
                                                                if(my $new_args = validate_strict({ input => $nested_with_defaults, schema => $rule_value, custom_types => $custom_types })) {
1735
34
51
                                                                        $value = $new_args;
1736                                                                } else {
1737
0
0
                                                                        $invalid_args{$key} = 1;
1738                                                                }
1739                                                        }
1740                                                } else {
1741
0
0
                                                        _error($logger, "$rule_description: nested schema: Parameter '$value' must be an hashref");
1742                                                }
1743                                        } else {
1744
1
2
                                                _error($logger, "$rule_description: Parameter '$key': 'schema' only supports arrayref and hashref, not $rules->{type}");
1745                                        }
1746                                } elsif(($rule_name eq 'validate') || ($rule_name eq 'validator')) {
1747
15
15
                                        if(ref($rule_value) eq 'CODE') {
1748
13
13
19
17
                                                if(my $error = &{$rule_value}($args)) {
1749
5
19
                                                        _error($logger, "$rule_description: $key not valid: $error");
1750
0
0
                                                        $invalid_args{$key} = 1;
1751                                                }
1752                                        } else {
1753                                                # _error($logger, "$rule_description: Parameter '$key': 'validate' only supports coderef, not $value");
1754
2
4
                                                _error($logger, "$rule_description: Parameter '$key': 'validate' only supports coderef, not " . ref($rule_value) // $rule_value);
1755                                        }
1756                                } elsif ($rule_name eq 'callback') {
1757                                        # Custom validation code
1758
50
53
                                        unless (defined &$rule_value) {
1759
1
1
                                                _error($logger, "$rule_description: callback for '$key' must be a code reference");
1760                                        }
1761
49
57
                                        my $res = $rule_value->($value, $args, $schema);
1762
47
121
                                        unless ($res) {
1763
18
34
                                                _rule_error($logger, $rules, "$rule_description: Parameter '$key' failed custom validation");
1764
0
0
                                                $invalid_args{$key} = 1;
1765                                        }
1766                                } elsif($rule_name eq 'position') {
1767
31
34
                                        if($rule_value < 0) {
1768
0
0
                                                _error($logger, "$rule_description: Parameter '$key': 'position' must be a positive integer, not $value");
1769                                        }
1770
31
50
                                        if($rule_value =~ /\D/) {
1771
1
2
                                                _error($logger, "$rule_description: Parameter '$key': 'position' must be a positive integer");
1772                                        }
1773                                } else {
1774
2
4
                                        _error($logger, "$rule_description: Unknown rule '$rule_name'");
1775                                }
1776                        }
1777                } elsif(ref($rules) eq 'ARRAY') {
1778
76
76
40
70
                        if(scalar(@{$rules})) {
1779                                # An argument can be one of several different types.
1780                                # This path handles both explicit array-of-rules schemas and the
1781                                # normalised form of union type shorthand (type => ['a', 'b', ...]).
1782
74
39
                                my $rc = 0;
1783
74
42
                                my @types;
1784
74
74
37
68
                                foreach my $rule(@{$rules}) {
1785
120
106
                                        if(ref($rule) ne 'HASH') {
1786
1
3
                                                _error($logger, "$rule_description: Parameter '$key' rules must be a hash reference");
1787                                        }
1788
119
104
                                        if(!defined($rule->{'type'})) {
1789
0
0
                                                _error($logger, "$rule_description: Parameter '$key' is missing a type in an alternative");
1790                                        }
1791
119
81
                                        push @types, $rule->{'type'};
1792
119
71
                                        my $result;
1793
119
63
                                        eval {
1794
119
272
                                                $result = validate_strict({ input => { $key => $value }, schema => { $key => $rule }, logger => undef, custom_types => $custom_types });
1795                                        };
1796
119
11402
                                        if(!$@) {
1797                                                # Capture coercion performed by the successful sub-validation
1798                                                # (e.g. integer/number coercion) so the outer scope sees it.
1799
51
56
                                                $value = $result->{$key} if(defined($result));
1800
51
29
                                                $rc = 1;
1801
51
47
                                                last;
1802                                        }
1803                                }
1804
73
77
                                if(!$rc) {
1805
22
37
                                        _error($logger, "$rule_description: Parameter: '$key': must be one of " . join(', ', @types));
1806
0
0
                                        $invalid_args{$key} = 1;
1807                                }
1808                        } else {
1809
2
4
                                _error($logger, "$rule_description: Parameter: '$key': schema is empty arrayref");
1810                        }
1811                } elsif(ref($rules)) {
1812
2
3
                        _error($logger, 'rules must be a hash reference or string');
1813                }
1814
1815
1320
1492
                $validated_args{$key} = $value;
1816        }
1817
1818        # Validate parameter relationships
1819
1025
865
        if (my $relationships = $params->{'relationships'}) {
1820
56
60
                _validate_relationships(\%validated_args, $relationships, $logger, $schema_description);
1821        }
1822
1823
999
692
        if(my $cross_validation = $params->{'cross_validation'}) {
1824
56
56
33
40
                foreach my $validator_name(keys %{$cross_validation}) {
1825
62
45
                        my $validator = $cross_validation->{$validator_name};
1826
62
75
                        if((!ref($validator)) || (ref($validator) ne 'CODE')) {
1827
2
4
                                _error($logger, "$schema_description: cross_validation $validator is not a code snippet");
1828
0
0
                                next;
1829                        }
1830
60
60
36
54
                        if(my $error = &{$validator}(\%validated_args, $validator)) {
1831
25
66
                                _error($logger, $error);
1832                                # We have no idea which parameters are still valid, so let's invalidate them all
1833
0
0
                                return;
1834                        }
1835                }
1836        }
1837
1838
971
751
        foreach my $key(keys %invalid_args) {
1839
0
0
                delete $validated_args{$key};
1840        }
1841
1842
971
616
        if($are_positional_args == 1) {
1843
21
25
                my @rc;
1844
21
21
15
23
                foreach my $key (keys %{$schema}) {
1845                        # Use exists() rather than if(my $value = ...) so that falsy but
1846                        # valid coerced values (integer 0, empty string, undef from an
1847                        # absent optional) are not silently dropped from the return array.
1848
34
36
                        if(exists $validated_args{$key}) {
1849
32
25
                                my $value = delete $validated_args{$key};
1850
32
36
                                my $position = $schema->{$key}->{'position'};
1851
32
30
                                if(defined($rc[$position])) {
1852
2
5
                                        _error($logger, "$schema_description: $key: position $position appears twice");
1853                                }
1854
30
59
                                $rc[$position] = $value;
1855                        }
1856                }
1857
19
35
                return \@rc;
1858        }
1859
950
1339
        return \%validated_args;
1860}
1861
1862# _schema_from_arrayref($arrayref, $logger)
1863#
1864# Normalise an arrayref schema:
1865#   [ { name => 'param', type => 'string', ... }, ... ]
1866# to the standard named-parameter hashref form:
1867#   { param => { type => 'string', ... }, ... }
1868#
1869# The 'name' key is consumed during conversion and does not become a rule.
1870# Croaks if any element is not a hashref, is missing 'name', or if a name
1871# appears more than once.
1872sub _schema_from_arrayref
1873{
1874
17
13
        my ($arrayref, $logger) = @_;
1875
1876
17
10
        my %schema;
1877
17
17
10
17
        foreach my $spec (@{$arrayref}) {
1878
23
26
                _error($logger, "validate_strict: each arrayref schema element must be a hashref")
1879                        unless ref($spec) eq 'HASH';
1880                _error($logger, "validate_strict: arrayref schema element must have a 'name' key")
1881
21
21
                        unless exists($spec->{'name'});
1882
19
19
7
20
                my %rule = %{$spec};
1883
19
14
                my $name = delete $rule{'name'};
1884                _error($logger, "validate_strict: duplicate parameter '$name' in arrayref schema")
1885
19
17
                        if exists($schema{$name});
1886
17
12
                $schema{$name} = \%rule;
1887        }
1888
11
9
        return \%schema;
1889}
1890
1891# Return number of visible characters not number of bytes
1892# Ensure string is decoded into Perl characters
1893sub _number_of_characters
1894{
1895
201
63767
        my $value = $_[0];
1896
1897
201
146
        return if(!defined($value));
1898
1899
200
545
        if($value !~ /[^[:ascii:]]/) {
1900
171
190
                return length($value);
1901        }
1902        # Decode only if it's not already a Perl character string
1903
29
89
        $value = decode_utf8($value) unless utf8::is_utf8($value);
1904
1905        # Count grapheme clusters (visible characters)
1906        # The pseudo-operator () = forces list context to count matches
1907        # return scalar( () = $value =~ /\X/g );
1908
1909
29
70
        return Unicode::GCString->new($value)->length();
1910}
1911
1912sub _apply_nested_defaults {
1913
70
3959
        my ($input, $schema) = @_;
1914
70
73
        my %result = %$input;
1915
1916
70
66
        foreach my $key (keys %$schema) {
1917
151
74
                my $rules = $schema->{$key};
1918
1919
151
199
                if (ref $rules eq 'HASH' && exists $rules->{default} && !exists $result{$key}) {
1920
11
10
                        $result{$key} = $rules->{default};
1921                }
1922
1923                # Recursively handle nested schema
1924
151
216
                if((ref $rules eq 'HASH') && $rules->{schema} && (ref $result{$key} eq 'HASH')) {
1925
10
17
                        $result{$key} = _apply_nested_defaults($result{$key}, $rules->{schema});
1926                }
1927        }
1928
1929
70
68
        return \%result;
1930}
1931
1932sub _validate_relationships {
1933
56
50
        my ($validated_args, $relationships, $logger, $description) = @_;
1934
1935
56
52
        return unless ref($relationships) eq 'ARRAY';
1936
1937
56
39
        foreach my $rel (@$relationships) {
1938
56
55
                my $type = $rel->{type} or next;
1939
1940
56
104
                if ($type eq 'mutually_exclusive') {
1941
8
13
                        _validate_mutually_exclusive($validated_args, $rel, $logger, $description);
1942                } elsif ($type eq 'required_group') {
1943
7
16
                        _validate_required_group($validated_args, $rel, $logger, $description);
1944                } elsif ($type eq 'conditional_requirement') {
1945
9
14
                        _validate_conditional_requirement($validated_args, $rel, $logger, $description);
1946                } elsif ($type eq 'dependency') {
1947
7
33
                        _validate_dependency($validated_args, $rel, $logger, $description);
1948                } elsif ($type eq 'value_constraint') {
1949
17
40
                        _validate_value_constraint($validated_args, $rel, $logger, $description);
1950                } elsif ($type eq 'value_conditional') {
1951
7
10
                        _validate_value_conditional($validated_args, $rel, $logger, $description);
1952                } else {
1953
1
2
                        _error($logger, "Unknown relationship type $type");
1954                }
1955        }
1956}
1957
1958sub _validate_mutually_exclusive {
1959
12
4020
        my ($args, $rel, $logger, $description) = @_;
1960
1961
12
12
9
20
        my @params = @{$rel->{params} || []};
1962
12
16
        return unless @params >= 2;
1963
1964
12
24
13
22
        my @present = grep { _param_defined($args, $_) } @params;
1965
1966
12
21
        if (@present > 1) {
1967
6
14
                my $msg = $rel->{description} || 'Cannot specify both ' . join(' and ', @present);
1968
6
13
                _error($logger, "$description: $msg");
1969        }
1970}
1971
1972sub _validate_required_group {
1973
9
1687
        my ($args, $rel, $logger, $description) = @_;
1974
1975
9
9
7
24
        my @params = @{$rel->{params} || []};
1976
9
14
        return unless @params >= 2;
1977
1978
8
16
10
15
        my @present = grep { _param_defined($args, $_) } @params;
1979
1980
8
16
        if (@present == 0) {
1981                my $msg = $rel->{description} ||
1982
4
12
                        'Must specify at least one of: ' . join(', ', @params);
1983
4
5
                _error($logger, "$description: $msg");
1984        }
1985}
1986
1987sub _validate_conditional_requirement {
1988
13
3205
        my ($args, $rel, $logger, $description) = @_;
1989
1990
13
19
        my $if_param = $rel->{if} or return;
1991
12
15
        my $then_param = $rel->{then_required} or return;
1992
1993        # If the condition parameter is present and defined
1994
11
30
        if (_param_defined($args, $if_param)) {
1995                # Check if it's truthy (for booleans and general values)
1996
9
11
                if ($args->{$if_param}) {
1997                        # Then the required parameter must also be present
1998
7
8
                        unless (_param_defined($args, $then_param)) {
1999
3
12
                                my $msg = $rel->{description} || "When $if_param is specified, $then_param is required";
2000
3
5
                                _error($logger, "$description: $msg");
2001                        }
2002                }
2003        }
2004}
2005
2006sub _validate_dependency {
2007
10
2474
        my ($args, $rel, $logger, $description) = @_;
2008
2009
10
50
        my $param = $rel->{param} or return;
2010
9
15
        my $requires = $rel->{requires} or return;
2011
2012        # If param is present, requires must also be present
2013
9
15
        if (_param_defined($args, $param)) {
2014
6
6
                unless (_param_defined($args, $requires)) {
2015
4
8
                        my $msg = $rel->{description} || "$param requires $requires to be specified";
2016
4
7
                        _error($logger, "$description: $msg");
2017                }
2018        }
2019}
2020
2021sub _validate_value_constraint {
2022
32
5236
        my ($args, $rel, $logger, $description) = @_;
2023
2024
32
36
        my $if_param = $rel->{if} or return;
2025
32
29
        my $then_param = $rel->{then} or return;
2026
32
47
        my $operator = $rel->{operator} or return;
2027
32
29
        my $value = $rel->{value};
2028
32
28
        return unless defined $value;
2029
2030        # If the condition parameter is present and truthy
2031
32
28
        if (_param_defined($args, $if_param) && $args->{$if_param}) {
2032                # Check if the then parameter exists
2033
29
20
                if (_param_defined($args, $then_param)) {
2034
29
19
                        my $actual = $args->{$then_param};
2035
29
14
                        my $valid = 0;
2036
2037
29
42
                        if ($operator eq '==') {
2038
8
9
                                $valid = ($actual == $value);
2039                        } elsif ($operator eq '!=') {
2040
4
4
                                $valid = ($actual != $value);
2041                        } elsif ($operator eq '<') {
2042
4
2
                                $valid = ($actual < $value);
2043                        } elsif ($operator eq '<=') {
2044
4
4
                                $valid = ($actual <= $value);
2045                        } elsif ($operator eq '>') {
2046
4
3
                                $valid = ($actual > $value);
2047                        } elsif ($operator eq '>=') {
2048
4
2
                                $valid = ($actual >= $value);
2049                        }
2050
2051
29
31
                        unless ($valid) {
2052
17
36
                                my $msg = $rel->{description} || "When $if_param is specified, $then_param must be $operator $value (got $actual)";
2053
17
20
                                _error($logger, "$description: $msg");
2054                        }
2055                }
2056        }
2057}
2058
2059sub _validate_value_conditional {
2060
11
3404
        my ($args, $rel, $logger, $description) = @_;
2061
2062
11
16
        my $if_param = $rel->{if} or return;
2063
11
9
        my $equals = $rel->{equals};
2064
11
14
        my $then_param = $rel->{then_required} or return;
2065
11
19
        return unless defined $equals;
2066
2067        # If the parameter has the specific value
2068
11
11
        if (_param_defined($args, $if_param)) {
2069
9
12
                if ($args->{$if_param} eq $equals) {
2070                        # Then the required parameter must be present
2071
6
8
                        unless (_param_defined($args, $then_param)) {
2072                                my $msg = $rel->{description} ||
2073
4
12
                                        "When $if_param equals '$equals', $then_param is required";
2074
4
7
                                _error($logger, "$description: $msg");
2075                        }
2076                }
2077        }
2078}
2079
2080# Emit either the rule's custom error_msg or the supplied default message.
2081# Accepts a list for @default_parts so callers can pass join() fragments
2082# without pre-allocating a concatenated string.
2083sub _rule_error
2084{
2085
535
467
        my ($logger, $rules, @default_parts) = @_;
2086
535
848
        _error($logger, $rules->{'error_msg'} || join('', @default_parts));
2087}
2088
2089# Package-level cache: maps "refaddr(list):mode" -> [weak_list_ref, lookup_hash].
2090# Each entry holds a WEAK reference to the original list arrayref alongside the
2091# compiled lookup hash.  When the list goes out of scope and is freed, the weak
2092# reference becomes undef; the next access detects the stale entry and rebuilds,
2093# preventing false cache hits after address reuse.
2094my %_pvs_memberof_cache;
2095
2096# Return true if $value is present in $list, respecting numeric vs string
2097# comparison and the case_sensitive flag.  Used by both memberof and notmemberof.
2098# On the first call for a given ($list, mode) pair the lookup hash is built
2099# (O(k)); subsequent calls with the same live list object are O(1).
2100sub _value_in_list
2101{
2102
165
180
        my ($value, $list, $type, $case_sensitive) = @_;
2103
165
287
        my $is_numeric = ($type eq 'integer') || ($type eq 'number') || ($type eq 'float');
2104
165
235
        my $is_icase   = !$is_numeric && defined($case_sensitive) && !$case_sensitive;
2105
2106        # Key combines address and comparison mode so the same list object can be
2107        # cached under multiple modes without collision.
2108
165
254
        my $ckey = Scalar::Util::refaddr($list) . ($is_numeric ? 'n' : $is_icase ? 'i' : 's');
2109
165
132
        my $entry = $_pvs_memberof_cache{$ckey};
2110
2111        # Stale check: if the weak ref is dead the list was freed and its address
2112        # may have been reused by a different list — discard the cached hash.
2113
165
177
        if(defined($entry) && !defined($entry->[0])) {
2114
0
0
                delete $_pvs_memberof_cache{$ckey};
2115
0
0
                $entry = undef;
2116        }
2117
2118
165
136
        unless(defined $entry) {
2119
121
60
                my $lookup;
2120
121
111
                if($is_numeric) {
2121                        # Normalise to numeric value so "1" and "1.0" hash identically.
2122
22
82
22
20
105
34
                        $lookup = { map { ($_ + 0) => 1 } @{$list} };
2123                } elsif($is_icase) {
2124
14
32
14
12
43
12
                        $lookup = { map { lc($_) => 1 } @{$list} };
2125                } else {
2126
85
292
85
64
283
53
                        $lookup = { map { $_ => 1 } @{$list} };
2127                }
2128                # Store [weak_ref_to_list, lookup_hash] — weak ref does not prevent GC.
2129
121
101
                my $weak = $list;
2130
121
137
                Scalar::Util::weaken($weak);
2131
121
148
                $_pvs_memberof_cache{$ckey} = [$weak, $lookup];
2132
121
100
                $entry = $_pvs_memberof_cache{$ckey};
2133        }
2134
2135
165
108
        my $lookup = $entry->[1];
2136        return $is_numeric ? exists($lookup->{$value + 0})
2137             : $is_icase   ? exists($lookup->{lc($value)})
2138
165
310
             :               exists($lookup->{$value});
2139}
2140
2141# Return true when $args->{$param} is both present (exists) and defined.
2142sub _param_defined
2143{
2144
151
99
        my ($args, $param) = @_;
2145
151
268
        return exists($args->{$param}) && defined($args->{$param});
2146}
2147
2148# Helper to log error or croak
2149sub _error
2150{
2151
800
2591
        my $logger = shift;
2152
800
631
        my $message = join('', @_);
2153        # Strip ASCII control characters to prevent log-injection / CRLF attacks
2154        # when user-supplied values appear in the message.
2155
800
777
        $message =~ s/[[:cntrl:]]/ /g;
2156
2157
800
661
        my @call_details = caller(0);
2158
800
8579
        if($logger) {
2159
21
40
                $logger->error(__PACKAGE__, ' line ', $call_details[2], ": $message");
2160        }
2161
800
2958
        croak(__PACKAGE__, ' line ', $call_details[2], ": $message");
2162}
2163
2164# Helper to log warning or carp
2165sub _warn
2166{
2167
18
2623
        my $logger = shift;
2168
18
21
        my $message = join('', @_);
2169        # Strip ASCII control characters to prevent log-injection / CRLF attacks.
2170
18
23
        $message =~ s/[[:cntrl:]]/ /g;
2171
2172
18
28
        if($logger) {
2173
7
15
                $logger->warn(__PACKAGE__, ": $message");
2174        } else {
2175
11
40
                carp(__PACKAGE__, ": $message");
2176        }
2177}
2178
2179 - 2367
=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 | scalar | scalarref | stringref | arrayref | hashref | coderef | object

    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;
        can: METHOD_NAME
    ]

    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>

=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
2368
23691;
2370