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: 711