This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move Params::Check from ext/ to cpan/
[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 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 $_ERROR_STRING
16                     ];
17
18     @ISA        =   qw[ Exporter ];
19     @EXPORT_OK  =   qw[check allow last_error];
20
21     $VERSION                = '0.26';
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 not do {
339                 local $_ERROR_STRING;
340                 allow( $args{$key}, $tmpl{'allow'} )
341             }         
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
362     ### done with our loop... if $wrong is set, somethign went wrong
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
380 The function that handles the C<allow> key in the template is also
381 available for independent use.
382
383 The function takes as first argument a key to test against, and
384 as second argument any form of criteria that are also allowed by
385 the C<allow> key in the template.
386
387 You can use the following types of values for allow:
388
389 =over 4
390
391 =item string
392
393 The provided argument MUST be equal to the string for the validation
394 to pass.
395
396 =item regexp
397
398 The provided argument MUST match the regular expression for the
399 validation to pass.
400
401 =item subroutine
402
403 The provided subroutine MUST return true in order for the validation
404 to pass and the argument accepted.
405
406 (This is particularly useful for more complicated data).
407
408 =item array ref
409
410 The provided argument MUST equal one of the elements of the array
411 ref for the validation to pass. An array ref can hold all the above
412 values.
413
414 =back
415
416 It returns true if the key matched the criteria, or false otherwise.
417
418 =cut
419
420 sub 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
438         ### also, short-cicruit when possible
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 ###
457 sub _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
476 sub _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
530 sub _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
537 sub _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
545 Returns a string containing all warnings and errors reported during
546 the last time C<check> was called.
547
548 This is useful if you want to report then some other way than
549 C<carp>'ing when the verbose flag is on.
550
551 It is exported upon request.
552
553 =cut
554
555 {   $_ERROR_STRING = '';
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
567         $_ERROR_STRING .= $err . "\n";
568     }
569
570     sub _clear_error {
571         $_ERROR_STRING = '';
572     }
573
574     sub last_error { $_ERROR_STRING }
575 }
576
577 1;
578
579 =head1 Global Variables
580
581 The behaviour of Params::Check can be altered by changing the
582 following global variables:
583
584 =head2 $Params::Check::VERBOSE
585
586 This controls whether Params::Check will issue warnings and
587 explanations as to why certain things may have failed.
588 If you set it to 0, Params::Check will not output any warnings.
589
590 The default is 1 when L<warnings> are enabled, 0 otherwise;
591
592 =head2 $Params::Check::STRICT_TYPE
593
594 This works like the C<strict_type> option you can pass to C<check>,
595 which will turn on C<strict_type> globally for all calls to C<check>.
596
597 The default is 0;
598
599 =head2 $Params::Check::ALLOW_UNKNOWN
600
601 If you set this flag, unknown options will still be present in the
602 return value, rather than filtered out. This is useful if your
603 subroutine is only interested in a few arguments, and wants to pass
604 the rest on blindly to perhaps another subroutine.
605
606 The default is 0;
607
608 =head2 $Params::Check::STRIP_LEADING_DASHES
609
610 If you set this flag, all keys passed in the following manner:
611
612     function( -key => 'val' );
613
614 will have their leading dashes stripped.
615
616 =head2 $Params::Check::NO_DUPLICATES
617
618 If set to true, all keys in the template that are marked as to be
619 stored in a scalar, will also be removed from the result set.
620
621 Default is false, meaning that when you use C<store> as a template
622 key, C<check> will put it both in the scalar you supplied, as well as
623 in the hashref it returns.
624
625 =head2 $Params::Check::PRESERVE_CASE
626
627 If set to true, L<Params::Check> will no longer convert all keys from
628 the user input to lowercase, but instead expect them to be in the
629 case the template provided. This is useful when you want to use
630 similar keys with different casing in your templates.
631
632 Understand that this removes the case-insensitivy feature of this
633 module.
634
635 Default is 0;
636
637 =head2 $Params::Check::ONLY_ALLOW_DEFINED
638
639 If set to true, L<Params::Check> will require all values passed to be
640 C<defined>. If you wish to enable this on a 'per key' basis, use the
641 template option C<defined> instead.
642
643 Default is 0;
644
645 =head2 $Params::Check::SANITY_CHECK_TEMPLATE
646
647 If set to true, L<Params::Check> will sanity check templates, validating
648 for errors and unknown keys. Although very useful for debugging, this
649 can be somewhat slow in hot-code and large loops.
650
651 To disable this check, set this variable to C<false>.
652
653 Default is 1;
654
655 =head2 $Params::Check::WARNINGS_FATAL
656
657 If set to true, L<Params::Check> will C<croak> when an error during 
658 template validation occurs, rather than return C<false>.
659
660 Default is 0;
661
662 =head2 $Params::Check::CALLER_DEPTH
663
664 This global modifies the argument given to C<caller()> by
665 C<Params::Check::check()> and is useful if you have a custom wrapper
666 function around C<Params::Check::check()>. The value must be an
667 integer, indicating the number of wrapper functions inserted between
668 the real function call and C<Params::Check::check()>.
669
670 Example 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
684 Default is 0;
685
686 =head1 AUTHOR
687
688 This module by
689 Jos Boumans E<lt>kane@cpan.orgE<gt>.
690
691 =head1 Acknowledgements
692
693 Thanks to Richard Soderberg for his performance improvements.
694
695 =head1 COPYRIGHT
696
697 This module is
698 copyright (c) 2003,2004 Jos Boumans E<lt>kane@cpan.orgE<gt>.
699 All rights reserved.
700
701 This library is free software;
702 you may redistribute and/or modify it under the same
703 terms 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: