This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Params::Check to the core
[perl5.git] / lib / Params / Check.pm
CommitLineData
703d525d
JB
1package Params::Check;
2
3use strict;
4
5use Carp qw[carp croak];
6use Locale::Maketext::Simple Style => 'gettext';
7
8use Data::Dumper;
9
10BEGIN {
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
34my %known_keys = map { $_ => 1 }
35 qw| required allow default strict_type no_override
36 store defined |;
37
38=pod
39
40=head1 NAME
41
42Params::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
86Params::Check is a generic input parsing/checking mechanism.
87
88It allows you to validate input via a template. The only requirement
89is that the arguments must be named.
90
91Params::Check can do the following things for you:
92
93=over 4
94
95=item *
96
97Convert all keys to lowercase
98
99=item *
100
101Check if all required arguments have been provided
102
103=item *
104
105Set arguments that have not been provided to the default
106
107=item *
108
109Weed out arguments that are not supported and warn about them to the
110user
111
112=item *
113
114Validate the arguments given by the user based on strings, regexes,
115lists or even subroutines
116
117=item *
118
119Enforce type integrity if required
120
121=back
122
123Most of Params::Check's power comes from its template, which we'll
124discuss below:
125
126=head1 Template
127
128As you can see in the synopsis, based on your template, the arguments
129provided will be validated.
130
131The template can take a different set of rules per key that is used.
132
133The following rules are available:
134
135=over 4
136
137=item default
138
139This is the default value if none was provided by the user.
140This is also the type C<strict_type> will look at when checking type
141integrity (see below).
142
143=item required
144
145A boolean flag that indicates if this argument was a required
146argument. If marked as required and not provided, check() will fail.
147
148=item strict_type
149
150This does a C<ref()> check on the argument provided. The C<ref> of the
151argument must be the same as the C<ref> of the default value for this
152check to pass.
153
154This is very useful if you insist on taking an array reference as
155argument for example.
156
157=item defined
158
159If this template key is true, enforces that if this key is provided by
160user input, its value is C<defined>. This just means that the user is
161not allowed to pass C<undef> as a value for this key and is equivalent
162to:
163 allow => sub { defined $_[0] && OTHER TESTS }
164
165=item no_override
166
167This allows you to specify C<constants> in your template. ie, they
168keys that are not allowed to be altered by the user. It pretty much
169allows you to keep all your C<configurable> data in one place; the
170C<Params::Check> template.
171
172=item store
173
174This allows you to pass a reference to a scalar, in which the data
175will be stored:
176
177 my $x;
178 my $args = check(foo => { default => 1, store => \$x }, $input);
179
180This is basically shorthand for saying:
181
182 my $args = check( { foo => { default => 1 }, $input );
183 my $x = $args->{foo};
184
185You can alter the global variable $Params::Check::NO_DUPLICATES to
186control whether the C<store>'d key will still be present in your
187result set. See the L<Global Variables> section below.
188
189=item allow
190
191A set of criteria used to validate a particular piece of data if it
192has to adhere to particular rules.
193
194See the C<allow()> function for details.
195
196=back
197
198=head1 Functions
199
200=head2 check( \%tmpl, \%args, [$verbose] );
201
202This function is not exported by default, so you'll have to ask for it
203via:
204
205 use Params::Check qw[check];
206
207or use its fully qualified name instead.
208
209C<check> takes a list of arguments, as follows:
210
211=over 4
212
213=item Template
214
215This is a hashreference which contains a template as explained in the
216C<SYNOPSIS> and C<Template> section.
217
218=item Arguments
219
220This is a reference to a hash of named arguments which need checking.
221
222=item Verbose
223
224A boolean to indicate whether C<check> should be verbose and warn
225about what went wrong in a check or not.
226
227You can enable this program wide by setting the package variable
228C<$Params::Check::VERBOSE> to a true value. For details, see the
229section on C<Global Variables> below.
230
231=back
232
233C<check> will return when it fails, or a hashref with lowercase
234keys of parsed arguments when it succeeds.
235
236So 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
241A lot of the behaviour of C<check()> can be altered by setting
242package variables. See the section on C<Global Variables> for details
243on this.
244
245=cut
246
247sub 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
378The function that handles the C<allow> key in the template is also
379available for independent use.
380
381The function takes as first argument a key to test against, and
382as second argument any form of criteria that are also allowed by
383the C<allow> key in the template.
384
385You can use the following types of values for allow:
386
387=over 4
388
389=item string
390
391The provided argument MUST be equal to the string for the validation
392to pass.
393
394=item regexp
395
396The provided argument MUST match the regular expression for the
397validation to pass.
398
399=item subroutine
400
401The provided subroutine MUST return true in order for the validation
402to pass and the argument accepted.
403
404(This is particularly useful for more complicated data).
405
406=item array ref
407
408The provided argument MUST equal one of the elements of the array
409ref for the validation to pass. An array ref can hold all the above
410values.
411
412=back
413
414It returns true if the key matched the criteria, or false otherwise.
415
416=cut
417
418sub 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 ###
455sub _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
474sub _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
528sub _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
535sub _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
543Returns a string containing all warnings and errors reported during
544the last time C<check> was called.
545
546This is useful if you want to report then some other way than
547C<carp>'ing when the verbose flag is on.
548
549It 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
5751;
576
577=head1 Global Variables
578
579The behaviour of Params::Check can be altered by changing the
580following global variables:
581
582=head2 $Params::Check::VERBOSE
583
584This controls whether Params::Check will issue warnings and
585explanations as to why certain things may have failed.
586If you set it to 0, Params::Check will not output any warnings.
587
588The default is 1 when L<warnings> are enabled, 0 otherwise;
589
590=head2 $Params::Check::STRICT_TYPE
591
592This works like the C<strict_type> option you can pass to C<check>,
593which will turn on C<strict_type> globally for all calls to C<check>.
594
595The default is 0;
596
597=head2 $Params::Check::ALLOW_UNKNOWN
598
599If you set this flag, unknown options will still be present in the
600return value, rather than filtered out. This is useful if your
601subroutine is only interested in a few arguments, and wants to pass
602the rest on blindly to perhaps another subroutine.
603
604The default is 0;
605
606=head2 $Params::Check::STRIP_LEADING_DASHES
607
608If you set this flag, all keys passed in the following manner:
609
610 function( -key => 'val' );
611
612will have their leading dashes stripped.
613
614=head2 $Params::Check::NO_DUPLICATES
615
616If set to true, all keys in the template that are marked as to be
617stored in a scalar, will also be removed from the result set.
618
619Default is false, meaning that when you use C<store> as a template
620key, C<check> will put it both in the scalar you supplied, as well as
621in the hashref it returns.
622
623=head2 $Params::Check::PRESERVE_CASE
624
625If set to true, L<Params::Check> will no longer convert all keys from
626the user input to lowercase, but instead expect them to be in the
627case the template provided. This is useful when you want to use
628similar keys with different casing in your templates.
629
630Understand that this removes the case-insensitivy feature of this
631module.
632
633Default is 0;
634
635=head2 $Params::Check::ONLY_ALLOW_DEFINED
636
637If set to true, L<Params::Check> will require all values passed to be
638C<defined>. If you wish to enable this on a 'per key' basis, use the
639template option C<defined> instead.
640
641Default is 0;
642
643=head2 $Params::Check::SANITY_CHECK_TEMPLATE
644
645If set to true, L<Params::Check> will sanity check templates, validating
646for errors and unknown keys. Although very useful for debugging, this
647can be somewhat slow in hot-code and large loops.
648
649To disable this check, set this variable to C<false>.
650
651Default is 1;
652
653=head2 $Params::Check::WARNINGS_FATAL
654
655If set to true, L<Params::Check> will C<croak> when an error during
656template validation occurs, rather than return C<false>.
657
658Default is 0;
659
660=head2 $Params::Check::CALLER_DEPTH
661
662This global modifies the argument given to C<caller()> by
663C<Params::Check::check()> and is useful if you have a custom wrapper
664function around C<Params::Check::check()>. The value must be an
665integer, indicating the number of wrapper functions inserted between
666the real function call and C<Params::Check::check()>.
667
668Example 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
682Default is 0;
683
684=head1 AUTHOR
685
686This module by
687Jos Boumans E<lt>kane@cpan.orgE<gt>.
688
689=head1 Acknowledgements
690
691Thanks to Richard Soderberg for his performance improvements.
692
693=head1 COPYRIGHT
694
695This module is
696copyright (c) 2003,2004 Jos Boumans E<lt>kane@cpan.orgE<gt>.
697All rights reserved.
698
699This library is free software;
700you may redistribute and/or modify it under the same
701terms 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: