2 use Test::More 'no_plan';
6 use_ok( 'Params::Check' );
7 Params::Check->import(qw|check last_error allow|);
10 ### verbose is good for debugging ###
11 $Params::Check::VERBOSE = $Params::Check::VERBOSE = $ARGV[0] ? 1 : 0;
13 ### basic things first, allow function ###
15 use constant FALSE => sub { 0 };
16 use constant TRUE => sub { 1 };
19 { ok( allow( 42, qr/^\d+$/ ), "Allow based on regex" );
20 ok( allow( $0, $0), " Allow based on string" );
21 ok( allow( 42, [0,42] ), " Allow based on list" );
22 ok( allow( 42, [50,sub{1}])," Allow based on list containing sub");
23 ok( allow( 42, TRUE ), " Allow based on constant sub" );
24 ok(!allow( $0, qr/^\d+$/ ), "Disallowing based on regex" );
25 ok(!allow( 42, $0 ), " Disallowing based on string" );
26 ok(!allow( 42, [0,$0] ), " Disallowing based on list" );
27 ok(!allow( 42, [50,sub{0}])," Disallowing based on list containing sub");
28 ok(!allow( 42, FALSE ), " Disallowing based on constant sub" );
30 ### check that allow short circuits where required
32 allow( 1, [ 1, sub { $sub_called++ } ] );
33 ok( !$sub_called, "Allow short-circuits properly" );
36 ### check if the subs for allow get what you expect ###
37 for my $thing (1,'foo',[1]) {
39 sub { is_deeply(+shift,$thing, "Allow coderef gets proper args") }
46 foo => { default => 1 }
49 ### empty args first ###
50 { my $args = check( $tmpl, {} );
52 ok( $args, "check() call with empty args" );
53 is( $args->{'foo'}, 1, " got default value" );
56 ### now provide an alternate value ###
57 { my $try = { foo => 2 };
58 my $args = check( $tmpl, $try );
60 ok( $args, "check() call with defined args" );
61 is_deeply( $args, $try, " found provided value in rv" );
64 ### now provide a different case ###
65 { my $try = { FOO => 2 };
66 my $args = check( $tmpl, $try );
67 ok( $args, "check() call with alternate case" );
68 is( $args->{foo}, 2, " found provided value in rv" );
71 ### now see if we can strip leading dashes ###
72 { local $Params::Check::STRIP_LEADING_DASHES = 1;
73 my $try = { -foo => 2 };
74 my $get = { foo => 2 };
76 my $args = check( $tmpl, $try );
77 ok( $args, "check() call with leading dashes" );
78 is_deeply( $args, $get, " found provided value in rv" );
82 ### preserve case tests ###
83 { my $tmpl = { Foo => { default => 1 } };
86 local $Params::Check::PRESERVE_CASE = $_;
88 my $expect = $_ ? { Foo => 42 } : { Foo => 1 };
90 my $rv = check( $tmpl, { Foo => 42 } );
91 ok( $rv, "check() call using PRESERVE_CASE: $_" );
92 is_deeply($rv, $expect, " found provided value in rv" );
99 ### disallow unknowns ###
101 my $rv = check( {}, { foo => 42 } );
103 is_deeply( $rv, {}, "check() call with unknown arguments" );
104 like( last_error(), qr/^Key 'foo' is not a valid key/,
105 " warning recorded ok" );
108 ### allow unknown ###
110 local $Params::Check::ALLOW_UNKNOWN = 1;
111 my $rv = check( {}, { foo => 42 } );
113 is_deeply( $rv, { foo => 42 },
114 "check call() with unknown args allowed" );
121 foo => { store => \$foo }
124 ### with/without store duplicates ###
126 local $Params::Check::NO_DUPLICATES = $_;
128 my $expect = $_ ? undef : 42;
130 my $rv = check( $tmpl, { foo => 42 } );
131 ok( $rv, "check() call with store key, no_dup: $_" );
132 is( $foo, 42, " found provided value in variable" );
133 is( $rv->{foo}, $expect, " found provided value in variable" );
137 ### no_override tests ###
139 foo => { no_override => 1, default => 42 },
142 my $rv = check( $tmpl, { foo => 13 } );
143 ok( $rv, "check() call with no_override key" );
144 is( $rv->{'foo'}, 42, " found default value in rv" );
146 like( last_error(), qr/^You are not allowed to override key/,
147 " warning recorded ok" );
150 ### strict_type tests ###
152 [ { strict_type => 1, default => [] }, 0 ],
153 [ { default => [] }, 1 ],
156 ### check for strict_type global, and in the template key ###
157 for my $aref (@list) {
159 my $tmpl = { foo => $aref->[0] };
160 local $Params::Check::STRICT_TYPE = $aref->[1];
163 { my $rv = check( $tmpl, { foo => [] } );
164 ok( $rv, "check() call with strict_type enabled" );
165 is( ref $rv->{foo}, 'ARRAY',
166 " found provided value in rv" );
169 ### improper value ###
170 { my $rv = check( $tmpl, { foo => {} } );
171 ok( !$rv, "check() call with strict_type violated" );
172 like( last_error(), qr/^Key 'foo' needs to be of type 'ARRAY'/,
173 " warning recorded ok" );
178 ### required tests ###
180 foo => { required => 1 }
183 ### required value provided ###
184 { my $rv = check( $tmpl, { foo => 42 } );
185 ok( $rv, "check() call with required key" );
186 is( $rv->{foo}, 42, " found provided value in rv" );
189 ### required value omitted ###
190 { my $rv = check( $tmpl, { } );
191 ok( !$rv, "check() call with required key omitted" );
192 like( last_error, qr/^Required option 'foo' is not provided/,
193 " warning recorded ok" );
197 ### defined tests ###
199 [ { defined => 1, default => 1 }, 0 ],
200 [ { default => 1 }, 1 ],
203 ### check for strict_type global, and in the template key ###
204 for my $aref (@list) {
206 my $tmpl = { foo => $aref->[0] };
207 local $Params::Check::ONLY_ALLOW_DEFINED = $aref->[1];
209 ### value provided defined ###
210 { my $rv = check( $tmpl, { foo => 42 } );
211 ok( $rv, "check() call with defined key" );
212 is( $rv->{foo}, 42, " found provided value in rv" );
215 ### value provided undefined ###
216 { my $rv = check( $tmpl, { foo => undef } );
217 ok( !$rv, "check() call with defined key undefined" );
218 like( last_error, qr/^Key 'foo' must be defined when passed/,
219 " warning recorded ok" );
224 ### check + allow tests ###
225 { ### check if the subs for allow get what you expect ###
226 for my $thing (1,'foo',[1]) {
229 sub { is_deeply(+shift,$thing,
230 " Allow coderef gets proper args") }
234 my $rv = check( $tmpl, { foo => $thing } );
235 ok( $rv, "check() call using allow key" );
239 ### invalid key tests
240 { my $tmpl = { foo => { allow => sub { 0 } } };
242 for my $val ( 1, 'foo', [], bless({},__PACKAGE__) ) {
243 my $rv = check( $tmpl, { foo => $val } );
244 my $text = "Key 'foo' ($val) is of invalid type";
245 my $re = quotemeta $text;
247 ok(!$rv, "check() fails with unalllowed value" );
248 like(last_error(), qr/$re/, " $text" );
252 ### warnings fatal test
253 { my $tmpl = { foo => { allow => sub { 0 } } };
255 local $Params::Check::WARNINGS_FATAL = 1;
257 eval { check( $tmpl, { foo => 1 } ) };
259 ok( $@, "Call dies with fatal toggled" );
260 like( $@, qr/invalid type/,
261 " error stored ok" );
264 ### store => \$foo tests
266 local $SIG{__WARN__} = sub {};
268 my $tmpl = { foo => { store => '' } };
271 my $re = quotemeta q|Store variable for 'foo' is not a reference!|;
272 like(last_error(), qr/$re/, "Caught non-reference 'store' variable" );
275 ### edge case tests ###
276 { ### if key is not provided, and value is '', will P::C treat
278 my $tmpl = { foo => { default => '' } };
279 my $rv = check( $tmpl, {} );
281 ok( $rv, "check() call with default = ''" );
282 ok( exists $rv->{foo}, " rv exists" );
283 ok( defined $rv->{foo}, " rv defined" );
284 ok( !$rv->{foo}, " rv false" );
285 is( $rv->{foo}, '', " rv = '' " );
288 ### big template test ###
292 ### the template to check against ###
294 firstname => { required => 1, defined => 1 },
295 lastname => { required => 1, store => \$lastname },
296 gender => { required => 1,
297 allow => [qr/M/i, qr/F/i],
299 married => { allow => [0,1] },
300 age => { default => 21,
303 id_list => { default => [],
306 phone => { allow => sub { 1 if +shift } },
307 bureau => { default => 'NSA',
312 ### the args to send ###
315 lastname => 'jackson',
323 ### the rv we expect ###
324 my $get = { %$try, bureau => 'NSA' };
326 my $rv = check( $tmpl, $try );
328 ok( $rv, "elaborate check() call" );
329 is_deeply( $rv, $get, " found provided values in rv" );
330 is( $rv->{lastname}, $lastname,
331 " found provided values in rv" );
334 ### $Params::Check::CALLER_DEPTH test
336 sub wrapper { check ( @_ ) };
337 sub inner { wrapper( @_ ) };
338 sub outer { inner ( @_ ) };
339 outer( { dummy => { required => 1 }}, {} );
341 like( last_error, qr/for .*::wrapper by .*::inner$/,
342 "wrong caller without CALLER_DEPTH" );
344 local $Params::Check::CALLER_DEPTH = 1;
345 outer( { dummy => { required => 1 }}, {} );
347 like( last_error, qr/for .*::inner by .*::outer$/,
348 "right caller with CALLER_DEPTH" );
351 ### test: #23824: Bug concering the loss of the last_error
352 ### message when checking recursively.
353 { ok( 1, "Test last_error() on recursive check() call" );
355 ### allow sub to call
356 my $clear = sub { check( {}, {} ) if shift; 1; };
358 ### recursively call check() or not?
359 for my $recurse ( 0, 1 ) {
362 { a => { defined => 1 },
363 b => { allow => sub { $clear->( $recurse ) } },
365 { a => undef, b => undef }
368 ok( last_error(), " last_error() with recurse: $recurse" );