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