local-lib5/lib/perl5/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 $_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
  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 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
 380 The function that handles the C<allow> key in the template is also
 381 available for independent use.
 382
 383 The function takes as first argument a key to test against, and
 384 as second argument any form of criteria that are also allowed by
 385 the C<allow> key in the template.
 386
 387 You can use the following types of values for allow:
 388
 389 =over 4
 390
 391 =item string
 392
 393 The provided argument MUST be equal to the string for the validation
 394 to pass.
 395
 396 =item regexp
 397
 398 The provided argument MUST match the regular expression for the
 399 validation to pass.
 400
 401 =item subroutine
 402
 403 The provided subroutine MUST return true in order for the validation
 404 to pass and the argument accepted.
 405
 406 (This is particularly useful for more complicated data).
 407
 408 =item array ref
 409
 410 The provided argument MUST equal one of the elements of the array
 411 ref for the validation to pass. An array ref can hold all the above
 412 values.
 413
 414 =back
 415
 416 It returns true if the key matched the criteria, or false otherwise.
 417
 418 =cut
 419
 420 sub 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 ###
 457 sub _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
 476 sub _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
 530 sub _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
 537 sub _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
 545 Returns a string containing all warnings and errors reported during
 546 the last time C<check> was called.
 547
 548 This is useful if you want to report then some other way than
 549 C<carp>'ing when the verbose flag is on.
 550
 551 It 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
 577 1;
 578
 579 =head1 Global Variables
 580
 581 The behaviour of Params::Check can be altered by changing the
 582 following global variables:
 583
 584 =head2 $Params::Check::VERBOSE
 585
 586 This controls whether Params::Check will issue warnings and
 587 explanations as to why certain things may have failed.
 588 If you set it to 0, Params::Check will not output any warnings.
 589
 590 The default is 1 when L<warnings> are enabled, 0 otherwise;
 591
 592 =head2 $Params::Check::STRICT_TYPE
 593
 594 This works like the C<strict_type> option you can pass to C<check>,
 595 which will turn on C<strict_type> globally for all calls to C<check>.
 596
 597 The default is 0;
 598
 599 =head2 $Params::Check::ALLOW_UNKNOWN
 600
 601 If you set this flag, unknown options will still be present in the
 602 return value, rather than filtered out. This is useful if your
 603 subroutine is only interested in a few arguments, and wants to pass
 604 the rest on blindly to perhaps another subroutine.
 605
 606 The default is 0;
 607
 608 =head2 $Params::Check::STRIP_LEADING_DASHES
 609
 610 If you set this flag, all keys passed in the following manner:
 611
 612     function( -key => 'val' );
 613
 614 will have their leading dashes stripped.
 615
 616 =head2 $Params::Check::NO_DUPLICATES
 617
 618 If set to true, all keys in the template that are marked as to be
 619 stored in a scalar, will also be removed from the result set.
 620
 621 Default is false, meaning that when you use C<store> as a template
 622 key, C<check> will put it both in the scalar you supplied, as well as
 623 in the hashref it returns.
 624
 625 =head2 $Params::Check::PRESERVE_CASE
 626
 627 If set to true, L<Params::Check> will no longer convert all keys from
 628 the user input to lowercase, but instead expect them to be in the
 629 case the template provided. This is useful when you want to use
 630 similar keys with different casing in your templates.
 631
 632 Understand that this removes the case-insensitivy feature of this
 633 module.
 634
 635 Default is 0;
 636
 637 =head2 $Params::Check::ONLY_ALLOW_DEFINED
 638
 639 If set to true, L<Params::Check> will require all values passed to be
 640 C<defined>. If you wish to enable this on a 'per key' basis, use the
 641 template option C<defined> instead.
 642
 643 Default is 0;
 644
 645 =head2 $Params::Check::SANITY_CHECK_TEMPLATE
 646
 647 If set to true, L<Params::Check> will sanity check templates, validating
 648 for errors and unknown keys. Although very useful for debugging, this
 649 can be somewhat slow in hot-code and large loops.
 650
 651 To disable this check, set this variable to C<false>.
 652
 653 Default is 1;
 654
 655 =head2 $Params::Check::WARNINGS_FATAL
 656
 657 If set to true, L<Params::Check> will C<croak> when an error during
 658 template validation occurs, rather than return C<false>.
 659
 660 Default is 0;
 661
 662 =head2 $Params::Check::CALLER_DEPTH
 663
 664 This global modifies the argument given to C<caller()> by
 665 C<Params::Check::check()> and is useful if you have a custom wrapper
 666 function around C<Params::Check::check()>. The value must be an
 667 integer, indicating the number of wrapper functions inserted between
 668 the real function call and C<Params::Check::check()>.
 669
 670 Example 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
 684 Default is 0;
 685
 686 =head1 AUTHOR
 687
 688 This module by
 689 Jos Boumans E<lt>kane@cpan.orgE<gt>.
 690
 691 =head1 Acknowledgements
 692
 693 Thanks to Richard Soderberg for his performance improvements.
 694
 695 =head1 COPYRIGHT
 696
 697 This module is
 698 copyright (c) 2003,2004 Jos Boumans E<lt>kane@cpan.orgE<gt>.
 699 All rights reserved.
 700
 701 This library is free software;
 702 you may redistribute and/or modify it under the same
 703 terms 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: