--- /dev/null
+package Params::Check;
+
+use strict;
+
+use Carp qw[carp croak];
+use Locale::Maketext::Simple Style => 'gettext';
+
+use Data::Dumper;
+
+BEGIN {
+ use Exporter ();
+ use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
+ $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
+ $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
+ $SANITY_CHECK_TEMPLATE $CALLER_DEPTH
+ ];
+
+ @ISA = qw[ Exporter ];
+ @EXPORT_OK = qw[check allow last_error];
+
+ $VERSION = '0.25';
+ $VERBOSE = $^W ? 1 : 0;
+ $NO_DUPLICATES = 0;
+ $STRIP_LEADING_DASHES = 0;
+ $STRICT_TYPE = 0;
+ $ALLOW_UNKNOWN = 0;
+ $PRESERVE_CASE = 0;
+ $ONLY_ALLOW_DEFINED = 0;
+ $SANITY_CHECK_TEMPLATE = 1;
+ $WARNINGS_FATAL = 0;
+ $CALLER_DEPTH = 0;
+}
+
+my %known_keys = map { $_ => 1 }
+ qw| required allow default strict_type no_override
+ store defined |;
+
+=pod
+
+=head1 NAME
+
+Params::Check - A generic input parsing/checking mechanism.
+
+=head1 SYNOPSIS
+
+ use Params::Check qw[check allow last_error];
+
+ sub fill_personal_info {
+ my %hash = @_;
+ my $x;
+
+ my $tmpl = {
+ firstname => { required => 1, defined => 1 },
+ lastname => { required => 1, store => \$x },
+ gender => { required => 1,
+ allow => [qr/M/i, qr/F/i],
+ },
+ married => { allow => [0,1] },
+ age => { default => 21,
+ allow => qr/^\d+$/,
+ },
+
+ phone => { allow => [ sub { return 1 if /$valid_re/ },
+ '1-800-PERL' ]
+ },
+ id_list => { default => [],
+ strict_type => 1
+ },
+ employer => { default => 'NSA', no_override => 1 },
+ };
+
+ ### check() returns a hashref of parsed args on success ###
+ my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
+ or die qw[Could not parse arguments!];
+
+ ... other code here ...
+ }
+
+ my $ok = allow( $colour, [qw|blue green yellow|] );
+
+ my $error = Params::Check::last_error();
+
+
+=head1 DESCRIPTION
+
+Params::Check is a generic input parsing/checking mechanism.
+
+It allows you to validate input via a template. The only requirement
+is that the arguments must be named.
+
+Params::Check can do the following things for you:
+
+=over 4
+
+=item *
+
+Convert all keys to lowercase
+
+=item *
+
+Check if all required arguments have been provided
+
+=item *
+
+Set arguments that have not been provided to the default
+
+=item *
+
+Weed out arguments that are not supported and warn about them to the
+user
+
+=item *
+
+Validate the arguments given by the user based on strings, regexes,
+lists or even subroutines
+
+=item *
+
+Enforce type integrity if required
+
+=back
+
+Most of Params::Check's power comes from its template, which we'll
+discuss below:
+
+=head1 Template
+
+As you can see in the synopsis, based on your template, the arguments
+provided will be validated.
+
+The template can take a different set of rules per key that is used.
+
+The following rules are available:
+
+=over 4
+
+=item default
+
+This is the default value if none was provided by the user.
+This is also the type C<strict_type> will look at when checking type
+integrity (see below).
+
+=item required
+
+A boolean flag that indicates if this argument was a required
+argument. If marked as required and not provided, check() will fail.
+
+=item strict_type
+
+This does a C<ref()> check on the argument provided. The C<ref> of the
+argument must be the same as the C<ref> of the default value for this
+check to pass.
+
+This is very useful if you insist on taking an array reference as
+argument for example.
+
+=item defined
+
+If this template key is true, enforces that if this key is provided by
+user input, its value is C<defined>. This just means that the user is
+not allowed to pass C<undef> as a value for this key and is equivalent
+to:
+ allow => sub { defined $_[0] && OTHER TESTS }
+
+=item no_override
+
+This allows you to specify C<constants> in your template. ie, they
+keys that are not allowed to be altered by the user. It pretty much
+allows you to keep all your C<configurable> data in one place; the
+C<Params::Check> template.
+
+=item store
+
+This allows you to pass a reference to a scalar, in which the data
+will be stored:
+
+ my $x;
+ my $args = check(foo => { default => 1, store => \$x }, $input);
+
+This is basically shorthand for saying:
+
+ my $args = check( { foo => { default => 1 }, $input );
+ my $x = $args->{foo};
+
+You can alter the global variable $Params::Check::NO_DUPLICATES to
+control whether the C<store>'d key will still be present in your
+result set. See the L<Global Variables> section below.
+
+=item allow
+
+A set of criteria used to validate a particular piece of data if it
+has to adhere to particular rules.
+
+See the C<allow()> function for details.
+
+=back
+
+=head1 Functions
+
+=head2 check( \%tmpl, \%args, [$verbose] );
+
+This function is not exported by default, so you'll have to ask for it
+via:
+
+ use Params::Check qw[check];
+
+or use its fully qualified name instead.
+
+C<check> takes a list of arguments, as follows:
+
+=over 4
+
+=item Template
+
+This is a hashreference which contains a template as explained in the
+C<SYNOPSIS> and C<Template> section.
+
+=item Arguments
+
+This is a reference to a hash of named arguments which need checking.
+
+=item Verbose
+
+A boolean to indicate whether C<check> should be verbose and warn
+about what went wrong in a check or not.
+
+You can enable this program wide by setting the package variable
+C<$Params::Check::VERBOSE> to a true value. For details, see the
+section on C<Global Variables> below.
+
+=back
+
+C<check> will return when it fails, or a hashref with lowercase
+keys of parsed arguments when it succeeds.
+
+So a typical call to check would look like this:
+
+ my $parsed = check( \%template, \%arguments, $VERBOSE )
+ or warn q[Arguments could not be parsed!];
+
+A lot of the behaviour of C<check()> can be altered by setting
+package variables. See the section on C<Global Variables> for details
+on this.
+
+=cut
+
+sub check {
+ my ($utmpl, $href, $verbose) = @_;
+
+ ### did we get the arguments we need? ###
+ return if !$utmpl or !$href;
+
+ ### sensible defaults ###
+ $verbose ||= $VERBOSE || 0;
+
+ ### clear the current error string ###
+ _clear_error();
+
+ ### XXX what type of template is it? ###
+ ### { key => { } } ?
+ #if (ref $args eq 'HASH') {
+ # 1;
+ #}
+
+ ### clean up the template ###
+ my $args = _clean_up_args( $href ) or return;
+
+ ### sanity check + defaults + required keys set? ###
+ my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
+ or return;
+
+ ### deref only once ###
+ my %utmpl = %$utmpl;
+ my %args = %$args;
+ my %defs = %$defs;
+
+ ### flag to see if anything went wrong ###
+ my $wrong;
+
+ ### flag to see if we warned for anything, needed for warnings_fatal
+ my $warned;
+
+ for my $key (keys %args) {
+
+ ### you gave us this key, but it's not in the template ###
+ unless( $utmpl{$key} ) {
+
+ ### but we'll allow it anyway ###
+ if( $ALLOW_UNKNOWN ) {
+ $defs{$key} = $args{$key};
+
+ ### warn about the error ###
+ } else {
+ _store_error(
+ loc("Key '%1' is not a valid key for %2 provided by %3",
+ $key, _who_was_it(), _who_was_it(1)), $verbose);
+ $warned ||= 1;
+ }
+ next;
+ }
+
+ ### check if you're even allowed to override this key ###
+ if( $utmpl{$key}->{'no_override'} ) {
+ _store_error(
+ loc(q[You are not allowed to override key '%1'].
+ q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
+ $verbose
+ );
+ $warned ||= 1;
+ next;
+ }
+
+ ### copy of this keys template instructions, to save derefs ###
+ my %tmpl = %{$utmpl{$key}};
+
+ ### check if you were supposed to provide defined() values ###
+ if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and
+ not defined $args{$key}
+ ) {
+ _store_error(loc(q|Key '%1' must be defined when passed|, $key),
+ $verbose );
+ $wrong ||= 1;
+ next;
+ }
+
+ ### check if they should be of a strict type, and if it is ###
+ if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
+ (ref $args{$key} ne ref $tmpl{'default'})
+ ) {
+ _store_error(loc(q|Key '%1' needs to be of type '%2'|,
+ $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
+ $wrong ||= 1;
+ next;
+ }
+
+ ### check if we have an allow handler, to validate against ###
+ ### allow() will report its own errors ###
+ if( exists $tmpl{'allow'} and
+ not allow($args{$key}, $tmpl{'allow'})
+ ) {
+ ### stringify the value in the error report -- we don't want dumps
+ ### of objects, but we do want to see *roughly* what we passed
+ _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
+ q|provided by %4|,
+ $key, "$args{$key}", _who_was_it(),
+ _who_was_it(1)), $verbose);
+ $wrong ||= 1;
+ next;
+ }
+
+ ### we got here, then all must be OK ###
+ $defs{$key} = $args{$key};
+
+ }
+
+ ### croak with the collected errors if there were errors and
+ ### we have the fatal flag toggled.
+ croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
+
+ ### done with our loop... if $wrong is set, somethign went wrong
+ ### and the user is already informed, just return...
+ return if $wrong;
+
+ ### check if we need to store any of the keys ###
+ ### can't do it before, because something may go wrong later,
+ ### leaving the user with a few set variables
+ for my $key (keys %defs) {
+ if( my $ref = $utmpl{$key}->{'store'} ) {
+ $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
+ }
+ }
+
+ return \%defs;
+}
+
+=head2 allow( $test_me, \@criteria );
+
+The function that handles the C<allow> key in the template is also
+available for independent use.
+
+The function takes as first argument a key to test against, and
+as second argument any form of criteria that are also allowed by
+the C<allow> key in the template.
+
+You can use the following types of values for allow:
+
+=over 4
+
+=item string
+
+The provided argument MUST be equal to the string for the validation
+to pass.
+
+=item regexp
+
+The provided argument MUST match the regular expression for the
+validation to pass.
+
+=item subroutine
+
+The provided subroutine MUST return true in order for the validation
+to pass and the argument accepted.
+
+(This is particularly useful for more complicated data).
+
+=item array ref
+
+The provided argument MUST equal one of the elements of the array
+ref for the validation to pass. An array ref can hold all the above
+values.
+
+=back
+
+It returns true if the key matched the criteria, or false otherwise.
+
+=cut
+
+sub allow {
+ ### use $_[0] and $_[1] since this is hot code... ###
+ #my ($val, $ref) = @_;
+
+ ### it's a regexp ###
+ if( ref $_[1] eq 'Regexp' ) {
+ local $^W; # silence warnings if $val is undef #
+ return if $_[0] !~ /$_[1]/;
+
+ ### it's a sub ###
+ } elsif ( ref $_[1] eq 'CODE' ) {
+ return unless $_[1]->( $_[0] );
+
+ ### it's an array ###
+ } elsif ( ref $_[1] eq 'ARRAY' ) {
+
+ ### loop over the elements, see if one of them says the
+ ### value is OK
+ ### also, short-cicruit when possible
+ for ( @{$_[1]} ) {
+ return 1 if allow( $_[0], $_ );
+ }
+
+ return;
+
+ ### fall back to a simple, but safe 'eq' ###
+ } else {
+ return unless _safe_eq( $_[0], $_[1] );
+ }
+
+ ### we got here, no failures ###
+ return 1;
+}
+
+### helper functions ###
+
+### clean up the template ###
+sub _clean_up_args {
+ ### don't even bother to loop, if there's nothing to clean up ###
+ return $_[0] if $PRESERVE_CASE and !$STRIP_LEADING_DASHES;
+
+ my %args = %{$_[0]};
+
+ ### keys are note aliased ###
+ for my $key (keys %args) {
+ my $org = $key;
+ $key = lc $key unless $PRESERVE_CASE;
+ $key =~ s/^-// if $STRIP_LEADING_DASHES;
+ $args{$key} = delete $args{$org} if $key ne $org;
+ }
+
+ ### return references so we always return 'true', even on empty
+ ### arguments
+ return \%args;
+}
+
+sub _sanity_check_and_defaults {
+ my %utmpl = %{$_[0]};
+ my %args = %{$_[1]};
+ my $verbose = $_[2];
+
+ my %defs; my $fail;
+ for my $key (keys %utmpl) {
+
+ ### check if required keys are provided
+ ### keys are now lower cased, unless preserve case was enabled
+ ### at which point, the utmpl keys must match, but that's the users
+ ### problem.
+ if( $utmpl{$key}->{'required'} and not exists $args{$key} ) {
+ _store_error(
+ loc(q|Required option '%1' is not provided for %2 by %3|,
+ $key, _who_was_it(1), _who_was_it(2)), $verbose );
+
+ ### mark the error ###
+ $fail++;
+ next;
+ }
+
+ ### next, set the default, make sure the key exists in %defs ###
+ $defs{$key} = $utmpl{$key}->{'default'}
+ if exists $utmpl{$key}->{'default'};
+
+ if( $SANITY_CHECK_TEMPLATE ) {
+ ### last, check if they provided any weird template keys
+ ### -- do this last so we don't always execute this code.
+ ### just a small optimization.
+ map { _store_error(
+ loc(q|Template type '%1' not supported [at key '%2']|,
+ $_, $key), 1, 1 );
+ } grep {
+ not $known_keys{$_}
+ } keys %{$utmpl{$key}};
+
+ ### make sure you passed a ref, otherwise, complain about it!
+ if ( exists $utmpl{$key}->{'store'} ) {
+ _store_error( loc(
+ q|Store variable for '%1' is not a reference!|, $key
+ ), 1, 1 ) unless ref $utmpl{$key}->{'store'};
+ }
+ }
+ }
+
+ ### errors found ###
+ return if $fail;
+
+ ### return references so we always return 'true', even on empty
+ ### defaults
+ return \%defs;
+}
+
+sub _safe_eq {
+ ### only do a straight 'eq' if they're both defined ###
+ return defined($_[0]) && defined($_[1])
+ ? $_[0] eq $_[1]
+ : defined($_[0]) eq defined($_[1]);
+}
+
+sub _who_was_it {
+ my $level = $_[0] || 0;
+
+ return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
+}
+
+=head2 last_error()
+
+Returns a string containing all warnings and errors reported during
+the last time C<check> was called.
+
+This is useful if you want to report then some other way than
+C<carp>'ing when the verbose flag is on.
+
+It is exported upon request.
+
+=cut
+
+{ my $ErrorString = '';
+
+ sub _store_error {
+ my($err, $verbose, $offset) = @_[0..2];
+ $verbose ||= 0;
+ $offset ||= 0;
+ my $level = 1 + $offset;
+
+ local $Carp::CarpLevel = $level;
+
+ carp $err if $verbose;
+
+ $ErrorString .= $err . "\n";
+ }
+
+ sub _clear_error {
+ $ErrorString = '';
+ }
+
+ sub last_error { $ErrorString }
+}
+
+1;
+
+=head1 Global Variables
+
+The behaviour of Params::Check can be altered by changing the
+following global variables:
+
+=head2 $Params::Check::VERBOSE
+
+This controls whether Params::Check will issue warnings and
+explanations as to why certain things may have failed.
+If you set it to 0, Params::Check will not output any warnings.
+
+The default is 1 when L<warnings> are enabled, 0 otherwise;
+
+=head2 $Params::Check::STRICT_TYPE
+
+This works like the C<strict_type> option you can pass to C<check>,
+which will turn on C<strict_type> globally for all calls to C<check>.
+
+The default is 0;
+
+=head2 $Params::Check::ALLOW_UNKNOWN
+
+If you set this flag, unknown options will still be present in the
+return value, rather than filtered out. This is useful if your
+subroutine is only interested in a few arguments, and wants to pass
+the rest on blindly to perhaps another subroutine.
+
+The default is 0;
+
+=head2 $Params::Check::STRIP_LEADING_DASHES
+
+If you set this flag, all keys passed in the following manner:
+
+ function( -key => 'val' );
+
+will have their leading dashes stripped.
+
+=head2 $Params::Check::NO_DUPLICATES
+
+If set to true, all keys in the template that are marked as to be
+stored in a scalar, will also be removed from the result set.
+
+Default is false, meaning that when you use C<store> as a template
+key, C<check> will put it both in the scalar you supplied, as well as
+in the hashref it returns.
+
+=head2 $Params::Check::PRESERVE_CASE
+
+If set to true, L<Params::Check> will no longer convert all keys from
+the user input to lowercase, but instead expect them to be in the
+case the template provided. This is useful when you want to use
+similar keys with different casing in your templates.
+
+Understand that this removes the case-insensitivy feature of this
+module.
+
+Default is 0;
+
+=head2 $Params::Check::ONLY_ALLOW_DEFINED
+
+If set to true, L<Params::Check> will require all values passed to be
+C<defined>. If you wish to enable this on a 'per key' basis, use the
+template option C<defined> instead.
+
+Default is 0;
+
+=head2 $Params::Check::SANITY_CHECK_TEMPLATE
+
+If set to true, L<Params::Check> will sanity check templates, validating
+for errors and unknown keys. Although very useful for debugging, this
+can be somewhat slow in hot-code and large loops.
+
+To disable this check, set this variable to C<false>.
+
+Default is 1;
+
+=head2 $Params::Check::WARNINGS_FATAL
+
+If set to true, L<Params::Check> will C<croak> when an error during
+template validation occurs, rather than return C<false>.
+
+Default is 0;
+
+=head2 $Params::Check::CALLER_DEPTH
+
+This global modifies the argument given to C<caller()> by
+C<Params::Check::check()> and is useful if you have a custom wrapper
+function around C<Params::Check::check()>. The value must be an
+integer, indicating the number of wrapper functions inserted between
+the real function call and C<Params::Check::check()>.
+
+Example wrapper function, using a custom stacktrace:
+
+ sub check {
+ my ($template, $args_in) = @_;
+
+ local $Params::Check::WARNINGS_FATAL = 1;
+ local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
+ my $args_out = Params::Check::check($template, $args_in);
+
+ my_stacktrace(Params::Check::last_error) unless $args_out;
+
+ return $args_out;
+ }
+
+Default is 0;
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Richard Soderberg for his performance improvements.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2003,2004 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
--- /dev/null
+use strict;
+use Test::More 'no_plan';
+
+### use && import ###
+BEGIN {
+ use_ok( 'Params::Check' );
+ Params::Check->import(qw|check last_error allow|);
+}
+
+### verbose is good for debugging ###
+$Params::Check::VERBOSE = $Params::Check::VERBOSE = $ARGV[0] ? 1 : 0;
+
+### basic things first, allow function ###
+
+use constant FALSE => sub { 0 };
+use constant TRUE => sub { 1 };
+
+### allow tests ###
+{ ok( allow( 42, qr/^\d+$/ ), "Allow based on regex" );
+ ok( allow( $0, $0), " Allow based on string" );
+ ok( allow( 42, [0,42] ), " Allow based on list" );
+ ok( allow( 42, [50,sub{1}])," Allow based on list containing sub");
+ ok( allow( 42, TRUE ), " Allow based on constant sub" );
+ ok(!allow( $0, qr/^\d+$/ ), "Disallowing based on regex" );
+ ok(!allow( 42, $0 ), " Disallowing based on string" );
+ ok(!allow( 42, [0,$0] ), " Disallowing based on list" );
+ ok(!allow( 42, [50,sub{0}])," Disallowing based on list containing sub");
+ ok(!allow( 42, FALSE ), " Disallowing based on constant sub" );
+
+ ### check that allow short circuits where required
+ { my $sub_called;
+ allow( 1, [ 1, sub { $sub_called++ } ] );
+ ok( !$sub_called, "Allow short-circuits properly" );
+ }
+
+ ### check if the subs for allow get what you expect ###
+ for my $thing (1,'foo',[1]) {
+ allow( $thing,
+ sub { is_deeply(+shift,$thing, "Allow coderef gets proper args") }
+ );
+ }
+}
+### default tests ###
+{
+ my $tmpl = {
+ foo => { default => 1 }
+ };
+
+ ### empty args first ###
+ { my $args = check( $tmpl, {} );
+
+ ok( $args, "check() call with empty args" );
+ is( $args->{'foo'}, 1, " got default value" );
+ }
+
+ ### now provide an alternate value ###
+ { my $try = { foo => 2 };
+ my $args = check( $tmpl, $try );
+
+ ok( $args, "check() call with defined args" );
+ is_deeply( $args, $try, " found provided value in rv" );
+ }
+
+ ### now provide a different case ###
+ { my $try = { FOO => 2 };
+ my $args = check( $tmpl, $try );
+ ok( $args, "check() call with alternate case" );
+ is( $args->{foo}, 2, " found provided value in rv" );
+ }
+
+ ### now see if we can strip leading dashes ###
+ { local $Params::Check::STRIP_LEADING_DASHES = 1;
+ my $try = { -foo => 2 };
+ my $get = { foo => 2 };
+
+ my $args = check( $tmpl, $try );
+ ok( $args, "check() call with leading dashes" );
+ is_deeply( $args, $get, " found provided value in rv" );
+ }
+}
+
+### preserve case tests ###
+{ my $tmpl = { Foo => { default => 1 } };
+
+ for (1,0) {
+ local $Params::Check::PRESERVE_CASE = $_;
+
+ my $expect = $_ ? { Foo => 42 } : { Foo => 1 };
+
+ my $rv = check( $tmpl, { Foo => 42 } );
+ ok( $rv, "check() call using PRESERVE_CASE: $_" );
+ is_deeply($rv, $expect, " found provided value in rv" );
+ }
+}
+
+
+### unknown tests ###
+{
+ ### disallow unknowns ###
+ {
+ my $rv = check( {}, { foo => 42 } );
+
+ is_deeply( $rv, {}, "check() call with unknown arguments" );
+ like( last_error(), qr/^Key 'foo' is not a valid key/,
+ " warning recorded ok" );
+ }
+
+ ### allow unknown ###
+ {
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+ my $rv = check( {}, { foo => 42 } );
+
+ is_deeply( $rv, { foo => 42 },
+ "check call() with unknown args allowed" );
+ }
+}
+
+### store tests ###
+{ my $foo;
+ my $tmpl = {
+ foo => { store => \$foo }
+ };
+
+ ### with/without store duplicates ###
+ for( 1, 0 ) {
+ local $Params::Check::NO_DUPLICATES = $_;
+
+ my $expect = $_ ? undef : 42;
+
+ my $rv = check( $tmpl, { foo => 42 } );
+ ok( $rv, "check() call with store key, no_dup: $_" );
+ is( $foo, 42, " found provided value in variable" );
+ is( $rv->{foo}, $expect, " found provided value in variable" );
+ }
+}
+
+### no_override tests ###
+{ my $tmpl = {
+ foo => { no_override => 1, default => 42 },
+ };
+
+ my $rv = check( $tmpl, { foo => 13 } );
+ ok( $rv, "check() call with no_override key" );
+ is( $rv->{'foo'}, 42, " found default value in rv" );
+
+ like( last_error(), qr/^You are not allowed to override key/,
+ " warning recorded ok" );
+}
+
+### strict_type tests ###
+{ my @list = (
+ [ { strict_type => 1, default => [] }, 0 ],
+ [ { default => [] }, 1 ],
+ );
+
+ ### check for strict_type global, and in the template key ###
+ for my $aref (@list) {
+
+ my $tmpl = { foo => $aref->[0] };
+ local $Params::Check::STRICT_TYPE = $aref->[1];
+
+ ### proper value ###
+ { my $rv = check( $tmpl, { foo => [] } );
+ ok( $rv, "check() call with strict_type enabled" );
+ is( ref $rv->{foo}, 'ARRAY',
+ " found provided value in rv" );
+ }
+
+ ### improper value ###
+ { my $rv = check( $tmpl, { foo => {} } );
+ ok( !$rv, "check() call with strict_type violated" );
+ like( last_error(), qr/^Key 'foo' needs to be of type 'ARRAY'/,
+ " warning recorded ok" );
+ }
+ }
+}
+
+### required tests ###
+{ my $tmpl = {
+ foo => { required => 1 }
+ };
+
+ ### required value provided ###
+ { my $rv = check( $tmpl, { foo => 42 } );
+ ok( $rv, "check() call with required key" );
+ is( $rv->{foo}, 42, " found provided value in rv" );
+ }
+
+ ### required value omitted ###
+ { my $rv = check( $tmpl, { } );
+ ok( !$rv, "check() call with required key omitted" );
+ like( last_error, qr/^Required option 'foo' is not provided/,
+ " warning recorded ok" );
+ }
+}
+
+### defined tests ###
+{ my @list = (
+ [ { defined => 1, default => 1 }, 0 ],
+ [ { default => 1 }, 1 ],
+ );
+
+ ### check for strict_type global, and in the template key ###
+ for my $aref (@list) {
+
+ my $tmpl = { foo => $aref->[0] };
+ local $Params::Check::ONLY_ALLOW_DEFINED = $aref->[1];
+
+ ### value provided defined ###
+ { my $rv = check( $tmpl, { foo => 42 } );
+ ok( $rv, "check() call with defined key" );
+ is( $rv->{foo}, 42, " found provided value in rv" );
+ }
+
+ ### value provided undefined ###
+ { my $rv = check( $tmpl, { foo => undef } );
+ ok( !$rv, "check() call with defined key undefined" );
+ like( last_error, qr/^Key 'foo' must be defined when passed/,
+ " warning recorded ok" );
+ }
+ }
+}
+
+### check + allow tests ###
+{ ### check if the subs for allow get what you expect ###
+ for my $thing (1,'foo',[1]) {
+ my $tmpl = {
+ foo => { allow =>
+ sub { is_deeply(+shift,$thing,
+ " Allow coderef gets proper args") }
+ }
+ };
+
+ my $rv = check( $tmpl, { foo => $thing } );
+ ok( $rv, "check() call using allow key" );
+ }
+}
+
+### invalid key tests
+{ my $tmpl = { foo => { allow => sub { 0 } } };
+
+ for my $val ( 1, 'foo', [], bless({},__PACKAGE__) ) {
+ my $rv = check( $tmpl, { foo => $val } );
+ my $text = "Key 'foo' ($val) is of invalid type";
+ my $re = quotemeta $text;
+
+ ok(!$rv, "check() fails with unalllowed value" );
+ like(last_error(), qr/$re/, " $text" );
+ }
+}
+
+### warnings fatal test
+{ my $tmpl = { foo => { allow => sub { 0 } } };
+
+ local $Params::Check::WARNINGS_FATAL = 1;
+
+ eval { check( $tmpl, { foo => 1 } ) };
+
+ ok( $@, "Call dies with fatal toggled" );
+ like( $@, qr/invalid type/,
+ " error stored ok" );
+}
+
+### store => \$foo tests
+{ ### quell warnings
+ local $SIG{__WARN__} = sub {};
+
+ my $tmpl = { foo => { store => '' } };
+ check( $tmpl, {} );
+
+ my $re = quotemeta q|Store variable for 'foo' is not a reference!|;
+ like(last_error(), qr/$re/, "Caught non-reference 'store' variable" );
+}
+
+### edge case tests ###
+{ ### if key is not provided, and value is '', will P::C treat
+ ### that correctly?
+ my $tmpl = { foo => { default => '' } };
+ my $rv = check( $tmpl, {} );
+
+ ok( $rv, "check() call with default = ''" );
+ ok( exists $rv->{foo}, " rv exists" );
+ ok( defined $rv->{foo}, " rv defined" );
+ ok( !$rv->{foo}, " rv false" );
+ is( $rv->{foo}, '', " rv = '' " );
+}
+
+### big template test ###
+{
+ my $lastname;
+
+ ### the template to check against ###
+ my $tmpl = {
+ firstname => { required => 1, defined => 1 },
+ lastname => { required => 1, store => \$lastname },
+ gender => { required => 1,
+ allow => [qr/M/i, qr/F/i],
+ },
+ married => { allow => [0,1] },
+ age => { default => 21,
+ allow => qr/^\d+$/,
+ },
+ id_list => { default => [],
+ strict_type => 1
+ },
+ phone => { allow => sub { 1 if +shift } },
+ bureau => { default => 'NSA',
+ no_override => 1
+ },
+ };
+
+ ### the args to send ###
+ my $try = {
+ firstname => 'joe',
+ lastname => 'jackson',
+ gender => 'M',
+ married => 1,
+ age => 21,
+ id_list => [1..3],
+ phone => '555-8844',
+ };
+
+ ### the rv we expect ###
+ my $get = { %$try, bureau => 'NSA' };
+
+ my $rv = check( $tmpl, $try );
+
+ ok( $rv, "elaborate check() call" );
+ is_deeply( $rv, $get, " found provided values in rv" );
+ is( $rv->{lastname}, $lastname,
+ " found provided values in rv" );
+}
+
+### $Params::Check::CALLER_DEPTH test
+{
+ sub wrapper { check ( @_ ) };
+ sub inner { wrapper( @_ ) };
+ sub outer { inner ( @_ ) };
+ outer( { dummy => { required => 1 }}, {} );
+
+ like( last_error, qr/for .*::wrapper by .*::inner$/,
+ "wrong caller without CALLER_DEPTH" );
+
+ local $Params::Check::CALLER_DEPTH = 1;
+ outer( { dummy => { required => 1 }}, {} );
+
+ like( last_error, qr/for .*::inner by .*::outer$/,
+ "right caller with CALLER_DEPTH" );
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff