Commit | Line | Data |
703d525d |
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: |