File Coverage

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

linestmtbrancondsubtimecode
1package Params::Validate::Strict;
2
3# FIXME: {max} doesn't play ball with non-ascii strings
4
5
19
19
19
1225006
16
255
use strict;
6
19
19
19
28
16
321
use warnings;
7
8
19
19
19
34
14
469
use Carp;
9
19
19
19
36
13
248
use Exporter qw(import);        # Required for @EXPORT_OK
10
19
19
19
3858
119029
775
use Encode qw(decode_utf8);
11
19
19
19
52
176
578
use List::Util 1.33 qw(any);    # Required for memberof validation
12
19
19
19
2853
77983
354
use Params::Get 0.13;
13
19
19
19
2938
53820
976
use Readonly::Values::Boolean;
14
19
19
19
77
17
282
use Scalar::Util;
15
19
19
19
2732
124972
62368
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.30

=cut
29
30our $VERSION = '0.30';
31
32 - 951
=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.

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<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
    ]
  };

=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<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<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 });

=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 Cvalidate>, 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
952
953sub validate_strict
954{
955
523
1728177
        my $params = Params::Get::get_params(undef, \@_);
956
957
523
6444
        my $schema = $params->{'schema'} || $params->{'members'};
958
523
786
        my $args = $params->{'args'} || $params->{'input'};
959
523
456
        my $logger = $params->{'logger'};
960
523
397
        my $custom_types = $params->{'custom_types'};
961
523
405
        my $unknown_parameter_handler = $params->{'unknown_parameter_handler'};
962
523
501
        if(!defined($unknown_parameter_handler)) {
963
507
584
                if($params->{'carp_on_warn'}) {
964
0
0
                        $unknown_parameter_handler = 'warn';
965                } else {
966
507
413
                        $unknown_parameter_handler = 'die';
967                }
968        }
969
970
523
485
        return $args if(!defined($schema));     # No schema, allow all arguments
971
972        # Check if schema and args are references to hashes
973
522
612
        if(ref($schema) ne 'HASH') {
974
2
3
                _error($logger, 'validate_strict: schema must be a hash reference');
975        }
976
977        # Inspired by Data::Processor
978
520
773
        my $schema_description = $params->{'description'} || 'validate_strict';
979
520
392
        my $error_msg = $params->{'error_msg'};
980
981
520
531
        if($schema->{'members'} && ($schema->{'description'} || $schema->{'error_msg'})) {
982
1
2
                $schema_description = $schema->{'description'};
983
1
1
                $error_msg = $schema->{'error_msg'};
984
1
1
                $schema = $schema->{'members'};
985        }
986
987
520
971
        if(exists($params->{'args'}) && (!defined($args))) {
988
1
1
                $args = {};
989        } elsif((ref($args) ne 'HASH') && (ref($args) ne 'ARRAY')) {
990
2
8
                _error($logger, $error_msg || "$schema_description: args must be a hash or array reference");
991        }
992
993
518
509
        if(ref($args) eq 'HASH') {
994                # Named args
995
513
513
349
592
                foreach my $key (keys %{$args}) {
996
672
695
                        if(!exists($schema->{$key})) {
997
13
23
                                if($unknown_parameter_handler eq 'die') {
998
5
10
                                        _error($logger, "$schema_description: Unknown parameter '$key'");
999                                } elsif($unknown_parameter_handler eq 'warn') {
1000
4
12
                                        _warn($logger, "$schema_description: Unknown parameter '$key'");
1001
4
192
                                        next;
1002                                } elsif($unknown_parameter_handler eq 'ignore') {
1003
2
2
                                        if($logger) {
1004
1
3
                                                $logger->debug(__PACKAGE__ . ": $schema_description: Unknown parameter '$key'");
1005                                        }
1006
2
6
                                        next;
1007                                } else {
1008
2
4
                                        _error($logger, "$schema_description: '$unknown_parameter_handler' unknown_parameter_handler must be one of die, warn, ignore");
1009                                }
1010                        }
1011                }
1012        }
1013
1014        # Find out if this routine takes positional arguments
1015
511
424
        my $are_positional_args = -1;
1016
511
511
341
480
        foreach my $key (keys %{$schema}) {
1017
511
538
                if(defined(my $rules = $schema->{$key})) {
1018
509
439
                        if(ref($rules) eq 'HASH') {
1019
481
488
                                if(!defined($rules->{'position'})) {
1020
475
438
                                        if($are_positional_args == 1) {
1021
0
0
                                                _error($logger, "::validate_strict: $key is missing position value");
1022                                        }
1023
475
341
                                        $are_positional_args = 0;
1024
475
444
                                        last;
1025                                }
1026
6
5
                                $are_positional_args = 1;
1027                        } else {
1028
28
20
                                $are_positional_args = 0;
1029
28
31
                                last;
1030                        }
1031                } else {
1032
2
2
                        $are_positional_args = 0;
1033
2
2
                        last;
1034                }
1035        }
1036
1037
511
397
        my %validated_args;
1038        my %invalid_args;
1039
511
511
336
473
        foreach my $key (keys %{$schema}) {
1040
724
508
                my $rules = $schema->{$key};
1041
724
432
                my $value;
1042
724
553
                if($are_positional_args == 1) {
1043
6
6
                        if(ref($args) ne 'ARRAY') {
1044
0
0
                                _error($logger, "::validate_strict: position $rules->{position} given for '$key', but args isn't an array");
1045                        }
1046
6
6
3
6
                        $value = @{$args}[$rules->{'position'}];
1047                } else {
1048
718
532
                        $value = $args->{$key};
1049                }
1050
1051
723
582
                if(!defined($rules)) {  # Allow anything
1052
2
2
                        $validated_args{$key} = $value;
1053
2
2
                        next;
1054                }
1055
1056                # If rules are a simple type string
1057
721
684
                if(ref($rules) eq '') {
1058
26
23
                        $rules = { type => $rules };
1059                }
1060
1061
721
461
                my $is_optional = 0;
1062
1063
721
426
                my $rule_description = $schema_description;     # Can be overridden in each element
1064
1065
721
625
                if(ref($rules) eq 'HASH') {
1066
708
676
                        if(exists($rules->{'description'})) {
1067
0
0
                                $rule_description = $rules->{'description'};
1068                        }
1069
708
707
                        if($rules->{'transform'} && defined($value)) {
1070
40
39
                                if(ref($rules->{'transform'}) eq 'CODE') {
1071
38
38
34
50
                                        $value = &{$rules->{'transform'}}($value);
1072                                } else {
1073
2
4
                                        _error($logger, "$rule_description: transforms must be a code ref");
1074                                }
1075                        }
1076
706
880
                        if(exists($rules->{optional})) {
1077
155
156
                                if(ref($rules->{'optional'}) eq 'CODE') {
1078
9
9
7
11
                                        $is_optional = &{$rules->{optional}}($value, $args);
1079                                } else {
1080
146
114
                                        $is_optional = $rules->{'optional'};
1081                                }
1082                        } elsif($rules->{nullable}) {
1083
0
0
                                $is_optional = $rules->{'nullable'};
1084                        }
1085                }
1086
1087                # Handle optional parameters
1088
719
1418
                if((ref($rules) eq 'HASH') && $is_optional) {
1089
147
101
                        my $look_for_default = 0;
1090
147
110
                        if($are_positional_args == 1) {
1091                                # if(!defined(@{$args}[$rules->{'position'}])) {
1092
2
4
                                if(!defined($args->[$rules->{position}])) {
1093
1
1
                                        $look_for_default = 1;
1094                                }
1095                        } else {
1096
145
130
                                if(!exists($args->{$key})) {
1097
76
58
                                        $look_for_default = 1;
1098                                }
1099                        }
1100
147
121
                        if($look_for_default) {
1101
77
109
                                if($are_positional_args == 1) {
1102
1
1
1
2
                                        if(scalar(@{$args}) < $rules->{'position'}) {
1103                                                # arg array is too short, so it must be missing
1104
0
0
                                                _error($logger, "$rule_description: Required parameter '$key' is missing");
1105
0
0
                                                next;
1106                                        }
1107                                }
1108
77
84
                                if(exists($rules->{'default'})) {
1109                                        # Populate missing optional parameters with the specified output values
1110
5
7
                                        $validated_args{$key} = $rules->{'default'};
1111                                }
1112
1113
77
76
                                if($rules->{'schema'}) {
1114
4
7
                                        $value = _apply_nested_defaults({}, $rules->{'schema'});
1115
4
4
4
6
                                        next unless scalar(%{$value});
1116                                        # The nested schema has a default value
1117                                } else {
1118
73
67
                                        next;   # optional and missing
1119                                }
1120                        }
1121                } elsif((ref($args) eq 'HASH') && !exists($args->{$key})) {
1122                        # The parameter is required
1123
7
28
                        _error($logger, "$rule_description: Required parameter '$key' is missing");
1124                }
1125
1126                # Validate based on rules
1127
636
563
                if(ref($rules) eq 'HASH') {
1128
623
1025
                        if(defined(my $min = $rules->{'min'} // $rules->{'minimum'}) && defined(my $max = $rules->{'max'})) {
1129
79
84
                                if($min > $max) {
1130
5
9
                                        _error($logger, "validate_strict($key): min must be <= max ($min > $max)");
1131                                }
1132                        }
1133
1134
618
548
                        if($rules->{'memberof'}) {
1135
68
122
                                if(defined(my $min = $rules->{'min'} // $rules->{'minimum'})) {
1136
3
7
                                        _error($logger, "validate_strict($key): min ($min) makes no sense with memberof");
1137                                }
1138
65
90
                                if(defined(my $max = $rules->{'max'})) {
1139
1
3
                                        _error($logger, "validate_strict($key): max ($max) makes no sense with memberof");
1140                                }
1141                        }
1142
1143
614
590
                        foreach my $rule_name (keys %$rules) {
1144
1163
809
                                my $rule_value = $rules->{$rule_name};
1145
1146
1163
1116
                                if((ref($rule_value) eq 'CODE') && ($rule_name ne 'validate') && ($rule_name ne 'callback') && ($rule_name ne 'validator')) {
1147
55
55
29
79
                                        $rule_value = &{$rule_value}($value, $args);
1148                                }
1149
1150                                # Better OOP, the routine has been given an object rather than a scalar
1151
1163
1416
                                if(Scalar::Util::blessed($rule_value) && $rule_value->can('as_string')) {
1152
0
0
                                        $rule_value = $rule_value->as_string();
1153                                }
1154
1155
1163
2304
                                if($rule_name eq 'type') {
1156
545
431
                                        my $type = lc($rule_value);
1157
1158
545
1074
                                        if(($type eq 'string') || ($type eq 'str')) {
1159
248
197
                                                if(ref($value)) {
1160
6
20
                                                        _error($logger, $rules->{'error_msg'} || "$rule_description: Parameter '$key' must be a string");
1161                                                }
1162
242
283
                                                unless((ref($value) eq '') || (defined($value) && length($value))) {    # Allow undef for optional strings
1163
0
0
                                                        _error($logger, $rules->{'error_msg'} || "$rule_description: Parameter '$key' must be a string");
1164                                                }
1165                                        } elsif($type eq 'integer') {
1166
91
88
                                                if(!defined($value)) {
1167
1
1
                                                        next;   # Skip if number is undefined
1168                                                }
1169
90
247
                                                if($value !~ /^\s*[+\-]?\d+\s*$/) {
1170
5
9
                                                        if($rules->{'error_msg'}) {
1171
1
3
                                                                _error($logger, $rules->{'error_msg'});
1172                                                        } else {
1173
4
11
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be an integer");
1174                                                        }
1175                                                }
1176
85
92
                                                $value = int($value); # Coerce to integer
1177                                        } elsif(($type eq 'number') || ($type eq 'float')) {
1178
49
50
                                                if(!defined($value)) {
1179
2
2
                                                        next;   # Skip if number is undefined
1180                                                }
1181
47
74
                                                if(!Scalar::Util::looks_like_number($value)) {
1182
2
3
                                                        if($rules->{'error_msg'}) {
1183
0
0
                                                                _error($logger, $rules->{'error_msg'});
1184                                                        } else {
1185
2
4
                                                                _error($logger, "$rule_description: Parameter '$key' must be a number");
1186                                                        }
1187                                                }
1188                                                # $value = eval $value; # Coerce to number (be careful with eval)
1189
45
63
                                                $value = 0 + $value;    # Numeric coercion
1190                                        } elsif($type eq 'arrayref') {
1191
41
64
                                                if(!defined($value)) {
1192
2
3
                                                        next;   # Skip if arrayref is undefined
1193                                                }
1194
39
65
                                                if(ref($value) ne 'ARRAY') {
1195
0
0
                                                        if($rules->{'error_msg'}) {
1196
0
0
                                                                _error($logger, $rules->{'error_msg'});
1197                                                        } else {
1198
0
0
                                                                _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1199                                                        }
1200                                                }
1201                                        } elsif($type eq 'hashref') {
1202
30
58
                                                if(!defined($value)) {
1203
2
2
                                                        next;   # Skip if hashref is undefined
1204                                                }
1205
28
37
                                                if(ref($value) ne 'HASH') {
1206
0
0
                                                        if($rules->{'error_msg'}) {
1207
0
0
                                                                _error($logger, $rules->{'error_msg'});
1208                                                        } else {
1209
0
0
                                                                _error($logger, "$rule_description: Parameter '$key' must be an hashref");
1210                                                        }
1211                                                }
1212                                        } elsif(($type eq 'boolean') || ($type eq 'bool')) {
1213
21
20
                                                if(!defined($value)) {
1214
1
1
                                                        next;   # Skip if bool is undefined
1215                                                }
1216
20
66
                                                if(defined(my $b = $Readonly::Values::Boolean::booleans{$value})) {
1217
18
95
                                                        $value = $b;
1218                                                } else {
1219
2
12
                                                        if($rules->{'error_msg'}) {
1220
0
0
                                                                _error($logger, $rules->{'error_msg'});
1221                                                        } else {
1222
2
5
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be a boolean");
1223                                                        }
1224                                                }
1225                                        } elsif($type eq 'coderef') {
1226
3
4
                                                if(!defined($value)) {
1227
1
2
                                                        next;   # Skip if code is undefined
1228                                                }
1229
2
6
                                                if(ref($value) ne 'CODE') {
1230
0
0
                                                        if($rules->{'error_msg'}) {
1231
0
0
                                                                _error($logger, $rules->{'error_msg'});
1232                                                        } else {
1233
0
0
                                                                _error($logger, "$rule_description: Parameter '$key' must be a coderef");
1234                                                        }
1235                                                }
1236                                        } elsif($type eq 'object') {
1237
16
17
                                                if(!defined($value)) {
1238
1
2
                                                        next;   # Skip if object is undefined
1239                                                }
1240
15
31
                                                if(!Scalar::Util::blessed($value)) {
1241
1
2
                                                        if($rules->{'error_msg'}) {
1242
0
0
                                                                _error($logger, $rules->{'error_msg'});
1243                                                        } else {
1244
1
2
                                                                _error($logger, "$rule_description: Parameter '$key' must be an object");
1245                                                        }
1246                                                }
1247                                        } elsif(my $custom_type = $custom_types->{$type}) {
1248
45
45
                                                if($custom_type->{'transform'}) {
1249                                                        # The custom type has a transform embedded within it
1250
6
7
                                                        if(ref($custom_type->{'transform'}) eq 'CODE') {
1251
6
6
5
16
                                                                $value = &{$custom_type->{'transform'}}($value);
1252                                                        } else {
1253
0
0
                                                                _error($logger, "$rule_description: transforms must be a code ref");
1254
0
0
                                                                next;
1255                                                        }
1256                                                }
1257
45
242
                                                validate_strict({ input => { $key => $value }, schema => { $key => $custom_type }, custom_types => $custom_types });
1258                                        } else {
1259
1
2
                                                _error($logger, "$rule_description: Unknown type '$type'");
1260                                        }
1261                                } elsif(($rule_name eq 'min') || ($rule_name eq 'minimum')) {
1262
155
155
                                        if(!defined($rules->{'type'})) {
1263
0
0
                                                _error($logger, "$rule_description: Don't know type of '$key' to determine its minimum value $rule_value");
1264                                        }
1265
155
158
                                        my $type = lc($rules->{'type'});
1266
155
300
                                        if(exists($custom_types->{$type}->{'min'}) || exists($custom_types->{$type}->{minimum})) {
1267
3
6
                                                $rule_value = $custom_types->{$type}->{'min'} // $custom_types->{$type}->{minumum};
1268
3
3
                                                $type = $custom_types->{$type}->{'type'};
1269                                        }
1270
155
350
                                        if(($type eq 'string') || ($type eq 'str')) {
1271
54
54
                                                if($rule_value < 0) {
1272
1
2
                                                        if($rules->{'error_msg'}) {
1273
0
0
                                                                _error($logger, $rules->{'error_msg'});
1274                                                        } else {
1275
1
1
                                                                _error($logger, "$rule_description: String parameter '$key' has meaningless minimum value that is less than zero");
1276                                                        }
1277                                                }
1278
53
49
                                                if(!defined($value)) {
1279
0
0
                                                        next;   # Skip if string is undefined
1280                                                }
1281
53
61
                                                if(defined(my $len = _number_of_characters($value))) {
1282
53
124
                                                        if($len < $rule_value) {
1283
8
43
                                                                _error($logger, $rules->{'error_msg'} || "$rule_description: String parameter '$key' too short, ($len characters), must be at least $rule_value characters");
1284
0
0
                                                                $invalid_args{$key} = 1;
1285                                                        }
1286                                                } else {
1287
0
0
                                                        _error($logger, $rules->{'error_msg'} || "$rule_description: '$key' can't be decoded");
1288
0
0
                                                        $invalid_args{$key} = 1;
1289                                                }
1290                                        } elsif($type eq 'arrayref') {
1291
16
19
                                                if(!defined($value)) {
1292
0
0
                                                        next;   # Skip if array is undefined
1293                                                }
1294
16
22
                                                if(ref($value) ne 'ARRAY') {
1295
0
0
                                                        if($rules->{'error_msg'}) {
1296
0
0
                                                                _error($logger, $rules->{'error_msg'});
1297                                                        } else {
1298
0
0
                                                                _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1299                                                        }
1300                                                }
1301
16
16
11
36
                                                if(scalar(@{$value}) < $rule_value) {
1302
2
3
                                                        if($rules->{'error_msg'}) {
1303
0
0
                                                                _error($logger, $rules->{'error_msg'});
1304                                                        } else {
1305
2
4
                                                                _error($logger, "$rule_description: Parameter '$key' must be at least length $rule_value");
1306                                                        }
1307
0
0
                                                        $invalid_args{$key} = 1;
1308                                                }
1309                                        } elsif($type eq 'hashref') {
1310
4
4
                                                if(!defined($value)) {
1311
0
0
                                                        next;   # Skip if hash is undefined
1312                                                }
1313
4
4
4
6
                                                if(scalar(keys(%{$value})) < $rule_value) {
1314
1
2
                                                        if($rules->{'error_msg'}) {
1315
0
0
                                                                _error($logger, $rules->{'error_msg'});
1316                                                        } else {
1317
1
3
                                                                _error($logger, "$rule_description: Parameter '$key' must contain at least $rule_value keys");
1318                                                        }
1319
0
0
                                                        $invalid_args{$key} = 1;
1320                                                }
1321                                        } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
1322
80
80
                                                if(!defined($value)) {
1323
0
0
                                                        next;   # Skip if hash is undefined
1324                                                }
1325
80
116
                                                if(Scalar::Util::looks_like_number($value)) {
1326
79
105
                                                        if($value < $rule_value) {
1327
18
27
                                                                if($rules->{'error_msg'}) {
1328
3
5
                                                                        _error($logger, $rules->{'error_msg'});
1329                                                                } else {
1330
15
30
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be at least $rule_value");
1331                                                                }
1332
0
0
                                                                $invalid_args{$key} = 1;
1333
0
0
                                                                next;
1334                                                        }
1335                                                } else {
1336
1
1
                                                        if($rules->{'error_msg'}) {
1337
0
0
                                                                _error($logger, $rules->{'error_msg'});
1338                                                        } else {
1339
1
3
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be a number");
1340                                                        }
1341
0
0
                                                        next;
1342                                                }
1343                                        } else {
1344
1
2
                                                _error($logger, "$rule_description: Parameter '$key' of type '$type' has meaningless min value $rule_value");
1345                                        }
1346                                } elsif($rule_name eq 'max') {
1347
68
75
                                        if(!defined($rules->{'type'})) {
1348
0
0
                                                _error($logger, "$rule_description: Don't know type of '$key' to determine its maximum value $rule_value");
1349                                        }
1350
68
65
                                        my $type = lc($rules->{'type'});
1351
68
93
                                        if(exists($custom_types->{$type}->{'max'})) {
1352
2
3
                                                $rule_value = $custom_types->{$type}->{'max'};
1353
2
2
                                                $type = $custom_types->{$type}->{'type'};
1354                                        }
1355
68
192
                                        if(($type eq 'string') || ($type eq 'str')) {
1356
22
36
                                                if(!defined($value)) {
1357
0
0
                                                        next;   # Skip if string is undefined
1358                                                }
1359
22
22
                                                if(defined(my $len = _number_of_characters($value))) {
1360
22
38
                                                        if($len > $rule_value) {
1361
5
22
                                                                _error($logger, $rules->{'error_msg'} || "$rule_description: String parameter '$key' too long, ($len characters), must be no longer than $rule_value");
1362
0
0
                                                                $invalid_args{$key} = 1;
1363                                                        }
1364                                                } else {
1365
0
0
                                                        _error($logger, $rules->{'error_msg'} || "$rule_description: '$key' can't be decoded");
1366
0
0
                                                        $invalid_args{$key} = 1;
1367                                                }
1368                                        } elsif($type eq 'arrayref') {
1369
8
8
                                                if(!defined($value)) {
1370
0
0
                                                        next;   # Skip if string is undefined
1371                                                }
1372
8
10
                                                if(ref($value) ne 'ARRAY') {
1373
0
0
                                                        if($rules->{'error_msg'}) {
1374
0
0
                                                                _error($logger, $rules->{'error_msg'});
1375                                                        } else {
1376
0
0
                                                                _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1377                                                        }
1378                                                }
1379
8
8
8
11
                                                if(scalar(@{$value}) > $rule_value) {
1380
4
7
                                                        if($rules->{'error_msg'}) {
1381
0
0
                                                                _error($logger, $rules->{'error_msg'});
1382                                                        } else {
1383
4
8
                                                                _error($logger, "$rule_description: Parameter '$key' must contain no more than $rule_value items");
1384                                                        }
1385
0
0
                                                        $invalid_args{$key} = 1;
1386                                                }
1387                                        } elsif($type eq 'hashref') {
1388
3
3
                                                if(!defined($value)) {
1389
0
0
                                                        next;   # Skip if hash is undefined
1390                                                }
1391
3
3
2
6
                                                if(scalar(keys(%{$value})) > $rule_value) {
1392
2
3
                                                        if($rules->{'error_msg'}) {
1393
0
0
                                                                _error($logger, $rules->{'error_msg'});
1394                                                        } else {
1395
2
5
                                                                _error($logger, "$rule_description: Parameter '$key' must contain no more than $rule_value keys");
1396                                                        }
1397
0
0
                                                        $invalid_args{$key} = 1;
1398                                                }
1399                                        } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
1400
34
40
                                                if(!defined($value)) {
1401
0
0
                                                        next;   # Skip if hash is undefined
1402                                                }
1403
34
49
                                                if(Scalar::Util::looks_like_number($value)) {
1404
34
51
                                                        if($value > $rule_value) {
1405
4
13
                                                                if($rules->{'error_msg'}) {
1406
0
0
                                                                        _error($logger, $rules->{'error_msg'});
1407                                                                } else {
1408
4
20
                                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must be no more than $rule_value");
1409                                                                }
1410
0
0
                                                                $invalid_args{$key} = 1;
1411
0
0
                                                                next;
1412                                                        }
1413                                                } else {
1414
0
0
                                                        if($rules->{'error_msg'}) {
1415
0
0
                                                                _error($logger, $rules->{'error_msg'});
1416                                                        } else {
1417
0
0
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be a number");
1418                                                        }
1419
0
0
                                                        next;
1420                                                }
1421                                        } else {
1422
1
2
                                                _error($logger, "$rule_description: Parameter '$key' of type '$type' has meaningless max value $rule_value");
1423                                        }
1424                                } elsif($rule_name eq 'matches') {
1425
56
56
                                        if(!defined($value)) {
1426
1
1
                                                next;   # Skip if string is undefined
1427                                        }
1428
55
63
                                        eval {
1429
55
81
                                                my $re = (ref($rule_value) eq 'Regexp') ? $rule_value : qr/\Q$rule_value\E/;
1430
55
269
                                                if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1431
2
4
2
2
10
2
                                                        my @matches = grep { $_ =~ $re } @{$value};
1432
2
2
2
6
                                                        if(scalar(@matches) != scalar(@{$value})) {
1433
0
0
                                                                if($rules->{'error_msg'}) {
1434
0
0
                                                                        _error($logger, $rules->{'error_msg'});
1435                                                                } else {
1436
0
0
0
0
                                                                        _error($logger, "$rule_description: All members of parameter '$key' [", join(', ', @{$value}), "] must match pattern '$rule_value'");
1437                                                                }
1438                                                        }
1439                                                } elsif($value !~ $re) {
1440
16
22
                                                        if($rules->{'error_msg'}) {
1441
2
3
                                                                _error($logger, $rules->{'error_msg'});
1442                                                        } else {
1443
14
45
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must match pattern '$re'");
1444                                                        }
1445                                                }
1446
39
75
                                                1;
1447                                        };
1448
55
18104
                                        if($@) {
1449
16
26
                                                if($rules->{'error_msg'}) {
1450
2
4
                                                        _error($logger, $rules->{'error_msg'});
1451                                                } else {
1452
14
37
                                                        _error($logger, "$rule_description: Parameter '$key' regex '$rule_value' error: $@");
1453                                                }
1454
0
0
                                                $invalid_args{$key} = 1;
1455                                        }
1456                                } elsif($rule_name eq 'nomatch') {
1457
7
10
                                        if(!defined($value)) {
1458
0
0
                                                next;   # Skip if string is undefined
1459                                        }
1460
7
31
                                        if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1461
3
9
3
1
16
4
                                                my @matches = grep { /$rule_value/ } @{$value};
1462
3
5
                                                if(scalar(@matches)) {
1463
1
1
                                                        if($rules->{'error_msg'}) {
1464
0
0
                                                                _error($logger, $rules->{'error_msg'});
1465                                                        } else {
1466
1
1
2
3
                                                                _error($logger, "$rule_description: No member of parameter '$key' [", join(', ', @{$value}), "] must match pattern '$rule_value'");
1467                                                        }
1468                                                }
1469                                        } elsif($value =~ $rule_value) {
1470
1
1
                                                if($rules->{'error_msg'}) {
1471
0
0
                                                        _error($logger, $rules->{'error_msg'});
1472                                                } else {
1473
1
3
                                                        _error($logger, "$rule_description: Parameter '$key' ($value) must not match pattern '$rule_value'");
1474                                                }
1475
0
0
                                                $invalid_args{$key} = 1;
1476                                        }
1477                                } elsif(($rule_name eq 'memberof') || ($rule_name eq 'enum')) {
1478
65
63
                                        if(!defined($value)) {
1479
0
0
                                                next;   # Skip if string is undefined
1480                                        }
1481
65
59
                                        if(ref($rule_value) eq 'ARRAY') {
1482
63
51
                                                my $ok = 1;
1483
63
136
                                                if(($rules->{'type'} eq 'integer') || ($rules->{'type'} eq 'number') || ($rules->{'type'} eq 'float')) {
1484
12
41
12
26
33
21
                                                        unless(List::Util::any { $_ == $value } @{$rule_value}) {
1485
5
5
                                                                $ok = 0;
1486                                                        }
1487                                                } else {
1488
51
48
                                                        my $l = lc($value);
1489
51
248
51
115
255
74
                                                        unless(List::Util::any { (!defined($rules->{'case_sensitive'}) || ($rules->{'case_sensitive'} == 1)) ? $_ eq $value : lc($_) eq $l } @{$rule_value}) {
1490
15
13
                                                                $ok = 0;
1491                                                        }
1492                                                }
1493
1494
63
132
                                                if(!$ok) {
1495
20
24
                                                        if($rules->{'error_msg'}) {
1496
3
5
                                                                _error($logger, $rules->{'error_msg'});
1497                                                        } else {
1498
17
17
22
37
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must be one of ", join(', ', @{$rule_value}));
1499                                                        }
1500
0
0
                                                        $invalid_args{$key} = 1;
1501                                                }
1502                                        } else {
1503
2
4
                                                if($rules->{'error_msg'}) {
1504
0
0
                                                        _error($logger, $rules->{'error_msg'});
1505                                                } else {
1506
2
4
                                                        _error($logger, "$rule_description: Parameter '$key' rule ($rule_value) must be an array reference");
1507                                                }
1508                                        }
1509                                } elsif($rule_name eq 'notmemberof') {
1510
24
23
                                        if(!defined($value)) {
1511
0
0
                                                next;   # Skip if string is undefined
1512                                        }
1513
24
21
                                        if(ref($rule_value) eq 'ARRAY') {
1514
23
16
                                                my $ok = 1;
1515
23
49
                                                if(($rules->{'type'} eq 'integer') || ($rules->{'type'} eq 'number') || ($rules->{'type'} eq 'float')) {
1516
6
17
6
10
13
13
                                                        if(List::Util::any { $_ == $value } @{$rule_value}) {
1517
4
4
                                                                $ok = 0;
1518                                                        }
1519                                                } else {
1520
17
16
                                                        my $l = lc($value);
1521
17
33
17
42
52
30
                                                        if(List::Util::any { (!defined($rules->{'case_sensitive'}) || ($rules->{'case_sensitive'} == 1)) ? $_ eq $value : lc($_) eq $l } @{$rule_value}) {
1522
9
9
                                                                $ok = 0;
1523                                                        }
1524                                                }
1525
1526
23
49
                                                if(!$ok) {
1527
13
14
                                                        if($rules->{'error_msg'}) {
1528
1
2
                                                                _error($logger, $rules->{'error_msg'});
1529                                                        } else {
1530
12
12
17
26
                                                                _error($logger, "$rule_description: Parameter '$key' ($value) must not be one of ", join(', ', @{$rule_value}));
1531                                                        }
1532
0
0
                                                        $invalid_args{$key} = 1;
1533                                                }
1534                                        } else {
1535
1
2
                                                if($rules->{'error_msg'}) {
1536
0
0
                                                        _error($logger, $rules->{'error_msg'});
1537                                                } else {
1538
1
2
                                                        _error($logger, "$rule_description: Parameter '$key' rule ($rule_value) must be an array reference");
1539                                                }
1540                                        }
1541                                } elsif($rule_name eq 'isa') {
1542
6
9
                                        if(!defined($value)) {
1543
0
0
                                                next;   # Skip if object not given
1544                                        }
1545
6
8
                                        if($rules->{'type'} eq 'object') {
1546
5
15
                                                if(!$value->isa($rule_value)) {
1547
1
7
                                                        _error($logger, "$rule_description: Parameter '$key' must be a '$rule_value' object got a " . (ref($value) ? ref($value) : $value) . ' object instead');
1548
0
0
                                                        $invalid_args{$key} = 1;
1549                                                }
1550                                        } else {
1551
1
2
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless isa value $rule_value");
1552                                        }
1553                                } elsif($rule_name eq 'can') {
1554
16
19
                                        if(!defined($value)) {
1555
0
0
                                                next;   # Skip if object not given
1556                                        }
1557
16
17
                                        if($rules->{'type'} eq 'object') {
1558
15
32
                                                if(ref($rule_value) eq 'ARRAY') {
1559                                                        # List of methods
1560
8
8
7
7
                                                        foreach my $method(@{$rule_value}) {
1561
15
42
                                                                if(!$value->can($method)) {
1562
4
10
                                                                        _error($logger, "$rule_description: Parameter '$key' must be an object that understands the $method method");
1563
0
0
                                                                        $invalid_args{$key} = 1;
1564                                                                }
1565                                                        }
1566                                                } elsif(!ref($rule_value)) {
1567
6
25
                                                        if(!$value->can($rule_value)) {
1568
3
8
                                                                _error($logger, "$rule_description: Parameter '$key' must be an object that understands the $rule_value method");
1569
0
0
                                                                $invalid_args{$key} = 1;
1570                                                        }
1571                                                } else {
1572
1
2
                                                        _error($logger, "$rule_description: 'can' rule for Parameter '$key must be either a scalar or an arrayref");
1573                                                }
1574                                        } else {
1575
1
2
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless can value '$rule_value' for parameter type $rules->{type}");
1576                                        }
1577                                } elsif($rule_name eq 'element_type') {
1578
21
50
                                        if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1579
21
17
                                                my $type = $rule_value;
1580
21
20
                                                my $custom_type = $custom_types->{$rule_value};
1581
21
40
                                                if($custom_type && $custom_type->{'type'}) {
1582
1
1
                                                        $type = $custom_type->{'type'};
1583                                                }
1584
21
21
16
36
                                                foreach my $member(@{$value}) {
1585
44
40
                                                        if($custom_type && $custom_type->{'transform'}) {
1586                                                                # The custom type has a transform embedded within it
1587
2
3
                                                                if(ref($custom_type->{'transform'}) eq 'CODE') {
1588
2
2
2
3
                                                                        $member = &{$custom_type->{'transform'}}($member);
1589                                                                } else {
1590
0
0
                                                                        _error($logger, "$rule_description: transforms must be a code ref");
1591
0
0
                                                                        last;
1592                                                                }
1593                                                        }
1594
44
78
                                                        if(($type eq 'string') || ($type eq 'Str')) {
1595
15
17
                                                                if(ref($member)) {
1596
0
0
                                                                        if($rules->{'error_msg'}) {
1597
0
0
                                                                                _error($logger, $rules->{'error_msg'});
1598                                                                        } else {
1599
0
0
                                                                                _error($logger, "$key can only contain strings");
1600                                                                        }
1601
0
0
                                                                        $invalid_args{$key} = 1;
1602                                                                }
1603                                                        } elsif($type eq 'integer') {
1604
25
46
                                                                if(ref($member) || ($member =~ /\D/)) {
1605
3
4
                                                                        if($rules->{'error_msg'}) {
1606
1
2
                                                                                _error($logger, $rules->{'error_msg'});
1607                                                                        } else {
1608
2
4
                                                                                _error($logger, "$key can only contain integers (found $member)");
1609                                                                        }
1610
0
0
                                                                        $invalid_args{$key} = 1;
1611                                                                }
1612                                                        } elsif(($type eq 'number') || ($rule_value eq 'float')) {
1613
4
14
                                                                if(ref($member) || ($member !~ /^[-+]?(\d*\.\d+|\d+\.?\d*)$/)) {
1614
1
3
                                                                        if($rules->{'error_msg'}) {
1615
0
0
                                                                                _error($logger, $rules->{'error_msg'});
1616                                                                        } else {
1617
1
3
                                                                                _error($logger, "$key can only contain numbers (found $member)");
1618                                                                        }
1619
0
0
                                                                        $invalid_args{$key} = 1;
1620                                                                }
1621                                                        } else {
1622
0
0
                                                                _error($logger, "BUG: Add $type to element_type list");
1623                                                        }
1624                                                }
1625                                        } else {
1626
0
0
                                                _error($logger, "$rule_description: Parameter '$key' has meaningless element_type value $rule_value");
1627                                        }
1628                                } elsif($rule_name eq 'optional') {
1629                                        # Already handled at the beginning of the loop
1630                                } elsif($rule_name eq 'default') {
1631                                        # Handled earlier
1632                                } elsif($rule_name eq 'error_msg') {
1633                                        # Handled inline
1634                                } elsif($rule_name eq 'transform') {
1635                                        # Handled before the loop
1636                                } elsif($rule_name eq 'case_sensitive') {
1637                                        # Handled inline
1638                                } elsif($rule_name eq 'description') {
1639                                        # A la, Data::Processor
1640                                } elsif($rule_name =~ /^_/) {
1641                                        # Ignore internal/metadata fields from schema extraction
1642                                } elsif($rule_name eq 'semantic') {
1643
1
2
                                        if($rule_value eq 'unix_timestamp') {
1644
1
3
                                                if($value < 0 || $value > 2147483647) {
1645
0
0
                                                        error($logger, 'Invalid Unix timestamp: $value');
1646                                                }
1647                                        } else {
1648
0
0
                                                _warn($logger, "semantic type $rule_value is not yet supported");
1649                                        }
1650                                } elsif($rule_name eq 'schema') {
1651                                        # Nested schema Run the given schema against each element of the array
1652
43
97
                                        if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1653
12
16
                                                if(ref($value) eq 'ARRAY') {
1654
11
11
7
15
                                                        foreach my $member(@{$value}) {
1655
17
71
                                                                if(!validate_strict({ input => { $key => $member }, schema => { $key => $rule_value }, custom_types => $custom_types })) {
1656
0
0
                                                                        $invalid_args{$key} = 1;
1657                                                                }
1658                                                        }
1659                                                } elsif(defined($value)) {      # Allow undef for optional values
1660
1
2
                                                        _error($logger, "$rule_description: nested schema: Parameter '$value' must be an arrayref");
1661                                                }
1662                                        } elsif($rules->{'type'} eq 'hashref') {
1663
31
34
                                                if(ref($value) eq 'HASH') {
1664                                                        # Apply nested defaults before validation
1665
31
39
                                                        my $nested_with_defaults = _apply_nested_defaults($value, $rule_value);
1666
31
31
20
37
                                                        if(scalar keys(%{$value})) {
1667
29
150
                                                                if(my $new_args = validate_strict({ input => $nested_with_defaults, schema => $rule_value, custom_types => $custom_types })) {
1668
18
32
                                                                        $value = $new_args;
1669                                                                } else {
1670
0
0
                                                                        $invalid_args{$key} = 1;
1671                                                                }
1672                                                        }
1673                                                } else {
1674
0
0
                                                        _error($logger, "$rule_description: nested schema: Parameter '$value' must be an hashref");
1675                                                }
1676                                        } else {
1677
0
0
                                                _error($logger, "$rule_description: Parameter '$key': 'schema' only supports arrayref and hashref, not $rules->{type}");
1678                                        }
1679                                } elsif(($rule_name eq 'validate') || ($rule_name eq 'validator')) {
1680
2
1
                                        if(ref($rule_value) eq 'CODE') {
1681
2
2
4
2
                                                if(my $error = &{$rule_value}($args)) {
1682
1
4
                                                        _error($logger, "$rule_description: $key not valid: $error");
1683
0
0
                                                        $invalid_args{$key} = 1;
1684                                                }
1685                                        } else {
1686                                                # _error($logger, "$rule_description: Parameter '$key': 'validate' only supports coderef, not $value");
1687
0
0
                                                _error($logger, "$rule_description: Parameter '$key': 'validate' only supports coderef, not " . ref($rule_value) // $rule_value);
1688                                        }
1689                                } elsif ($rule_name eq 'callback') {
1690                                        # Custom validation code
1691
17
39
                                        unless (defined &$rule_value) {
1692
1
2
                                                _error($logger, "$rule_description: callback for '$key' must be a code reference");
1693                                        }
1694
16
25
                                        my $res = $rule_value->($value, $args, $schema);
1695
15
2859
                                        unless ($res) {
1696
6
8
                                                if($rules->{'error_msg'}) {
1697
0
0
                                                        _error($logger, $rules->{'error_msg'});
1698                                                } else {
1699
6
12
                                                        _error($logger, "$rule_description: Parameter '$key' failed custom validation");
1700                                                }
1701
0
0
                                                $invalid_args{$key} = 1;
1702                                        }
1703                                } elsif($rule_name eq 'position') {
1704
5
6
                                        if($rule_value =~ /\D/) {
1705
0
0
                                                _error($logger, "$rule_description: Parameter '$key': 'position' must be an integer");
1706                                        }
1707
5
7
                                        if($rule_value < 0) {
1708
0
0
                                                _error($logger, "$rule_description: Parameter '$key': 'position' must be a positive integer, not $value");
1709                                        }
1710                                } else {
1711
0
0
                                        _error($logger, "$rule_description: Unknown rule '$rule_name'");
1712                                }
1713                        }
1714                } elsif(ref($rules) eq 'ARRAY') {
1715
12
12
7
14
                        if(scalar(@{$rules})) {
1716                                # An argument can be one of several different type
1717
10
14
                                my $rc = 0;
1718
10
7
                                my @types;
1719
10
10
9
11
                                foreach my $rule(@{$rules}) {
1720
17
23
                                        if(ref($rule) ne 'HASH') {
1721
1
3
                                                _error($logger, "$rule_description: Parameter '$key' rules must be a hash reference");
1722
0
0
                                                next;
1723                                        }
1724
16
19
                                        if(!defined($rule->{'type'})) {
1725
0
0
                                                _error($logger, "$rule_description: Parameter '$key' is missing a type in an alternative");
1726
0
0
                                                next;
1727                                        }
1728
16
17
                                        push @types, $rule->{'type'};
1729
16
16
                                        eval {
1730
16
55
                                                validate_strict({ input => { $key => $value }, schema => { $key => $rule }, logger => undef, custom_types => $custom_types });
1731                                        };
1732
16
10765
                                        if(!$@) {
1733
7
4
                                                $rc = 1;
1734
7
6
                                                last;
1735                                        }
1736                                }
1737
9
16
                                if(!$rc) {
1738
2
5
                                        _error($logger, "$rule_description: Parameter: '$key': must be one of " . join(', ', @types));
1739
0
0
                                        $invalid_args{$key} = 1;
1740                                }
1741                        } else {
1742
2
8
                                _error($logger, "$rule_description: Parameter: '$key': schema is empty arrayref");
1743                        }
1744                } elsif(ref($rules)) {
1745
1
2
                        _error($logger, 'rules must be a hash reference or string');
1746                }
1747
1748
446
550
                $validated_args{$key} = $value;
1749        }
1750
1751        # Validate parameter relationships
1752
311
364
        if (my $relationships = $params->{'relationships'}) {
1753
6
10
                _validate_relationships(\%validated_args, $relationships, $logger, $schema_description);
1754        }
1755
1756
306
282
        if(my $cross_validation = $params->{'cross_validation'}) {
1757
37
37
25
37
                foreach my $validator_name(keys %{$cross_validation}) {
1758
42
34
                        my $validator = $cross_validation->{$validator_name};
1759
42
58
                        if((!ref($validator)) || (ref($validator) ne 'CODE')) {
1760
1
3
                                _error($logger, "$schema_description: cross_validation $validator is not a code snippet");
1761
0
0
                                next;
1762                        }
1763
41
41
31
44
                        if(my $error = &{$validator}(\%validated_args, $validator)) {
1764
18
70
                                _error($logger, $error);
1765                                # We have no idea which parameters are still valid, so let's invalidate them all
1766
0
0
                                return;
1767                        }
1768                }
1769        }
1770
1771
287
309
        foreach my $key(keys %invalid_args) {
1772
0
0
                delete $validated_args{$key};
1773        }
1774
1775
287
245
        if($are_positional_args == 1) {
1776
4
3
                my @rc;
1777
4
4
2
4
                foreach my $key (keys %{$schema}) {
1778
6
11
                        if(my $value = delete $validated_args{$key}) {
1779
6
4
                                my $position = $schema->{$key}->{'position'};
1780
6
6
                                if(defined($rc[$position])) {
1781
1
2
                                        _error($logger, "$schema_description: $key: position $position appears twice");
1782                                }
1783
5
6
                                $rc[$position] = $value;
1784                        }
1785                }
1786
3
6
                return \@rc;
1787        }
1788
283
675
        return \%validated_args;
1789}
1790
1791# Return number of visible characters not number of bytes
1792# Ensure string is decoded into Perl characters
1793sub _number_of_characters
1794{
1795
75
62
        my $value = $_[0];
1796
1797
75
66
        return if(!defined($value));
1798
1799
75
387
        if($value !~ /[^[:ascii:]]/) {
1800
69
103
                return length($value);
1801        }
1802        # Decode only if it's not already a Perl character string
1803
6
34
        $value = decode_utf8($value) unless utf8::is_utf8($value);
1804
1805        # Count grapheme clusters (visible characters)
1806        # The pseudo-operator () = forces list context to count matches
1807        # return scalar( () = $value =~ /\X/g );
1808
1809
6
33
        return Unicode::GCString->new($value)->length();
1810}
1811
1812sub _apply_nested_defaults {
1813
43
43
        my ($input, $schema) = @_;
1814
43
84
        my %result = %$input;
1815
1816
43
54
        foreach my $key (keys %$schema) {
1817
99
68
                my $rules = $schema->{$key};
1818
1819
99
164
                if (ref $rules eq 'HASH' && exists $rules->{default} && !exists $result{$key}) {
1820
2
20
                        $result{$key} = $rules->{default};
1821                }
1822
1823                # Recursively handle nested schema
1824
99
185
                if((ref $rules eq 'HASH') && $rules->{schema} && (ref $result{$key} eq 'HASH')) {
1825
8
14
                        $result{$key} = _apply_nested_defaults($result{$key}, $rules->{schema});
1826                }
1827        }
1828
1829
43
46
        return \%result;
1830}
1831
1832sub _validate_relationships {
1833
6
6
        my ($validated_args, $relationships, $logger, $description) = @_;
1834
1835
6
7
        return unless ref($relationships) eq 'ARRAY';
1836
1837
6
6
        foreach my $rel (@$relationships) {
1838
6
6
                my $type = $rel->{type} or next;
1839
1840
6
11
                if ($type eq 'mutually_exclusive') {
1841
1
2
                        _validate_mutually_exclusive($validated_args, $rel, $logger, $description);
1842                } elsif ($type eq 'required_group') {
1843
1
2
                        _validate_required_group($validated_args, $rel, $logger, $description);
1844                } elsif ($type eq 'conditional_requirement') {
1845
1
2
                        _validate_conditional_requirement($validated_args, $rel, $logger, $description);
1846                } elsif ($type eq 'dependency') {
1847
1
2
                        _validate_dependency($validated_args, $rel, $logger, $description);
1848                } elsif ($type eq 'value_constraint') {
1849
1
2
                        _validate_value_constraint($validated_args, $rel, $logger, $description);
1850                } elsif ($type eq 'value_conditional') {
1851
1
2
                        _validate_value_conditional($validated_args, $rel, $logger, $description);
1852                } else {
1853
0
0
                        _error($logger, "Unknown relationship type $type");
1854                }
1855        }
1856}
1857
1858sub _validate_mutually_exclusive {
1859
1
3
        my ($args, $rel, $logger, $description) = @_;
1860
1861
1
1
1
2
        my @params = @{$rel->{params} || []};
1862
1
2
        return unless @params >= 2;
1863
1864
1
2
1
5
        my @present = grep { exists($args->{$_}) && defined($args->{$_}) } @params;
1865
1866
1
1
        if (@present > 1) {
1867
1
3
                my $msg = $rel->{description} || 'Cannot specify both ' . join(' and ', @present);
1868
1
2
                _error($logger, "$description: $msg");
1869        }
1870}
1871
1872sub _validate_required_group {
1873
1
1
        my ($args, $rel, $logger, $description) = @_;
1874
1875
1
1
1
3
        my @params = @{$rel->{params} || []};
1876
1
1
        return unless @params >= 2;
1877
1878
1
2
2
3
        my @present = grep { exists($args->{$_}) && defined($args->{$_}) } @params;
1879
1880
1
2
        if (@present == 0) {
1881                my $msg = $rel->{description} ||
1882
1
12
                        'Must specify at least one of: ' . join(', ', @params);
1883
1
3
                _error($logger, "$description: $msg");
1884        }
1885}
1886
1887sub _validate_conditional_requirement {
1888
1
1
        my ($args, $rel, $logger, $description) = @_;
1889
1890
1
5
        my $if_param = $rel->{if} or return;
1891
1
2
        my $then_param = $rel->{then_required} or return;
1892
1893        # If the condition parameter is present and defined
1894
1
3
        if (exists($args->{$if_param}) && defined($args->{$if_param})) {
1895                # Check if it's truthy (for booleans and general values)
1896
1
2
                if ($args->{$if_param}) {
1897                        # Then the required parameter must also be present
1898
1
3
                        unless (exists($args->{$then_param}) && defined($args->{$then_param})) {
1899
0
0
                                my $msg = $rel->{description} || "When $if_param is specified, $then_param is required";
1900
0
0
                                _error($logger, "$description: $msg");
1901                        }
1902                }
1903        }
1904}
1905
1906sub _validate_dependency {
1907
1
2
        my ($args, $rel, $logger, $description) = @_;
1908
1909
1
1
        my $param = $rel->{param} or return;
1910
1
3
        my $requires = $rel->{requires} or return;
1911
1912        # If param is present, requires must also be present
1913
1
2
        if (exists($args->{$param}) && defined($args->{$param})) {
1914
1
3
                unless (exists($args->{$requires}) && defined($args->{$requires})) {
1915
1
6
                        my $msg = $rel->{description} || "$param requires $requires to be specified";
1916
1
3
                        _error($logger, "$description: $msg");
1917                }
1918        }
1919}
1920
1921sub _validate_value_constraint {
1922
1
2
        my ($args, $rel, $logger, $description) = @_;
1923
1924
1
2
        my $if_param = $rel->{if} or return;
1925
1
1
        my $then_param = $rel->{then} or return;
1926
1
2
        my $operator = $rel->{operator} or return;
1927
1
1
        my $value = $rel->{value};
1928
1
1
        return unless defined $value;
1929
1930        # If the condition parameter is present and truthy
1931
1
5
        if (exists($args->{$if_param}) && defined($args->{$if_param}) && $args->{$if_param}) {
1932                # Check if the then parameter exists
1933
1
11
                if (exists($args->{$then_param}) && defined($args->{$then_param})) {
1934
1
11
                        my $actual = $args->{$then_param};
1935
1
1
                        my $valid = 0;
1936
1937
1
1
                        if ($operator eq '==') {
1938
1
2
                                $valid = ($actual == $value);
1939                        } elsif ($operator eq '!=') {
1940
0
0
                                $valid = ($actual != $value);
1941                        } elsif ($operator eq '<') {
1942
0
0
                                $valid = ($actual < $value);
1943                        } elsif ($operator eq '<=') {
1944
0
0
                                $valid = ($actual <= $value);
1945                        } elsif ($operator eq '>') {
1946
0
0
                                $valid = ($actual > $value);
1947                        } elsif ($operator eq '>=') {
1948
0
0
                                $valid = ($actual >= $value);
1949                        }
1950
1951
1
2
                        unless ($valid) {
1952
1
1
                                my $msg = $rel->{description} || "When $if_param is specified, $then_param must be $operator $value (got $actual)";
1953
1
2
                                _error($logger, "$description: $msg");
1954                        }
1955                }
1956        }
1957}
1958
1959sub _validate_value_conditional {
1960
1
1
        my ($args, $rel, $logger, $description) = @_;
1961
1962
1
3
        my $if_param = $rel->{if} or return;
1963
1
0
        my $equals = $rel->{equals};
1964
1
5
        my $then_param = $rel->{then_required} or return;
1965
1
1
        return unless defined $equals;
1966
1967        # If the parameter has the specific value
1968
1
3
        if (exists($args->{$if_param}) && defined($args->{$if_param})) {
1969
1
2
                if ($args->{$if_param} eq $equals) {
1970                        # Then the required parameter must be present
1971
1
2
                        unless (exists($args->{$then_param}) && defined($args->{$then_param})) {
1972                                my $msg = $rel->{description} ||
1973
1
6
                                        "When $if_param equals '$equals', $then_param is required";
1974
1
2
                                _error($logger, "$description: $msg");
1975                        }
1976                }
1977        }
1978}
1979
1980# Helper to log error or croak
1981sub _error
1982{
1983
219
161
        my $logger = shift;
1984
219
259
        my $message = join('', @_);
1985
1986
219
282
        my @call_details = caller(0);
1987
219
3364
        if($logger) {
1988
12
39
                $logger->error(__PACKAGE__, ' line ', $call_details[2], ": $message");
1989        }
1990
214
1167
        croak(__PACKAGE__, ' line ', $call_details[2], ": $message");
1991        # Be absolutely sure, sometimes croak doesn't die for me in Test::Most scripts
1992
0
0
        die (__PACKAGE__, ' line ', $call_details[2], ": $message");
1993}
1994
1995# Helper to log warning or carp
1996sub _warn
1997{
1998
4
4
        my $logger = shift;
1999
4
7
        my $message = join('', @_);
2000
2001
4
6
        if($logger) {
2002
3
10
                $logger->warn(__PACKAGE__, ": $message");
2003        } else {
2004
1
7
                carp(__PACKAGE__, ": $message");
2005        }
2006}
2007
2008 - 2157
=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

    SimpleType ::= string | integer | number | arrayref | hashref | coderef | object

    ComplexRule == [
        type: TYPE_NAME;
        min: ℕ₁;
        max: ℕ₁;
        optional: 𝔹;
        matches: REGEX;
        nomatch: REGEX;
        memberof: 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.min) ∧
      Â¬(rule.memberof ∧ 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

=cut
2158
21591;
2160