r5308 - in /packages/libparams-check-perl/trunk: CHANGES MANIFEST
META.yml
Makefile.PL Params-Check-0.26.tar.gz debian/changelog debian/watch
lib/Params/Check.pm t/01_Params-Check.t
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Tue Apr 24 13:00:35 UTC 2007
Author: eloy
Date: Tue Apr 24 13:00:35 2007
New Revision: 5308
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=5308
Log:
new upstream version
Added:
packages/libparams-check-perl/trunk/Params-Check-0.26.tar.gz
- copied unchanged from r5307, packages/libparams-check-perl/branches/upstream/current/Params-Check-0.26.tar.gz
Modified:
packages/libparams-check-perl/trunk/CHANGES
packages/libparams-check-perl/trunk/MANIFEST
packages/libparams-check-perl/trunk/META.yml
packages/libparams-check-perl/trunk/Makefile.PL
packages/libparams-check-perl/trunk/debian/changelog
packages/libparams-check-perl/trunk/debian/watch
packages/libparams-check-perl/trunk/lib/Params/Check.pm
packages/libparams-check-perl/trunk/t/01_Params-Check.t
Modified: packages/libparams-check-perl/trunk/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/trunk/CHANGES?rev=5308&op=diff
==============================================================================
--- packages/libparams-check-perl/trunk/CHANGES (original)
+++ packages/libparams-check-perl/trunk/CHANGES Tue Apr 24 13:00:35 2007
@@ -1,10 +1,17 @@
+Changes for 0.26 Thu Mar 1 12:05:08 2007
+============================================
+
+* Set install_dirs to 'perl' if perl >= 5.9.5
+* Address #23824: Bug concering the loss of the
+ last_error message when checking recursively.
+
Changes for 0.25 Wed Jul 5 17:13:07 2006
============================================
* Apply patch from #20299 that implements the
$Params::Check::CALLER_DEPTH variable.
* Add a warning if the store => variable
- s not a reference.
+ is not a reference.
Changes for 0.24 Thu Mar 2 13:04:27 2006
============================================
Modified: packages/libparams-check-perl/trunk/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/trunk/MANIFEST?rev=5308&op=diff
==============================================================================
--- packages/libparams-check-perl/trunk/MANIFEST (original)
+++ packages/libparams-check-perl/trunk/MANIFEST Tue Apr 24 13:00:35 2007
@@ -1,7 +1,8 @@
-Makefile.PL
-MANIFEST
-README
CHANGES
lib/Params/Check.pm
+Makefile.PL
+MANIFEST This list of files
+Params-Check-0.26.tar.gz
+README
t/01_Params-Check.t
META.yml Module meta-data (added by MakeMaker)
Modified: packages/libparams-check-perl/trunk/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/trunk/META.yml?rev=5308&op=diff
==============================================================================
--- packages/libparams-check-perl/trunk/META.yml (original)
+++ packages/libparams-check-perl/trunk/META.yml Tue Apr 24 13:00:35 2007
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Params-Check
-version: 0.25
+version: 0.26
version_from: lib/Params/Check.pm
installdirs: site
requires:
Modified: packages/libparams-check-perl/trunk/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/trunk/Makefile.PL?rev=5308&op=diff
==============================================================================
--- packages/libparams-check-perl/trunk/Makefile.PL (original)
+++ packages/libparams-check-perl/trunk/Makefile.PL Tue Apr 24 13:00:35 2007
@@ -9,6 +9,7 @@
'Test::More' => 0,
'Locale::Maketext::Simple' => 0,
},
+ INSTALLDIRS => ( $] >= 5.009005 ? 'perl' : 'site' ),
AUTHOR => 'Jos Boumans <kane[at]cpan.org>',
ABSTRACT => 'Templated based param validation'
);
Modified: packages/libparams-check-perl/trunk/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/trunk/debian/changelog?rev=5308&op=diff
==============================================================================
--- packages/libparams-check-perl/trunk/debian/changelog (original)
+++ packages/libparams-check-perl/trunk/debian/changelog Tue Apr 24 13:00:35 2007
@@ -1,3 +1,9 @@
+libparams-check-perl (0.26-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Krzysztof Krzyzaniak (eloy) <eloy at debian.org> Tue, 24 Apr 2007 14:59:12 +0200
+
libparams-check-perl (0.25-1) unstable; urgency=low
* New upstream release.
Modified: packages/libparams-check-perl/trunk/debian/watch
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/trunk/debian/watch?rev=5308&op=diff
==============================================================================
--- packages/libparams-check-perl/trunk/debian/watch (original)
+++ packages/libparams-check-perl/trunk/debian/watch Tue Apr 24 13:00:35 2007
@@ -1,4 +1,4 @@
# format version number, currently 2; this line is compulsory!
version=2
-http://mirrors.kernel.org/cpan/modules/by-module/Params/Params-Check-([\.\d]+).tar.gz
+http://www.cpan.org/modules/by-module/Params/Params-Check-([\.\d]+).tar.gz
Modified: packages/libparams-check-perl/trunk/lib/Params/Check.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/trunk/lib/Params/Check.pm?rev=5308&op=diff
==============================================================================
--- packages/libparams-check-perl/trunk/lib/Params/Check.pm (original)
+++ packages/libparams-check-perl/trunk/lib/Params/Check.pm Tue Apr 24 13:00:35 2007
@@ -12,13 +12,13 @@
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
+ $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
];
@ISA = qw[ Exporter ];
@EXPORT_OK = qw[check allow last_error];
- $VERSION = '0.25';
+ $VERSION = '0.26';
$VERBOSE = $^W ? 1 : 0;
$NO_DUPLICATES = 0;
$STRIP_LEADING_DASHES = 0;
@@ -39,7 +39,7 @@
=head1 NAME
-Params::Check -- A generic input parsing/checking mechanism.
+Params::Check - A generic input parsing/checking mechanism.
=head1 SYNOPSIS
@@ -335,8 +335,10 @@
### 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'})
+ if( exists $tmpl{'allow'} and not do {
+ local $_ERROR_STRING;
+ 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
@@ -550,7 +552,7 @@
=cut
-{ my $ErrorString = '';
+{ $_ERROR_STRING = '';
sub _store_error {
my($err, $verbose, $offset) = @_[0..2];
@@ -562,14 +564,14 @@
carp $err if $verbose;
- $ErrorString .= $err . "\n";
+ $_ERROR_STRING .= $err . "\n";
}
sub _clear_error {
- $ErrorString = '';
- }
-
- sub last_error { $ErrorString }
+ $_ERROR_STRING = '';
+ }
+
+ sub last_error { $_ERROR_STRING }
}
1;
Modified: packages/libparams-check-perl/trunk/t/01_Params-Check.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/trunk/t/01_Params-Check.t?rev=5308&op=diff
==============================================================================
--- packages/libparams-check-perl/trunk/t/01_Params-Check.t (original)
+++ packages/libparams-check-perl/trunk/t/01_Params-Check.t Tue Apr 24 13:00:35 2007
@@ -1,349 +1,371 @@
-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" );
-}
+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" );
+}
+
+### test: #23824: Bug concering the loss of the last_error
+### message when checking recursively.
+{ ok( 1, "Test last_error() on recursive check() call" );
+
+ ### allow sub to call
+ my $clear = sub { check( {}, {} ) if shift; 1; };
+
+ ### recursively call check() or not?
+ for my $recurse ( 0, 1 ) {
+
+ check(
+ { a => { defined => 1 },
+ b => { allow => sub { $clear->( $recurse ) } },
+ },
+ { a => undef, b => undef }
+ );
+
+ ok( last_error(), " last_error() with recurse: $recurse" );
+ }
+}
+
More information about the Pkg-perl-cvs-commits
mailing list