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