This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update HTTP-Tiny to CPAN version 0.033
[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.36';
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;
269
270     ### don't even bother to loop, if there's nothing to clean up ###
271     if( $PRESERVE_CASE and !$STRIP_LEADING_DASHES ) {
272         $args = $href;
273     } else {
274         ### keys are not aliased ###
275         for my $key (keys %$href) {
276             my $org = $key;
277             $key = lc $key unless $PRESERVE_CASE;
278             $key =~ s/^-// if $STRIP_LEADING_DASHES;
279             $args->{$key} = $href->{$org};
280         }
281     }
282
283     my %defs;
284
285     ### which template entries have a 'store' member
286     my @want_store;
287
288     ### sanity check + defaults + required keys set? ###
289     my $fail;
290     for my $key (keys %$utmpl) {
291         my $tmpl = $utmpl->{$key};
292
293         ### check if required keys are provided
294         ### keys are now lower cased, unless preserve case was enabled
295         ### at which point, the utmpl keys must match, but that's the users
296         ### problem.
297         if( $tmpl->{'required'} and not exists $args->{$key} ) {
298             _store_error(
299                 loc(q|Required option '%1' is not provided for %2 by %3|,
300                     $key, _who_was_it(), _who_was_it(1)), $verbose );
301
302             ### mark the error ###
303             $fail++;
304             next;
305         }
306
307         ### next, set the default, make sure the key exists in %defs ###
308         $defs{$key} = $tmpl->{'default'}
309                         if exists $tmpl->{'default'};
310
311         if( $SANITY_CHECK_TEMPLATE ) {
312             ### last, check if they provided any weird template keys
313             ### -- do this last so we don't always execute this code.
314             ### just a small optimization.
315             map {   _store_error(
316                         loc(q|Template type '%1' not supported [at key '%2']|,
317                         $_, $key), 1, 0 );
318             } grep {
319                 not $known_keys{$_}
320             } keys %$tmpl;
321
322             ### make sure you passed a ref, otherwise, complain about it!
323             if ( exists $tmpl->{'store'} ) {
324                 _store_error( loc(
325                     q|Store variable for '%1' is not a reference!|, $key
326                 ), 1, 0 ) unless ref $tmpl->{'store'};
327             }
328         }
329
330         push @want_store, $key if $tmpl->{'store'};
331     }
332
333     ### errors found ###
334     return if $fail;
335
336     ### flag to see if anything went wrong ###
337     my $wrong;
338
339     ### flag to see if we warned for anything, needed for warnings_fatal
340     my $warned;
341
342     for my $key (keys %$args) {
343         my $arg = $args->{$key};
344
345         ### you gave us this key, but it's not in the template ###
346         unless( $utmpl->{$key} ) {
347
348             ### but we'll allow it anyway ###
349             if( $ALLOW_UNKNOWN ) {
350                 $defs{$key} = $arg;
351
352             ### warn about the error ###
353             } else {
354                 _store_error(
355                     loc("Key '%1' is not a valid key for %2 provided by %3",
356                         $key, _who_was_it(), _who_was_it(1)), $verbose);
357                 $warned ||= 1;
358             }
359             next;
360         }
361
362         ### copy of this keys template instructions, to save derefs ###
363         my %tmpl = %{$utmpl->{$key}};
364
365         ### check if you're even allowed to override this key ###
366         if( $tmpl{'no_override'} ) {
367             _store_error(
368                 loc(q[You are not allowed to override key '%1'].
369                     q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
370                 $verbose
371             );
372             $warned ||= 1;
373             next;
374         }
375
376         ### check if you were supposed to provide defined() values ###
377         if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and not defined $arg ) {
378             _store_error(loc(q|Key '%1' must be defined when passed|, $key),
379                 $verbose );
380             $wrong ||= 1;
381             next;
382         }
383
384         ### check if they should be of a strict type, and if it is ###
385         if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
386             (ref $arg ne ref $tmpl{'default'})
387         ) {
388             _store_error(loc(q|Key '%1' needs to be of type '%2'|,
389                         $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
390             $wrong ||= 1;
391             next;
392         }
393
394         ### check if we have an allow handler, to validate against ###
395         ### allow() will report its own errors ###
396         if( exists $tmpl{'allow'} and not do {
397                 local $_ERROR_STRING;
398                 allow( $arg, $tmpl{'allow'} )
399             }
400         ) {
401             ### stringify the value in the error report -- we don't want dumps
402             ### of objects, but we do want to see *roughly* what we passed
403             _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
404                              q|provided by %4|,
405                             $key, "$arg", _who_was_it(),
406                             _who_was_it(1)), $verbose);
407             $wrong ||= 1;
408             next;
409         }
410
411         ### we got here, then all must be OK ###
412         $defs{$key} = $arg;
413
414     }
415
416     ### croak with the collected errors if there were errors and
417     ### we have the fatal flag toggled.
418     croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
419
420     ### done with our loop... if $wrong is set, something went wrong
421     ### and the user is already informed, just return...
422     return if $wrong;
423
424     ### check if we need to store any of the keys ###
425     ### can't do it before, because something may go wrong later,
426     ### leaving the user with a few set variables
427     for my $key (@want_store) {
428         next unless exists $defs{$key};
429         my $ref = $utmpl->{$key}{'store'};
430         $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
431     }
432
433     return \%defs;
434 }
435
436 =head2 allow( $test_me, \@criteria );
437
438 The function that handles the C<allow> key in the template is also
439 available for independent use.
440
441 The function takes as first argument a key to test against, and
442 as second argument any form of criteria that are also allowed by
443 the C<allow> key in the template.
444
445 You can use the following types of values for allow:
446
447 =over 4
448
449 =item string
450
451 The provided argument MUST be equal to the string for the validation
452 to pass.
453
454 =item regexp
455
456 The provided argument MUST match the regular expression for the
457 validation to pass.
458
459 =item subroutine
460
461 The provided subroutine MUST return true in order for the validation
462 to pass and the argument accepted.
463
464 (This is particularly useful for more complicated data).
465
466 =item array ref
467
468 The provided argument MUST equal one of the elements of the array
469 ref for the validation to pass. An array ref can hold all the above
470 values.
471
472 =back
473
474 It returns true if the key matched the criteria, or false otherwise.
475
476 =cut
477
478 sub allow {
479     ### use $_[0] and $_[1] since this is hot code... ###
480     #my ($val, $ref) = @_;
481
482     ### it's a regexp ###
483     if( ref $_[1] eq 'Regexp' ) {
484         local $^W;  # silence warnings if $val is undef #
485         return if $_[0] !~ /$_[1]/;
486
487     ### it's a sub ###
488     } elsif ( ref $_[1] eq 'CODE' ) {
489         return unless $_[1]->( $_[0] );
490
491     ### it's an array ###
492     } elsif ( ref $_[1] eq 'ARRAY' ) {
493
494         ### loop over the elements, see if one of them says the
495         ### value is OK
496         ### also, short-circuit when possible
497         for ( @{$_[1]} ) {
498             return 1 if allow( $_[0], $_ );
499         }
500
501         return;
502
503     ### fall back to a simple, but safe 'eq' ###
504     } else {
505         return unless _safe_eq( $_[0], $_[1] );
506     }
507
508     ### we got here, no failures ###
509     return 1;
510 }
511
512 ### helper functions ###
513
514 sub _safe_eq {
515     ### only do a straight 'eq' if they're both defined ###
516     return defined($_[0]) && defined($_[1])
517                 ? $_[0] eq $_[1]
518                 : defined($_[0]) eq defined($_[1]);
519 }
520
521 sub _who_was_it {
522     my $level = $_[0] || 0;
523
524     return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
525 }
526
527 =head2 last_error()
528
529 Returns a string containing all warnings and errors reported during
530 the last time C<check> was called.
531
532 This is useful if you want to report then some other way than
533 C<carp>'ing when the verbose flag is on.
534
535 It is exported upon request.
536
537 =cut
538
539 {   $_ERROR_STRING = '';
540
541     sub _store_error {
542         my($err, $verbose, $offset) = @_[0..2];
543         $verbose ||= 0;
544         $offset  ||= 0;
545         my $level   = 1 + $offset;
546
547         local $Carp::CarpLevel = $level;
548
549         carp $err if $verbose;
550
551         $_ERROR_STRING .= $err . "\n";
552     }
553
554     sub _clear_error {
555         $_ERROR_STRING = '';
556     }
557
558     sub last_error { $_ERROR_STRING }
559 }
560
561 1;
562
563 =head1 Global Variables
564
565 The behaviour of Params::Check can be altered by changing the
566 following global variables:
567
568 =head2 $Params::Check::VERBOSE
569
570 This controls whether Params::Check will issue warnings and
571 explanations as to why certain things may have failed.
572 If you set it to 0, Params::Check will not output any warnings.
573
574 The default is 1 when L<warnings> are enabled, 0 otherwise;
575
576 =head2 $Params::Check::STRICT_TYPE
577
578 This works like the C<strict_type> option you can pass to C<check>,
579 which will turn on C<strict_type> globally for all calls to C<check>.
580
581 The default is 0;
582
583 =head2 $Params::Check::ALLOW_UNKNOWN
584
585 If you set this flag, unknown options will still be present in the
586 return value, rather than filtered out. This is useful if your
587 subroutine is only interested in a few arguments, and wants to pass
588 the rest on blindly to perhaps another subroutine.
589
590 The default is 0;
591
592 =head2 $Params::Check::STRIP_LEADING_DASHES
593
594 If you set this flag, all keys passed in the following manner:
595
596     function( -key => 'val' );
597
598 will have their leading dashes stripped.
599
600 =head2 $Params::Check::NO_DUPLICATES
601
602 If set to true, all keys in the template that are marked as to be
603 stored in a scalar, will also be removed from the result set.
604
605 Default is false, meaning that when you use C<store> as a template
606 key, C<check> will put it both in the scalar you supplied, as well as
607 in the hashref it returns.
608
609 =head2 $Params::Check::PRESERVE_CASE
610
611 If set to true, L<Params::Check> will no longer convert all keys from
612 the user input to lowercase, but instead expect them to be in the
613 case the template provided. This is useful when you want to use
614 similar keys with different casing in your templates.
615
616 Understand that this removes the case-insensitivity feature of this
617 module.
618
619 Default is 0;
620
621 =head2 $Params::Check::ONLY_ALLOW_DEFINED
622
623 If set to true, L<Params::Check> will require all values passed to be
624 C<defined>. If you wish to enable this on a 'per key' basis, use the
625 template option C<defined> instead.
626
627 Default is 0;
628
629 =head2 $Params::Check::SANITY_CHECK_TEMPLATE
630
631 If set to true, L<Params::Check> will sanity check templates, validating
632 for errors and unknown keys. Although very useful for debugging, this
633 can be somewhat slow in hot-code and large loops.
634
635 To disable this check, set this variable to C<false>.
636
637 Default is 1;
638
639 =head2 $Params::Check::WARNINGS_FATAL
640
641 If set to true, L<Params::Check> will C<croak> when an error during
642 template validation occurs, rather than return C<false>.
643
644 Default is 0;
645
646 =head2 $Params::Check::CALLER_DEPTH
647
648 This global modifies the argument given to C<caller()> by
649 C<Params::Check::check()> and is useful if you have a custom wrapper
650 function around C<Params::Check::check()>. The value must be an
651 integer, indicating the number of wrapper functions inserted between
652 the real function call and C<Params::Check::check()>.
653
654 Example wrapper function, using a custom stacktrace:
655
656     sub check {
657         my ($template, $args_in) = @_;
658
659         local $Params::Check::WARNINGS_FATAL = 1;
660         local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
661         my $args_out = Params::Check::check($template, $args_in);
662
663         my_stacktrace(Params::Check::last_error) unless $args_out;
664
665         return $args_out;
666     }
667
668 Default is 0;
669
670 =head1 Acknowledgements
671
672 Thanks to Richard Soderberg for his performance improvements.
673
674 =head1 BUG REPORTS
675
676 Please report bugs or other issues to E<lt>bug-params-check@rt.cpan.orgE<gt>.
677
678 =head1 AUTHOR
679
680 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
681
682 =head1 COPYRIGHT
683
684 This library is free software; you may redistribute and/or modify it
685 under the same terms as Perl itself.
686
687
688 =cut
689
690 # Local variables:
691 # c-indentation-style: bsd
692 # c-basic-offset: 4
693 # indent-tabs-mode: nil
694 # End:
695 # vim: expandtab shiftwidth=4: