File Coverage

blib/lib/Params/Validate/Strict.pm
Criterion Covered Total %
statement 516 637 81.0
branch 444 578 76.8
condition 149 233 63.9
subroutine 25 25 100.0
pod 1 1 100.0
total 1135 1474 77.0


line stmt bran cond sub pod time code
1             package Params::Validate::Strict;
2              
3             # FIXME: {max} doesn't play ball with non-ascii strings
4              
5 19     19   3639039 use strict;
  19         40  
  19         741  
6 19     19   107 use warnings;
  19         34  
  19         1089  
7              
8 19     19   100 use Carp;
  19         42  
  19         1322  
9 19     19   108 use Exporter qw(import); # Required for @EXPORT_OK
  19         43  
  19         853  
10 19     19   11374 use Encode qw(decode_utf8);
  19         352196  
  19         2569  
11 19     19   204 use List::Util 1.33 qw(any); # Required for memberof validation
  19         616  
  19         1577  
12 19     19   9673 use Params::Get 0.13;
  19         236286  
  19         1122  
13 19     19   292 use Scalar::Util;
  19         66  
  19         650  
14 19     19   9839 use Unicode::GCString;
  19         371328  
  19         197400  
15              
16             our @ISA = qw(Exporter);
17             our @EXPORT_OK = qw(validate_strict);
18              
19             =head1 NAME
20              
21             Params::Validate::Strict - Validates a set of parameters against a schema
22              
23             =head1 VERSION
24              
25             Version 0.30
26              
27             =cut
28              
29             our $VERSION = '0.30';
30              
31             =head1 SYNOPSIS
32              
33             my $schema = {
34             username => { type => 'string', min => 3, max => 50 },
35             age => { type => 'integer', min => 0, max => 150 },
36             };
37              
38             my $input = {
39             username => 'john_doe',
40             age => '30', # Will be coerced to integer
41             };
42              
43             my $validated_input = validate_strict(schema => $schema, input => $input);
44              
45             if(defined($validated_input)) {
46             print "Example 1: Validation successful!\n";
47             print 'Username: ', $validated_input->{username}, "\n";
48             print 'Age: ', $validated_input->{age}, "\n"; # It's an integer now
49             } else {
50             print "Example 1: Validation failed: $@\n";
51             }
52              
53             Upon first reading this may seem overly complex and full of scope creep in a sledgehammer to crack a nut sort of way,
54             however two use cases make use of the extensive logic that comes with this code
55             and I have a couple of other reasons for writing it.
56              
57             =over 4
58              
59             =item * Black Box Testing
60              
61             The schema can be plumbed into L to automatically create a set of black-box test cases.
62              
63             =item * WAF
64              
65             The schema can be plumbed into a WAF to protect from random user input.
66              
67             =item * Improved API Documentation
68              
69             Even if you don't use this module,
70             the specification syntax can help with documentation.
71              
72             =item * I like it
73              
74             I find it fun to write this,
75             even if nobody else finds it useful,
76             though I hope you will.
77              
78             =back
79              
80             =head1 METHODS
81              
82             =head2 validate_strict
83              
84             Validates a set of parameters against a schema.
85              
86             This function takes two mandatory arguments:
87              
88             =over 4
89              
90             =item * C || C
91              
92             A reference to a hash that defines the validation rules for each parameter.
93             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.
94              
95             For some sort of compatibility with L,
96             it is possible to wrap the schema within a hash like this:
97              
98             $schema = {
99             description => 'Describe what this schema does',
100             error_msg => 'An error message',
101             schema => {
102             # ... schema goes here
103             }
104             }
105              
106             =item * C || C
107              
108             A reference to a hash containing the parameters to be validated.
109             The keys of the hash are the parameter names, and the values are the parameter values.
110              
111             =back
112              
113             It takes optional arguments:
114              
115             =over 4
116              
117             =item * C
118              
119             What the schema does,
120             used in error messages.
121              
122             =item * C
123              
124             Overrides the default message when something doesn't validate.
125              
126             =item * C
127              
128             This parameter describes what to do when a parameter is given that is not in the schema of valid parameters.
129             It must be one of C, C, or C.
130              
131             It defaults to C unless C is given, in which case it defaults to C.
132              
133             =item * C
134              
135             A logging object that understands messages such as C and C.
136              
137             =item * C
138              
139             A reference to a hash that defines reusable custom types.
140             Custom types allow you to define validation rules once and reuse them throughout your schema,
141             making your validation logic more maintainable and readable.
142              
143             Each custom type is defined as a hash reference containing the same validation rules available for regular parameters
144             (C, C, C, C, C, C, C, C, etc.).
145              
146             my $custom_types = {
147             email => {
148             type => 'string',
149             matches => qr/^[\w\.\-]+@[\w\.\-]+\.\w+$/,
150             error_msg => 'Invalid email address format'
151             }, phone => {
152             type => 'string',
153             matches => qr/^\+?[1-9]\d{1,14}$/,
154             min => 10,
155             max => 15
156             }, percentage => {
157             type => 'number',
158             min => 0,
159             max => 100
160             }, status => {
161             type => 'string',
162             memberof => ['draft', 'published', 'archived']
163             }
164             };
165              
166             my $schema = {
167             user_email => { type => 'email' },
168             contact_number => { type => 'phone', optional => 1 },
169             completion => { type => 'percentage' },
170             post_status => { type => 'status' }
171             };
172              
173             my $validated = validate_strict(
174             schema => $schema,
175             input => $input,
176             custom_types => $custom_types
177             );
178              
179             Custom types can be extended or overridden in the schema by specifying additional constraints:
180              
181             my $schema = {
182             admin_username => {
183             type => 'username', # Uses custom type definition
184             min => 5, # Overrides custom type's min value
185             max => 15 # Overrides custom type's max value
186             }
187             };
188              
189             Custom types work seamlessly with nested schema, optional parameters, and all other validation features.
190              
191             =back
192              
193             The schema can define the following rules for each parameter:
194              
195             =over 4
196              
197             =item * C
198              
199             The data type of the parameter.
200             Valid types are C, C, C, C C, C, C, C and C.
201              
202             A type can be an arrayref when a parameter could have different types (e.g. a string or an object).
203              
204             $schema = {
205             username => [
206             { type => 'string', min => 3, max => 50 }, # Name
207             { type => 'integer', 'min' => 1 }, # UID that isn't root
208             ]
209             };
210              
211             =item * C
212              
213             The parameter must be an object that understands the method C.
214             C can be a simple scalar string of a method name,
215             or an arrayref of a list of method names, all of which must be supported by the object.
216              
217             $schema = {
218             gedcom => { type => object, can => 'get_individual' }
219             }
220              
221             =item * C
222              
223             The parameter must be an object of type C.
224              
225             =item * C
226              
227             The parameter must be a member of the given arrayref.
228              
229             status => {
230             type => 'string',
231             memberof => ['draft', 'published', 'archived']
232             }
233              
234             priority => {
235             type => 'integer',
236             memberof => [1, 2, 3, 4, 5]
237             }
238              
239             For string types, the comparison is case-sensitive by default. Use the C
240             flag to control this behavior:
241              
242             # Case-sensitive (default) - must be exact match
243             code => {
244             type => 'string',
245             memberof => ['ABC', 'DEF', 'GHI']
246             # 'abc' will fail
247             }
248              
249             # Case-insensitive - any case accepted
250             code => {
251             type => 'string',
252             memberof => ['ABC', 'DEF', 'GHI'],
253             case_sensitive => 0
254             # 'abc', 'Abc', 'ABC' all pass, original case preserved
255             }
256              
257             For numeric types (C, C, C), the comparison uses numeric
258             equality (C<==> operator):
259              
260             rating => {
261             type => 'number',
262             memberof => [0.5, 1.0, 1.5, 2.0]
263             }
264              
265             Note that C cannot be combined with C or C constraints as they
266             serve conflicting purposes - C defines an explicit whitelist while C/C
267             define ranges.
268              
269             =item * C
270              
271             Same as C.
272              
273             =item * C
274              
275             The parameter must not be a member of the given arrayref (blacklist).
276             This is the inverse of C.
277              
278             username => {
279             type => 'string',
280             notmemberof => ['admin', 'root', 'system', 'administrator']
281             }
282              
283             port => {
284             type => 'integer',
285             notmemberof => [22, 23, 25, 80, 443] # Reserved ports
286             }
287              
288             Like C, string comparisons are case-sensitive by default but can be controlled
289             with the C flag:
290              
291             # Case-sensitive (default)
292             username => {
293             type => 'string',
294             notmemberof => ['Admin', 'Root']
295             # 'admin' would pass, 'Admin' would fail
296             }
297              
298             # Case-insensitive
299             username => {
300             type => 'string',
301             notmemberof => ['Admin', 'Root'],
302             case_sensitive => 0
303             # 'admin', 'ADMIN', 'Admin' all fail
304             }
305              
306             The blacklist is checked after any C rules are applied, allowing you to
307             normalize input before checking:
308              
309             username => {
310             type => 'string',
311             transform => sub { lc($_[0]) }, # Normalize to lowercase
312             notmemberof => ['admin', 'root', 'system']
313             }
314              
315             C can be combined with other validation rules:
316              
317             username => {
318             type => 'string',
319             notmemberof => ['admin', 'root', 'system'],
320             min => 3,
321             max => 20,
322             matches => qr/^[a-z0-9_]+$/
323             }
324              
325             =item * C
326              
327             A boolean value indicating whether string comparisons should be case-sensitive.
328             This flag affects the C and C validation rules.
329             The default value is C<1> (case-sensitive).
330              
331             When set to C<0>, string comparisons are performed case-insensitively, allowing values
332             with different casing to match. The original case of the input value is preserved in
333             the validated output.
334              
335             # Case-sensitive (default)
336             status => {
337             type => 'string',
338             memberof => ['Draft', 'Published', 'Archived'] # Input 'draft' will fail - must match exact case
339             }
340              
341             # Case-insensitive
342             status => {
343             type => 'string',
344             memberof => ['Draft', 'Published', 'Archived'],
345             case_sensitive => 0 # Input 'draft', 'DRAFT', or 'DrAfT' will all pass
346             }
347              
348             country_code => {
349             type => 'string',
350             memberof => ['US', 'UK', 'CA', 'FR'],
351             case_sensitive => 0 # Accept 'us', 'US', 'Us', etc.
352             }
353              
354             This flag has no effect on numeric types (C, C, C) as numbers
355             do not have case.
356              
357             =item * C
358              
359             The minimum length (for strings in characters not bytes), value (for numbers) or number of keys (for hashrefs).
360              
361             =item * C
362              
363             The maximum length (for strings in characters not bytes), value (for numbers) or number of keys (for hashrefs).
364              
365             =item * C
366              
367             A regular expression that the parameter value must match.
368             Checks all members of arrayrefs.
369              
370             =item * C
371              
372             A regular expression that the parameter value must not match.
373             Checks all members of arrayrefs.
374              
375             =item * C
376              
377             For routines and methods that take positional args,
378             this integer value defines which position the argument will be in.
379             If this is set for all arguments,
380             C will return a reference to an array, rather than a reference to a hash.
381              
382             =item * C
383              
384             The description of the rule
385              
386             =item * C
387              
388             A code reference to a subroutine that performs custom validation logic.
389             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.
390              
391             Use this to test more complex examples:
392              
393             my $schema = {
394             even_number => {
395             type => 'integer',
396             callback => sub { $_[0] % 2 == 0 }
397             };
398              
399             # Specify the arguments for a routine which has a second, optional argument, which, if given, must be less than or equal to the first
400             my $schema = {
401             first => {
402             type => 'integer'
403             }, second => {
404             type => 'integer',
405             optional => 1,
406             callback => sub {
407             my($value, $args) = @_;
408             # The 'defined' is needed in case 'second' is evaluated before 'first'
409             return (defined($args->{first}) && $value <= $args->{first}) ? 1 : 0
410             }
411             }
412             };
413              
414             =item * C
415              
416             A boolean value indicating whether the parameter is optional.
417             If true, the parameter is not required.
418             If false or omitted, the parameter is required.
419              
420             It can be a reference to a code snippet that will return true or false,
421             to determine if the parameter is optional or not.
422             The code will be called with two arguments: the value of the parameter and hash ref of all parameters:
423              
424             my $schema = {
425             optional_field => {
426             type => 'string',
427             optional => sub {
428             my ($value, $all_params) = @_;
429             return $all_params->{make_optional} ? 1 : 0;
430             }
431             },
432             make_optional => { type => 'boolean' }
433             };
434              
435             my $result = validate_strict(schema => $schema, input => { make_optional => 1 });
436              
437             =item * C
438              
439             Populate missing optional parameters with the specified value.
440             Note that this value is not validated.
441              
442             username => {
443             type => 'string',
444             optional => 1,
445             default => 'guest'
446             }
447              
448             =item * C
449              
450             Extends the validation to individual elements of arrays.
451              
452             tags => {
453             type => 'arrayref',
454             element_type => 'number', # Float means the same
455             min => 1, # this is the length of the array, not the min value for each of the numbers. For that, add a C rule
456             max => 5
457             }
458              
459             =item * C
460              
461             The custom error message to be used in the event of a validation failure.
462              
463             age => {
464             type => 'integer',
465             min => 18,
466             error_msg => 'You must be at least 18 years old'
467             }
468              
469             =item * C
470              
471             Like optional,
472             though this cannot be a coderef,
473             only a flag.
474              
475             =item * C
476              
477             You can validate nested hashrefs and arrayrefs using the C property:
478              
479             my $schema = {
480             user => { # 'user' is a hashref
481             type => 'hashref',
482             schema => { # Specify what the elements of the hash should be
483             name => { type => 'string' },
484             age => { type => 'integer', min => 0 },
485             hobbies => { # 'hobbies' is an array ref that this user has
486             type => 'arrayref',
487             schema => { type => 'string' }, # Validate each hobby
488             min => 1 # At least one hobby
489             }
490             }
491             },
492             metadata => {
493             type => 'hashref',
494             schema => {
495             created => { type => 'string' },
496             tags => {
497             type => 'arrayref',
498             schema => {
499             type => 'string',
500             matches => qr/^[a-z]+$/ # Or you can say matches => '^[a-z]+$'
501             }
502             }
503             }
504             }
505             };
506              
507             =item * C
508              
509             A snippet of code that validates the input.
510             It's passed the input arguments,
511             and return a string containing a reason for rejection,
512             or undef if it's allowed.
513              
514             my $schema = {
515             user => {
516             type => 'string',
517             validate => sub {
518             if($_[0]->{'password'} eq 'bar') {
519             return undef;
520             }
521             return 'Invalid password, try again';
522             }
523             }, password => {
524             type => 'string'
525             }
526             };
527              
528             =item * C
529              
530             A code reference to a subroutine that transforms/sanitizes the parameter value before validation.
531             The subroutine should accept the parameter value as an argument and return the transformed value.
532             The transformation is applied before any validation rules are checked, allowing you to normalize
533             or clean data before it is validated.
534              
535             Common use cases include trimming whitespace, normalizing case, formatting phone numbers,
536             sanitizing user input, and converting between data formats.
537              
538             # Simple string transformations
539             username => {
540             type => 'string',
541             transform => sub { lc(trim($_[0])) }, # lowercase and trim
542             matches => qr/^[a-z0-9_]+$/
543             }
544              
545             email => {
546             type => 'string',
547             transform => sub { lc(trim($_[0])) }, # normalize email
548             matches => qr/^[\w\.\-]+@[\w\.\-]+\.\w+$/
549             }
550              
551             # Array transformations
552             tags => {
553             type => 'arrayref',
554             transform => sub { [map { lc($_) } @{$_[0]}] }, # lowercase all elements
555             element_type => 'string'
556             }
557              
558             keywords => {
559             type => 'arrayref',
560             transform => sub {
561             my @arr = map { lc(trim($_)) } @{$_[0]};
562             my %seen;
563             return [grep { !$seen{$_}++ } @arr]; # remove duplicates
564             }
565             }
566              
567             # Numeric transformations
568             quantity => {
569             type => 'integer',
570             transform => sub { int($_[0] + 0.5) }, # round to nearest integer
571             min => 1
572             }
573              
574             # Sanitization
575             slug => {
576             type => 'string',
577             transform => sub {
578             my $str = lc(trim($_[0]));
579             $str =~ s/[^\w\s-]//g; # remove special characters
580             $str =~ s/\s+/-/g; # replace spaces with hyphens
581             return $str;
582             },
583             matches => qr/^[a-z0-9-]+$/
584             }
585              
586             phone => {
587             type => 'string',
588             transform => sub {
589             my $str = $_[0];
590             $str =~ s/\D//g; # remove all non-digits
591             return $str;
592             },
593             matches => qr/^\d{10}$/
594             }
595              
596             The C function is applied to the value before any validation checks (C, C,
597             C, C, etc.), ensuring that validation rules are checked against the cleaned data.
598              
599             Transformations work with all parameter types including nested structures:
600              
601             user => {
602             type => 'hashref',
603             schema => {
604             name => {
605             type => 'string',
606             transform => sub { trim($_[0]) }
607             },
608             email => {
609             type => 'string',
610             transform => sub { lc(trim($_[0])) }
611             }
612             }
613             }
614              
615             Transformations can also be defined in custom types for reusability:
616              
617             my $custom_types = {
618             email => {
619             type => 'string',
620             transform => sub { lc(trim($_[0])) },
621             matches => qr/^[\w\.\-]+@[\w\.\-]+\.\w+$/
622             }
623             };
624              
625             Note that the transformed value is what gets returned in the validated result and is what
626             subsequent validation rules will check against. If a transformation might fail, ensure it
627             handles edge cases appropriately.
628             It is the responsibility of the transformer to ensure that the type of the returned value is correct,
629             since that is what will be validated.
630              
631             Many validators also allow a code ref to be passed so that you can create your own, conditional validation rule, e.g.:
632              
633             $schema = {
634             age => {
635             type => 'integer',
636             min => sub {
637             my ($value, $all_params) = @_;
638             return $all_params->{country} eq 'US' ? 21 : 18;
639             }
640             }
641             }
642              
643             =item * C
644              
645             A synonym of Cvalidate>, for compatibility with L.
646              
647             =item * C
648              
649             A reference to a hash that defines validation rules that depend on more than one parameter.
650             Cross-field validations are performed after all individual parameter validations have passed,
651             allowing you to enforce business logic that requires checking relationships between different fields.
652              
653             Each cross-validation rule is a key-value pair where the key is a descriptive name for the validation
654             and the value is a code reference that accepts a hash reference of all validated parameters.
655             The subroutine should return C if the validation passes, or an error message string if it fails.
656              
657             my $schema = {
658             password => { type => 'string', min => 8 },
659             password_confirm => { type => 'string' }
660             };
661              
662             my $cross_validation = {
663             passwords_match => sub {
664             my $params = shift;
665             return $params->{password} eq $params->{password_confirm}
666             ? undef : "Passwords don't match";
667             }
668             };
669              
670             my $validated = validate_strict(
671             schema => $schema,
672             input => $input,
673             cross_validation => $cross_validation
674             );
675              
676             Common use cases include password confirmation, date range validation, numeric comparisons,
677             and conditional requirements:
678              
679             # Date range validation
680             my $cross_validation = {
681             date_range_valid => sub {
682             my $params = shift;
683             return $params->{start_date} le $params->{end_date}
684             ? undef : "Start date must be before or equal to end date";
685             }
686             };
687              
688             # Price range validation
689             my $cross_validation = {
690             price_range_valid => sub {
691             my $params = shift;
692             return $params->{min_price} <= $params->{max_price}
693             ? undef : "Minimum price must be less than or equal to maximum price";
694             }
695             };
696              
697             # Conditional required field
698             my $cross_validation = {
699             address_required_for_delivery => sub {
700             my $params = shift;
701             if ($params->{shipping_method} eq 'delivery' && !$params->{delivery_address}) {
702             return "Delivery address is required when shipping method is 'delivery'";
703             }
704             return undef;
705             }
706             };
707              
708             Multiple cross-validations can be defined in the same hash, and they are all checked in order.
709             If any cross-validation fails, the function will C with the error message returned by the validation:
710              
711             my $cross_validation = {
712             passwords_match => sub {
713             my $params = shift;
714             return $params->{password} eq $params->{password_confirm}
715             ? undef : "Passwords don't match";
716             },
717             emails_match => sub {
718             my $params = shift;
719             return $params->{email} eq $params->{email_confirm}
720             ? undef : "Email addresses don't match";
721             },
722             age_matches_birth_year => sub {
723             my $params = shift;
724             my $current_year = (localtime)[5] + 1900;
725             my $calculated_age = $current_year - $params->{birth_year};
726             return abs($calculated_age - $params->{age}) <= 1
727             ? undef : "Age doesn't match birth year";
728             }
729             };
730              
731             Cross-validations receive the parameters after individual validation and transformation have been applied,
732             so you can rely on the data being in the correct format and type:
733              
734             my $schema = {
735             email => {
736             type => 'string',
737             transform => sub { lc($_[0]) } # Lowercased before cross-validation
738             },
739             email_confirm => {
740             type => 'string',
741             transform => sub { lc($_[0]) }
742             }
743             };
744              
745             my $cross_validation = {
746             emails_match => sub {
747             my $params = shift;
748             # Both emails are already lowercased at this point
749             return $params->{email} eq $params->{email_confirm}
750             ? undef : "Email addresses don't match";
751             }
752             };
753              
754             Cross-validations can access nested structures and optional fields:
755              
756             my $cross_validation = {
757             guardian_required_for_minors => sub {
758             my $params = shift;
759             if ($params->{user}{age} < 18 && !$params->{guardian}) {
760             return "Guardian information required for users under 18";
761             }
762             return undef;
763             }
764             };
765              
766             =item * metadata
767              
768             Fields starting with <_> are generated by L,
769             and are currently ignored.
770              
771             =item * schematic
772              
773             TODO: gives an idea of what the field will be, e.g. C.
774              
775             All cross-validations must pass for the overall validation to succeed.
776              
777             =item * C
778              
779             A reference to an array that defines validation rules based on relationships between parameters.
780             Relationship validations are performed after all individual parameter validations have passed,
781             but before cross-validations.
782              
783             Each relationship is a hash reference with a C field and additional fields depending on the type:
784              
785             =over 4
786              
787             =item * B
788              
789             Parameters that cannot be specified together.
790              
791             relationships => [
792             {
793             type => 'mutually_exclusive',
794             params => ['file', 'content'],
795             description => 'Cannot specify both file and content'
796             }
797             ]
798              
799             =item * B
800              
801             At least one parameter from the group must be specified.
802              
803             relationships => [
804             {
805             type => 'required_group',
806             params => ['id', 'name'],
807             logic => 'or',
808             description => 'Must specify either id or name'
809             }
810             ]
811              
812             =item * B
813              
814             If one parameter is specified, another becomes required.
815              
816             relationships => [
817             {
818             type => 'conditional_requirement',
819             if => 'async',
820             then_required => 'callback',
821             description => 'When async is specified, callback is required'
822             }
823             ]
824              
825             =item * B
826              
827             One parameter requires another to be present.
828              
829             relationships => [
830             {
831             type => 'dependency',
832             param => 'port',
833             requires => 'host',
834             description => 'port requires host to be specified'
835             }
836             ]
837              
838             =item * B
839              
840             Specific value requirements between parameters.
841              
842             relationships => [
843             {
844             type => 'value_constraint',
845             if => 'ssl',
846             then => 'port',
847             operator => '==',
848             value => 443,
849             description => 'When ssl is specified, port must equal 443'
850             }
851             ]
852              
853             =item * B
854              
855             Parameter required when another has a specific value.
856              
857             relationships => [
858             {
859             type => 'value_conditional',
860             if => 'mode',
861             equals => 'secure',
862             then_required => 'key',
863             description => "When mode equals 'secure', key is required"
864             }
865             ]
866              
867             =back
868              
869             If a parameter is optional and its value is C,
870             validation will be skipped for that parameter.
871              
872             If the validation fails, the function will C with an error message describing the validation failure.
873              
874             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.
875              
876             The C field is optional but recommended for clearer error messages.
877              
878             =back
879              
880             =head2 Example Usage
881              
882             my $schema = {
883             host => { type => 'string' },
884             port => { type => 'integer' },
885             ssl => { type => 'boolean' },
886             file => { type => 'string', optional => 1 },
887             content => { type => 'string', optional => 1 }
888             };
889              
890             my $relationships = [
891             {
892             type => 'mutually_exclusive',
893             params => ['file', 'content']
894             },
895             {
896             type => 'required_group',
897             params => ['host', 'file']
898             },
899             {
900             type => 'dependency',
901             param => 'port',
902             requires => 'host'
903             },
904             {
905             type => 'value_constraint',
906             if => 'ssl',
907             then => 'port',
908             operator => '==',
909             value => 443
910             }
911             ];
912              
913             my $validated = validate_strict(
914             schema => $schema,
915             input => $input,
916             relationships => $relationships
917             );
918              
919             =head1 MIGRATION FROM LEGACY VALIDATORS
920              
921             =head2 From L
922              
923             # Old style
924             validate(@_, {
925             name => { type => SCALAR },
926             age => { type => SCALAR, regex => qr/^\d+$/ }
927             });
928              
929             # New style
930             validate_strict(
931             schema => { # or "members"
932             name => 'string',
933             age => { type => 'integer', min => 0 }
934             },
935             args => { @_ }
936             );
937              
938             =head2 From L
939              
940             # Old style
941             my ($name, $age) = validate_positional \@_, Str, Int;
942              
943             # New style - requires converting to named parameters first
944             my %args = (name => $_[0], age => $_[1]);
945             my $validated = validate_strict(
946             schema => { name => 'string', age => 'integer' },
947             args => \%args
948             );
949              
950             =cut
951              
952             sub validate_strict
953             {
954 525     525 1 5451391 my $params = Params::Get::get_params(undef, \@_);
955              
956 525   100     17834 my $schema = $params->{'schema'} || $params->{'members'};
957 525   100     2835 my $args = $params->{'args'} || $params->{'input'};
958 525         1102 my $logger = $params->{'logger'};
959 525         1119 my $custom_types = $params->{'custom_types'};
960 525         1317 my $unknown_parameter_handler = $params->{'unknown_parameter_handler'};
961 525 100       1422 if(!defined($unknown_parameter_handler)) {
962 509 50       1341 if($params->{'carp_on_warn'}) {
963 0         0 $unknown_parameter_handler = 'warn';
964             } else {
965 509         1008 $unknown_parameter_handler = 'die';
966             }
967             }
968              
969 525 100       1244 return $args if(!defined($schema)); # No schema, allow all arguments
970              
971             # Check if schema and args are references to hashes
972 524 100       1606 if(ref($schema) ne 'HASH') {
973 2         10 _error($logger, 'validate_strict: schema must be a hash reference');
974             }
975              
976             # Inspired by Data::Processor
977 522   100     2391 my $schema_description = $params->{'description'} || 'validate_strict';
978 522         1006 my $error_msg = $params->{'error_msg'};
979              
980 522 50 33     1551 if($schema->{'members'} && ($schema->{'description'} || $schema->{'error_msg'})) {
      66        
981 1         19 $schema_description = $schema->{'description'};
982 1         3 $error_msg = $schema->{'error_msg'};
983 1         2 $schema = $schema->{'members'};
984             }
985              
986 522 100 100     3084 if(exists($params->{'args'}) && (!defined($args))) {
    100 100        
987 1         2 $args = {};
988             } elsif((ref($args) ne 'HASH') && (ref($args) ne 'ARRAY')) {
989 2   33     16 _error($logger, $error_msg || "$schema_description: args must be a hash or array reference");
990             }
991              
992 520 100       1514 if(ref($args) eq 'HASH') {
993             # Named args
994 515         924 foreach my $key (keys %{$args}) {
  515         1975  
995 676 100       2003 if(!exists($schema->{$key})) {
996 13 100       72 if($unknown_parameter_handler eq 'die') {
    100          
    100          
997 5         22 _error($logger, "$schema_description: Unknown parameter '$key'");
998             } elsif($unknown_parameter_handler eq 'warn') {
999 4         28 _warn($logger, "$schema_description: Unknown parameter '$key'");
1000 4         665 next;
1001             } elsif($unknown_parameter_handler eq 'ignore') {
1002 2 100       12 if($logger) {
1003 1         8 $logger->debug(__PACKAGE__ . ": $schema_description: Unknown parameter '$key'");
1004             }
1005 2         16 next;
1006             } else {
1007 2         11 _error($logger, "$schema_description: '$unknown_parameter_handler' unknown_parameter_handler must be one of die, warn, ignore");
1008             }
1009             }
1010             }
1011             }
1012              
1013             # Find out if this routine takes positional arguments
1014 513         1249 my $are_positional_args = -1;
1015 513         785 foreach my $key (keys %{$schema}) {
  513         1433  
1016 514 100       1502 if(defined(my $rules = $schema->{$key})) {
1017 512 100       1409 if(ref($rules) eq 'HASH') {
1018 480 100       1398 if(!defined($rules->{'position'})) {
1019 473 100       1238 if($are_positional_args == 1) {
1020 1         5 _error($logger, "::validate_strict: $key is missing position value");
1021             }
1022 472         781 $are_positional_args = 0;
1023 472         1184 last;
1024             }
1025 7         14 $are_positional_args = 1;
1026             } else {
1027 32         63 $are_positional_args = 0;
1028 32         100 last;
1029             }
1030             } else {
1031 2         5 $are_positional_args = 0;
1032 2         7 last;
1033             }
1034             }
1035              
1036 512         1278 my %validated_args;
1037             my %invalid_args;
1038 512         873 foreach my $key (keys %{$schema}) {
  512         1183  
1039 740         1412 my $rules = $schema->{$key};
1040 740         1210 my $value;
1041 740 100       1624 if($are_positional_args == 1) {
1042 6 50       16 if(ref($args) ne 'ARRAY') {
1043 0         0 _error($logger, "::validate_strict: position $rules->{position} given for '$key', but args isn't an array");
1044             }
1045 6         13 $value = @{$args}[$rules->{'position'}];
  6         28  
1046             } else {
1047 734         1425 $value = $args->{$key};
1048             }
1049              
1050 740 100       1664 if(!defined($rules)) { # Allow anything
1051 2         7 $validated_args{$key} = $value;
1052 2         6 next;
1053             }
1054              
1055             # If rules are a simple type string
1056 738 100       1850 if(ref($rules) eq '') {
1057 27         87 $rules = { type => $rules };
1058             }
1059              
1060 738         1265 my $is_optional = 0;
1061              
1062 738         1202 my $rule_description = $schema_description; # Can be overridden in each element
1063              
1064 738 100       1859 if(ref($rules) eq 'HASH') {
1065 725 50       1717 if(exists($rules->{'description'})) {
1066 0         0 $rule_description = $rules->{'description'};
1067             }
1068 725 100 100     2211 if($rules->{'transform'} && defined($value)) {
1069 40 100       207 if(ref($rules->{'transform'}) eq 'CODE') {
1070 38         73 $value = &{$rules->{'transform'}}($value);
  38         143  
1071             } else {
1072 2         18 _error($logger, "$rule_description: transforms must be a code ref");
1073             }
1074             }
1075 723 100       2754 if(exists($rules->{optional})) {
    50          
1076 162 100       392 if(ref($rules->{'optional'}) eq 'CODE') {
1077 9         22 $is_optional = &{$rules->{optional}}($value, $args);
  9         39  
1078             } else {
1079 153         329 $is_optional = $rules->{'optional'};
1080             }
1081             } elsif($rules->{nullable}) {
1082 0         0 $is_optional = $rules->{'nullable'};
1083             }
1084             }
1085              
1086             # Handle optional parameters
1087 736 100 100     4784 if((ref($rules) eq 'HASH') && $is_optional) {
    100 100        
1088 153         265 my $look_for_default = 0;
1089 153 100       312 if($are_positional_args == 1) {
1090             # if(!defined(@{$args}[$rules->{'position'}])) {
1091 2 100       10 if(!defined($args->[$rules->{position}])) {
1092 1         2 $look_for_default = 1;
1093             }
1094             } else {
1095 151 100       367 if(!exists($args->{$key})) {
1096 79         200 $look_for_default = 1;
1097             }
1098             }
1099 153 100       423 if($look_for_default) {
1100 80 100       199 if($are_positional_args == 1) {
1101 1 50       2 if(scalar(@{$args}) < $rules->{'position'}) {
  1         8  
1102             # arg array is too short, so it must be missing
1103 0         0 _error($logger, "$rule_description: Required parameter '$key' is missing");
1104 0         0 next;
1105             }
1106             }
1107 80 100       229 if(exists($rules->{'default'})) {
1108             # Populate missing optional parameters with the specified output values
1109 5         25 $validated_args{$key} = $rules->{'default'};
1110             }
1111              
1112 80 100       243 if($rules->{'schema'}) {
1113 4         20 $value = _apply_nested_defaults({}, $rules->{'schema'});
1114 4 100       12 next unless scalar(%{$value});
  4         20  
1115             # The nested schema has a default value
1116             } else {
1117 76         177 next; # optional and missing
1118             }
1119             }
1120             } elsif((ref($args) eq 'HASH') && !exists($args->{$key})) {
1121             # The parameter is required
1122 7         51 _error($logger, "$rule_description: Required parameter '$key' is missing");
1123             }
1124              
1125             # Validate based on rules
1126 650 100       1598 if(ref($rules) eq 'HASH') {
    100          
    50          
1127 637 100 100     5058 if(defined(my $min = $rules->{'min'}) && defined(my $max = $rules->{'max'})) {
1128 80 100       206 if($min > $max) {
1129 5         57 _error($logger, "validate_strict($key): min must be <= max ($min > $max)");
1130             }
1131             }
1132              
1133 632 100       1557 if($rules->{'memberof'}) {
1134 69 100       270 if(defined(my $min = $rules->{'min'})) {
1135 3         20 _error($logger, "validate_strict($key): min ($min) makes no sense with memberof");
1136             }
1137 66 100       271 if(defined(my $max = $rules->{'max'})) {
1138 1         7 _error($logger, "validate_strict($key): max ($max) makes no sense with memberof");
1139             }
1140             }
1141              
1142 628         1662 foreach my $rule_name (keys %$rules) {
1143 1192         2435 my $rule_value = $rules->{$rule_name};
1144              
1145 1192 100 100     3496 if((ref($rule_value) eq 'CODE') && ($rule_name ne 'validate') && ($rule_name ne 'callback') && ($rule_name ne 'validator')) {
      100        
      66        
1146 53         97 $rule_value = &{$rule_value}($value, $args);
  53         184  
1147             }
1148              
1149             # Better OOP, the routine has been given an object rather than a scalar
1150 1192 50 66     3645 if(Scalar::Util::blessed($rule_value) && $rule_value->can('as_string')) {
1151 0         0 $rule_value = $rule_value->as_string();
1152             }
1153              
1154 1192 100 100     6491 if($rule_name eq 'type') {
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
1155 565         1236 my $type = lc($rule_value);
1156              
1157 565 100 100     3505 if(($type eq 'string') || ($type eq 'str')) {
    100 100        
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
1158 256 100       661 if(ref($value)) {
1159 6   33     58 _error($logger, $rules->{'error_msg'} || "$rule_description: Parameter '$key' must be a string");
1160             }
1161 250 0 0     855 unless((ref($value) eq '') || (defined($value) && length($value))) { # Allow undef for optional strings
      33        
1162 0   0     0 _error($logger, $rules->{'error_msg'} || "$rule_description: Parameter '$key' must be a string");
1163             }
1164             } elsif($type eq 'integer') {
1165 94 100       305 if(!defined($value)) {
1166 1         3 next; # Skip if number is undefined
1167             }
1168 93 100       733 if($value !~ /^\s*[+\-]?\d+\s*$/) {
1169 6 100       26 if($rules->{'error_msg'}) {
1170 1         5 _error($logger, $rules->{'error_msg'});
1171             } else {
1172 5         36 _error($logger, "$rule_description: Parameter '$key' ($value) must be an integer");
1173             }
1174             }
1175 87         276 $value = int($value); # Coerce to integer
1176             } elsif(($type eq 'number') || ($type eq 'float')) {
1177 49 100       152 if(!defined($value)) {
1178 2         8 next; # Skip if number is undefined
1179             }
1180 47 100       231 if(!Scalar::Util::looks_like_number($value)) {
1181 2 50       8 if($rules->{'error_msg'}) {
1182 0         0 _error($logger, $rules->{'error_msg'});
1183             } else {
1184 2         11 _error($logger, "$rule_description: Parameter '$key' must be a number");
1185             }
1186             }
1187             # $value = eval $value; # Coerce to number (be careful with eval)
1188 45         216 $value = 0 + $value; # Numeric coercion
1189             } elsif($type eq 'arrayref') {
1190 37 100       152 if(!defined($value)) {
1191 2         6 next; # Skip if arrayref is undefined
1192             }
1193 35 100       138 if(ref($value) ne 'ARRAY') {
1194 1 50       5 if($rules->{'error_msg'}) {
1195 0         0 _error($logger, $rules->{'error_msg'});
1196             } else {
1197 1         9 _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1198             }
1199             }
1200             } elsif($type eq 'hashref') {
1201 39 100       145 if(!defined($value)) {
1202 2         7 next; # Skip if hashref is undefined
1203             }
1204 37 50       138 if(ref($value) ne 'HASH') {
1205 0 0       0 if($rules->{'error_msg'}) {
1206 0         0 _error($logger, $rules->{'error_msg'});
1207             } else {
1208 0         0 _error($logger, "$rule_description: Parameter '$key' must be an hashref");
1209             }
1210             }
1211             } elsif(($type eq 'boolean') || ($type eq 'bool')) {
1212 23 100       104 if(!defined($value)) {
1213 1         4 next; # Skip if bool is undefined
1214             }
1215 22 100 100     275 if(($value eq 'true') || ($value eq 'on') || ($value eq 'yes')) {
    100 100        
      100        
      100        
1216 3         6 $value = 1;
1217             } elsif(($value eq 'false') || ($value eq 'off') || ($value eq 'no')) {
1218 3         9 $value = 0;
1219             }
1220 22 100 100     107 if(($value ne '1') && ($value ne '0')) { # Do string compare
1221 2 50       8 if($rules->{'error_msg'}) {
1222 0         0 _error($logger, $rules->{'error_msg'});
1223             } else {
1224 2         14 _error($logger, "$rule_description: Parameter '$key' ($value) must be a boolean");
1225             }
1226             }
1227 20         106 $value = int($value); # Coerce to integer
1228             } elsif($type eq 'coderef') {
1229 3 100       18 if(!defined($value)) {
1230 1         4 next; # Skip if code is undefined
1231             }
1232 2 50       31 if(ref($value) ne 'CODE') {
1233 0 0       0 if($rules->{'error_msg'}) {
1234 0         0 _error($logger, $rules->{'error_msg'});
1235             } else {
1236 0         0 _error($logger, "$rule_description: Parameter '$key' must be a coderef");
1237             }
1238             }
1239             } elsif($type eq 'object') {
1240 17 100       61 if(!defined($value)) {
1241 1         2 next; # Skip if object is undefined
1242             }
1243 16 100       63 if(!Scalar::Util::blessed($value)) {
1244 1 50       26 if($rules->{'error_msg'}) {
1245 0         0 _error($logger, $rules->{'error_msg'});
1246             } else {
1247 1         7 _error($logger, "$rule_description: Parameter '$key' must be an object");
1248             }
1249             }
1250             } elsif(my $custom_type = $custom_types->{$type}) {
1251 46 100       109 if($custom_type->{'transform'}) {
1252             # The custom type has a transform embedded within it
1253 6 50       27 if(ref($custom_type->{'transform'}) eq 'CODE') {
1254 6         12 $value = &{$custom_type->{'transform'}}($value);
  6         23  
1255             } else {
1256 0         0 _error($logger, "$rule_description: transforms must be a code ref");
1257 0         0 next;
1258             }
1259             }
1260 46         671 validate_strict({ input => { $key => $value }, schema => { $key => $custom_type }, custom_types => $custom_types });
1261             } else {
1262 1         6 _error($logger, "$rule_description: Unknown type '$type'");
1263             }
1264             } elsif($rule_name eq 'min') {
1265 162 50       451 if(!defined($rules->{'type'})) {
1266 0         0 _error($logger, "$rule_description: Don't know type of '$key' to determine its minimum value $rule_value");
1267             }
1268 162         407 my $type = lc($rules->{'type'});
1269 162 100       656 if(exists($custom_types->{$type}->{'min'})) {
1270 3         8 $rule_value = $custom_types->{$type}->{'min'};
1271 3         8 $type = $custom_types->{$type}->{'type'};
1272             }
1273 162 100 100     1284 if(($type eq 'string') || ($type eq 'str')) {
    100 100        
    100 100        
    100          
1274 56 100       179 if($rule_value < 0) {
1275 1 50       4 if($rules->{'error_msg'}) {
1276 0         0 _error($logger, $rules->{'error_msg'});
1277             } else {
1278 1         5 _error($logger, "$rule_description: String parameter '$key' has meaningless minimum value that is less than zero");
1279             }
1280             }
1281 55 100       143 if(!defined($value)) {
1282 1         2 next; # Skip if string is undefined
1283             }
1284 54 50       256 if(defined(my $len = _number_of_characters($value))) {
1285 54 100       425 if($len < $rule_value) {
1286 7   33     84 _error($logger, $rules->{'error_msg'} || "$rule_description: String parameter '$key' too short, ($len characters), must be at least $rule_value characters");
1287 0         0 $invalid_args{$key} = 1;
1288             }
1289             } else {
1290 0   0     0 _error($logger, $rules->{'error_msg'} || "$rule_description: '$key' can't be decoded");
1291 0         0 $invalid_args{$key} = 1;
1292             }
1293             } elsif($type eq 'arrayref') {
1294 17 50       81 if(!defined($value)) {
1295 0         0 next; # Skip if array is undefined
1296             }
1297 17 100       62 if(ref($value) ne 'ARRAY') {
1298 1 50       5 if($rules->{'error_msg'}) {
1299 0         0 _error($logger, $rules->{'error_msg'});
1300             } else {
1301 1         6 _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1302             }
1303             }
1304 16 100       30 if(scalar(@{$value}) < $rule_value) {
  16         78  
1305 2 50       11 if($rules->{'error_msg'}) {
1306 0         0 _error($logger, $rules->{'error_msg'});
1307             } else {
1308 2         10 _error($logger, "$rule_description: Parameter '$key' must be at least length $rule_value");
1309             }
1310 0         0 $invalid_args{$key} = 1;
1311             }
1312             } elsif($type eq 'hashref') {
1313 4 50       13 if(!defined($value)) {
1314 0         0 next; # Skip if hash is undefined
1315             }
1316 4 100       7 if(scalar(keys(%{$value})) < $rule_value) {
  4         19  
1317 1 50       4 if($rules->{'error_msg'}) {
1318 0         0 _error($logger, $rules->{'error_msg'});
1319             } else {
1320 1         6 _error($logger, "$rule_description: Parameter '$key' must contain at least $rule_value keys");
1321             }
1322 0         0 $invalid_args{$key} = 1;
1323             }
1324             } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
1325 84 50       271 if(!defined($value)) {
1326 0         0 next; # Skip if hash is undefined
1327             }
1328 84 50       400 if(Scalar::Util::looks_like_number($value)) {
1329 84 100       340 if($value < $rule_value) {
1330 19 100       77 if($rules->{'error_msg'}) {
1331 3         16 _error($logger, $rules->{'error_msg'});
1332             } else {
1333 16         133 _error($logger, "$rule_description: Parameter '$key' ($value) must be at least $rule_value");
1334             }
1335 0         0 $invalid_args{$key} = 1;
1336 0         0 next;
1337             }
1338             } else {
1339 0 0       0 if($rules->{'error_msg'}) {
1340 0         0 _error($logger, $rules->{'error_msg'});
1341             } else {
1342 0         0 _error($logger, "$rule_description: Parameter '$key' ($value) must be a number");
1343             }
1344 0         0 next;
1345             }
1346             } else {
1347 1         8 _error($logger, "$rule_description: Parameter '$key' of type '$type' has meaningless min value $rule_value");
1348             }
1349             } elsif($rule_name eq 'max') {
1350 66 50       234 if(!defined($rules->{'type'})) {
1351 0         0 _error($logger, "$rule_description: Don't know type of '$key' to determine its maximum value $rule_value");
1352             }
1353 66         186 my $type = lc($rules->{'type'});
1354 66 100       212 if(exists($custom_types->{$type}->{'max'})) {
1355 2         4 $rule_value = $custom_types->{$type}->{'max'};
1356 2         5 $type = $custom_types->{$type}->{'type'};
1357             }
1358 66 100 66     529 if(($type eq 'string') || ($type eq 'str')) {
    100 100        
    100 100        
    100          
1359 24 100       64 if(!defined($value)) {
1360 1         2 next; # Skip if string is undefined
1361             }
1362 23 50       59 if(defined(my $len = _number_of_characters($value))) {
1363 23 100       124 if($len > $rule_value) {
1364 5   33     81 _error($logger, $rules->{'error_msg'} || "$rule_description: String parameter '$key' too long, ($len characters), must be no longer than $rule_value");
1365 0         0 $invalid_args{$key} = 1;
1366             }
1367             } else {
1368 0   0     0 _error($logger, $rules->{'error_msg'} || "$rule_description: '$key' can't be decoded");
1369 0         0 $invalid_args{$key} = 1;
1370             }
1371             } elsif($type eq 'arrayref') {
1372 7 50       25 if(!defined($value)) {
1373 0         0 next; # Skip if string is undefined
1374             }
1375 7 50       28 if(ref($value) ne 'ARRAY') {
1376 0 0       0 if($rules->{'error_msg'}) {
1377 0         0 _error($logger, $rules->{'error_msg'});
1378             } else {
1379 0         0 _error($logger, "$rule_description: Parameter '$key' must be an arrayref, not " . ref($value));
1380             }
1381             }
1382 7 100       13 if(scalar(@{$value}) > $rule_value) {
  7         27  
1383 4 50       15 if($rules->{'error_msg'}) {
1384 0         0 _error($logger, $rules->{'error_msg'});
1385             } else {
1386 4         22 _error($logger, "$rule_description: Parameter '$key' must contain no more than $rule_value items");
1387             }
1388 0         0 $invalid_args{$key} = 1;
1389             }
1390             } elsif($type eq 'hashref') {
1391 3 50       12 if(!defined($value)) {
1392 0         0 next; # Skip if hash is undefined
1393             }
1394 3 100       6 if(scalar(keys(%{$value})) > $rule_value) {
  3         14  
1395 2 50       7 if($rules->{'error_msg'}) {
1396 0         0 _error($logger, $rules->{'error_msg'});
1397             } else {
1398 2         14 _error($logger, "$rule_description: Parameter '$key' must contain no more than $rule_value keys");
1399             }
1400 0         0 $invalid_args{$key} = 1;
1401             }
1402             } elsif(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
1403 31 50       122 if(!defined($value)) {
1404 0         0 next; # Skip if hash is undefined
1405             }
1406 31 50       121 if(Scalar::Util::looks_like_number($value)) {
1407 31 100       114 if($value > $rule_value) {
1408 4 50       14 if($rules->{'error_msg'}) {
1409 0         0 _error($logger, $rules->{'error_msg'});
1410             } else {
1411 4         24 _error($logger, "$rule_description: Parameter '$key' ($value) must be no more than $rule_value");
1412             }
1413 0         0 $invalid_args{$key} = 1;
1414 0         0 next;
1415             }
1416             } else {
1417 0 0       0 if($rules->{'error_msg'}) {
1418 0         0 _error($logger, $rules->{'error_msg'});
1419             } else {
1420 0         0 _error($logger, "$rule_description: Parameter '$key' ($value) must be a number");
1421             }
1422 0         0 next;
1423             }
1424             } else {
1425 1         13 _error($logger, "$rule_description: Parameter '$key' of type '$type' has meaningless max value $rule_value");
1426             }
1427             } elsif($rule_name eq 'matches') {
1428 59 100       171 if(!defined($value)) {
1429 1         14 next; # Skip if string is undefined
1430             }
1431 58         227 eval {
1432 58 100       250 my $re = (ref($rule_value) eq 'Regexp') ? $rule_value : qr/\Q$rule_value\E/;
1433 58 100 66     787 if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
    100          
1434 2         6 my @matches = grep { $_ =~ $re } @{$value};
  4         69  
  2         7  
1435 2 50       6 if(scalar(@matches) != scalar(@{$value})) {
  2         12  
1436 0 0       0 if($rules->{'error_msg'}) {
1437 0         0 _error($logger, $rules->{'error_msg'});
1438             } else {
1439 0         0 _error($logger, "$rule_description: All members of parameter '$key' [", join(', ', @{$value}), "] must match pattern '$rule_value'");
  0         0  
1440             }
1441             }
1442             } elsif($value !~ $re) {
1443 17 100       65 if($rules->{'error_msg'}) {
1444 3         29 _error($logger, $rules->{'error_msg'});
1445             } else {
1446 14         115 _error($logger, "$rule_description: Parameter '$key' ($value) must match pattern '$re'");
1447             }
1448             }
1449 41         91 1;
1450             };
1451 58 100       49980 if($@) {
1452 17 100       114 if($rules->{'error_msg'}) {
1453 3         17 _error($logger, $rules->{'error_msg'});
1454             } else {
1455 14         189 _error($logger, "$rule_description: Parameter '$key' regex '$rule_value' error: $@");
1456             }
1457 0         0 $invalid_args{$key} = 1;
1458             }
1459             } elsif($rule_name eq 'nomatch') {
1460 7 50       23 if(!defined($value)) {
1461 0         0 next; # Skip if string is undefined
1462             }
1463 7 100 66     84 if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
    100          
1464 3         6 my @matches = grep { /$rule_value/ } @{$value};
  9         63  
  3         9  
1465 3 100       12 if(scalar(@matches)) {
1466 1 50       3 if($rules->{'error_msg'}) {
1467 0         0 _error($logger, $rules->{'error_msg'});
1468             } else {
1469 1         3 _error($logger, "$rule_description: No member of parameter '$key' [", join(', ', @{$value}), "] must match pattern '$rule_value'");
  1         6  
1470             }
1471             }
1472             } elsif($value =~ $rule_value) {
1473 1 50       4 if($rules->{'error_msg'}) {
1474 0         0 _error($logger, $rules->{'error_msg'});
1475             } else {
1476 1         9 _error($logger, "$rule_description: Parameter '$key' ($value) must not match pattern '$rule_value'");
1477             }
1478 0         0 $invalid_args{$key} = 1;
1479             }
1480             } elsif(($rule_name eq 'memberof') || ($rule_name eq 'enum')) {
1481 65 50       184 if(!defined($value)) {
1482 0         0 next; # Skip if string is undefined
1483             }
1484 65 100       187 if(ref($rule_value) eq 'ARRAY') {
1485 63         122 my $ok = 1;
1486 63 100 100     537 if(($rules->{'type'} eq 'integer') || ($rules->{'type'} eq 'number') || ($rules->{'type'} eq 'float')) {
      66        
1487 12 100   41   112 unless(List::Util::any { $_ == $value } @{$rule_value}) {
  41         100  
  12         84  
1488 5         14 $ok = 0;
1489             }
1490             } else {
1491 51         202 my $l = lc($value);
1492 51 100 100 246   472 unless(List::Util::any { (!defined($rules->{'case_sensitive'}) || ($rules->{'case_sensitive'} == 1)) ? $_ eq $value : lc($_) eq $l } @{$rule_value}) {
  246 100       813  
  51         276  
1493 15         38 $ok = 0;
1494             }
1495             }
1496              
1497 63 100       412 if(!$ok) {
1498 20 100       67 if($rules->{'error_msg'}) {
1499 3         81 _error($logger, $rules->{'error_msg'});
1500             } else {
1501 17         79 _error($logger, "$rule_description: Parameter '$key' ($value) must be one of ", join(', ', @{$rule_value}));
  17         127  
1502             }
1503 0         0 $invalid_args{$key} = 1;
1504             }
1505             } else {
1506 2 50       11 if($rules->{'error_msg'}) {
1507 0         0 _error($logger, $rules->{'error_msg'});
1508             } else {
1509 2         16 _error($logger, "$rule_description: Parameter '$key' rule ($rule_value) must be an array reference");
1510             }
1511             }
1512             } elsif($rule_name eq 'notmemberof') {
1513 24 50       86 if(!defined($value)) {
1514 0         0 next; # Skip if string is undefined
1515             }
1516 24 100       59 if(ref($rule_value) eq 'ARRAY') {
1517 23         40 my $ok = 1;
1518 23 100 100     171 if(($rules->{'type'} eq 'integer') || ($rules->{'type'} eq 'number') || ($rules->{'type'} eq 'float')) {
      66        
1519 6 100   17   33 if(List::Util::any { $_ == $value } @{$rule_value}) {
  17         37  
  6         28  
1520 4         38 $ok = 0;
1521             }
1522             } else {
1523 17         48 my $l = lc($value);
1524 17 50 33 33   181 if(List::Util::any { (!defined($rules->{'case_sensitive'}) || ($rules->{'case_sensitive'} == 1)) ? $_ eq $value : lc($_) eq $l } @{$rule_value}) {
  33 100       138  
  17         87  
1525 9         21 $ok = 0;
1526             }
1527             }
1528              
1529 23 100       136 if(!$ok) {
1530 13 100       33 if($rules->{'error_msg'}) {
1531 1         6 _error($logger, $rules->{'error_msg'});
1532             } else {
1533 12         41 _error($logger, "$rule_description: Parameter '$key' ($value) must not be one of ", join(', ', @{$rule_value}));
  12         72  
1534             }
1535 0         0 $invalid_args{$key} = 1;
1536             }
1537             } else {
1538 1 50       5 if($rules->{'error_msg'}) {
1539 0         0 _error($logger, $rules->{'error_msg'});
1540             } else {
1541 1         7 _error($logger, "$rule_description: Parameter '$key' rule ($rule_value) must be an array reference");
1542             }
1543             }
1544             } elsif($rule_name eq 'isa') {
1545 6 50       27 if(!defined($value)) {
1546 0         0 next; # Skip if object not given
1547             }
1548 6 100       24 if($rules->{'type'} eq 'object') {
1549 5 100       56 if(!$value->isa($rule_value)) {
1550 1 50       23 _error($logger, "$rule_description: Parameter '$key' must be a '$rule_value' object got a " . (ref($value) ? ref($value) : $value) . ' object instead');
1551 0         0 $invalid_args{$key} = 1;
1552             }
1553             } else {
1554 1         6 _error($logger, "$rule_description: Parameter '$key' has meaningless isa value $rule_value");
1555             }
1556             } elsif($rule_name eq 'can') {
1557 16 50       57 if(!defined($value)) {
1558 0         0 next; # Skip if object not given
1559             }
1560 16 100       49 if($rules->{'type'} eq 'object') {
1561 15 100       57 if(ref($rule_value) eq 'ARRAY') {
    100          
1562             # List of methods
1563 8         16 foreach my $method(@{$rule_value}) {
  8         26  
1564 15 100       123 if(!$value->can($method)) {
1565 4         27 _error($logger, "$rule_description: Parameter '$key' must be an object that understands the $method method");
1566 0         0 $invalid_args{$key} = 1;
1567             }
1568             }
1569             } elsif(!ref($rule_value)) {
1570 6 100       69 if(!$value->can($rule_value)) {
1571 3         21 _error($logger, "$rule_description: Parameter '$key' must be an object that understands the $rule_value method");
1572 0         0 $invalid_args{$key} = 1;
1573             }
1574             } else {
1575 1         8 _error($logger, "$rule_description: 'can' rule for Parameter '$key must be either a scalar or an arrayref");
1576             }
1577             } else {
1578 1         8 _error($logger, "$rule_description: Parameter '$key' has meaningless can value '$rule_value' for parameter type $rules->{type}");
1579             }
1580             } elsif($rule_name eq 'element_type') {
1581 18 50 33     87 if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
1582 18         36 my $type = $rule_value;
1583 18         38 my $custom_type = $custom_types->{$rule_value};
1584 18 50 66     54 if($custom_type && $custom_type->{'type'}) {
1585 1         3 $type = $custom_type->{'type'};
1586             }
1587 18         27 foreach my $member(@{$value}) {
  18         48  
1588 42 50 66     86 if($custom_type && $custom_type->{'transform'}) {
1589             # The custom type has a transform embedded within it
1590 2 50       7 if(ref($custom_type->{'transform'}) eq 'CODE') {
1591 2         4 $member = &{$custom_type->{'transform'}}($member);
  2         5  
1592             } else {
1593 0         0 _error($logger, "$rule_description: transforms must be a code ref");
1594 0         0 last;
1595             }
1596             }
1597 42 100 66     157 if(($type eq 'string') || ($type eq 'Str')) {
    100 33        
    50          
1598 15 50       47 if(ref($member)) {
1599 0 0       0 if($rules->{'error_msg'}) {
1600 0         0 _error($logger, $rules->{'error_msg'});
1601             } else {
1602 0         0 _error($logger, "$key can only contain strings");
1603             }
1604 0         0 $invalid_args{$key} = 1;
1605             }
1606             } elsif($type eq 'integer') {
1607 23 100 66     163 if(ref($member) || ($member =~ /\D/)) {
1608 2 100       7 if($rules->{'error_msg'}) {
1609 1         6 _error($logger, $rules->{'error_msg'});
1610             } else {
1611 1         4 _error($logger, "$key can only contain integers (found $member)");
1612             }
1613 0         0 $invalid_args{$key} = 1;
1614             }
1615             } elsif(($type eq 'number') || ($rule_value eq 'float')) {
1616 4 100 66     44 if(ref($member) || ($member !~ /^[-+]?(\d*\.\d+|\d+\.?\d*)$/)) {
1617 1 50       4 if($rules->{'error_msg'}) {
1618 0         0 _error($logger, $rules->{'error_msg'});
1619             } else {
1620 1         4 _error($logger, "$key can only contain numbers (found $member)");
1621             }
1622 0         0 $invalid_args{$key} = 1;
1623             }
1624             } else {
1625 0         0 _error($logger, "BUG: Add $type to element_type list");
1626             }
1627             }
1628             } else {
1629 0         0 _error($logger, "$rule_description: Parameter '$key' has meaningless element_type value $rule_value");
1630             }
1631             } elsif($rule_name eq 'optional') {
1632             # Already handled at the beginning of the loop
1633             } elsif($rule_name eq 'default') {
1634             # Handled earlier
1635             } elsif($rule_name eq 'error_msg') {
1636             # Handled inline
1637             } elsif($rule_name eq 'transform') {
1638             # Handled before the loop
1639             } elsif($rule_name eq 'case_sensitive') {
1640             # Handled inline
1641             } elsif($rule_name eq 'description') {
1642             # A la, Data::Processor
1643             } elsif($rule_name =~ /^_/) {
1644             # Ignore internal/metadata fields from schema extraction
1645             } elsif($rule_name eq 'semantic') {
1646 1 50       6 if($rule_value eq 'unix_timestamp') {
1647 1 50 33     8 if($value < 0 || $value > 2147483647) {
1648 0         0 error($logger, 'Invalid Unix timestamp: $value');
1649             }
1650             } else {
1651 0         0 _warn($logger, "semantic type $rule_value is not yet supported");
1652             }
1653             } elsif($rule_name eq 'schema') {
1654             # Nested schema Run the given schema against each element of the array
1655 44 100 66     329 if(($rules->{'type'} eq 'arrayref') || ($rules->{'type'} eq 'ArrayRef')) {
    50          
1656 11 50       35 if(ref($value) eq 'ARRAY') {
    0          
1657 11         25 foreach my $member(@{$value}) {
  11         34  
1658 16 50       150 if(!validate_strict({ input => { $key => $member }, schema => { $key => $rule_value }, custom_types => $custom_types })) {
1659 0         0 $invalid_args{$key} = 1;
1660             }
1661             }
1662             } elsif(defined($value)) { # Allow undef for optional values
1663 0         0 _error($logger, "$rule_description: nested schema: Parameter '$value' must be an arrayref");
1664             }
1665             } elsif($rules->{'type'} eq 'hashref') {
1666 33 50       138 if(ref($value) eq 'HASH') {
1667             # Apply nested defaults before validation
1668 33         94 my $nested_with_defaults = _apply_nested_defaults($value, $rule_value);
1669 33 100       59 if(scalar keys(%{$value})) {
  33         94  
1670 31 50       452 if(my $new_args = validate_strict({ input => $nested_with_defaults, schema => $rule_value, custom_types => $custom_types })) {
1671 20         84 $value = $new_args;
1672             } else {
1673 0         0 $invalid_args{$key} = 1;
1674             }
1675             }
1676             } else {
1677 0         0 _error($logger, "$rule_description: nested schema: Parameter '$value' must be an hashref");
1678             }
1679             } else {
1680 0         0 _error($logger, "$rule_description: Parameter '$key': 'schema' only supports arrayref and hashref, not $rules->{type}");
1681             }
1682             } elsif(($rule_name eq 'validate') || ($rule_name eq 'validator')) {
1683 2 50       8 if(ref($rule_value) eq 'CODE') {
1684 2 100       3 if(my $error = &{$rule_value}($args)) {
  2         15  
1685 1         14 _error($logger, "$rule_description: $key not valid: $error");
1686 0         0 $invalid_args{$key} = 1;
1687             }
1688             } else {
1689             # _error($logger, "$rule_description: Parameter '$key': 'validate' only supports coderef, not $value");
1690 0   0     0 _error($logger, "$rule_description: Parameter '$key': 'validate' only supports coderef, not " . ref($rule_value) // $rule_value);
1691             }
1692             } elsif ($rule_name eq 'callback') {
1693 17 100       67 unless (defined &$rule_value) {
1694 1         6 _error($logger, "$rule_description: callback for '$key' must be a code reference");
1695             }
1696 16         72 my $res = $rule_value->($value, $args, $schema);
1697 15 100       7105 unless ($res) {
1698 6 50       29 if($rules->{'error_msg'}) {
1699 0         0 _error($logger, $rules->{'error_msg'});
1700             } else {
1701 6         31 _error($logger, "$rule_description: Parameter '$key' failed custom validation");
1702             }
1703 0         0 $invalid_args{$key} = 1;
1704             }
1705             } elsif($rule_name eq 'position') {
1706 5 50       20 if($rule_value =~ /\D/) {
1707 0         0 _error($logger, "$rule_description: Parameter '$key': 'position' must be an integer");
1708             }
1709 5 50       16 if($rule_value < 0) {
1710 0         0 _error($logger, "$rule_description: Parameter '$key': 'position' must be a positive integer, not $value");
1711             }
1712             } else {
1713 0         0 _error($logger, "$rule_description: Unknown rule '$rule_name'");
1714             }
1715             }
1716             } elsif(ref($rules) eq 'ARRAY') {
1717 12 100       24 if(scalar(@{$rules})) {
  12         39  
1718             # An argument can be one of several different type
1719 10         39 my $rc = 0;
1720 10         20 my @types;
1721 10         21 foreach my $rule(@{$rules}) {
  10         52  
1722 17 100       86 if(ref($rule) ne 'HASH') {
1723 1         6 _error($logger, "$rule_description: Parameter '$key' rules must be a hash reference");
1724 0         0 next;
1725             }
1726 16 50       62 if(!defined($rule->{'type'})) {
1727 0         0 _error($logger, "$rule_description: Parameter '$key' is missing a type in an alternative");
1728 0         0 next;
1729             }
1730 16         49 push @types, $rule->{'type'};
1731 16         33 eval {
1732 16         213 validate_strict({ input => { $key => $value }, schema => { $key => $rule }, logger => undef, custom_types => $custom_types });
1733             };
1734 16 100       29978 if(!$@) {
1735 7         16 $rc = 1;
1736 7         18 last;
1737             }
1738             }
1739 9 100       37 if(!$rc) {
1740 2         17 _error($logger, "$rule_description: Parameter: '$key': must be one of " . join(', ', @types));
1741 0         0 $invalid_args{$key} = 1;
1742             }
1743             } else {
1744 2         14 _error($logger, "$rule_description: Parameter: '$key': schema is empty arrayref");
1745             }
1746             } elsif(ref($rules)) {
1747 1         6 _error($logger, 'rules must be a hash reference or string');
1748             }
1749              
1750 459         1868 $validated_args{$key} = $value;
1751             }
1752              
1753             # Validate parameter relationships
1754 312 100       1114 if (my $relationships = $params->{'relationships'}) {
1755 6         22 _validate_relationships(\%validated_args, $relationships, $logger, $schema_description);
1756             }
1757              
1758 307 100       929 if(my $cross_validation = $params->{'cross_validation'}) {
1759 37         59 foreach my $validator_name(keys %{$cross_validation}) {
  37         99  
1760 42         141 my $validator = $cross_validation->{$validator_name};
1761 42 100 66     195 if((!ref($validator)) || (ref($validator) ne 'CODE')) {
1762 1         10 _error($logger, "$schema_description: cross_validation $validator is not a code snippet");
1763 0         0 next;
1764             }
1765 41 100       75 if(my $error = &{$validator}(\%validated_args, $validator)) {
  41         134  
1766 18         203 _error($logger, $error);
1767             # We have no idea which parameters are still valid, so let's invalidate them all
1768 0         0 return;
1769             }
1770             }
1771             }
1772              
1773 288         938 foreach my $key(keys %invalid_args) {
1774 0         0 delete $validated_args{$key};
1775             }
1776              
1777 288 100       886 if($are_positional_args == 1) {
1778 4         7 my @rc;
1779 4         5 foreach my $key (keys %{$schema}) {
  4         9  
1780 6 50       18 if(my $value = delete $validated_args{$key}) {
1781 6         11 my $position = $schema->{$key}->{'position'};
1782 6 100       13 if(defined($rc[$position])) {
1783 1         6 _error($logger, "$schema_description: $key: position $position appears twice");
1784             }
1785 5         11 $rc[$position] = $value;
1786             }
1787             }
1788 3         19 return \@rc;
1789             }
1790 284         2112 return \%validated_args;
1791             }
1792              
1793             # Return number of visible characters not number of bytes
1794             # Ensure string is decoded into Perl characters
1795             sub _number_of_characters
1796             {
1797 77     77   188 my $value = $_[0];
1798              
1799 77 50       190 return if(!defined($value));
1800              
1801 77 100       2259 if($value !~ /[^[:ascii:]]/) {
1802 71         236 return length($value);
1803             }
1804             # Decode only if it's not already a Perl character string
1805 6 50       142 $value = decode_utf8($value) unless utf8::is_utf8($value);
1806              
1807             # Count grapheme clusters (visible characters)
1808             # The pseudo-operator () = forces list context to count matches
1809             # return scalar( () = $value =~ /\X/g );
1810              
1811 6         110 return Unicode::GCString->new($value)->length();
1812             }
1813              
1814             sub _apply_nested_defaults {
1815 45     45   199 my ($input, $schema) = @_;
1816 45         184 my %result = %$input;
1817              
1818 45         126 foreach my $key (keys %$schema) {
1819 105         181 my $rules = $schema->{$key};
1820              
1821 105 100 66     450 if (ref $rules eq 'HASH' && exists $rules->{default} && !exists $result{$key}) {
      100        
1822 2         5 $result{$key} = $rules->{default};
1823             }
1824              
1825             # Recursively handle nested schema
1826 105 100 66     446 if((ref $rules eq 'HASH') && $rules->{schema} && (ref $result{$key} eq 'HASH')) {
      100        
1827 8         29 $result{$key} = _apply_nested_defaults($result{$key}, $rules->{schema});
1828             }
1829             }
1830              
1831 45         140 return \%result;
1832             }
1833              
1834             sub _validate_relationships {
1835 6     6   34 my ($validated_args, $relationships, $logger, $description) = @_;
1836              
1837 6 50       21 return unless ref($relationships) eq 'ARRAY';
1838              
1839 6         15 foreach my $rel (@$relationships) {
1840 6 50       26 my $type = $rel->{type} or next;
1841              
1842 6 100       42 if ($type eq 'mutually_exclusive') {
    100          
    100          
    100          
    100          
    50          
1843 1         5 _validate_mutually_exclusive($validated_args, $rel, $logger, $description);
1844             } elsif ($type eq 'required_group') {
1845 1         5 _validate_required_group($validated_args, $rel, $logger, $description);
1846             } elsif ($type eq 'conditional_requirement') {
1847 1         6 _validate_conditional_requirement($validated_args, $rel, $logger, $description);
1848             } elsif ($type eq 'dependency') {
1849 1         5 _validate_dependency($validated_args, $rel, $logger, $description);
1850             } elsif ($type eq 'value_constraint') {
1851 1         6 _validate_value_constraint($validated_args, $rel, $logger, $description);
1852             } elsif ($type eq 'value_conditional') {
1853 1         5 _validate_value_conditional($validated_args, $rel, $logger, $description);
1854             } else {
1855 0         0 _error($logger, "Unknown relationship type $type");
1856             }
1857             }
1858             }
1859              
1860             sub _validate_mutually_exclusive {
1861 1     1   4 my ($args, $rel, $logger, $description) = @_;
1862              
1863 1 50       1 my @params = @{$rel->{params} || []};
  1         30  
1864 1 50       6 return unless @params >= 2;
1865              
1866 1 50       3 my @present = grep { exists($args->{$_}) && defined($args->{$_}) } @params;
  2         14  
1867              
1868 1 50       3 if (@present > 1) {
1869 1   33     34 my $msg = $rel->{description} || 'Cannot specify both ' . join(' and ', @present);
1870 1         8 _error($logger, "$description: $msg");
1871             }
1872             }
1873              
1874             sub _validate_required_group {
1875 1     1   3 my ($args, $rel, $logger, $description) = @_;
1876              
1877 1 50       3 my @params = @{$rel->{params} || []};
  1         26  
1878 1 50       11 return unless @params >= 2;
1879              
1880 1 50       5 my @present = grep { exists($args->{$_}) && defined($args->{$_}) } @params;
  2         13  
1881              
1882 1 50       4 if (@present == 0) {
1883             my $msg = $rel->{description} ||
1884 1   33     5 'Must specify at least one of: ' . join(', ', @params);
1885 1         6 _error($logger, "$description: $msg");
1886             }
1887             }
1888              
1889             sub _validate_conditional_requirement {
1890 1     1   3 my ($args, $rel, $logger, $description) = @_;
1891              
1892 1 50       4 my $if_param = $rel->{if} or return;
1893 1 50       3 my $then_param = $rel->{then_required} or return;
1894              
1895             # If the condition parameter is present and defined
1896 1 50 33     7 if (exists($args->{$if_param}) && defined($args->{$if_param})) {
1897             # Check if it's truthy (for booleans and general values)
1898 1 50       3 if ($args->{$if_param}) {
1899             # Then the required parameter must also be present
1900 1 50 33     10 unless (exists($args->{$then_param}) && defined($args->{$then_param})) {
1901 0   0     0 my $msg = $rel->{description} || "When $if_param is specified, $then_param is required";
1902 0         0 _error($logger, "$description: $msg");
1903             }
1904             }
1905             }
1906             }
1907              
1908             sub _validate_dependency {
1909 1     1   4 my ($args, $rel, $logger, $description) = @_;
1910              
1911 1 50       7 my $param = $rel->{param} or return;
1912 1 50       3 my $requires = $rel->{requires} or return;
1913              
1914             # If param is present, requires must also be present
1915 1 50 33     9 if (exists($args->{$param}) && defined($args->{$param})) {
1916 1 50 33     52 unless (exists($args->{$requires}) && defined($args->{$requires})) {
1917 1   33     6 my $msg = $rel->{description} || "$param requires $requires to be specified";
1918 1         8 _error($logger, "$description: $msg");
1919             }
1920             }
1921             }
1922              
1923             sub _validate_value_constraint {
1924 1     1   3 my ($args, $rel, $logger, $description) = @_;
1925              
1926 1 50       5 my $if_param = $rel->{if} or return;
1927 1 50       4 my $then_param = $rel->{then} or return;
1928 1 50       4 my $operator = $rel->{operator} or return;
1929 1         3 my $value = $rel->{value};
1930 1 50       3 return unless defined $value;
1931              
1932             # If the condition parameter is present and truthy
1933 1 50 33     16 if (exists($args->{$if_param}) && defined($args->{$if_param}) && $args->{$if_param}) {
      33        
1934             # Check if the then parameter exists
1935 1 50 33     28 if (exists($args->{$then_param}) && defined($args->{$then_param})) {
1936 1         3 my $actual = $args->{$then_param};
1937 1         3 my $valid = 0;
1938              
1939 1 50       20 if ($operator eq '==') {
    0          
    0          
    0          
    0          
    0          
1940 1         5 $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             } elsif ($operator eq '>=') {
1950 0         0 $valid = ($actual >= $value);
1951             }
1952              
1953 1 50       3 unless ($valid) {
1954 1   33     6 my $msg = $rel->{description} || "When $if_param is specified, $then_param must be $operator $value (got $actual)";
1955 1         5 _error($logger, "$description: $msg");
1956             }
1957             }
1958             }
1959             }
1960              
1961             sub _validate_value_conditional {
1962 1     1   4 my ($args, $rel, $logger, $description) = @_;
1963              
1964 1 50       5 my $if_param = $rel->{if} or return;
1965 1         3 my $equals = $rel->{equals};
1966 1 50       4 my $then_param = $rel->{then_required} or return;
1967 1 50       4 return unless defined $equals;
1968              
1969             # If the parameter has the specific value
1970 1 50 33     7 if (exists($args->{$if_param}) && defined($args->{$if_param})) {
1971 1 50       4 if ($args->{$if_param} eq $equals) {
1972             # Then the required parameter must be present
1973 1 50 33     24 unless (exists($args->{$then_param}) && defined($args->{$then_param})) {
1974             my $msg = $rel->{description} ||
1975 1   33     6 "When $if_param equals '$equals', $then_param is required";
1976 1         5 _error($logger, "$description: $msg");
1977             }
1978             }
1979             }
1980             }
1981              
1982             # Helper to log error or croak
1983             sub _error
1984             {
1985 222     222   484 my $logger = shift;
1986 222         770 my $message = join('', @_);
1987              
1988 222         945 my @call_details = caller(0);
1989 222 100       9524 if($logger) {
1990 12         89 $logger->error(__PACKAGE__, ' line ', $call_details[2], ": $message");
1991             }
1992 217         3778 croak(__PACKAGE__, ' line ', $call_details[2], ": $message");
1993             # Be absolutely sure, sometimes croak doesn't die for me in Test::Most scripts
1994 0         0 die (__PACKAGE__, ' line ', $call_details[2], ": $message");
1995             }
1996              
1997             # Helper to log warning or carp
1998             sub _warn
1999             {
2000 4     4   11 my $logger = shift;
2001 4         17 my $message = join('', @_);
2002              
2003 4 100       16 if($logger) {
2004 3         38 $logger->warn(__PACKAGE__, ": $message");
2005             } else {
2006 1         15 carp(__PACKAGE__, ": $message");
2007             }
2008             }
2009              
2010             =head1 AUTHOR
2011              
2012             Nigel Horne, C<< >>
2013              
2014             =encoding utf-8
2015              
2016             =head1 FORMAL SPECIFICATION
2017              
2018             [PARAM_NAME, VALUE, TYPE_NAME, CONSTRAINT_VALUE]
2019              
2020             ValidationRule ::= SimpleType | ComplexRule
2021              
2022             SimpleType ::= string | integer | number | arrayref | hashref | coderef | object
2023              
2024             ComplexRule == [
2025             type: TYPE_NAME;
2026             min: ℕ₁;
2027             max: ℕ₁;
2028             optional: 𝔹;
2029             matches: REGEX;
2030             nomatch: REGEX;
2031             memberof: seq VALUE;
2032             notmemberof: seq VALUE;
2033             callback: FUNCTION;
2034             isa: TYPE_NAME;
2035             can: METHOD_NAME
2036             ]
2037              
2038             Schema == PARAM_NAME ⇸ ValidationRule
2039              
2040             Arguments == PARAM_NAME ⇸ VALUE
2041              
2042             ValidatedResult == PARAM_NAME ⇸ VALUE
2043              
2044             ∀ rule: ComplexRule •
2045             rule.min ≤ rule.max ∧
2046             ¬(rule.memberof ∧ rule.min) ∧
2047             ¬(rule.memberof ∧ rule.max) ∧
2048             ¬(rule.notmemberof ∧ rule.min) ∧
2049             ¬(rule.notmemberof ∧ rule.max)
2050              
2051             ∀ schema: Schema; args: Arguments •
2052             dom(validate_strict(schema, args)) ⊆ dom(schema) ∪ dom(args)
2053              
2054             validate_strict: Schema × Arguments → ValidatedResult
2055              
2056             ∀ schema: Schema; args: Arguments •
2057             let result == validate_strict(schema, args) •
2058             (∀ name: dom(schema) ∩ dom(args) •
2059             name ∈ dom(result) ⇒
2060             type_matches(result(name), schema(name))) ∧
2061             (∀ name: dom(schema) •
2062             ¬optional(schema(name)) ⇒ name ∈ dom(args))
2063              
2064             type_matches: VALUE × ValidationRule → 𝔹
2065              
2066             =head1 EXAMPLE
2067              
2068             use Params::Get;
2069             use Params::Validate::Strict;
2070              
2071             sub where_am_i
2072             {
2073             my $params = Params::Validate::Strict::validate_strict({
2074             args => Params::Get::get_params(undef, \@_),
2075             description => 'Print a string of latitude and longitude',
2076             error_msg => 'Latitude is a number between +/- 90, longitude is a number between +/- 180',
2077             members => {
2078             'latitude' => {
2079             type => 'number',
2080             min => -90,
2081             max => 90
2082             }, 'longitude' => {
2083             type => 'number',
2084             min => -180,
2085             max => 180
2086             }
2087             }
2088             });
2089              
2090             print 'You are at ', $params->{'latitude'}, ', ', $params->{'longitude'}, "\n";
2091             }
2092              
2093             where_am_i({ latitude => 3.14, longitude => -155 });
2094              
2095             =head1 BUGS
2096              
2097             =head1 SEE ALSO
2098              
2099             =over 4
2100              
2101             =item * L
2102              
2103             =item * L
2104              
2105             =item * L
2106              
2107             =item * L
2108              
2109             =item * L
2110              
2111             =item * L
2112              
2113             =item * L
2114              
2115             =back
2116              
2117             =head1 SUPPORT
2118              
2119             This module is provided as-is without any warranty.
2120              
2121             Please report any bugs or feature requests to C,
2122             or through the web interface at
2123             L.
2124             I will be notified, and then you'll
2125             automatically be notified of progress on your bug as I make changes.
2126              
2127             You can find documentation for this module with the perldoc command.
2128              
2129             perldoc Params::Validate::Strict
2130              
2131             You can also look for information at:
2132              
2133             =over 4
2134              
2135             =item * MetaCPAN
2136              
2137             L
2138              
2139             =item * RT: CPAN's request tracker
2140              
2141             L
2142              
2143             =item * CPAN Testers' Matrix
2144              
2145             L
2146              
2147             =item * CPAN Testers Dependencies
2148              
2149             L
2150              
2151             =back
2152              
2153             =head1 LICENSE AND COPYRIGHT
2154              
2155             Copyright 2025-2026 Nigel Horne.
2156              
2157             This program is released under the following licence: GPL2
2158              
2159             =cut
2160              
2161             1;
2162              
2163             __END__