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