[p5sagit/p5-mst-13.2.git] / lib / Params / Check / t / 01_Params-Check.t

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" );
    }
}
Commit	Line	Data
703d525d	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	}
7720784c	350
	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" );
	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