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__