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 }
 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