File Coverage

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

linestmtbrancondsubtimecode
1package Params::Validate::Strict;
2
3# FIXME: {max} doesn't play ball with non-ascii strings
4
5
25
25
25
1611642
23
330
use strict;
6
25
25
25
39
18
409
use warnings;
7
8
25
25
25
44
20
528
use Carp;
9
25
25
25
35
24
304
use Exporter qw(import);        # Required for @EXPORT_OK
10
25
25
25
5068
151078
963
use Encode qw(decode_utf8);
11
25
25
25
62
262
664
use List::Util 1.33 qw(any);    # Required for memberof validation
12
25
25
25
4004
104738
474
use Params::Get 0.13;
13
25
25
25
4005
93911
1255
use Readonly::Values::Boolean;
14
25
25
25
58
19
337
use Scalar::Util;
15
25
25
25
3920
162830
85916
use Unicode::GCString;
16
17our @ISA = qw(Exporter);
18our @EXPORT_OK = qw(validate_strict);
19
20 - 28
=head1 NAME

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

=head1 VERSION

Version 0.32

=cut
29
30our $VERSION = '0.32';
31
32 - 998
=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 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 find 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/^[\w\.\-]+@[\w\.\-]+\.\w+$/,
      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<hashref>, C<arrayref>, C<object> and C<coderef>.

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/^[\w\.\-]+@[\w\.\-]+\.\w+$/
  }

  # 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/^[\w\.\-]+@[\w\.\-]+\.\w+$/
    }
  };

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 * 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
999
1000sub validate_strict
1001{
1002
1094
2911064
        my $params = Params::Get::get_params(undef, \@_);
1003
1004
1094
12838
        my $schema = $params->{'schema'} || $params->{'members'};
1005
1094
1732
        my $args = $params->{'args'} || $params->{'input'};
1006
1094
824
        my $logger = $params->{'logger'};
1007
1094
755
        my $custom_types = $params->{'custom_types'};
1008
1094
824
        my $unknown_parameter_handler = $params->{'unknown_parameter_handler'};
1009
1094
1019
        if(!defined($unknown_parameter_handler)) {
1010
1068
933
                if($params->{'carp_on_warn'}) {
1011
2
4
                        $unknown_parameter_handler = 'warn';
1012                } else {
1013
1066
794
                        $unknown_parameter_handler = 'die';
1014                }
1015        }
1016
1017
1094
971
        return $args if(!defined($schema));     # No schema, allow all arguments
1018
1019        # Accept arrayref schema: [{ name=>'param', type=>'...', ... }, ...]
1020        # Normalise to the standard named-parameter hashref form before further processing.
1021
1090
1070
        if(ref($schema) eq 'ARRAY') {
1022
13
15
                $schema = _schema_from_arrayref($schema, $logger);
1023        }
1024
1025        # Check if schema and args are references to hashes
1026
1087
1064
        if(ref($schema) ne 'HASH') {
1027
3
5
                _error($logger, 'validate_strict: schema must be a hash reference');
1028        }
1029
1030        # Inspired by Data::Processor
1031
1084
1504
        my $schema_description = $params->{'description'} || 'validate_strict';
1032
1084
771
        my $error_msg = $params->{'error_msg'};
1033
1034
1084
1054
        if($schema->{'members'} && ($schema->{'description'} || $schema->{'error_msg'})) {
1035
8
7
                $schema_description = $schema->{'description'};
1036
8
9
                $error_msg = $schema->{'error_msg'};
1037
8
6
                $schema = $schema->{'members'};
1038                # The members value may also be in arrayref form
1039
8
13
                if(ref($schema) eq 'ARRAY') {
1040
1
2
                        $schema = _schema_from_arrayref($schema, $logger);
1041                }
1042        }
1043
1044
1084
1824
        if(exists($params->{'args'}) && (!defined($args))) {
1045
1
1
                $args = {};
1046        } elsif((ref($args) ne 'HASH') && (ref($args) ne 'ARRAY')) {
1047
2
6
                _error($logger, $error_msg || "$schema_description: args must be a hash or array reference");
1048        }
1049
1050
1082
1017
        if(ref($args) eq 'HASH') {
1051                # Named args
1052
1070
1070
675
1165
                foreach my $key (keys %{$args}) {
1053
1383
1312
                        if(!exists($schema->{$key})) {
1054
31
53
                                if($unknown_parameter_handler eq 'die') {
1055
9
15
                                        _error($logger, "$schema_description: Unknown parameter '$key'");
1056                                } elsif($unknown_parameter_handler eq 'warn') {
1057
14
35
                                        _warn($logger, "$schema_description: Unknown parameter '$key'");
1058
14
1130
                                        next;
1059                                } elsif($unknown_parameter_handler eq 'ignore') {
1060
5
7
                                        if($logger) {
1061
1
4
                                                $logger->debug(__PACKAGE__ . ": $schema_description: Unknown parameter '$key'");
1062                                        }
1063
5
10
                                        next;
1064                                } else {
1065
3
8
                                        _error($logger, "$schema_description: '$unknown_parameter_handler' unknown_parameter_handler must be one of die, warn, ignore");
1066                                }
1067                        }
1068                }
1069        }
1070
1071        # Find out if this routine takes positional arguments
1072
1070
828
        my $are_positional_args = -1;
1073
1070
1070
653
993
        foreach my $key (keys %{$schema}) {
1074
1073
986
                if(defined(my $rules = $schema->{$key})) {
1075
1071
924
                        if(ref($rules) eq 'HASH') {
1076
1031
976
                                if(!defined($rules->{'position'})) {
1077
1013
864
                                        if($are_positional_args == 1) {
1078
0
0
                                                _error($logger, "::validate_strict: $key is missing position value");
1079                                        }
1080
1013
677
                                        $are_positional_args = 0;
1081
1013
851
                                        last;
1082                                }
1083
18
16
                                $are_positional_args = 1;
1084                        } else {
1085
40
30
                                $are_positional_args = 0;
1086
40
40
                                last;
1087                        }
1088                } else {
1089
2
1
                        $are_positional_args = 0;
1090
2
2
                        last;
1091                }
1092        }
1093
1094
1070
826
        my %validated_args;
1095        my %invalid_args;
1096
1070
1070
611
853
        foreach my $key (keys %{$schema}) {
1097
1506
1069
                my $rules = $schema->{$key};
1098
1506
884
                my $value;
1099
1506
1091
                if($are_positional_args == 1) {
1100
18
31
                        if(ref($args) ne 'ARRAY') {
1101
0
0
                                _error($logger, "::validate_strict: position $rules->{position} given for '$key', but args isn't an array");
1102                        }
1103
18
18
10
19
                        $value = @{$args}[$rules->{'position'}];
1104                } else {
1105
1488
1069
                        $value = $args->{$key};
1106                }
1107
1108
1505
1252
                if(!defined($rules)) {  # Allow anything
1109
2
3
                        $validated_args{$key} = $value;
1110
2
5
                        next;
1111                }
1112
1113                # If rules are a simple type string
1114
1503
1277
                if(ref($rules) eq '') {
1115
31
29
                        $rules = { type => $rules };
1116                }
1117
1118
1503
914
                my $is_optional = 0;
1119
1120
1503
946
                my $rule_description = $schema_description;     # Can be overridden in each element
1121
1122
1503
1215
                if(ref($rules) eq 'HASH') {
1123
1483
1211
                        if(exists($rules->{'description'})) {
1124
0
0
                                $rule_description = $rules->{'description'};
1125                        }
1126
1483
1365
                        if($rules->{'transform'} && defined($value)) {
1127
64
85
                                if(ref($rules->{'transform'}) eq 'CODE') {
1128
61
61
46
87
                                        $value = &{$rules->{'transform'}}($value);
1129                                } else {
1130
3
6
                                        _error($logger, "$rule_description: transforms must be a code ref");
1131                                }
1132                        }
1133
1480
1686
                        if(exists($rules->{optional})) {
1134
288
285
                                if(ref($rules->{'optional'}) eq 'CODE') {
1135
15
15
34
20
                                        $is_optional = &{$rules->{optional}}($value, $args);
1136                                } else {
1137
273
196
                                        $is_optional = $rules->{'optional'};
1138                                }
1139                        } elsif($rules->{nullable}) {
1140
3
3
                                $is_optional = $rules->{'nullable'};
1141                        }
1142                }
1143
1144                # Handle optional parameters
1145
1500
2800
                if((ref($rules) eq 'HASH') && $is_optional) {
1146
280
176
                        my $look_for_default = 0;
1147
280
231
                        if($are_positional_args == 1) {
1148                                # if(!defined(@{$args}[$rules->{'position'}])) {
1149
3
6
                                if(!defined($args->[$rules->{position}])) {
1150
2
18
                                        $look_for_default = 1;
1151                                }
1152                        } else {
1153
277
293
                                if(!exists($args->{$key})) {
1154
140
97
                                        $look_for_default = 1;
1155                                }
1156                        }
1157
280
264
                        if($look_for_default) {
1158
142
139
                                if($are_positional_args == 1) {
1159
2
2
2
4
                                        if(scalar(@{$args}) < $rules->{'position'}) {
1160                                                # arg array is too short, so it must be missing
1161
0
0
                                                _error($logger, "$rule_description: Required parameter '$key' is missing");
1162
0
0
                                                next;
1163                                        }
1164                                }
1165
142
147
                                if(exists($rules->{'default'})) {
1166                                        # Populate missing optional parameters with the specified output values
1167
20
22
                                        $validated_args{$key} = $rules->{'default'};
1168
20
20
                                        next;   # default wins; do not fall through to the schema branch
1169                                }
1170
1171
122
123
                                if($rules->{'schema'}) {
1172
6
12
                                        $value = _apply_nested_defaults({}, $rules->{'schema'});
1173
6
6
7
22
                                        next unless scalar(%{$value});
1174                                        # The nested schema has a default value
1175                                } else {
1176
116
109
                                        next;   # optional and missing
1177                                }
1178                        }
1179                } elsif((ref($args) eq 'HASH') && !exists($args->{$key})) {
1180                        # The parameter is required
1181                        # Use exists rather than defined, so that an undefined value can be passed, but the key is there
1182
16
47
                        _error($logger, "$rule_description: Required parameter '$key' is missing");
1183                }
1184
1185                # Normalise union type shorthand: { type => ['string', 'integer'], ... }
1186                # into the array-of-rules form that the ARRAY handler below already supports.
1187                # Each candidate type inherits all other constraints from the parent rule
1188                # (min, max, matches, optional, etc.) so they are each fully validated.
1189                # Must run after optional/transform handling above but before rule dispatch below.
1190
1344
1815
                if(ref($rules) eq 'HASH' && ref($rules->{'type'}) eq 'ARRAY') {
1191
17
17
11
19
                        my %base = %{$rules};
1192
17
17
11
25
                        my @type_list = @{delete $base{'type'}};
1193
17
16
                        if(!@type_list) {
1194
2
3
                                _error($logger, "$rule_description: Parameter '$key': union type list must not be empty");
1195                        }
1196                        # Expand into one full rule hash per candidate type
1197
15
29
15
39
                        $rules = [ map { { %base, type => $_ } } @type_list ];
1198                }
1199
1200                # Validate based on rules
1201
1342
1120
                if(ref($rules) eq 'HASH') {
1202
1307
2079
                        if(defined(my $min = $rules->{'min'} // $rules->{'minimum'}) && defined(my $max = $rules->{'max'})) {
1203
115
125
                                if($min > $max) {
1204
7
18
                                        _error($logger, "validate_strict($key): min must be <= max ($min > $max)");
1205                                }
1206                        }
1207
1208                        # memberof and its synonym enum cannot be combined with min or max
1209
1300
2260
                        if($rules->{'memberof'} || $rules->{'enum'} || $rules->{'values'}) {
1210
102
202
                                if(defined(my $min = $rules->{'min'} // $rules->{'minimum'})) {
1211
6
13
                                        _error($logger, "validate_strict($key): min ($min) makes no sense with memberof/enum/values");
1212                                }
1213
96
108
                                if(defined(my $max = $rules->{'max'})) {
1214
3
7
                                        _error($logger, "validate_strict($key): max ($max) makes no sense with memberof/enum/values");
1215                                }
1216                        }
1217
1218
1291
1129
                        foreach my $rule_name (keys %$rules) {
1219
2176
1711
                                my $rule_value = $rules->{$rule_name};
1220
1221
2176
2100
                                if((ref($rule_value) eq 'CODE')
1222                                        && ($rule_name ne 'validate')
1223                                        && ($rule_name ne 'callback')
1224                                        && ($rule_name ne 'validator')
1225                                        && ($rule_name ne 'transform')  # already applied before this loop
1226                                        && ($rule_name ne 'optional')) {        # already applied before this loop
1227
13
13
8
16
                                        $rule_value = &{$rule_value}($value, $args);
1228                                }
1229
1230                                # Better OOP, the routine has been given an object rather than a scalar
1231
2176
2442
                                if(Scalar::Util::blessed($rule_value) && $rule_value->can('as_string')) {
1232
0
0
                                        $rule_value = $rule_value->as_string();
1233                                }
1234
1235
2176
4590
                                if($rule_name eq 'type') {
1236
1144
875
                                        my $type = lc($rule_value);
1237
1238
1144
2464
                                        if(($type eq 'string') || ($type eq 'str')) {
1239
583
485
                                                if(ref($value)) {
1240
14
46
                                                        _error($logger, $rules->{'error_msg'} || "$rule_description: Parameter '$key' must be a string");
1241                                                }
1242
569
600
                                                unless((ref($value) eq '') || (defined($value) && length($value))) {    # Allow undef for optional strings
1243
0
0
                                                        _error($logger, $rules->{'error_msg'} || "$rule_description: Parameter '$key' must be a string");
1244                                                }
1245                                        } elsif(($type eq 'integer') || ($type eq 'int')) {
1246
215
184
                                                if(!defined($value)) {
1247
2
3
                                                        next;   # Skip if number is undefined
1248                                                }
1249
213
543
                                                if($value !~ /^\s*[+\-]?\d+\s*$/) {
1250
26
35
                                                        if($rules->{'error_msg'}) {
1251
2
4
                                                                _error($logger, $rules->{'error_msg'});
1252                                                        } else {
1253
24
42
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be an integer");
1254                                                        }
1255                                                }
1256
187
200
                                                $value = int($value); # Coerce to integer
1257                                        } elsif(($type eq 'number') || ($type eq 'float') || ($type eq 'num') || ($type eq 'double')) {
1258
69
83
                                                if(!defined($value)) {
1259
2
2
                                                        next;   # Skip if number is undefined
1260                                                }
1261
67
96
                                                if(!Scalar::Util::looks_like_number($value)) {
1262
5
9
                                                        if($rules->{'error_msg'}) {
1263
0
0
                                                                _error($logger, $rules->{'error_msg'});
1264                                                        } else {
1265
5
12
                                                                _error($logger, "$rule_description: Parameter '$key' must be a number");
1266                                                        }
1267                                                }
1268                                                # $value = eval $value; # Coerce to number (be careful with eval)
1269
62
97
                                                $value = 0 + $value;    # Numeric coercion
1270                                        } elsif($type eq 'arrayref') {
1271
66
70
                                                if(!defined($value)) {
1272
2
2
                                                        next;   # Skip if arrayref is undefined
1273                                                }
1274
64
92
                                                if(ref($value) ne 'ARRAY') {
1275
9
9
                                                        if($rules->{'error_msg'}) {
1276
0
0
                                                                _error($logger, $rules->{'error_msg'});
1277                                                        } else {
1278
9
20
                                                                _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1279                                                        }
1280                                                }
1281                                        } elsif($type eq 'hashref') {
1282
45
46
                                                if(!defined($value)) {
1283
2
2
                                                        next;   # Skip if hashref is undefined
1284                                                }
1285
43
65
                                                if(ref($value) ne 'HASH') {
1286
3
5
                                                        if($rules->{'error_msg'}) {
1287
0
0
                                                                _error($logger, $rules->{'error_msg'});
1288                                                        } else {
1289
3
9
                                                                _error($logger, "$rule_description: Parameter '$key' must be an hashref");
1290                                                        }
1291                                                }
1292                                        } elsif(($type eq 'boolean') || ($type eq 'bool')) {
1293
64
67
                                                if(!defined($value)) {
1294
2
2
                                                        next;   # Skip if bool is undefined
1295                                                }
1296
62
162
                                                if(defined(my $b = $Readonly::Values::Boolean::booleans{$value})) {
1297
55
281
                                                        $value = $b;
1298                                                } else {
1299
7
29
                                                        if($rules->{'error_msg'}) {
1300
0
0
                                                                _error($logger, $rules->{'error_msg'});
1301                                                        } else {
1302
7
13
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be a boolean");
1303                                                        }
1304                                                }
1305                                        } elsif($type eq 'coderef') {
1306
9
15
                                                if(!defined($value)) {
1307
1
1
                                                        next;   # Skip if code is undefined
1308                                                }
1309
8
15
                                                if(ref($value) ne 'CODE') {
1310
3
4
                                                        if($rules->{'error_msg'}) {
1311
0
0
                                                                _error($logger, $rules->{'error_msg'});
1312                                                        } else {
1313
3
11
                                                                _error($logger, "$rule_description: Parameter '$key' must be a coderef, not a ref to " . ref($value));
1314                                                        }
1315                                                }
1316                                        } elsif($type eq 'object') {
1317
37
48
                                                if(!defined($value)) {
1318
1
2
                                                        next;   # Skip if object is undefined
1319                                                }
1320
36
69
                                                if(!Scalar::Util::blessed($value)) {
1321
4
15
                                                        if($rules->{'error_msg'}) {
1322
0
0
                                                                _error($logger, $rules->{'error_msg'});
1323                                                        } else {
1324
4
10
                                                                _error($logger, "$rule_description: Parameter '$key' must be an object");
1325                                                        }
1326                                                }
1327                                        } elsif(my $custom_type = $custom_types->{$type}) {
1328
53
60
                                                if($custom_type->{'transform'}) {
1329                                                        # The custom type has a transform embedded within it
1330
8
12
                                                        if(ref($custom_type->{'transform'}) eq 'CODE') {
1331
7
7
7
18
                                                                $value = &{$custom_type->{'transform'}}($value);
1332                                                        } else {
1333
1
4
                                                                _error($logger, "$rule_description: transforms must be a code ref");
1334
0
0
                                                                next;
1335                                                        }
1336                                                }
1337
52
286
                                                validate_strict({ input => { $key => $value }, schema => { $key => $custom_type }, custom_types => $custom_types });
1338                                        } else {
1339
3
7
                                                _error($logger, "$rule_description: Unknown type '$type'");
1340                                        }
1341                                } elsif(($rule_name eq 'min') || ($rule_name eq 'minimum')) {
1342
238
255
                                        if(!defined($rules->{'type'})) {
1343
0
0
                                                _error($logger, "$rule_description: Don't know type of '$key' to determine its minimum value $rule_value");
1344                                        }
1345
238
231
                                        my $type = lc($rules->{'type'});
1346
238
477
                                        if(exists($custom_types->{$type}->{'min'}) || exists($custom_types->{$type}->{minimum})) {
1347
3
4
                                                $rule_value = $custom_types->{$type}->{'min'} // $custom_types->{$type}->{minumum};
1348
3
4
                                                $type = $custom_types->{$type}->{'type'};
1349                                        }
1350
238
555
                                        if(($type eq 'string') || ($type eq 'str')) {
1351
93
92
                                                if($rule_value < 0) {
1352
1
2
                                                        if($rules->{'error_msg'}) {
1353
0
0
                                                                _error($logger, $rules->{'error_msg'});
1354                                                        } else {
1355
1
3
                                                                _error($logger, "$rule_description: String parameter '$key' has meaningless minimum value that is less than zero");
1356                                                        }
1357                                                }
1358
92
117
                                                if(!defined($value)) {
1359
1
1
                                                        next;   # Skip if string is undefined
1360                                                }
1361
91
97
                                                if(defined(my $len = _number_of_characters($value))) {
1362
91
295
                                                        if($len < $rule_value) {
1363
18
71
                                                                _error($logger, $rules->{'error_msg'} || "$rule_description: String parameter '$key' too short, ($len characters), must be at least $rule_value characters");
1364
0
0
                                                                $invalid_args{$key} = 1;
1365                                                        }
1366                                                } else {
1367
0
0
                                                        _error($logger, $rules->{'error_msg'} || "$rule_description: '$key' can't be decoded");
1368
0
0
                                                        $invalid_args{$key} = 1;
1369                                                }
1370                                        } elsif($type eq 'arrayref') {
1371
18
35
                                                if(!defined($value)) {
1372
0
0
                                                        next;   # Skip if array is undefined
1373                                                }
1374
18
27
                                                if(ref($value) ne 'ARRAY') {
1375
1
2
                                                        if($rules->{'error_msg'}) {
1376
0
0
                                                                _error($logger, $rules->{'error_msg'});
1377                                                        } else {
1378
1
2
                                                                _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1379                                                        }
1380                                                }
1381
17
17
15
30
                                                if(scalar(@{$value}) < $rule_value) {
1382
4
8
                                                        if($rules->{'error_msg'}) {
1383
0
0
                                                                _error($logger, $rules->{'error_msg'});
1384                                                        } else {
1385
4
9
                                                                _error($logger, "$rule_description: Parameter '$key' must be at least length $rule_value");
1386                                                        }
1387
0
0
                                                        $invalid_args{$key} = 1;
1388                                                }
1389                                        } elsif($type eq 'hashref') {
1390
5
6
                                                if(!defined($value)) {
1391
0
0
                                                        next;   # Skip if hash is undefined
1392                                                }
1393
5
5
3
10
                                                if(scalar(keys(%{$value})) < $rule_value) {
1394
2
4
                                                        if($rules->{'error_msg'}) {
1395
0
0
                                                                _error($logger, $rules->{'error_msg'});
1396                                                        } else {
1397
2
5
                                                                _error($logger, "$rule_description: Parameter '$key' must contain at least $rule_value keys");
1398                                                        }
1399
0
0
                                                        $invalid_args{$key} = 1;
1400                                                }
1401                                        } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
1402
121
108
                                                if(!defined($value)) {
1403
0
0
                                                        next;   # Skip if hash is undefined
1404                                                }
1405
121
161
                                                if(Scalar::Util::looks_like_number($value)) {
1406
120
164
                                                        if($value < $rule_value) {
1407
27
39
                                                                if($rules->{'error_msg'}) {
1408
7
12
                                                                        _error($logger, $rules->{'error_msg'});
1409                                                                } else {
1410
20
46
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be at least $rule_value");
1411                                                                }
1412
0
0
                                                                $invalid_args{$key} = 1;
1413
0
0
                                                                next;
1414                                                        }
1415                                                } else {
1416
1
2
                                                        if($rules->{'error_msg'}) {
1417
0
0
                                                                _error($logger, $rules->{'error_msg'});
1418                                                        } else {
1419
1
4
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be a number");
1420                                                        }
1421
0
0
                                                        next;
1422                                                }
1423                                        } else {
1424
1
2
                                                _error($logger, "$rule_description: Parameter '$key' of type '$type' has meaningless min value $rule_value");
1425                                        }
1426                                } elsif($rule_name eq 'max') {
1427
118
147
                                        if(!defined($rules->{'type'})) {
1428
0
0
                                                _error($logger, "$rule_description: Don't know type of '$key' to determine its maximum value $rule_value");
1429                                        }
1430
118
113
                                        my $type = lc($rules->{'type'});
1431
118
150
                                        if(exists($custom_types->{$type}->{'max'})) {
1432
4
4
                                                $rule_value = $custom_types->{$type}->{'max'};
1433
4
4
                                                $type = $custom_types->{$type}->{'type'};
1434                                        }
1435
118
312
                                        if(($type eq 'string') || ($type eq 'str')) {
1436
53
50
                                                if(!defined($value)) {
1437
1
1
                                                        next;   # Skip if string is undefined
1438                                                }
1439
52
60
                                                if(defined(my $len = _number_of_characters($value))) {
1440
52
181
                                                        if($len > $rule_value) {
1441
11
42
                                                                _error($logger, $rules->{'error_msg'} || "$rule_description: String parameter '$key' too long, ($len characters), must be no longer than $rule_value");
1442
0
0
                                                                $invalid_args{$key} = 1;
1443                                                        }
1444                                                } else {
1445
0
0
                                                        _error($logger, $rules->{'error_msg'} || "$rule_description: '$key' can't be decoded");
1446
0
0
                                                        $invalid_args{$key} = 1;
1447                                                }
1448                                        } elsif($type eq 'arrayref') {
1449
10
13
                                                if(!defined($value)) {
1450
0
0
                                                        next;   # Skip if string is undefined
1451                                                }
1452
10
14
                                                if(ref($value) ne 'ARRAY') {
1453
0
0
                                                        if($rules->{'error_msg'}) {
1454
0
0
                                                                _error($logger, $rules->{'error_msg'});
1455                                                        } else {
1456
0
0
                                                                _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1457                                                        }
1458                                                }
1459
10
10
7
18
                                                if(scalar(@{$value}) > $rule_value) {
1460
5
8
                                                        if($rules->{'error_msg'}) {
1461
0
0
                                                                _error($logger, $rules->{'error_msg'});
1462                                                        } else {
1463
5
9
                                                                _error($logger, "$rule_description: Parameter '$key' must contain no more than $rule_value items");
1464                                                        }
1465
0
0
                                                        $invalid_args{$key} = 1;
1466                                                }
1467                                        } elsif($type eq 'hashref') {
1468
5
4
                                                if(!defined($value)) {
1469
0
0
                                                        next;   # Skip if hash is undefined
1470                                                }
1471
5
5
5
9
                                                if(scalar(keys(%{$value})) > $rule_value) {
1472
3
3
                                                        if($rules->{'error_msg'}) {
1473
0
0
                                                                _error($logger, $rules->{'error_msg'});
1474                                                        } else {
1475
3
8
                                                                _error($logger, "$rule_description: Parameter '$key' must contain no more than $rule_value keys");
1476                                                        }
1477
0
0
                                                        $invalid_args{$key} = 1;
1478                                                }
1479                                        } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
1480
49
57
                                                if(!defined($value)) {
1481
0
0
                                                        next;   # Skip if hash is undefined
1482                                                }
1483
49
77
                                                if(Scalar::Util::looks_like_number($value)) {
1484
49
73
                                                        if($value > $rule_value) {
1485
10
17
                                                                if($rules->{'error_msg'}) {
1486
0
0
                                                                        _error($logger, $rules->{'error_msg'});
1487                                                                } else {
1488
10
28
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be no more than $rule_value");
1489                                                                }
1490
0
0
                                                                $invalid_args{$key} = 1;
1491
0
0
                                                                next;
1492                                                        }
1493                                                } else {
1494
0
0
                                                        if($rules->{'error_msg'}) {
1495
0
0
                                                                _error($logger, $rules->{'error_msg'});
1496                                                        } else {
1497
0
0
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be a number");
1498                                                        }
1499
0
0
                                                        next;
1500                                                }
1501                                        } else {
1502
1
3
                                                _error($logger, "$rule_description: Parameter '$key' of type '$type' has meaningless max value $rule_value");
1503                                        }
1504                                } elsif(($rule_name eq 'matches') || ($rule_name eq 'regex')) {
1505
91
83
                                        if(!defined($value)) {
1506
1
1
                                                next;   # Skip if string is undefined
1507                                        }
1508
90
78
                                        eval {
1509
90
137
                                                my $re = (ref($rule_value) eq 'Regexp') ? $rule_value : qr/\Q$rule_value\E/;
1510
90
393
                                                if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1511
5
11
5
11
27
7
                                                        my @matches = grep { $_ =~ $re } @{$value};
1512
5
5
6
8
                                                        if(scalar(@matches) != scalar(@{$value})) {
1513
2
4
                                                                if($rules->{'error_msg'}) {
1514
0
0
                                                                        _error($logger, $rules->{'error_msg'});
1515                                                                } else {
1516
2
2
4
6
                                                                        _error($logger, "$rule_description: All members of parameter '$key' [", join(', ', @{$value}), "] must match pattern '$rule_value'");
1517                                                                }
1518                                                        }
1519                                                } elsif($value !~ $re) {
1520
25
41
                                                        if($rules->{'error_msg'}) {
1521
4
6
                                                                _error($logger, $rules->{'error_msg'});
1522                                                        } else {
1523
21
67
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must match pattern '$re'");
1524                                                        }
1525                                                }
1526
63
60
                                                1;
1527                                        };
1528
90
33064
                                        if($@) {
1529
27
42
                                                if($rules->{'error_msg'}) {
1530
4
6
                                                        _error($logger, $rules->{'error_msg'});
1531                                                } else {
1532
23
66
                                                        _error($logger, "$rule_description: Parameter '$key' regex '$rule_value' error: $@");
1533                                                }
1534
0
0
                                                $invalid_args{$key} = 1;
1535                                        }
1536                                } elsif($rule_name eq 'nomatch') {
1537
17
22
                                        if(!defined($value)) {
1538
0
0
                                                next;   # Skip if string is undefined
1539                                        }
1540
17
72
                                        if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1541
5
15
5
6
35
5
                                                my @matches = grep { /$rule_value/ } @{$value};
1542
5
8
                                                if(scalar(@matches)) {
1543
2
4
                                                        if($rules->{'error_msg'}) {
1544
0
0
                                                                _error($logger, $rules->{'error_msg'});
1545                                                        } else {
1546
2
2
3
6
                                                                _error($logger, "$rule_description: No member of parameter '$key' [", join(', ', @{$value}), "] must match pattern '$rule_value'");
1547                                                        }
1548                                                }
1549                                        } elsif($value =~ $rule_value) {
1550
6
10
                                                if($rules->{'error_msg'}) {
1551
1
2
                                                        _error($logger, $rules->{'error_msg'});
1552                                                } else {
1553
5
17
                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must not match pattern '$rule_value'");
1554                                                }
1555
0
0
                                                $invalid_args{$key} = 1;
1556                                        }
1557                                } elsif(($rule_name eq 'memberof') || ($rule_name eq 'enum') || ($rule_name eq 'values')) {
1558
92
84
                                        if(!defined($value)) {
1559
0
0
                                                next;   # Skip if string is undefined
1560                                        }
1561
92
113
                                        if(ref($rule_value) eq 'ARRAY') {
1562
90
60
                                                my $ok = 1;
1563
90
194
                                                if(($rules->{'type'} eq 'integer') || ($rules->{'type'} eq 'number') || ($rules->{'type'} eq 'float')) {
1564
16
49
16
33
43
24
                                                        unless(List::Util::any { $_ == $value } @{$rule_value}) {
1565
5
3
                                                                $ok = 0;
1566                                                        }
1567                                                } else {
1568
74
73
                                                        my $l = lc($value);
1569
74
279
74
138
336
109
                                                        unless(List::Util::any { (!defined($rules->{'case_sensitive'}) || ($rules->{'case_sensitive'} == 1)) ? $_ eq $value : lc($_) eq $l } @{$rule_value}) {
1570
24
20
                                                                $ok = 0;
1571                                                        }
1572                                                }
1573
1574
90
206
                                                if(!$ok) {
1575
29
33
                                                        if($rules->{'error_msg'}) {
1576
3
6
                                                                _error($logger, $rules->{'error_msg'});
1577                                                        } else {
1578
26
26
36
60
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be one of ", join(', ', @{$rule_value}));
1579                                                        }
1580
0
0
                                                        $invalid_args{$key} = 1;
1581                                                }
1582                                        } else {
1583
2
4
                                                if($rules->{'error_msg'}) {
1584
0
0
                                                        _error($logger, $rules->{'error_msg'});
1585                                                } else {
1586
2
4
                                                        _error($logger, "$rule_description: Parameter '$key' rule ($rule_value) must be an array reference");
1587                                                }
1588                                        }
1589                                } elsif($rule_name eq 'notmemberof') {
1590
35
35
                                        if(!defined($value)) {
1591
0
0
                                                next;   # Skip if string is undefined
1592                                        }
1593
35
32
                                        if(ref($rule_value) eq 'ARRAY') {
1594
34
21
                                                my $ok = 1;
1595
34
81
                                                if(($rules->{'type'} eq 'integer') || ($rules->{'type'} eq 'number') || ($rules->{'type'} eq 'float')) {
1596
6
17
6
10
14
6
                                                        if(List::Util::any { $_ == $value } @{$rule_value}) {
1597
4
3
                                                                $ok = 0;
1598                                                        }
1599                                                } else {
1600
28
29
                                                        my $l = lc($value);
1601
28
47
28
63
75
38
                                                        if(List::Util::any { (!defined($rules->{'case_sensitive'}) || ($rules->{'case_sensitive'} == 1)) ? $_ eq $value : lc($_) eq $l } @{$rule_value}) {
1602
16
13
                                                                $ok = 0;
1603                                                        }
1604                                                }
1605
1606
34
73
                                                if(!$ok) {
1607
20
23
                                                        if($rules->{'error_msg'}) {
1608
1
2
                                                                _error($logger, $rules->{'error_msg'});
1609                                                        } else {
1610
19
19
26
38
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must not be one of ", join(', ', @{$rule_value}));
1611                                                        }
1612
0
0
                                                        $invalid_args{$key} = 1;
1613                                                }
1614                                        } else {
1615
1
1
                                                if($rules->{'error_msg'}) {
1616
0
0
                                                        _error($logger, $rules->{'error_msg'});
1617                                                } else {
1618
1
2
                                                        _error($logger, "$rule_description: Parameter '$key' rule ($rule_value) must be an array reference");
1619                                                }
1620                                        }
1621                                } elsif($rule_name eq 'isa') {
1622
15
20
                                        if(!defined($value)) {
1623
0
0
                                                next;   # Skip if object not given
1624                                        }
1625
15
22
                                        if($rules->{'type'} eq 'object') {
1626
14
50
                                                if(!$value->isa($rule_value)) {
1627
3
13
                                                        _error($logger, "$rule_description: Parameter '$key' must be a '$rule_value' object got a " . (ref($value) ? ref($value) : $value) . ' object instead');
1628
0
0
                                                        $invalid_args{$key} = 1;
1629                                                }
1630                                        } else {
1631
1
2
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless isa value $rule_value");
1632                                        }
1633                                } elsif($rule_name eq 'can') {
1634
30
34
                                        if(!defined($value)) {
1635
0
0
                                                next;   # Skip if object not given
1636                                        }
1637
30
42
                                        if($rules->{'type'} eq 'object') {
1638
29
47
                                                if(ref($rule_value) eq 'ARRAY') {
1639                                                        # List of methods
1640
13
13
12
16
                                                        foreach my $method(@{$rule_value}) {
1641
25
62
                                                                if(!$value->can($method)) {
1642
5
13
                                                                        _error($logger, "$rule_description: Parameter '$key' must be an object that understands the $method method");
1643
0
0
                                                                        $invalid_args{$key} = 1;
1644                                                                }
1645                                                        }
1646                                                } elsif(!ref($rule_value)) {
1647
15
77
                                                        if(!$value->can($rule_value)) {
1648
7
20
                                                                _error($logger, "$rule_description: Parameter '$key' must be an object that understands the $rule_value method");
1649
0
0
                                                                $invalid_args{$key} = 1;
1650                                                        }
1651                                                } else {
1652
1
2
                                                        _error($logger, "$rule_description: 'can' rule for Parameter '$key must be either a scalar or an arrayref");
1653                                                }
1654                                        } else {
1655
1
2
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless can value '$rule_value' for parameter type $rules->{type}");
1656                                        }
1657                                } elsif($rule_name eq 'element_type') {
1658
36
71
                                        if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1659
35
30
                                                my $type = $rule_value;
1660
35
33
                                                my $custom_type = $custom_types->{$rule_value};
1661
35
62
                                                if($custom_type && $custom_type->{'type'}) {
1662
4
3
                                                        $type = $custom_type->{'type'};
1663                                                }
1664
35
35
25
58
                                                foreach my $member(@{$value}) {
1665
74
85
                                                        if($custom_type && $custom_type->{'transform'}) {
1666                                                                # The custom type has a transform embedded within it
1667
5
9
                                                                if(ref($custom_type->{'transform'}) eq 'CODE') {
1668
4
4
3
5
                                                                        $member = &{$custom_type->{'transform'}}($member);
1669                                                                } else {
1670
1
2
                                                                        _error($logger, "$rule_description: transforms must be a code ref");
1671
0
0
                                                                        last;
1672                                                                }
1673                                                        }
1674
73
119
                                                        if(($type eq 'string') || ($type eq 'Str')) {
1675
24
34
                                                                if(ref($member)) {
1676
2
8
                                                                        if($rules->{'error_msg'}) {
1677
0
0
                                                                                _error($logger, $rules->{'error_msg'});
1678                                                                        } else {
1679
2
4
                                                                                _error($logger, "$key can only contain strings");
1680                                                                        }
1681
0
0
                                                                        $invalid_args{$key} = 1;
1682                                                                }
1683                                                        } elsif($type eq 'integer') {
1684
35
89
                                                                if(ref($member) || ($member =~ /\D/)) {
1685
5
10
                                                                        if($rules->{'error_msg'}) {
1686
1
2
                                                                                _error($logger, $rules->{'error_msg'});
1687                                                                        } else {
1688
4
7
                                                                                _error($logger, "$key can only contain integers (found $member)");
1689                                                                        }
1690
0
0
                                                                        $invalid_args{$key} = 1;
1691                                                                }
1692                                                        } elsif(($type eq 'number') || ($rule_value eq 'float')) {
1693
14
55
                                                                if(ref($member) || ($member !~ /^[-+]?(\d*\.\d+|\d+\.?\d*)$/)) {
1694
2
10
                                                                        if($rules->{'error_msg'}) {
1695
0
0
                                                                                _error($logger, $rules->{'error_msg'});
1696                                                                        } else {
1697
2
5
                                                                                _error($logger, "$key can only contain numbers (found $member)");
1698                                                                        }
1699
0
0
                                                                        $invalid_args{$key} = 1;
1700                                                                }
1701                                                        } else {
1702
0
0
                                                                _error($logger, "BUG: Add $type to element_type list");
1703                                                        }
1704                                                }
1705                                        } else {
1706
1
2
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless element_type value $rule_value");
1707                                        }
1708                                } elsif($rule_name eq 'optional') {
1709                                        # Already handled at the beginning of the loop
1710                                } elsif($rule_name eq 'nullable') {
1711                                        # Already handled at the beginning of the loop (same as optional)
1712                                } elsif($rule_name eq 'default') {
1713                                        # Handled earlier
1714                                } elsif($rule_name eq 'error_msg') {
1715                                        # Handled inline
1716                                } elsif($rule_name eq 'transform') {
1717                                        # Handled before the loop
1718                                } elsif($rule_name eq 'case_sensitive') {
1719                                        # Handled inline
1720                                } elsif($rule_name eq 'description') {
1721                                        # A la, Data::Processor
1722                                } elsif($rule_name =~ /^_/) {
1723                                        # Ignore internal/metadata fields from schema extraction
1724                                } elsif($rule_name eq 'semantic') {
1725
3
4
                                        if($rule_value eq 'unix_timestamp') {
1726
2
6
                                                if($value < 0 || $value > 2147483647) {
1727
0
0
                                                        error($logger, 'Invalid Unix timestamp: $value');
1728                                                }
1729                                        } else {
1730
1
2
                                                _warn($logger, "semantic type $rule_value is not yet supported");
1731                                        }
1732                                } elsif($rule_name eq 'schema') {
1733                                        # Nested schema Run the given schema against each element of the array
1734
58
132
                                        if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1735
16
29
                                                if(ref($value) eq 'ARRAY') {
1736
15
15
12
19
                                                        foreach my $member(@{$value}) {
1737                                                                # Distinguish two schema forms:
1738                                                                # (a) Rule hash   â€” has a top-level 'type' key, e.g. { type=>'string', matches=>qr/.../ }
1739                                                                #     â†’ validate each element against that rule directly.
1740                                                                # (b) Field-schema hash — keys are field names whose values are rule hashes,
1741                                                                #     e.g. { name=>{type=>'string'}, age=>{type=>'integer'} }
1742                                                                #     â†’ validate each hashref element against the field schema directly.
1743
24
44
                                                                my $is_field_schema = (ref($rule_value) eq 'HASH') && !exists($rule_value->{'type'});
1744
24
24
                                                                my %inner = (custom_types => $custom_types);
1745
24
27
                                                                if($is_field_schema) {
1746
3
2
                                                                        $inner{input}  = $member;
1747
3
2
                                                                        $inner{schema} = $rule_value;
1748                                                                } else {
1749
21
25
                                                                        $inner{input}  = { $key => $member };
1750
21
21
                                                                        $inner{schema} = { $key => $rule_value };
1751                                                                }
1752
24
71
                                                                if(!validate_strict(\%inner)) {
1753
0
0
                                                                        $invalid_args{$key} = 1;
1754                                                                }
1755                                                        }
1756                                                } elsif(defined($value)) {      # Allow undef for optional values
1757
1
8
                                                        _error($logger, "$rule_description: nested schema: Parameter '$value' must be an arrayref");
1758                                                }
1759                                        } elsif($rules->{'type'} eq 'hashref') {
1760
41
55
                                                if(ref($rule_value) eq 'HASH') {
1761                                                        # Apply nested defaults before validation
1762
41
81
                                                        my $nested_with_defaults = _apply_nested_defaults($value, $rule_value);
1763
41
41
26
48
                                                        if(scalar keys(%{$nested_with_defaults})) {
1764
39
213
                                                                if(my $new_args = validate_strict({ input => $nested_with_defaults, schema => $rule_value, custom_types => $custom_types })) {
1765
27
47
                                                                        $value = $new_args;
1766                                                                } else {
1767
0
0
                                                                        $invalid_args{$key} = 1;
1768                                                                }
1769                                                        }
1770                                                } else {
1771
0
0
                                                        _error($logger, "$rule_description: nested schema: Parameter '$value' must be an hashref");
1772                                                }
1773                                        } else {
1774
1
2
                                                _error($logger, "$rule_description: Parameter '$key': 'schema' only supports arrayref and hashref, not $rules->{type}");
1775                                        }
1776                                } elsif(($rule_name eq 'validate') || ($rule_name eq 'validator')) {
1777
9
29
                                        if(ref($rule_value) eq 'CODE') {
1778
9
9
6
14
                                                if(my $error = &{$rule_value}($args)) {
1779
3
14
                                                        _error($logger, "$rule_description: $key not valid: $error");
1780
0
0
                                                        $invalid_args{$key} = 1;
1781                                                }
1782                                        } else {
1783                                                # _error($logger, "$rule_description: Parameter '$key': 'validate' only supports coderef, not $value");
1784
0
0
                                                _error($logger, "$rule_description: Parameter '$key': 'validate' only supports coderef, not " . ref($rule_value) // $rule_value);
1785                                        }
1786                                } elsif ($rule_name eq 'callback') {
1787                                        # Custom validation code
1788
32
40
                                        unless (defined &$rule_value) {
1789
1
2
                                                _error($logger, "$rule_description: callback for '$key' must be a code reference");
1790                                        }
1791
31
45
                                        my $res = $rule_value->($value, $args, $schema);
1792
29
2399
                                        unless ($res) {
1793
12
24
                                                if($rules->{'error_msg'}) {
1794
0
0
                                                        _error($logger, $rules->{'error_msg'});
1795                                                } else {
1796
12
25
                                                        _error($logger, "$rule_description: Parameter '$key' failed custom validation");
1797                                                }
1798
0
0
                                                $invalid_args{$key} = 1;
1799                                        }
1800                                } elsif($rule_name eq 'position') {
1801
16
25
                                        if($rule_value =~ /\D/) {
1802
0
0
                                                _error($logger, "$rule_description: Parameter '$key': 'position' must be an integer");
1803                                        }
1804
16
22
                                        if($rule_value < 0) {
1805
0
0
                                                _error($logger, "$rule_description: Parameter '$key': 'position' must be a positive integer, not $value");
1806                                        }
1807                                } else {
1808
1
2
                                        _error($logger, "$rule_description: Unknown rule '$rule_name'");
1809                                }
1810                        }
1811                } elsif(ref($rules) eq 'ARRAY') {
1812
33
33
31
49
                        if(scalar(@{$rules})) {
1813                                # An argument can be one of several different types.
1814                                # This path handles both explicit array-of-rules schemas and the
1815                                # normalised form of union type shorthand (type => ['a', 'b', ...]).
1816
31
27
                                my $rc = 0;
1817
31
23
                                my @types;
1818
31
31
16
35
                                foreach my $rule(@{$rules}) {
1819
51
61
                                        if(ref($rule) ne 'HASH') {
1820
1
2
                                                _error($logger, "$rule_description: Parameter '$key' rules must be a hash reference");
1821
0
0
                                                next;
1822                                        }
1823
50
52
                                        if(!defined($rule->{'type'})) {
1824
0
0
                                                _error($logger, "$rule_description: Parameter '$key' is missing a type in an alternative");
1825
0
0
                                                next;
1826                                        }
1827
50
49
                                        push @types, $rule->{'type'};
1828
50
36
                                        my $result;
1829
50
44
                                        eval {
1830
50
206
                                                $result = validate_strict({ input => { $key => $value }, schema => { $key => $rule }, logger => undef, custom_types => $custom_types });
1831                                        };
1832
50
32050
                                        if(!$@) {
1833                                                # Capture coercion performed by the successful sub-validation
1834                                                # (e.g. integer/number coercion) so the outer scope sees it.
1835
21
32
                                                $value = $result->{$key} if(defined($result));
1836
21
19
                                                $rc = 1;
1837
21
22
                                                last;
1838                                        }
1839                                }
1840
30
42
                                if(!$rc) {
1841
9
27
                                        _error($logger, "$rule_description: Parameter: '$key': must be one of " . join(', ', @types));
1842
0
0
                                        $invalid_args{$key} = 1;
1843                                }
1844                        } else {
1845
2
4
                                _error($logger, "$rule_description: Parameter: '$key': schema is empty arrayref");
1846                        }
1847                } elsif(ref($rules)) {
1848
2
3
                        _error($logger, 'rules must be a hash reference or string');
1849                }
1850
1851
980
1160
                $validated_args{$key} = $value;
1852        }
1853
1854        # Validate parameter relationships
1855
686
739
        if (my $relationships = $params->{'relationships'}) {
1856
44
51
                _validate_relationships(\%validated_args, $relationships, $logger, $schema_description);
1857        }
1858
1859
665
564
        if(my $cross_validation = $params->{'cross_validation'}) {
1860
52
52
36
49
                foreach my $validator_name(keys %{$cross_validation}) {
1861
59
62
                        my $validator = $cross_validation->{$validator_name};
1862
59
85
                        if((!ref($validator)) || (ref($validator) ne 'CODE')) {
1863
1
3
                                _error($logger, "$schema_description: cross_validation $validator is not a code snippet");
1864
0
0
                                next;
1865                        }
1866
58
58
49
71
                        if(my $error = &{$validator}(\%validated_args, $validator)) {
1867
23
85
                                _error($logger, $error);
1868                                # We have no idea which parameters are still valid, so let's invalidate them all
1869
0
0
                                return;
1870                        }
1871                }
1872        }
1873
1874
640
625
        foreach my $key(keys %invalid_args) {
1875
0
0
                delete $validated_args{$key};
1876        }
1877
1878
640
549
        if($are_positional_args == 1) {
1879
11
10
                my @rc;
1880
11
11
7
11
                foreach my $key (keys %{$schema}) {
1881                        # Use exists() rather than if(my $value = ...) so that falsy but
1882                        # valid coerced values (integer 0, empty string, undef from an
1883                        # absent optional) are not silently dropped from the return array.
1884
18
21
                        if(exists $validated_args{$key}) {
1885
17
12
                                my $value = delete $validated_args{$key};
1886
17
16
                                my $position = $schema->{$key}->{'position'};
1887
17
24
                                if(defined($rc[$position])) {
1888
1
2
                                        _error($logger, "$schema_description: $key: position $position appears twice");
1889                                }
1890
16
14
                                $rc[$position] = $value;
1891                        }
1892                }
1893
10
25
                return \@rc;
1894        }
1895
629
1476
        return \%validated_args;
1896}
1897
1898# _schema_from_arrayref($arrayref, $logger)
1899#
1900# Normalise an arrayref schema:
1901#   [ { name => 'param', type => 'string', ... }, ... ]
1902# to the standard named-parameter hashref form:
1903#   { param => { type => 'string', ... }, ... }
1904#
1905# The 'name' key is consumed during conversion and does not become a rule.
1906# Croaks if any element is not a hashref, is missing 'name', or if a name
1907# appears more than once.
1908sub _schema_from_arrayref
1909{
1910
14
15
        my ($arrayref, $logger) = @_;
1911
1912
14
9
        my %schema;
1913
14
14
10
16
        foreach my $spec (@{$arrayref}) {
1914
19
20
                _error($logger, "validate_strict: each arrayref schema element must be a hashref")
1915                        unless ref($spec) eq 'HASH';
1916                _error($logger, "validate_strict: arrayref schema element must have a 'name' key")
1917
18
20
                        unless exists($spec->{'name'});
1918
17
17
9
26
                my %rule = %{$spec};
1919
17
18
                my $name = delete $rule{'name'};
1920                _error($logger, "validate_strict: duplicate parameter '$name' in arrayref schema")
1921
17
16
                        if exists($schema{$name});
1922
16
20
                $schema{$name} = \%rule;
1923        }
1924
11
10
        return \%schema;
1925}
1926
1927# Return number of visible characters not number of bytes
1928# Ensure string is decoded into Perl characters
1929sub _number_of_characters
1930{
1931
148
79144
        my $value = $_[0];
1932
1933
148
142
        return if(!defined($value));
1934
1935
147
575
        if($value !~ /[^[:ascii:]]/) {
1936
118
147
                return length($value);
1937        }
1938        # Decode only if it's not already a Perl character string
1939
29
98
        $value = decode_utf8($value) unless utf8::is_utf8($value);
1940
1941        # Count grapheme clusters (visible characters)
1942        # The pseudo-operator () = forces list context to count matches
1943        # return scalar( () = $value =~ /\X/g );
1944
1945
29
96
        return Unicode::GCString->new($value)->length();
1946}
1947
1948sub _apply_nested_defaults {
1949
60
5695
        my ($input, $schema) = @_;
1950
60
87
        my %result = %$input;
1951
1952
60
72
        foreach my $key (keys %$schema) {
1953
129
97
                my $rules = $schema->{$key};
1954
1955
129
221
                if (ref $rules eq 'HASH' && exists $rules->{default} && !exists $result{$key}) {
1956
11
11
                        $result{$key} = $rules->{default};
1957                }
1958
1959                # Recursively handle nested schema
1960
129
210
                if((ref $rules eq 'HASH') && $rules->{schema} && (ref $result{$key} eq 'HASH')) {
1961
9
15
                        $result{$key} = _apply_nested_defaults($result{$key}, $rules->{schema});
1962                }
1963        }
1964
1965
60
61
        return \%result;
1966}
1967
1968sub _validate_relationships {
1969
44
45
        my ($validated_args, $relationships, $logger, $description) = @_;
1970
1971
44
49
        return unless ref($relationships) eq 'ARRAY';
1972
1973
44
38
        foreach my $rel (@$relationships) {
1974
44
51
                my $type = $rel->{type} or next;
1975
1976
44
86
                if ($type eq 'mutually_exclusive') {
1977
8
15
                        _validate_mutually_exclusive($validated_args, $rel, $logger, $description);
1978                } elsif ($type eq 'required_group') {
1979
4
7
                        _validate_required_group($validated_args, $rel, $logger, $description);
1980                } elsif ($type eq 'conditional_requirement') {
1981
5
8
                        _validate_conditional_requirement($validated_args, $rel, $logger, $description);
1982                } elsif ($type eq 'dependency') {
1983
6
30
                        _validate_dependency($validated_args, $rel, $logger, $description);
1984                } elsif ($type eq 'value_constraint') {
1985
16
23
                        _validate_value_constraint($validated_args, $rel, $logger, $description);
1986                } elsif ($type eq 'value_conditional') {
1987
5
10
                        _validate_value_conditional($validated_args, $rel, $logger, $description);
1988                } else {
1989
0
0
                        _error($logger, "Unknown relationship type $type");
1990                }
1991        }
1992}
1993
1994sub _validate_mutually_exclusive {
1995
12
6613
        my ($args, $rel, $logger, $description) = @_;
1996
1997
12
12
8
26
        my @params = @{$rel->{params} || []};
1998
12
16
        return unless @params >= 2;
1999
2000
12
24
13
45
        my @present = grep { exists($args->{$_}) && defined($args->{$_}) } @params;
2001
2002
12
19
        if (@present > 1) {
2003
6
17
                my $msg = $rel->{description} || 'Cannot specify both ' . join(' and ', @present);
2004
6
11
                _error($logger, "$description: $msg");
2005        }
2006}
2007
2008sub _validate_required_group {
2009
6
3571
        my ($args, $rel, $logger, $description) = @_;
2010
2011
6
6
11
13
        my @params = @{$rel->{params} || []};
2012
6
10
        return unless @params >= 2;
2013
2014
6
12
9
30
        my @present = grep { exists($args->{$_}) && defined($args->{$_}) } @params;
2015
2016
6
25
        if (@present == 0) {
2017                my $msg = $rel->{description} ||
2018
3
10
                        'Must specify at least one of: ' . join(', ', @params);
2019
3
6
                _error($logger, "$description: $msg");
2020        }
2021}
2022
2023sub _validate_conditional_requirement {
2024
9
5743
        my ($args, $rel, $logger, $description) = @_;
2025
2026
9
14
        my $if_param = $rel->{if} or return;
2027
9
9
        my $then_param = $rel->{then_required} or return;
2028
2029        # If the condition parameter is present and defined
2030
9
24
        if (exists($args->{$if_param}) && defined($args->{$if_param})) {
2031                # Check if it's truthy (for booleans and general values)
2032
7
11
                if ($args->{$if_param}) {
2033                        # Then the required parameter must also be present
2034
5
20
                        unless (exists($args->{$then_param}) && defined($args->{$then_param})) {
2035
2
6
                                my $msg = $rel->{description} || "When $if_param is specified, $then_param is required";
2036
2
4
                                _error($logger, "$description: $msg");
2037                        }
2038                }
2039        }
2040}
2041
2042sub _validate_dependency {
2043
9
4657
        my ($args, $rel, $logger, $description) = @_;
2044
2045
9
19
        my $param = $rel->{param} or return;
2046
9
14
        my $requires = $rel->{requires} or return;
2047
2048        # If param is present, requires must also be present
2049
9
24
        if (exists($args->{$param}) && defined($args->{$param})) {
2050
6
17
                unless (exists($args->{$requires}) && defined($args->{$requires})) {
2051
4
9
                        my $msg = $rel->{description} || "$param requires $requires to be specified";
2052
4
8
                        _error($logger, "$description: $msg");
2053                }
2054        }
2055}
2056
2057sub _validate_value_constraint {
2058
31
14701
        my ($args, $rel, $logger, $description) = @_;
2059
2060
31
57
        my $if_param = $rel->{if} or return;
2061
31
35
        my $then_param = $rel->{then} or return;
2062
31
32
        my $operator = $rel->{operator} or return;
2063
31
27
        my $value = $rel->{value};
2064
31
66
        return unless defined $value;
2065
2066        # If the condition parameter is present and truthy
2067
31
82
        if (exists($args->{$if_param}) && defined($args->{$if_param}) && $args->{$if_param}) {
2068                # Check if the then parameter exists
2069
28
47
                if (exists($args->{$then_param}) && defined($args->{$then_param})) {
2070
28
28
                        my $actual = $args->{$then_param};
2071
28
15
                        my $valid = 0;
2072
2073
28
54
                        if ($operator eq '==') {
2074
8
8
                                $valid = ($actual == $value);
2075                        } elsif ($operator eq '!=') {
2076
4
4
                                $valid = ($actual != $value);
2077                        } elsif ($operator eq '<') {
2078
4
3
                                $valid = ($actual < $value);
2079                        } elsif ($operator eq '<=') {
2080
4
4
                                $valid = ($actual <= $value);
2081                        } elsif ($operator eq '>') {
2082
4
4
                                $valid = ($actual > $value);
2083                        } elsif ($operator eq '>=') {
2084
4
4
                                $valid = ($actual >= $value);
2085                        }
2086
2087
28
42
                        unless ($valid) {
2088
16
32
                                my $msg = $rel->{description} || "When $if_param is specified, $then_param must be $operator $value (got $actual)";
2089
16
27
                                _error($logger, "$description: $msg");
2090                        }
2091                }
2092        }
2093}
2094
2095sub _validate_value_conditional {
2096
9
5908
        my ($args, $rel, $logger, $description) = @_;
2097
2098
9
12
        my $if_param = $rel->{if} or return;
2099
9
9
        my $equals = $rel->{equals};
2100
9
12
        my $then_param = $rel->{then_required} or return;
2101
9
13
        return unless defined $equals;
2102
2103        # If the parameter has the specific value
2104
9
23
        if (exists($args->{$if_param}) && defined($args->{$if_param})) {
2105
7
13
                if ($args->{$if_param} eq $equals) {
2106                        # Then the required parameter must be present
2107
5
16
                        unless (exists($args->{$then_param}) && defined($args->{$then_param})) {
2108                                my $msg = $rel->{description} ||
2109
3
7
                                        "When $if_param equals '$equals', $then_param is required";
2110
3
6
                                _error($logger, "$description: $msg");
2111                        }
2112                }
2113        }
2114}
2115
2116# Helper to log error or croak
2117sub _error
2118{
2119
454
4322
        my $logger = shift;
2120
454
525
        my $message = join('', @_);
2121
2122
454
554
        my @call_details = caller(0);
2123
454
6724
        if($logger) {
2124
15
41
                $logger->error(__PACKAGE__, ' line ', $call_details[2], ": $message");
2125        }
2126
449
2760
        croak(__PACKAGE__, ' line ', $call_details[2], ": $message");
2127        # Be absolutely sure, sometimes croak doesn't die for me in Test::Most scripts
2128
0
0
        die (__PACKAGE__, ' line ', $call_details[2], ": $message");
2129}
2130
2131# Helper to log warning or carp
2132sub _warn
2133{
2134
17
4607
        my $logger = shift;
2135
17
26
        my $message = join('', @_);
2136
2137
17
26
        if($logger) {
2138
7
21
                $logger->warn(__PACKAGE__, ": $message");
2139        } else {
2140
10
49
                carp(__PACKAGE__, ": $message");
2141        }
2142}
2143
2144 - 2300
=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 | 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 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
2301
23021;
2303