File Coverage

blib/lib/Params/Check/Faster.pm

Criterion	Covered	Total	%
statement	155	168	92.2
branch	66	82	80.4
condition	35	51	68.6
subroutine	15	15	100.0
pod	3	3	100.0
total	274	319	85.8

line	stmt	bran	cond	sub	pod	time	code
1							package Params::Check::Faster;
2
3	1			1		35009	use 5.006; #warnings.pm
	1					3
	1					45
4	1			1		6	use strict;
	1					2
	1					41
5
6	1			1		6	use Carp qw[carp croak];
	1					15
	1					108
7	1			1		1062	use Locale::Maketext::Simple Style => 'gettext';
	1					2514
	1					12
8
9							BEGIN {
10	1			1		644	use Exporter ();
	1					2
	1					39
11	1					319	use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
12							$STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
13							$PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
14							$SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
15	1			1		6	];
	1					2
16
17	1			1		24	@ISA = qw[ Exporter ];
18	1					4	@EXPORT_OK = qw[check allow last_error];
19
20	1					3	$VERSION = '0.03';
21	1	50				7	$VERBOSE = $^W ? 1 : 0;
22	1					2	$NO_DUPLICATES = 0;
23	1					2	$STRIP_LEADING_DASHES = 0;
24	1					2	$STRICT_TYPE = 0;
25	1					2	$ALLOW_UNKNOWN = 0;
26	1					2	$PRESERVE_CASE = 0;
27	1					2	$ONLY_ALLOW_DEFINED = 0;
28	1					2	$SANITY_CHECK_TEMPLATE = 1;
29	1					10	$WARNINGS_FATAL = 0;
30	1					1521	$CALLER_DEPTH = 0;
31							}
32
33							my %known_keys = map { $_ => 1 }
34							qw\| required allow default strict_type no_override
35							store defined \|;
36
37							=pod
38
39							=head1 NAME
40
41							Params::Check::Faster - A generic input parsing/checking mechanism. Reimplementation of Params::Check.
42
43							=head1 SYNOPSIS
44
45							use Params::Check::Faster qw[check allow last_error];
46
47							sub fill_personal_info {
48							my %hash = @_;
49							my $x;
50
51							my $tmpl = {
52							firstname => { required => 1, defined => 1 },
53							lastname => { required => 1, store => \$x },
54							gender => { required => 1,
55							allow => [qr/M/i, qr/F/i],
56							},
57							married => { allow => [0,1] },
58							age => { default => 21,
59							allow => qr/^\d+$/,
60							},
61
62							phone => { allow => [ sub { return 1 if /$valid_re/ },
63							'1-800-PERL' ]
64							},
65							id_list => { default => [],
66							strict_type => 1
67							},
68							employer => { default => 'NSA', no_override => 1 },
69							};
70
71							### check() returns a hashref of parsed args on success ###
72							my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
73							or die qw[Could not parse arguments!];
74
75							... other code here ...
76							}
77
78							my $ok = allow( $colour, [qw\|blue green yellow\|] );
79
80							my $error = Params::Check::Faster::last_error();
81
82
83							=head1 DESCRIPTION
84
85							Params::Check::Faster is a generic input parsing/checking mechanism.
86
87							This module is a faster reimplementation of Params::Check. It should be 100%
88							compatible. It might be merged with Params::Check at some point, after its author (kane) has reviewed it and is happy with merging it.
89
90							It allows you to validate input via a template. The only requirement
91							is that the arguments must be named.
92
93							Params::Check::Faster can do the following things for you:
94
95							=over 4
96
97							=item *
98
99							Convert all keys to lowercase
100
101							=item *
102
103							Check if all required arguments have been provided
104
105							=item *
106
107							Set arguments that have not been provided to the default
108
109							=item *
110
111							Weed out arguments that are not supported and warn about them to the
112							user
113
114							=item *
115
116							Validate the arguments given by the user based on strings, regexes,
117							lists or even subroutines
118
119							=item *
120
121							Enforce type integrity if required
122
123							=back
124
125							Most of Params::Check::Faster's power comes from its template, which we'll
126							discuss below:
127
128							=head1 Template
129
130							As you can see in the synopsis, based on your template, the arguments
131							provided will be validated.
132
133							The template can take a different set of rules per key that is used.
134
135							The following rules are available:
136
137							=over 4
138
139							=item default
140
141							This is the default value if none was provided by the user.
142							This is also the type C will look at when checking type
143							integrity (see below).
144
145							=item required
146
147							A boolean flag that indicates if this argument was a required
148							argument. If marked as required and not provided, check() will fail.
149
150							=item strict_type
151
152							This does a C check on the argument provided. The C of the
153							argument must be the same as the C of the default value for this
154							check to pass.
155
156							This is very useful if you insist on taking an array reference as
157							argument for example.
158
159							=item defined
160
161							If this template key is true, enforces that if this key is provided by
162							user input, its value is C. This just means that the user is
163							not allowed to pass C as a value for this key and is equivalent
164							to:
165							allow => sub { defined $_[0] && OTHER TESTS }
166
167							=item no_override
168
169							This allows you to specify C in your template. ie, they
170							keys that are not allowed to be altered by the user. It pretty much
171							allows you to keep all your C data in one place; the
172							C template.
173
174							=item store
175
176							This allows you to pass a reference to a scalar, in which the data
177							will be stored:
178
179							my $x;
180							my $args = check(foo => { default => 1, store => \$x }, $input);
181
182							This is basically shorthand for saying:
183
184							my $args = check( { foo => { default => 1 } }, $input );
185							my $x = $args->{foo};
186
187							It works for arrays or hash reference too. You can write :
188
189							my @array;
190							my %hash;
191							my $args = check(foo => { default => [ 1 ], store => \@array },
192							bar => { default => { answer => 42 }, store => \%hash },
193							$input);
194
195							And @array and %hash contains directly the corresponding array or hash dereferenced.
196
197
198							You can alter the global variable $Params::Check::Faster::NO_DUPLICATES to
199							control whether the C'd key will still be present in your
200							result set. See the L section below.
201
202							=item allow
203
204							A set of criteria used to validate a particular piece of data if it
205							has to adhere to particular rules.
206
207							See the C function for details.
208
209							=back
210
211							=head1 Functions
212
213							=head2 check( \%tmpl, \%args, [$verbose] );
214
215							This function is not exported by default, so you'll have to ask for it
216							via:
217
218							use Params::Check::Faster qw[check];
219
220							or use its fully qualified name instead.
221
222							C takes a list of arguments, as follows:
223
224							=over 4
225
226							=item Template
227
228							This is a hashreference which contains a template as explained in the
229							C and C
230
231							=item Arguments
232
233							This is a reference to a hash of named arguments which need checking.
234
235							=item Verbose
236
237							A boolean to indicate whether C should be verbose and warn
238							about what went wrong in a check or not.
239
240							You can enable this program wide by setting the package variable
241							C<$Params::Check::Faster::VERBOSE> to a true value. For details, see the
242							section on C below.
243
244							=back
245
246							C will return when it fails, or a hashref with lowercase
247							keys of parsed arguments when it succeeds.
248
249							So a typical call to check would look like this:
250
251							my $parsed = check( \%template, \%arguments, $VERBOSE )
252							or warn q[Arguments could not be parsed!];
253
254							A lot of the behaviour of C can be altered by setting
255							package variables. See the section on C for details
256							on this.
257
258							=cut
259
260
261							sub check {
262							# for speed purpose we don't copy @_; check if we have anything to work on
263	38	50	33	38	1	28359	if (!$_[0] \|\| !$_[1]) {
264	0					0	return;
265							}
266
267	38					49	my %template = %{$_[0]};
	38					130
268	38					46	my %args = %{$_[1]};
	38					118
269	38		50			847	my $verbose = $_[2] \|\| $VERBOSE \|\| 0;
270
271							# clear current error
272	38					88	_clear_error();
273
274							# flag to see if we warned for anything, needed for warnings_fatal
275	38					36	my $warned;
276
277							# flag to see if anything went wrong
278							my $wrong;
279
280							# key to remove from the args, if unauthorised
281	38					48	my @keys_to_remove = ();
282
283							# keys to rename : [ old_key_name, new_key_name]
284	38					40	my @keys_to_rename = ();
285
286							# list of values to store into ref : [ $type, $ref, $value ]
287	38					40	my @to_store = ();
288
289							# list of keys to delete from args
290	38					69	my @to_delete = ();
291
292							# ARG_LOOP:
293							# loop on the arguments
294	38					135	while (my ($arg_key, $arg_value) = each %args) {
295
296							# handle key name
297	41	100	66			110	if (!$PRESERVE_CASE \|\| $STRIP_LEADING_DASHES) {
298	40					43	my $orig_arg_key = $arg_key;
299	40	50				105	$arg_key = lc($arg_key) unless $PRESERVE_CASE;
300	40	100				70	$arg_key =~ s/^-// if $STRIP_LEADING_DASHES;
301	40	100				96	if ($arg_key ne $orig_arg_key) {
302	3					9	push @keys_to_rename, [ $arg_key, $orig_arg_key ];
303							}
304							}
305
306							# the argument doesn't exist in the template
307	41	100				85	if ( !exists $template{$arg_key} ) {
308	3	100				19	if (!$ALLOW_UNKNOWN) {
309	2					7	_store_error(
310							loc(q(Key '%1' is not a valid key for %2 provided by %3),
311							$arg_key, _who_was_it(), _who_was_it(1)), $verbose);
312	2					4	$warned = 1;
313	2					5	push @keys_to_remove, $arg_key;
314							}
315	3					11	next;
316							};
317
318							# copy of this keys template instructions, to save derefs
319	38					34	my %arg_template = %{delete $template{$arg_key} };
	38					126
320
321	38	50				76	if ($SANITY_CHECK_TEMPLATE) {
322	38					72	foreach(grep { ! $known_keys{$_} } keys %arg_template) {
	48					159
323	0					0	_store_error(loc(q(Template type '%1' not supported [at key '%2']),
324							$_, $arg_key), $verbose)
325							}
326							}
327
328							# the argument cannot be overridden
329	38	100				79	if ($arg_template{no_override}) {
330	1					4	_store_error(
331							loc(q(You are not allowed to override key '%1' for %2 from %3),
332							$arg_key, _who_was_it(), _who_was_it(1)),
333							$verbose
334							);
335	1					2	$warned = 1;
336	1					2	push @keys_to_remove, $arg_key;
337	1					3	$template{$arg_key} = \%arg_template;
338	1					4	next;
339							}
340
341							# check if you were supposed to provide defined() values
342	37	100	66			153	if ( ($arg_template{defined} \|\| $ONLY_ALLOW_DEFINED) && !defined $arg_value ) {
			100
343	4					12	_store_error(loc(q(Key '%1' must be defined when passed), $arg_key),
344							$verbose );
345	4					7	$wrong = 1;
346	4					8	push @keys_to_remove, $arg_key;
347	4					9	$template{$arg_key} = \%arg_template;
348	4					17	next;
349							}
350
351							# check if they should be of a strict type, and if it is
352	33	100	66			127	if ( ($arg_template{strict_type} \|\| $STRICT_TYPE) && ref $arg_value ne ref $arg_template{default}) {
			100
353	2		50			14	_store_error(loc(q(Key '%1' needs to be of type '%2'),
354							$arg_key, ref($arg_template{default}) \|\| 'SCALAR'),
355							$verbose );
356	2					4	$wrong = 1;
357	2					4	push @keys_to_remove, $arg_key;
358	2					5	$template{$arg_key} = \%arg_template;
359	2					7	next;
360							}
361
362							# check if we have an allow handler, to validate against
363							# allow() will report its own errors
364	31	100	100			68	if (exists $arg_template{allow} && !do {
365	14					15	local $_ERROR_STRING;
366	14					33	allow($arg_value, $arg_template{allow})
367							}) {
368							# stringify the value in the error report -- we don't want dumps
369							# of objects, but we do want to see roughly what we passed
370	5					35	_store_error(loc(q(Key '%1' (%2) is of invalid type for '%3' provided by %4),
371							$arg_key, $arg_value, _who_was_it(),
372							_who_was_it(1)), $verbose);
373	5					7	$wrong = 1;
374	5					12	push @keys_to_remove, $arg_key;
375	5					15	$template{$arg_key} = \%arg_template;
376	5					24	next;
377							}
378
379							# check if we need to store the argument value to a provided ref
380	26	100				1794	if (my $ref = $arg_template{store}) {
381	6	50				17	if ( !_store_var($arg_key, $ref, $arg_value, $verbose, \@to_store, \@to_delete)) {
382	0					0	$wrong = 1;
383	0					0	next;
384							}
385							}
386							}
387
388
389							# if we needed to rename keys
390	38					122	foreach (@keys_to_rename) {
391	3					11	$args{$_->[0]} = delete $args{$_->[1]};
392							}
393
394							# if we needed to remove unknown keys, so that default applies
395	38	100				75	if (@keys_to_remove) {
396	14					31	delete @args{@keys_to_remove};
397							}
398
399							# now check if there is any key left in the template
400	38					105	while (my ($t_key, $t_value) = each %template) {
401
402							# check if required key is missing
403	20	100				49	if ($t_value->{required}) {
404	3					12	_store_error(
405							loc(q(Required option '%1' is not provided for %2 by %3),
406							$t_key, _who_was_it(), _who_was_it(1)), $verbose );
407	3					10	$wrong = 1;
408	3					14	next;
409							}
410
411							# set default argument omitted
412	17	100				48	if (exists $t_value->{default}) {
413	9					19	$args{$t_key} = $t_value->{default};
414							# check if we need to store the default value to a provided ref
415	9	50				23	if (my $ref = $t_value->{store}) {
416	0	0				0	if (!_store_var($t_key, $ref, $t_value->{default}, $verbose, \@to_store, \@to_delete)) {
417	0					0	$wrong = 1;
418	0					0	next;
419							}
420							}
421							}
422							# special case to be backward compatible
423	17	100	66			127	if ($SANITY_CHECK_TEMPLATE && exists $t_value->{store} && !ref $t_value->{store} ) {
			66
424	1					4	_store_error( loc(
425							q(Store variable for '%1' is not a reference!), $t_key
426							), $verbose);
427							}
428
429							}
430
431							# croak with the collected errors if there were errors and we have the
432							# fatal flag toggled.
433	38	100	100			160	if ( ($wrong \|\| $warned) && $WARNINGS_FATAL) {
			66
434	1					9	croak(__PACKAGE__->last_error());
435							}
436
437							# if $wrong is set, somethign went wrong and the user is already informed,
438							# just return...
439	37	100				112	return if $wrong;
440
441							# check if we need to store any of the keys. can't do it before, because
442							# something may go wrong later, leaving the user with a few set variables
443
444	24					72	foreach(@to_store) {
445	6					8	my ($type, $ref, $value) = @$_;
446	6	100				21	if ($type == 0) {
		100
		50
447	4					8	$$ref = $value;
448							}
449							elsif ($type == 1) {
450	1					1	@{$ref} = @{$value};
	1					5
	1					2
451							}
452							elsif ($type == 2) {
453	1					2	%{$ref} = %{$value};
	1					3
	1					2
454							}
455							}
456	24	100				42	$NO_DUPLICATES and delete @args{@to_delete};
457
458							# now, everything is fine, we can return the arguments
459	24					91	return(\%args);
460							}
461
462							sub _store_var {
463	6			6		15	my ($key, $ref, $value, $verbose, $to_store, $to_delete) = @_;
464
465	6	50	33			27	if ($SANITY_CHECK_TEMPLATE && !ref($ref)) {
466	0					0	_store_error( loc(
467							q(Store variable for '%1' is not a reference!), $key
468							), $verbose, 1 );
469	0					0	return; #error
470							}
471
472	6	100				21	if (ref($ref) eq 'ARRAY') {
		100
473	1	50				5	if (ref($value) ne 'ARRAY') {
474	0					0	_store_error(
475							loc(q(Key '%1' (value %2) is not a ARRAYREF. For %3 by %4),
476							$key, $value, _who_was_it(1), _who_was_it(2)), $verbose, 1);
477	0					0	return; # error
478							}
479							# push the refs/values to execute later
480	1					5	push @$to_store, [ 1, $ref, $value]; # 1 = array
481	1	50				3	$NO_DUPLICATES and push @$to_delete, $key;
482							}
483							elsif (ref($ref) eq 'HASH') {
484	1	50				4	if (ref($value) ne 'HASH') {
485	0					0	_store_error(
486							loc(q(Key '%1' (value %2) is not a HASHREF. For %3 by %4),
487							$key, $value, _who_was_it(1), _who_was_it(2)), $verbose, 1);
488	0					0	return; # error
489							}
490							# push the refs/values to execute later
491	1					2	push @$to_store, [ 2, $ref, $value]; # 2 = hash
492	1	50				3	$NO_DUPLICATES and push @$to_delete, $key;
493							}
494							else {
495							# push the refs/values to execute later
496	4					12	push @$to_store, [ 0, $ref, $value]; # 0 = scalar ref
497	4	100				10	$NO_DUPLICATES and push(@$to_delete, $key);
498							}
499
500	6					33	return 1; # success
501							}
502
503							=head2 allow( $test_me, \@criteria );
504
505							The function that handles the C key in the template is also
506							available for independent use.
507
508							The function takes as first argument a key to test against, and
509							as second argument any form of criteria that are also allowed by
510							the C key in the template.
511
512							You can use the following types of values for allow:
513
514							=over 4
515
516							=item string
517
518							The provided argument MUST be equal to the string for the validation
519							to pass.
520
521							=item regexp
522
523							The provided argument MUST match the regular expression for the
524							validation to pass.
525
526							=item subroutine
527
528							The provided subroutine MUST return true in order for the validation
529							to pass and the argument accepted.
530
531							(This is particularly useful for more complicated data).
532
533							=item array ref
534
535							The provided argument MUST equal one of the elements of the array
536							ref for the validation to pass. An array ref can hold all the above
537							values.
538
539							=back
540
541							It returns true if the key matched the criteria, or false otherwise.
542
543							=cut
544
545							sub allow {
546
547							# it's a regexp
548	40	100		40	1	2332	if (ref($_[1]) eq 'Regexp') {
549	1			1		9	no warnings;
	1					2
	1					449
550	4					42	return(scalar $_[0] =~ /$_[1]/); ## no critic (Regular expression)
551							}
552
553							# it's a sub
554	36	100				81	if (ref($_[1]) eq 'CODE') {
555	18					58	return $_[1]->($_[0]);
556							}
557
558							# it's an array
559	18	100				36	if (ref($_[1])eq 'ARRAY') {
560
561							# loop over the elements, see if one of them says the
562							# value is OK
563							# also, short-cicruit when possible
564	7					8	foreach (@{$_[1]}) {
	7					19
565	12	100				23	if (allow($_[0], $_)) {
566	5					21	return 1;
567							}
568							}
569	2					10	return;
570							}
571
572							# fall back to a simple, but safe 'eq'
573	11	50	33			77	return (defined $_[0] && defined $_[1]
574							? $_[0] eq $_[1]
575							: defined $_[0] eq defined $_[1]
576							);
577							}
578
579							# helper functions
580
581							sub _who_was_it {
582	22		100	22		70	my $level = $_[0] \|\| 0;
583
584	22		100			151	return (caller(2 + $CALLER_DEPTH + $level))[3] \|\| 'ANON'
585							}
586
587							=head2 last_error()
588
589							Returns a string containing all warnings and errors reported during
590							the last time C was called.
591
592							This is useful if you want to report then some other way than
593							C'ing when the verbose flag is on.
594
595							It is exported upon request.
596
597							=cut
598
599							{ $_ERROR_STRING = '';
600
601							sub _store_error {
602	18			18		453	my($err, $verbose, $offset) = @_[0..2];
603	18		50			66	$verbose \|\|= 0;
604	18		50			58	$offset \|\|= 0;
605	18					24	my $level = 1 + $offset;
606
607	18					27	local $Carp::CarpLevel = $level;
608
609	18	50				37	carp $err if $verbose;
610
611	18					46	$_ERROR_STRING .= $err . "\n";
612							}
613
614							sub _clear_error {
615	38			38		66	$_ERROR_STRING = '';
616							}
617
618	17			17	1	5795	sub last_error { $_ERROR_STRING }
619							}
620
621							1;
622
623							=head1 Global Variables
624
625							The behaviour of Params::Check::Faster can be altered by changing the
626							following global variables:
627
628							=head2 $Params::Check::Faster::VERBOSE
629
630							This controls whether Params::Check::Faster will issue warnings and
631							explanations as to why certain things may have failed.
632							If you set it to 0, Params::Check::Faster will not output any warnings.
633
634							The default is 1 when L are enabled, 0 otherwise;
635
636							=head2 $Params::Check::Faster::STRICT_TYPE
637
638							This works like the C option you can pass to C,
639							which will turn on C globally for all calls to C.
640
641							The default is 0;
642
643							=head2 $Params::Check::Faster::ALLOW_UNKNOWN
644
645							If you set this flag, unknown options will still be present in the
646							return value, rather than filtered out. This is useful if your
647							subroutine is only interested in a few arguments, and wants to pass
648							the rest on blindly to perhaps another subroutine.
649
650							The default is 0;
651
652							=head2 $Params::Check::Faster::STRIP_LEADING_DASHES
653
654							If you set this flag, all keys passed in the following manner:
655
656							function( -key => 'val' );
657
658							will have their leading dashes stripped.
659
660							=head2 $Params::Check::Faster::NO_DUPLICATES
661
662							If set to true, all keys in the template that are marked as to be
663							stored in a scalar, will also be removed from the result set.
664
665							Default is false, meaning that when you use C as a template
666							key, C will put it both in the scalar you supplied, as well as
667							in the hashref it returns.
668
669							=head2 $Params::Check::Faster::PRESERVE_CASE
670
671							If set to true, L will no longer convert all keys from
672							the user input to lowercase, but instead expect them to be in the
673							case the template provided. This is useful when you want to use
674							similar keys with different casing in your templates.
675
676							Understand that this removes the case-insensitivy feature of this
677							module.
678
679							Default is 0;
680
681							=head2 $Params::Check::Faster::ONLY_ALLOW_DEFINED
682
683							If set to true, L will require all values passed to be
684							C. If you wish to enable this on a 'per key' basis, use the
685							template option C instead.
686
687							Default is 0;
688
689							=head2 $Params::Check::Faster::SANITY_CHECK_TEMPLATE
690
691							If set to true, L will sanity check templates, validating
692							for errors and unknown keys. Although very useful for debugging, this
693							can be somewhat slow in hot-code and large loops.
694
695							To disable this check, set this variable to C.
696
697							Default is 1;
698
699							=head2 $Params::Check::Faster::WARNINGS_FATAL
700
701							If set to true, L will C when an error during
702							template validation occurs, rather than return C.
703
704							Default is 0;
705
706							=head2 $Params::Check::Faster::CALLER_DEPTH
707
708							This global modifies the argument given to C by
709							C and is useful if you have a custom wrapper
710							function around C. The value must be an
711							integer, indicating the number of wrapper functions inserted between
712							the real function call and C.
713
714							Example wrapper function, using a custom stacktrace:
715
716							sub check {
717							my ($template, $args_in) = @_;
718
719							local $Params::Check::Faster::WARNINGS_FATAL = 1;
720							local $Params::Check::Faster::CALLER_DEPTH = $Params::Check::Faster::CALLER_DEPTH + 1;
721							my $args_out = Params::Check::Faster::check($template, $args_in);
722
723							my_stacktrace(Params::Check::Faster::last_error) unless $args_out;
724
725							return $args_out;
726							}
727
728							Default is 0;
729
730							=head1 AUTHOR
731
732							This module by
733							Damien "dams" Krotkine Edams@cpan.orgE.
734
735							=head1 COPYRIGHT
736
737							This module is
738							copyright (c) 2007 Damien "dams" Krotkine Edams@cpan.orgE.
739							All rights reserved.
740
741							This library is free software;
742							you may redistribute and/or modify it under the same
743							terms as Perl itself.
744
745							=cut
746
747							# Local variables:
748							# c-indentation-style: bsd
749							# c-basic-offset: 4
750							# indent-tabs-mode: nil
751							# End:
752							# vim: expandtab shiftwidth=4: