[Summary view] [Print] [Text view]

   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: