This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix typos (spelling errors) in cpan/Params-Check/*.
[perl5.git] / cpan / Params-Check / t / 01_Params-Check.t
CommitLineData
703d525d
JB
1use strict;
2use Test::More 'no_plan';
3
4### use && import ###
5BEGIN {
6 use_ok( 'Params::Check' );
7 Params::Check->import(qw|check last_error allow|);
8}
9
10### verbose is good for debugging ###
11$Params::Check::VERBOSE = $Params::Check::VERBOSE = $ARGV[0] ? 1 : 0;
12
13### basic things first, allow function ###
14
15use constant FALSE => sub { 0 };
16use constant TRUE => sub { 1 };
17
18### allow tests ###
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" );
29
30 ### check that allow short circuits where required
31 { my $sub_called;
32 allow( 1, [ 1, sub { $sub_called++ } ] );
33 ok( !$sub_called, "Allow short-circuits properly" );
34 }
35
36 ### check if the subs for allow get what you expect ###
37 for my $thing (1,'foo',[1]) {
38 allow( $thing,
39 sub { is_deeply(+shift,$thing, "Allow coderef gets proper args") }
40 );
41 }
42}
43### default tests ###
44{
45 my $tmpl = {
46 foo => { default => 1 }
47 };
48
49 ### empty args first ###
50 { my $args = check( $tmpl, {} );
51
52 ok( $args, "check() call with empty args" );
53 is( $args->{'foo'}, 1, " got default value" );
54 }
55
56 ### now provide an alternate value ###
57 { my $try = { foo => 2 };
58 my $args = check( $tmpl, $try );
59
60 ok( $args, "check() call with defined args" );
61 is_deeply( $args, $try, " found provided value in rv" );
62 }
63
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" );
69 }
70
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 };
75
76 my $args = check( $tmpl, $try );
77 ok( $args, "check() call with leading dashes" );
78 is_deeply( $args, $get, " found provided value in rv" );
79 }
80}
81
82### preserve case tests ###
83{ my $tmpl = { Foo => { default => 1 } };
84
85 for (1,0) {
86 local $Params::Check::PRESERVE_CASE = $_;
87
88 my $expect = $_ ? { Foo => 42 } : { Foo => 1 };
89
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" );
93 }
94}
95
96
97### unknown tests ###
98{
99 ### disallow unknowns ###
100 {
101 my $rv = check( {}, { foo => 42 } );
102
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" );
106 }
107
108 ### allow unknown ###
109 {
110 local $Params::Check::ALLOW_UNKNOWN = 1;
111 my $rv = check( {}, { foo => 42 } );
112
113 is_deeply( $rv, { foo => 42 },
114 "check call() with unknown args allowed" );
115 }
116}
117
118### store tests ###
119{ my $foo;
120 my $tmpl = {
121 foo => { store => \$foo }
122 };
123
124 ### with/without store duplicates ###
125 for( 1, 0 ) {
126 local $Params::Check::NO_DUPLICATES = $_;
127
128 my $expect = $_ ? undef : 42;
129
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" );
134 }
135}
136
137### no_override tests ###
138{ my $tmpl = {
139 foo => { no_override => 1, default => 42 },
140 };
141
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" );
145
146 like( last_error(), qr/^You are not allowed to override key/,
147 " warning recorded ok" );
148}
149
150### strict_type tests ###
151{ my @list = (
152 [ { strict_type => 1, default => [] }, 0 ],
153 [ { default => [] }, 1 ],
154 );
155
156 ### check for strict_type global, and in the template key ###
157 for my $aref (@list) {
158
159 my $tmpl = { foo => $aref->[0] };
160 local $Params::Check::STRICT_TYPE = $aref->[1];
161
162 ### proper value ###
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" );
167 }
168
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" );
174 }
175 }
176}
177
178### required tests ###
179{ my $tmpl = {
180 foo => { required => 1 }
181 };
182
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" );
187 }
188
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" );
194 }
195}
196
197### defined tests ###
198{ my @list = (
199 [ { defined => 1, default => 1 }, 0 ],
200 [ { default => 1 }, 1 ],
201 );
202
203 ### check for strict_type global, and in the template key ###
204 for my $aref (@list) {
205
206 my $tmpl = { foo => $aref->[0] };
207 local $Params::Check::ONLY_ALLOW_DEFINED = $aref->[1];
208
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" );
213 }
214
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" );
220 }
221 }
222}
223
224### check + allow tests ###
225{ ### check if the subs for allow get what you expect ###
226 for my $thing (1,'foo',[1]) {
227 my $tmpl = {
228 foo => { allow =>
229 sub { is_deeply(+shift,$thing,
230 " Allow coderef gets proper args") }
231 }
232 };
233
234 my $rv = check( $tmpl, { foo => $thing } );
235 ok( $rv, "check() call using allow key" );
236 }
237}
238
239### invalid key tests
240{ my $tmpl = { foo => { allow => sub { 0 } } };
241
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;
246
da827d75 247 ok(!$rv, "check() fails with unallowed value" );
703d525d
JB
248 like(last_error(), qr/$re/, " $text" );
249 }
250}
251
252### warnings fatal test
253{ my $tmpl = { foo => { allow => sub { 0 } } };
254
255 local $Params::Check::WARNINGS_FATAL = 1;
256
257 eval { check( $tmpl, { foo => 1 } ) };
258
259 ok( $@, "Call dies with fatal toggled" );
260 like( $@, qr/invalid type/,
261 " error stored ok" );
262}
263
264### store => \$foo tests
265{ ### quell warnings
266 local $SIG{__WARN__} = sub {};
267
268 my $tmpl = { foo => { store => '' } };
269 check( $tmpl, {} );
270
271 my $re = quotemeta q|Store variable for 'foo' is not a reference!|;
272 like(last_error(), qr/$re/, "Caught non-reference 'store' variable" );
273}
274
275### edge case tests ###
276{ ### if key is not provided, and value is '', will P::C treat
277 ### that correctly?
278 my $tmpl = { foo => { default => '' } };
279 my $rv = check( $tmpl, {} );
280
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 = '' " );
286}
287
288### big template test ###
289{
290 my $lastname;
291
292 ### the template to check against ###
293 my $tmpl = {
294 firstname => { required => 1, defined => 1 },
295 lastname => { required => 1, store => \$lastname },
296 gender => { required => 1,
297 allow => [qr/M/i, qr/F/i],
298 },
299 married => { allow => [0,1] },
300 age => { default => 21,
301 allow => qr/^\d+$/,
302 },
303 id_list => { default => [],
304 strict_type => 1
305 },
306 phone => { allow => sub { 1 if +shift } },
307 bureau => { default => 'NSA',
308 no_override => 1
309 },
310 };
311
312 ### the args to send ###
313 my $try = {
314 firstname => 'joe',
315 lastname => 'jackson',
316 gender => 'M',
317 married => 1,
318 age => 21,
319 id_list => [1..3],
320 phone => '555-8844',
321 };
322
323 ### the rv we expect ###
324 my $get = { %$try, bureau => 'NSA' };
325
326 my $rv = check( $tmpl, $try );
327
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" );
332}
333
334### $Params::Check::CALLER_DEPTH test
335{
336 sub wrapper { check ( @_ ) };
337 sub inner { wrapper( @_ ) };
338 sub outer { inner ( @_ ) };
339 outer( { dummy => { required => 1 }}, {} );
340
341 like( last_error, qr/for .*::wrapper by .*::inner$/,
342 "wrong caller without CALLER_DEPTH" );
343
344 local $Params::Check::CALLER_DEPTH = 1;
345 outer( { dummy => { required => 1 }}, {} );
346
347 like( last_error, qr/for .*::inner by .*::outer$/,
348 "right caller with CALLER_DEPTH" );
349}
7720784c 350
da827d75 351### test: #23824: Bug concerning the loss of the last_error
7720784c
RGS
352### message when checking recursively.
353{ ok( 1, "Test last_error() on recursive check() call" );
354
355 ### allow sub to call
356 my $clear = sub { check( {}, {} ) if shift; 1; };
357
358 ### recursively call check() or not?
359 for my $recurse ( 0, 1 ) {
360
361 check(
362 { a => { defined => 1 },
363 b => { allow => sub { $clear->( $recurse ) } },
364 },
365 { a => undef, b => undef }
366 );
367
368 ok( last_error(), " last_error() with recurse: $recurse" );
369 }
370}
371