Update Params-Check to CPAN version 0.36

  [DELTA]

  Changes for 0.36    Fri Apr 27 22:57:02 2012
  ============================================
  * More speed enhancements by Vincent Pit

  Changes for 0.34    Wed Apr 25 13:51:31 2012
  ============================================
  * check() now works fasteh thanks to
    Vincent Pit

1 files changed, 82 insertions, 100 deletions

diff --git a/cpan/Params-Check/lib/Params/Check.pm b/cpan/Params-Check/lib/Params/Check.pm
index c1365a9abe..536a7c08a8 100644
--- a/cpan/Params-Check/lib/Params/Check.pm
+++ b/cpan/Params-Check/lib/Params/Check.pm
@@ -16,7 +16,7 @@ BEGIN {
     @ISA        =   qw[ Exporter ];
     @EXPORT_OK  =   qw[check allow last_error];
 
-    $VERSION                = '0.32';
+    $VERSION                = '0.36';
     $VERBOSE                = $^W ? 1 : 0;
     $NO_DUPLICATES          = 0;
     $STRIP_LEADING_DASHES   = 0;
@@ -265,16 +265,73 @@ sub check {
     #}
 
     ### clean up the template ###
-    my $args = _clean_up_args( $href ) or return;
+    my $args;
+
+    ### don't even bother to loop, if there's nothing to clean up ###
+    if( $PRESERVE_CASE and !$STRIP_LEADING_DASHES ) {
+        $args = $href;
+    } else {
+        ### keys are not aliased ###
+        for my $key (keys %$href) {
+            my $org = $key;
+            $key = lc $key unless $PRESERVE_CASE;
+            $key =~ s/^-// if $STRIP_LEADING_DASHES;
+            $args->{$key} = $href->{$org};
+        }
+    }
+
+    my %defs;
+
+    ### which template entries have a 'store' member
+    my @want_store;
 
     ### sanity check + defaults + required keys set? ###
-    my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
-                    or return;
+    my $fail;
+    for my $key (keys %$utmpl) {
+        my $tmpl = $utmpl->{$key};
+
+        ### check if required keys are provided
+        ### keys are now lower cased, unless preserve case was enabled
+        ### at which point, the utmpl keys must match, but that's the users
+        ### problem.
+        if( $tmpl->{'required'} and not exists $args->{$key} ) {
+            _store_error(
+                loc(q|Required option '%1' is not provided for %2 by %3|,
+                    $key, _who_was_it(), _who_was_it(1)), $verbose );
+
+            ### mark the error ###
+            $fail++;
+            next;
+        }
+
+        ### next, set the default, make sure the key exists in %defs ###
+        $defs{$key} = $tmpl->{'default'}
+                        if exists $tmpl->{'default'};
+
+        if( $SANITY_CHECK_TEMPLATE ) {
+            ### last, check if they provided any weird template keys
+            ### -- do this last so we don't always execute this code.
+            ### just a small optimization.
+            map {   _store_error(
+                        loc(q|Template type '%1' not supported [at key '%2']|,
+                        $_, $key), 1, 0 );
+            } grep {
+                not $known_keys{$_}
+            } keys %$tmpl;
 
-    ### deref only once ###
-    my %utmpl   = %$utmpl;
-    my %args    = %$args;
-    my %defs    = %$defs;
+            ### make sure you passed a ref, otherwise, complain about it!
+            if ( exists $tmpl->{'store'} ) {
+                _store_error( loc(
+                    q|Store variable for '%1' is not a reference!|, $key
+                ), 1, 0 ) unless ref $tmpl->{'store'};
+            }
+        }
+
+        push @want_store, $key if $tmpl->{'store'};
+    }
+
+    ### errors found ###
+    return if $fail;
 
     ### flag to see if anything went wrong ###
     my $wrong;
@@ -282,14 +339,15 @@ sub check {
     ### flag to see if we warned for anything, needed for warnings_fatal
     my $warned;
 
-    for my $key (keys %args) {
+    for my $key (keys %$args) {
+        my $arg = $args->{$key};
 
         ### you gave us this key, but it's not in the template ###
-        unless( $utmpl{$key} ) {
+        unless( $utmpl->{$key} ) {
 
             ### but we'll allow it anyway ###
             if( $ALLOW_UNKNOWN ) {
-                $defs{$key} = $args{$key};
+                $defs{$key} = $arg;
 
             ### warn about the error ###
             } else {
@@ -301,8 +359,11 @@ sub check {
             next;
         }
 
+        ### copy of this keys template instructions, to save derefs ###
+        my %tmpl = %{$utmpl->{$key}};
+
         ### check if you're even allowed to override this key ###
-        if( $utmpl{$key}->{'no_override'} ) {
+        if( $tmpl{'no_override'} ) {
             _store_error(
                 loc(q[You are not allowed to override key '%1'].
                     q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
@@ -312,13 +373,8 @@ sub check {
             next;
         }
 
-        ### copy of this keys template instructions, to save derefs ###
-        my %tmpl = %{$utmpl{$key}};
-
         ### check if you were supposed to provide defined() values ###
-        if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and
-            not defined $args{$key}
-        ) {
+        if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and not defined $arg ) {
             _store_error(loc(q|Key '%1' must be defined when passed|, $key),
                 $verbose );
             $wrong ||= 1;
@@ -327,7 +383,7 @@ sub check {
 
         ### check if they should be of a strict type, and if it is ###
         if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
-            (ref $args{$key} ne ref $tmpl{'default'})
+            (ref $arg ne ref $tmpl{'default'})
         ) {
             _store_error(loc(q|Key '%1' needs to be of type '%2'|,
                         $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
@@ -339,21 +395,21 @@ sub check {
         ### allow() will report its own errors ###
         if( exists $tmpl{'allow'} and not do {
                 local $_ERROR_STRING;
-                allow( $args{$key}, $tmpl{'allow'} )
+                allow( $arg, $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
             _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
                              q|provided by %4|,
-                            $key, "$args{$key}", _who_was_it(),
+                            $key, "$arg", _who_was_it(),
                             _who_was_it(1)), $verbose);
             $wrong ||= 1;
             next;
         }
 
         ### we got here, then all must be OK ###
-        $defs{$key} = $args{$key};
+        $defs{$key} = $arg;
 
     }
 
@@ -368,10 +424,10 @@ sub check {
     ### check if we need to store any of the keys ###
     ### can't do it before, because something may go wrong later,
     ### leaving the user with a few set variables
-    for my $key (keys %defs) {
-        if( my $ref = $utmpl{$key}->{'store'} ) {
-            $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
-        }
+    for my $key (@want_store) {
+        next unless exists $defs{$key};
+        my $ref = $utmpl->{$key}{'store'};
+        $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
     }
 
     return \%defs;
@@ -455,80 +511,6 @@ sub allow {
 
 ### helper functions ###
 
-### clean up the template ###
-sub _clean_up_args {
-    ### don't even bother to loop, if there's nothing to clean up ###
-    return $_[0] if $PRESERVE_CASE and !$STRIP_LEADING_DASHES;
-
-    my %args = %{$_[0]};
-
-    ### keys are note aliased ###
-    for my $key (keys %args) {
-        my $org = $key;
-        $key = lc $key unless $PRESERVE_CASE;
-        $key =~ s/^-// if $STRIP_LEADING_DASHES;
-        $args{$key} = delete $args{$org} if $key ne $org;
-    }
-
-    ### return references so we always return 'true', even on empty
-    ### arguments
-    return \%args;
-}
-
-sub _sanity_check_and_defaults {
-    my %utmpl   = %{$_[0]};
-    my %args    = %{$_[1]};
-    my $verbose = $_[2];
-
-    my %defs; my $fail;
-    for my $key (keys %utmpl) {
-
-        ### check if required keys are provided
-        ### keys are now lower cased, unless preserve case was enabled
-        ### at which point, the utmpl keys must match, but that's the users
-        ### problem.
-        if( $utmpl{$key}->{'required'} and not exists $args{$key} ) {
-            _store_error(
-                loc(q|Required option '%1' is not provided for %2 by %3|,
-                    $key, _who_was_it(1), _who_was_it(2)), $verbose );
-
-            ### mark the error ###
-            $fail++;
-            next;
-        }
-
-        ### next, set the default, make sure the key exists in %defs ###
-        $defs{$key} = $utmpl{$key}->{'default'}
-                        if exists $utmpl{$key}->{'default'};
-
-        if( $SANITY_CHECK_TEMPLATE ) {
-            ### last, check if they provided any weird template keys
-            ### -- do this last so we don't always execute this code.
-            ### just a small optimization.
-            map {   _store_error(
-                        loc(q|Template type '%1' not supported [at key '%2']|,
-                        $_, $key), 1, 1 );
-            } 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(
-                    q|Store variable for '%1' is not a reference!|, $key
-                ), 1, 1 ) unless ref $utmpl{$key}->{'store'};
-            }
-        }
-    }
-
-    ### errors found ###
-    return if $fail;
-
-    ### return references so we always return 'true', even on empty
-    ### defaults
-    return \%defs;
-}
-
 sub _safe_eq {
     ### only do a straight 'eq' if they're both defined ###
     return defined($_[0]) && defined($_[1])