lib/Params/Check.pm

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