This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix typos (spelling errors) in cpan/Params-Check/*.
[perl5.git] / cpan / Params-Check / lib / Params / Check.pm
CommitLineData
703d525d
JB
1package Params::Check;
2
3use strict;
4
5use Carp qw[carp croak];
6use Locale::Maketext::Simple Style => 'gettext';
7
8use Data::Dumper;
9
10BEGIN {
11 use Exporter ();
12 use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
13 $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
14 $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
7720784c 15 $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
703d525d
JB
16 ];
17
18 @ISA = qw[ Exporter ];
19 @EXPORT_OK = qw[check allow last_error];
20
7720784c 21 $VERSION = '0.26';
703d525d
JB
22 $VERBOSE = $^W ? 1 : 0;
23 $NO_DUPLICATES = 0;
24 $STRIP_LEADING_DASHES = 0;
25 $STRICT_TYPE = 0;
26 $ALLOW_UNKNOWN = 0;
27 $PRESERVE_CASE = 0;
28 $ONLY_ALLOW_DEFINED = 0;
29 $SANITY_CHECK_TEMPLATE = 1;
30 $WARNINGS_FATAL = 0;
31 $CALLER_DEPTH = 0;
32}
33
34my %known_keys = map { $_ => 1 }
35 qw| required allow default strict_type no_override
36 store defined |;
37
38=pod
39
40=head1 NAME
41
42Params::Check - A generic input parsing/checking mechanism.
43
44=head1 SYNOPSIS
45
46 use Params::Check qw[check allow last_error];
47
48 sub fill_personal_info {
49 my %hash = @_;
50 my $x;
51
52 my $tmpl = {
53 firstname => { required => 1, defined => 1 },
54 lastname => { required => 1, store => \$x },
55 gender => { required => 1,
56 allow => [qr/M/i, qr/F/i],
57 },
58 married => { allow => [0,1] },
59 age => { default => 21,
60 allow => qr/^\d+$/,
61 },
62
63 phone => { allow => [ sub { return 1 if /$valid_re/ },
64 '1-800-PERL' ]
65 },
66 id_list => { default => [],
67 strict_type => 1
68 },
69 employer => { default => 'NSA', no_override => 1 },
70 };
71
72 ### check() returns a hashref of parsed args on success ###
73 my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
74 or die qw[Could not parse arguments!];
75
76 ... other code here ...
77 }
78
79 my $ok = allow( $colour, [qw|blue green yellow|] );
80
81 my $error = Params::Check::last_error();
82
83
84=head1 DESCRIPTION
85
86Params::Check is a generic input parsing/checking mechanism.
87
88It allows you to validate input via a template. The only requirement
89is that the arguments must be named.
90
91Params::Check can do the following things for you:
92
93=over 4
94
95=item *
96
97Convert all keys to lowercase
98
99=item *
100
101Check if all required arguments have been provided
102
103=item *
104
105Set arguments that have not been provided to the default
106
107=item *
108
109Weed out arguments that are not supported and warn about them to the
110user
111
112=item *
113
114Validate the arguments given by the user based on strings, regexes,
115lists or even subroutines
116
117=item *
118
119Enforce type integrity if required
120
121=back
122
123Most of Params::Check's power comes from its template, which we'll
124discuss below:
125
126=head1 Template
127
128As you can see in the synopsis, based on your template, the arguments
129provided will be validated.
130
131The template can take a different set of rules per key that is used.
132
133The following rules are available:
134
135=over 4
136
137=item default
138
139This is the default value if none was provided by the user.
140This is also the type C<strict_type> will look at when checking type
141integrity (see below).
142
143=item required
144
145A boolean flag that indicates if this argument was a required
146argument. If marked as required and not provided, check() will fail.
147
148=item strict_type
149
150This does a C<ref()> check on the argument provided. The C<ref> of the
151argument must be the same as the C<ref> of the default value for this
152check to pass.
153
154This is very useful if you insist on taking an array reference as
155argument for example.
156
157=item defined
158
159If this template key is true, enforces that if this key is provided by
160user input, its value is C<defined>. This just means that the user is
161not allowed to pass C<undef> as a value for this key and is equivalent
162to:
163 allow => sub { defined $_[0] && OTHER TESTS }
164
165=item no_override
166
167This allows you to specify C<constants> in your template. ie, they
168keys that are not allowed to be altered by the user. It pretty much
169allows you to keep all your C<configurable> data in one place; the
170C<Params::Check> template.
171
172=item store
173
174This allows you to pass a reference to a scalar, in which the data
175will be stored:
176
177 my $x;
178 my $args = check(foo => { default => 1, store => \$x }, $input);
179
180This is basically shorthand for saying:
181
182 my $args = check( { foo => { default => 1 }, $input );
183 my $x = $args->{foo};
184
185You can alter the global variable $Params::Check::NO_DUPLICATES to
186control whether the C<store>'d key will still be present in your
187result set. See the L<Global Variables> section below.
188
189=item allow
190
191A set of criteria used to validate a particular piece of data if it
192has to adhere to particular rules.
193
194See the C<allow()> function for details.
195
196=back
197
198=head1 Functions
199
200=head2 check( \%tmpl, \%args, [$verbose] );
201
202This function is not exported by default, so you'll have to ask for it
203via:
204
205 use Params::Check qw[check];
206
207or use its fully qualified name instead.
208
209C<check> takes a list of arguments, as follows:
210
211=over 4
212
213=item Template
214
215This is a hashreference which contains a template as explained in the
216C<SYNOPSIS> and C<Template> section.
217
218=item Arguments
219
220This is a reference to a hash of named arguments which need checking.
221
222=item Verbose
223
224A boolean to indicate whether C<check> should be verbose and warn
225about what went wrong in a check or not.
226
227You can enable this program wide by setting the package variable
228C<$Params::Check::VERBOSE> to a true value. For details, see the
229section on C<Global Variables> below.
230
231=back
232
233C<check> will return when it fails, or a hashref with lowercase
234keys of parsed arguments when it succeeds.
235
236So a typical call to check would look like this:
237
238 my $parsed = check( \%template, \%arguments, $VERBOSE )
239 or warn q[Arguments could not be parsed!];
240
241A lot of the behaviour of C<check()> can be altered by setting
242package variables. See the section on C<Global Variables> for details
243on this.
244
245=cut
246
247sub check {
248 my ($utmpl, $href, $verbose) = @_;
249
250 ### did we get the arguments we need? ###
251 return if !$utmpl or !$href;
252
253 ### sensible defaults ###
254 $verbose ||= $VERBOSE || 0;
255
256 ### clear the current error string ###
257 _clear_error();
258
259 ### XXX what type of template is it? ###
260 ### { key => { } } ?
261 #if (ref $args eq 'HASH') {
262 # 1;
263 #}
264
265 ### clean up the template ###
266 my $args = _clean_up_args( $href ) or return;
267
268 ### sanity check + defaults + required keys set? ###
269 my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
270 or return;
271
272 ### deref only once ###
273 my %utmpl = %$utmpl;
274 my %args = %$args;
275 my %defs = %$defs;
276
277 ### flag to see if anything went wrong ###
278 my $wrong;
279
280 ### flag to see if we warned for anything, needed for warnings_fatal
281 my $warned;
282
283 for my $key (keys %args) {
284
285 ### you gave us this key, but it's not in the template ###
286 unless( $utmpl{$key} ) {
287
288 ### but we'll allow it anyway ###
289 if( $ALLOW_UNKNOWN ) {
290 $defs{$key} = $args{$key};
291
292 ### warn about the error ###
293 } else {
294 _store_error(
295 loc("Key '%1' is not a valid key for %2 provided by %3",
296 $key, _who_was_it(), _who_was_it(1)), $verbose);
297 $warned ||= 1;
298 }
299 next;
300 }
301
302 ### check if you're even allowed to override this key ###
303 if( $utmpl{$key}->{'no_override'} ) {
304 _store_error(
305 loc(q[You are not allowed to override key '%1'].
306 q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
307 $verbose
308 );
309 $warned ||= 1;
310 next;
311 }
312
313 ### copy of this keys template instructions, to save derefs ###
314 my %tmpl = %{$utmpl{$key}};
315
316 ### check if you were supposed to provide defined() values ###
317 if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and
318 not defined $args{$key}
319 ) {
320 _store_error(loc(q|Key '%1' must be defined when passed|, $key),
321 $verbose );
322 $wrong ||= 1;
323 next;
324 }
325
326 ### check if they should be of a strict type, and if it is ###
327 if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
328 (ref $args{$key} ne ref $tmpl{'default'})
329 ) {
330 _store_error(loc(q|Key '%1' needs to be of type '%2'|,
331 $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
332 $wrong ||= 1;
333 next;
334 }
335
336 ### check if we have an allow handler, to validate against ###
337 ### allow() will report its own errors ###
7720784c
RGS
338 if( exists $tmpl{'allow'} and not do {
339 local $_ERROR_STRING;
340 allow( $args{$key}, $tmpl{'allow'} )
341 }
703d525d
JB
342 ) {
343 ### stringify the value in the error report -- we don't want dumps
344 ### of objects, but we do want to see *roughly* what we passed
345 _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
346 q|provided by %4|,
347 $key, "$args{$key}", _who_was_it(),
348 _who_was_it(1)), $verbose);
349 $wrong ||= 1;
350 next;
351 }
352
353 ### we got here, then all must be OK ###
354 $defs{$key} = $args{$key};
355
356 }
357
358 ### croak with the collected errors if there were errors and
359 ### we have the fatal flag toggled.
360 croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
361
da827d75 362 ### done with our loop... if $wrong is set, something went wrong
703d525d
JB
363 ### and the user is already informed, just return...
364 return if $wrong;
365
366 ### check if we need to store any of the keys ###
367 ### can't do it before, because something may go wrong later,
368 ### leaving the user with a few set variables
369 for my $key (keys %defs) {
370 if( my $ref = $utmpl{$key}->{'store'} ) {
371 $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
372 }
373 }
374
375 return \%defs;
376}
377
378=head2 allow( $test_me, \@criteria );
379
380The function that handles the C<allow> key in the template is also
381available for independent use.
382
383The function takes as first argument a key to test against, and
384as second argument any form of criteria that are also allowed by
385the C<allow> key in the template.
386
387You can use the following types of values for allow:
388
389=over 4
390
391=item string
392
393The provided argument MUST be equal to the string for the validation
394to pass.
395
396=item regexp
397
398The provided argument MUST match the regular expression for the
399validation to pass.
400
401=item subroutine
402
403The provided subroutine MUST return true in order for the validation
404to pass and the argument accepted.
405
406(This is particularly useful for more complicated data).
407
408=item array ref
409
410The provided argument MUST equal one of the elements of the array
411ref for the validation to pass. An array ref can hold all the above
412values.
413
414=back
415
416It returns true if the key matched the criteria, or false otherwise.
417
418=cut
419
420sub allow {
421 ### use $_[0] and $_[1] since this is hot code... ###
422 #my ($val, $ref) = @_;
423
424 ### it's a regexp ###
425 if( ref $_[1] eq 'Regexp' ) {
426 local $^W; # silence warnings if $val is undef #
427 return if $_[0] !~ /$_[1]/;
428
429 ### it's a sub ###
430 } elsif ( ref $_[1] eq 'CODE' ) {
431 return unless $_[1]->( $_[0] );
432
433 ### it's an array ###
434 } elsif ( ref $_[1] eq 'ARRAY' ) {
435
436 ### loop over the elements, see if one of them says the
437 ### value is OK
da827d75 438 ### also, short-circuit when possible
703d525d
JB
439 for ( @{$_[1]} ) {
440 return 1 if allow( $_[0], $_ );
441 }
442
443 return;
444
445 ### fall back to a simple, but safe 'eq' ###
446 } else {
447 return unless _safe_eq( $_[0], $_[1] );
448 }
449
450 ### we got here, no failures ###
451 return 1;
452}
453
454### helper functions ###
455
456### clean up the template ###
457sub _clean_up_args {
458 ### don't even bother to loop, if there's nothing to clean up ###
459 return $_[0] if $PRESERVE_CASE and !$STRIP_LEADING_DASHES;
460
461 my %args = %{$_[0]};
462
463 ### keys are note aliased ###
464 for my $key (keys %args) {
465 my $org = $key;
466 $key = lc $key unless $PRESERVE_CASE;
467 $key =~ s/^-// if $STRIP_LEADING_DASHES;
468 $args{$key} = delete $args{$org} if $key ne $org;
469 }
470
471 ### return references so we always return 'true', even on empty
472 ### arguments
473 return \%args;
474}
475
476sub _sanity_check_and_defaults {
477 my %utmpl = %{$_[0]};
478 my %args = %{$_[1]};
479 my $verbose = $_[2];
480
481 my %defs; my $fail;
482 for my $key (keys %utmpl) {
483
484 ### check if required keys are provided
485 ### keys are now lower cased, unless preserve case was enabled
486 ### at which point, the utmpl keys must match, but that's the users
487 ### problem.
488 if( $utmpl{$key}->{'required'} and not exists $args{$key} ) {
489 _store_error(
490 loc(q|Required option '%1' is not provided for %2 by %3|,
491 $key, _who_was_it(1), _who_was_it(2)), $verbose );
492
493 ### mark the error ###
494 $fail++;
495 next;
496 }
497
498 ### next, set the default, make sure the key exists in %defs ###
499 $defs{$key} = $utmpl{$key}->{'default'}
500 if exists $utmpl{$key}->{'default'};
501
502 if( $SANITY_CHECK_TEMPLATE ) {
503 ### last, check if they provided any weird template keys
504 ### -- do this last so we don't always execute this code.
505 ### just a small optimization.
506 map { _store_error(
507 loc(q|Template type '%1' not supported [at key '%2']|,
508 $_, $key), 1, 1 );
509 } grep {
510 not $known_keys{$_}
511 } keys %{$utmpl{$key}};
512
513 ### make sure you passed a ref, otherwise, complain about it!
514 if ( exists $utmpl{$key}->{'store'} ) {
515 _store_error( loc(
516 q|Store variable for '%1' is not a reference!|, $key
517 ), 1, 1 ) unless ref $utmpl{$key}->{'store'};
518 }
519 }
520 }
521
522 ### errors found ###
523 return if $fail;
524
525 ### return references so we always return 'true', even on empty
526 ### defaults
527 return \%defs;
528}
529
530sub _safe_eq {
531 ### only do a straight 'eq' if they're both defined ###
532 return defined($_[0]) && defined($_[1])
533 ? $_[0] eq $_[1]
534 : defined($_[0]) eq defined($_[1]);
535}
536
537sub _who_was_it {
538 my $level = $_[0] || 0;
539
540 return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
541}
542
543=head2 last_error()
544
545Returns a string containing all warnings and errors reported during
546the last time C<check> was called.
547
548This is useful if you want to report then some other way than
549C<carp>'ing when the verbose flag is on.
550
551It is exported upon request.
552
553=cut
554
7720784c 555{ $_ERROR_STRING = '';
703d525d
JB
556
557 sub _store_error {
558 my($err, $verbose, $offset) = @_[0..2];
559 $verbose ||= 0;
560 $offset ||= 0;
561 my $level = 1 + $offset;
562
563 local $Carp::CarpLevel = $level;
564
565 carp $err if $verbose;
566
7720784c 567 $_ERROR_STRING .= $err . "\n";
703d525d
JB
568 }
569
570 sub _clear_error {
7720784c 571 $_ERROR_STRING = '';
703d525d
JB
572 }
573
7720784c 574 sub last_error { $_ERROR_STRING }
703d525d
JB
575}
576
5771;
578
579=head1 Global Variables
580
581The behaviour of Params::Check can be altered by changing the
582following global variables:
583
584=head2 $Params::Check::VERBOSE
585
586This controls whether Params::Check will issue warnings and
587explanations as to why certain things may have failed.
588If you set it to 0, Params::Check will not output any warnings.
589
590The default is 1 when L<warnings> are enabled, 0 otherwise;
591
592=head2 $Params::Check::STRICT_TYPE
593
594This works like the C<strict_type> option you can pass to C<check>,
595which will turn on C<strict_type> globally for all calls to C<check>.
596
597The default is 0;
598
599=head2 $Params::Check::ALLOW_UNKNOWN
600
601If you set this flag, unknown options will still be present in the
602return value, rather than filtered out. This is useful if your
603subroutine is only interested in a few arguments, and wants to pass
604the rest on blindly to perhaps another subroutine.
605
606The default is 0;
607
608=head2 $Params::Check::STRIP_LEADING_DASHES
609
610If you set this flag, all keys passed in the following manner:
611
612 function( -key => 'val' );
613
614will have their leading dashes stripped.
615
616=head2 $Params::Check::NO_DUPLICATES
617
618If set to true, all keys in the template that are marked as to be
619stored in a scalar, will also be removed from the result set.
620
621Default is false, meaning that when you use C<store> as a template
622key, C<check> will put it both in the scalar you supplied, as well as
623in the hashref it returns.
624
625=head2 $Params::Check::PRESERVE_CASE
626
627If set to true, L<Params::Check> will no longer convert all keys from
628the user input to lowercase, but instead expect them to be in the
629case the template provided. This is useful when you want to use
630similar keys with different casing in your templates.
631
da827d75 632Understand that this removes the case-insensitivity feature of this
703d525d
JB
633module.
634
635Default is 0;
636
637=head2 $Params::Check::ONLY_ALLOW_DEFINED
638
639If set to true, L<Params::Check> will require all values passed to be
640C<defined>. If you wish to enable this on a 'per key' basis, use the
641template option C<defined> instead.
642
643Default is 0;
644
645=head2 $Params::Check::SANITY_CHECK_TEMPLATE
646
647If set to true, L<Params::Check> will sanity check templates, validating
648for errors and unknown keys. Although very useful for debugging, this
649can be somewhat slow in hot-code and large loops.
650
651To disable this check, set this variable to C<false>.
652
653Default is 1;
654
655=head2 $Params::Check::WARNINGS_FATAL
656
657If set to true, L<Params::Check> will C<croak> when an error during
658template validation occurs, rather than return C<false>.
659
660Default is 0;
661
662=head2 $Params::Check::CALLER_DEPTH
663
664This global modifies the argument given to C<caller()> by
665C<Params::Check::check()> and is useful if you have a custom wrapper
666function around C<Params::Check::check()>. The value must be an
667integer, indicating the number of wrapper functions inserted between
668the real function call and C<Params::Check::check()>.
669
670Example wrapper function, using a custom stacktrace:
671
672 sub check {
673 my ($template, $args_in) = @_;
674
675 local $Params::Check::WARNINGS_FATAL = 1;
676 local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
677 my $args_out = Params::Check::check($template, $args_in);
678
679 my_stacktrace(Params::Check::last_error) unless $args_out;
680
681 return $args_out;
682 }
683
684Default is 0;
685
686=head1 AUTHOR
687
688This module by
689Jos Boumans E<lt>kane@cpan.orgE<gt>.
690
691=head1 Acknowledgements
692
693Thanks to Richard Soderberg for his performance improvements.
694
695=head1 COPYRIGHT
696
697This module is
698copyright (c) 2003,2004 Jos Boumans E<lt>kane@cpan.orgE<gt>.
699All rights reserved.
700
701This library is free software;
702you may redistribute and/or modify it under the same
703terms as Perl itself.
704
705=cut
706
707# Local variables:
708# c-indentation-style: bsd
709# c-basic-offset: 4
710# indent-tabs-mode: nil
711# End:
712# vim: expandtab shiftwidth=4: