1package Params::Check; 2 3use strict; 4 5use Carp qw[carp croak]; 6use Locale::Maketext::Simple Style => 'gettext'; 7 8BEGIN { 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.38'; 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 32my %known_keys = map { $_ => 1 } 33 qw| required allow default strict_type no_override 34 store defined |; 35 36=pod 37 38=head1 NAME 39 40Params::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 84Params::Check is a generic input parsing/checking mechanism. 85 86It allows you to validate input via a template. The only requirement 87is that the arguments must be named. 88 89Params::Check can do the following things for you: 90 91=over 4 92 93=item * 94 95Convert all keys to lowercase 96 97=item * 98 99Check if all required arguments have been provided 100 101=item * 102 103Set arguments that have not been provided to the default 104 105=item * 106 107Weed out arguments that are not supported and warn about them to the 108user 109 110=item * 111 112Validate the arguments given by the user based on strings, regexes, 113lists or even subroutines 114 115=item * 116 117Enforce type integrity if required 118 119=back 120 121Most of Params::Check's power comes from its template, which we'll 122discuss below: 123 124=head1 Template 125 126As you can see in the synopsis, based on your template, the arguments 127provided will be validated. 128 129The template can take a different set of rules per key that is used. 130 131The following rules are available: 132 133=over 4 134 135=item default 136 137This is the default value if none was provided by the user. 138This is also the type C<strict_type> will look at when checking type 139integrity (see below). 140 141=item required 142 143A boolean flag that indicates if this argument was a required 144argument. If marked as required and not provided, check() will fail. 145 146=item strict_type 147 148This does a C<ref()> check on the argument provided. The C<ref> of the 149argument must be the same as the C<ref> of the default value for this 150check to pass. 151 152This is very useful if you insist on taking an array reference as 153argument for example. 154 155=item defined 156 157If this template key is true, enforces that if this key is provided by 158user input, its value is C<defined>. This just means that the user is 159not allowed to pass C<undef> as a value for this key and is equivalent 160to: 161 allow => sub { defined $_[0] && OTHER TESTS } 162 163=item no_override 164 165This allows you to specify C<constants> in your template. ie, they 166keys that are not allowed to be altered by the user. It pretty much 167allows you to keep all your C<configurable> data in one place; the 168C<Params::Check> template. 169 170=item store 171 172This allows you to pass a reference to a scalar, in which the data 173will be stored: 174 175 my $x; 176 my $args = check(foo => { default => 1, store => \$x }, $input); 177 178This is basically shorthand for saying: 179 180 my $args = check( { foo => { default => 1 }, $input ); 181 my $x = $args->{foo}; 182 183You can alter the global variable $Params::Check::NO_DUPLICATES to 184control whether the C<store>'d key will still be present in your 185result set. See the L<Global Variables> section below. 186 187=item allow 188 189A set of criteria used to validate a particular piece of data if it 190has to adhere to particular rules. 191 192See the C<allow()> function for details. 193 194=back 195 196=head1 Functions 197 198=head2 check( \%tmpl, \%args, [$verbose] ); 199 200This function is not exported by default, so you'll have to ask for it 201via: 202 203 use Params::Check qw[check]; 204 205or use its fully qualified name instead. 206 207C<check> takes a list of arguments, as follows: 208 209=over 4 210 211=item Template 212 213This is a hash reference which contains a template as explained in the 214C<SYNOPSIS> and C<Template> section. 215 216=item Arguments 217 218This is a reference to a hash of named arguments which need checking. 219 220=item Verbose 221 222A boolean to indicate whether C<check> should be verbose and warn 223about what went wrong in a check or not. 224 225You can enable this program wide by setting the package variable 226C<$Params::Check::VERBOSE> to a true value. For details, see the 227section on C<Global Variables> below. 228 229=back 230 231C<check> will return when it fails, or a hashref with lowercase 232keys of parsed arguments when it succeeds. 233 234So 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 239A lot of the behaviour of C<check()> can be altered by setting 240package variables. See the section on C<Global Variables> for details 241on this. 242 243=cut 244 245sub 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 438The function that handles the C<allow> key in the template is also 439available for independent use. 440 441The function takes as first argument a key to test against, and 442as second argument any form of criteria that are also allowed by 443the C<allow> key in the template. 444 445You can use the following types of values for allow: 446 447=over 4 448 449=item string 450 451The provided argument MUST be equal to the string for the validation 452to pass. 453 454=item regexp 455 456The provided argument MUST match the regular expression for the 457validation to pass. 458 459=item subroutine 460 461The provided subroutine MUST return true in order for the validation 462to pass and the argument accepted. 463 464(This is particularly useful for more complicated data). 465 466=item array ref 467 468The provided argument MUST equal one of the elements of the array 469ref for the validation to pass. An array ref can hold all the above 470values. 471 472=back 473 474It returns true if the key matched the criteria, or false otherwise. 475 476=cut 477 478sub 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 514sub _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 521sub _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 529Returns a string containing all warnings and errors reported during 530the last time C<check> was called. 531 532This is useful if you want to report then some other way than 533C<carp>'ing when the verbose flag is on. 534 535It 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 5611; 562 563=head1 Global Variables 564 565The behaviour of Params::Check can be altered by changing the 566following global variables: 567 568=head2 $Params::Check::VERBOSE 569 570This controls whether Params::Check will issue warnings and 571explanations as to why certain things may have failed. 572If you set it to 0, Params::Check will not output any warnings. 573 574The default is 1 when L<warnings> are enabled, 0 otherwise; 575 576=head2 $Params::Check::STRICT_TYPE 577 578This works like the C<strict_type> option you can pass to C<check>, 579which will turn on C<strict_type> globally for all calls to C<check>. 580 581The default is 0; 582 583=head2 $Params::Check::ALLOW_UNKNOWN 584 585If you set this flag, unknown options will still be present in the 586return value, rather than filtered out. This is useful if your 587subroutine is only interested in a few arguments, and wants to pass 588the rest on blindly to perhaps another subroutine. 589 590The default is 0; 591 592=head2 $Params::Check::STRIP_LEADING_DASHES 593 594If you set this flag, all keys passed in the following manner: 595 596 function( -key => 'val' ); 597 598will have their leading dashes stripped. 599 600=head2 $Params::Check::NO_DUPLICATES 601 602If set to true, all keys in the template that are marked as to be 603stored in a scalar, will also be removed from the result set. 604 605Default is false, meaning that when you use C<store> as a template 606key, C<check> will put it both in the scalar you supplied, as well as 607in the hashref it returns. 608 609=head2 $Params::Check::PRESERVE_CASE 610 611If set to true, L<Params::Check> will no longer convert all keys from 612the user input to lowercase, but instead expect them to be in the 613case the template provided. This is useful when you want to use 614similar keys with different casing in your templates. 615 616Understand that this removes the case-insensitivity feature of this 617module. 618 619Default is 0; 620 621=head2 $Params::Check::ONLY_ALLOW_DEFINED 622 623If set to true, L<Params::Check> will require all values passed to be 624C<defined>. If you wish to enable this on a 'per key' basis, use the 625template option C<defined> instead. 626 627Default is 0; 628 629=head2 $Params::Check::SANITY_CHECK_TEMPLATE 630 631If set to true, L<Params::Check> will sanity check templates, validating 632for errors and unknown keys. Although very useful for debugging, this 633can be somewhat slow in hot-code and large loops. 634 635To disable this check, set this variable to C<false>. 636 637Default is 1; 638 639=head2 $Params::Check::WARNINGS_FATAL 640 641If set to true, L<Params::Check> will C<croak> when an error during 642template validation occurs, rather than return C<false>. 643 644Default is 0; 645 646=head2 $Params::Check::CALLER_DEPTH 647 648This global modifies the argument given to C<caller()> by 649C<Params::Check::check()> and is useful if you have a custom wrapper 650function around C<Params::Check::check()>. The value must be an 651integer, indicating the number of wrapper functions inserted between 652the real function call and C<Params::Check::check()>. 653 654Example 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 668Default is 0; 669 670=head1 Acknowledgements 671 672Thanks to Richard Soderberg for his performance improvements. 673 674=head1 BUG REPORTS 675 676Please report bugs or other issues to E<lt>bug-params-check@rt.cpan.orgE<gt>. 677 678=head1 AUTHOR 679 680This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. 681 682=head1 COPYRIGHT 683 684This library is free software; you may redistribute and/or modify it 685under 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: 696