Update Params-Check to CPAN version 0.30

  [DELTA]

  Changes for 0.30    Mon Jul 25 14:44:40 2011
  ============================================
  * Resolve [rt #69626] reported by Diab Jerius,
    WARNINGS_FATAL should apply to all check()
    failures now.

2 files changed, 88 insertions, 73 deletions

diff --git a/cpan/Params-Check/lib/Params/Check.pm b/cpan/Params-Check/lib/Params/Check.pm
index 9b2643dd0c..a86256d2c6 100644
--- a/cpan/Params-Check/lib/Params/Check.pm
+++ b/cpan/Params-Check/lib/Params/Check.pm
@@ -18,7 +18,7 @@ BEGIN {
     @ISA        =   qw[ Exporter ];
     @EXPORT_OK  =   qw[check allow last_error];
 
-    $VERSION                = '0.28';
+    $VERSION                = '0.30';
     $VERBOSE                = $^W ? 1 : 0;
     $NO_DUPLICATES          = 0;
     $STRIP_LEADING_DASHES   = 0;
@@ -247,15 +247,19 @@ on this.
 sub check {
     my ($utmpl, $href, $verbose) = @_;
 
+    ### clear the current error string ###
+    _clear_error();
+
     ### did we get the arguments we need? ###
-    return if !$utmpl or !$href;
+    if ( !$utmpl or !$href ) {
+      _store_error(loc('check() expects two arguments'));
+      return unless $WARNINGS_FATAL;
+      croak(__PACKAGE__->last_error);
+    }
 
     ### sensible defaults ###
     $verbose ||= $VERBOSE || 0;
 
-    ### clear the current error string ###
-    _clear_error();
-
     ### XXX what type of template is it? ###
     ### { key => { } } ?
     #if (ref $args eq 'HASH') {
@@ -275,8 +279,8 @@ sub check {
     my %defs    = %$defs;
 
     ### flag to see if anything went wrong ###
-    my $wrong; 
-    
+    my $wrong;
+
     ### flag to see if we warned for anything, needed for warnings_fatal
     my $warned;
 
@@ -338,7 +342,7 @@ sub check {
         if( exists $tmpl{'allow'} and not do {
                 local $_ERROR_STRING;
                 allow( $args{$key}, $tmpl{'allow'} )
-            }         
+            }
         ) {
             ### stringify the value in the error report -- we don't want dumps
             ### of objects, but we do want to see *roughly* what we passed
@@ -355,7 +359,7 @@ sub check {
 
     }
 
-    ### croak with the collected errors if there were errors and 
+    ### croak with the collected errors if there were errors and
     ### we have the fatal flag toggled.
     croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
 
@@ -439,7 +443,7 @@ sub allow {
         for ( @{$_[1]} ) {
             return 1 if allow( $_[0], $_ );
         }
-        
+
         return;
 
     ### fall back to a simple, but safe 'eq' ###
@@ -509,7 +513,7 @@ sub _sanity_check_and_defaults {
             } grep {
                 not $known_keys{$_}
             } keys %{$utmpl{$key}};
-        
+
             ### make sure you passed a ref, otherwise, complain about it!
             if ( exists $utmpl{$key}->{'store'} ) {
                 _store_error( loc(
@@ -654,7 +658,7 @@ Default is 1;
 
 =head2 $Params::Check::WARNINGS_FATAL
 
-If set to true, L<Params::Check> will C<croak> when an error during 
+If set to true, L<Params::Check> will C<croak> when an error during
 template validation occurs, rather than return C<false>.
 
 Default is 0;
diff --git a/cpan/Params-Check/t/01_Params-Check.t b/cpan/Params-Check/t/01_Params-Check.t
index 7fd10dbb41..f17d1cdef7 100644
--- a/cpan/Params-Check/t/01_Params-Check.t
+++ b/cpan/Params-Check/t/01_Params-Check.t
@@ -5,7 +5,7 @@ use Test::More 'no_plan';
 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;
@@ -27,36 +27,36 @@ use constant TRUE   => sub { 1 };
     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 
+    ### 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") } 
+        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" );
     }
@@ -72,7 +72,7 @@ use constant TRUE   => sub { 1 };
     {   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" );
@@ -81,35 +81,35 @@ use constant TRUE   => sub { 1 };
 
 ### 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" ); 
+
+        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 } );        
-        
+        my $rv = check( {}, { foo => 42 } );
+
         is_deeply( $rv, { foo => 42 },
                                 "check call() with unknown args allowed" );
     }
@@ -124,26 +124,26 @@ use constant TRUE   => sub { 1 };
     ### 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 } );        
+
+    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/, 
+    like( last_error(), qr/^You are not allowed to override key/,
                                 "   warning recorded ok" );
 }
 
@@ -158,39 +158,39 @@ use constant TRUE   => sub { 1 };
 
         my $tmpl = { foo => $aref->[0] };
         local   $Params::Check::STRICT_TYPE = $aref->[1];
-                
-        ### proper value ###    
+
+        ### 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'/, 
+            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" );            
+                                    "   warning recorded ok" );
     }
 }
 
@@ -205,19 +205,19 @@ use constant TRUE   => sub { 1 };
 
         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" );
-        }                                             
+        }
     }
 }
 
@@ -226,35 +226,46 @@ use constant TRUE   => sub { 1 };
     for my $thing (1,'foo',[1]) {
         my $tmpl = {
             foo => { allow =>
-                    sub { is_deeply(+shift,$thing,  
-                                    "   Allow coderef gets proper args") } 
+                    sub { is_deeply(+shift,$thing,
+                                    "   Allow coderef gets proper args") }
             }
         };
-        
+
         my $rv = check( $tmpl, { foo => $thing } );
-        ok( $rv,                    "check() call using allow key" );  
+        ok( $rv,                    "check() call using allow key" );
     }
 }
 
-### invalid key tests 
+### 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 unallowed value" );
         like(last_error(), qr/$re/, "   $text" );
     }
 }
 
+### warnings [rt.cpan.org #69626]
+{
+    local $Params::Check::WARNINGS_FATAL = 1;
+
+    eval { check() };
+
+    ok( $@,             "Call dies with fatal toggled" );
+    like( $@,           qr/expects two arguments/,
+                            "   error stored ok" );
+}
+
 ### warnings fatal test
 {   my $tmpl = { foo => { allow => sub { 0 } } };
 
     local $Params::Check::WARNINGS_FATAL = 1;
 
-    eval { check( $tmpl, { foo => 1 } ) };      
+    eval { check( $tmpl, { foo => 1 } ) };
 
     ok( $@,             "Call dies with fatal toggled" );
     like( $@,           qr/invalid type/,
@@ -264,20 +275,20 @@ use constant TRUE   => sub { 1 };
 ### 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? 
+    ### 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" );
@@ -288,7 +299,7 @@ use constant TRUE   => sub { 1 };
 ### big template test ###
 {
     my $lastname;
-    
+
     ### the template to check against ###
     my $tmpl = {
         firstname   => { required   => 1, defined => 1 },
@@ -324,10 +335,10 @@ use constant TRUE   => sub { 1 };
     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, 
+    is( $rv->{lastname}, $lastname,
                             "   found provided values in rv" );
 }
 
@@ -350,21 +361,21 @@ use constant TRUE   => sub { 1 };
 
 ### test: #23824: Bug concerning the loss of the last_error
 ### message when checking recursively.
-{   ok( 1,                      "Test last_error() on recursive check() call" ); 
-    
+{   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(  
+    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" );
     }
 }