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
247        ok(!$rv,                    "check() fails with unallowed value" );
248        like(last_error(), qr/$re/, "   $text" );
249    }
250}
251
252### warnings [rt.cpan.org #69626]
253{
254    local $Params::Check::WARNINGS_FATAL = 1;
255
256    eval { check() };
257
258    ok( $@,             "Call dies with fatal toggled" );
259    like( $@,           qr/expects two arguments/,
260                            "   error stored ok" );
261}
262
263### warnings fatal test
264{   my $tmpl = { foo => { allow => sub { 0 } } };
265
266    local $Params::Check::WARNINGS_FATAL = 1;
267
268    eval { check( $tmpl, { foo => 1 } ) };
269
270    ok( $@,             "Call dies with fatal toggled" );
271    like( $@,           qr/invalid type/,
272                            "   error stored ok" );
273}
274
275### store => \$foo tests
276{   ### quell warnings
277    local $SIG{__WARN__} = sub {};
278
279    my $tmpl = { foo => { store => '' } };
280    check( $tmpl, {} );
281
282    my $re = quotemeta q|Store variable for 'foo' is not a reference!|;
283    like(last_error(), qr/$re/, "Caught non-reference 'store' variable" );
284}
285
286### edge case tests ###
287{   ### if key is not provided, and value is '', will P::C treat
288    ### that correctly?
289    my $tmpl = { foo => { default => '' } };
290    my $rv   = check( $tmpl, {} );
291
292    ok( $rv,                    "check() call with default = ''" );
293    ok( exists $rv->{foo},      "   rv exists" );
294    ok( defined $rv->{foo},     "   rv defined" );
295    ok( !$rv->{foo},            "   rv false" );
296    is( $rv->{foo}, '',         "   rv = '' " );
297}
298
299### big template test ###
300{
301    my $lastname;
302
303    ### the template to check against ###
304    my $tmpl = {
305        firstname   => { required   => 1, defined => 1 },
306        lastname    => { required   => 1, store => \$lastname },
307        gender      => { required   => 1,
308                         allow      => [qr/M/i, qr/F/i],
309                    },
310        married     => { allow      => [0,1] },
311        age         => { default    => 21,
312                         allow      => qr/^\d+$/,
313                    },
314        id_list     => { default        => [],
315                         strict_type    => 1
316                    },
317        phone       => { allow          => sub { 1 if +shift } },
318        bureau      => { default        => 'NSA',
319                         no_override    => 1
320                    },
321    };
322
323    ### the args to send ###
324    my $try = {
325        firstname   => 'joe',
326        lastname    => 'jackson',
327        gender      => 'M',
328        married     => 1,
329        age         => 21,
330        id_list     => [1..3],
331        phone       => '555-8844',
332    };
333
334    ### the rv we expect ###
335    my $get = { %$try, bureau => 'NSA' };
336
337    my $rv = check( $tmpl, $try );
338
339    ok( $rv,                "elaborate check() call" );
340    is_deeply( $rv, $get,   "   found provided values in rv" );
341    is( $rv->{lastname}, $lastname,
342                            "   found provided values in rv" );
343}
344
345### $Params::Check::CALLER_DEPTH test
346{
347    sub wrapper { check  ( @_ ) };
348    sub inner   { wrapper( @_ ) };
349    sub outer   { inner  ( @_ ) };
350    outer( { dummy => { required => 1 }}, {} );
351
352    like( last_error, qr/for .*::wrapper by .*::inner$/,
353                            "wrong caller without CALLER_DEPTH" );
354
355    local $Params::Check::CALLER_DEPTH = 1;
356    outer( { dummy => { required => 1 }}, {} );
357
358    like( last_error, qr/for .*::inner by .*::outer$/,
359                            "right caller with CALLER_DEPTH" );
360}
361
362### test: #23824: Bug concerning the loss of the last_error
363### message when checking recursively.
364{   ok( 1,                      "Test last_error() on recursive check() call" );
365
366    ### allow sub to call
367    my $clear   = sub { check( {}, {} ) if shift; 1; };
368
369    ### recursively call check() or not?
370    for my $recurse ( 0, 1 ) {
371
372        check(
373            { a => { defined => 1 },
374              b => { allow   => sub { $clear->( $recurse ) } },
375            },
376            { a => undef, b => undef }
377        );
378
379        ok( last_error(),       "   last_error() with recurse: $recurse" );
380    }
381}
382
383