This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e868d13169d309f7a642988e12f8c3329d72e079
[perl5.git] / lib / Params / Check / t / 01_Params-Check.t
1 use strict;
2 use Test::More 'no_plan';
3
4 ### use && import ###
5 BEGIN {
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
15 use constant FALSE  => sub { 0 };
16 use 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 unalllowed value" );
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 }