From e795a0fa50205d7756615b8d536c62ee4c345eb6 Mon Sep 17 00:00:00 2001
From: Packit <packit>
Date: Sep 16 2020 15:18:57 +0000
Subject: perl-Params-Check-0.38 base


---

diff --git a/CHANGES b/CHANGES
new file mode 100644
index 0000000..e9a1cce
--- /dev/null
+++ b/CHANGES
@@ -0,0 +1,96 @@
+Changes for 0.38    Thu Jun 20 10:43:37 2013
+============================================
+* Typo fixes by David Steinbrunner
+
+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
+
+Changes for 0.32    Mon Aug  8 10:53:36 2011
+============================================
+* Removed unnecessary use Data::Dumper
+
+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.
+
+Changes for 0.28    Fri Jan  7 21:52:28 2011
+============================================
+* Apply blead patch from Peter Acklam
+
+Changes for 0.26    Thu Mar  1 12:05:08 2007
+============================================
+
+* Set install_dirs to 'perl' if perl >= 5.9.5
+* Address #23824: Bug concering the loss of the
+  last_error message when checking recursively.
+
+Changes for 0.25    Wed Jul  5 17:13:07 2006
+============================================
+
+* Apply patch from #20299 that implements the
+  $Params::Check::CALLER_DEPTH variable.
+* Add a warning if the store => variable
+  is not a reference.
+
+Changes for 0.24    Thu Mar  2 13:04:27 2006
+============================================
+
+* Fix issue where allow() wouldn't shortcut
+    after the first successful match (#17364)
+
+Changes for 0.22    Thu Nov 11 11:11:33 2004
+============================================
+
+* Make error reporting of invalid keys contain
+    the stringified version of the disallowed
+    value.
+
+Changes for 0.21    Fri Jun 18 18:38:21 2004
+============================================
+
+* Make template defaults of '' (empty string)
+    work as they should.
+
+Changes for 0.20    Thu Jun 17 19:33:41 2004
+============================================
+
+* ground up rewrite of both code and tests
+    to improve performance
+
+Changes for 0.07    Thu Feb 25 11:14:48 2004
+============================================
+
+* quell a 'use of undefined variable' warning
+    when checking 'undef' values
+
+Changes for 0.06    Thu Feb 19 15:14:48 2004
+============================================
+
+* add template option 'defined'
+
+Changes for 0.05    Tue Feb 10 18:18:23 2004
+============================================
+
+* allow nested lists in allow()
+
+Changes for 0.04    Thu Sep 18 13:41:48 2003
+============================================
+
+* Use carp to get a better caller perspective
+* add the last_error() routine
+* add the allow() routine
+
+
+Changes for 0.03    Wed May 14 14:33:17 2003
+============================================
+
+* Verbosity's default setting depends on $^W
+* New global flag to not change the casing of keys
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..cc17767
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,8 @@
+CHANGES
+lib/Params/Check.pm
+Makefile.PL
+MANIFEST			This list of files
+README
+t/01_Params-Check.t
+META.yml                                 Module YAML meta-data (added by MakeMaker)
+META.json                                Module JSON meta-data (added by MakeMaker)
diff --git a/META.json b/META.json
new file mode 100644
index 0000000..0be93aa
--- /dev/null
+++ b/META.json
@@ -0,0 +1,47 @@
+{
+   "abstract" : "Templated based param validation",
+   "author" : [
+      "Jos Boumans <kane[at]cpan.org>"
+   ],
+   "dynamic_config" : 1,
+   "generated_by" : "ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.131560",
+   "license" : [
+      "perl_5"
+   ],
+   "meta-spec" : {
+      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+      "version" : "2"
+   },
+   "name" : "Params-Check",
+   "no_index" : {
+      "directory" : [
+         "t",
+         "inc"
+      ]
+   },
+   "prereqs" : {
+      "build" : {
+         "requires" : {
+            "ExtUtils::MakeMaker" : "0"
+         }
+      },
+      "configure" : {
+         "requires" : {
+            "ExtUtils::MakeMaker" : "0"
+         }
+      },
+      "runtime" : {
+         "requires" : {
+            "Locale::Maketext::Simple" : "0",
+            "Test::More" : "0"
+         }
+      }
+   },
+   "release_status" : "stable",
+   "resources" : {
+      "repository" : {
+         "url" : "https://github.com/jib/params-check"
+      }
+   },
+   "version" : "0.38"
+}
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..359075f
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,25 @@
+---
+abstract: 'Templated based param validation'
+author:
+  - 'Jos Boumans <kane[at]cpan.org>'
+build_requires:
+  ExtUtils::MakeMaker: 0
+configure_requires:
+  ExtUtils::MakeMaker: 0
+dynamic_config: 1
+generated_by: 'ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.131560'
+license: perl
+meta-spec:
+  url: http://module-build.sourceforge.net/META-spec-v1.4.html
+  version: 1.4
+name: Params-Check
+no_index:
+  directory:
+    - t
+    - inc
+requires:
+  Locale::Maketext::Simple: 0
+  Test::More: 0
+resources:
+  repository: https://github.com/jib/params-check
+version: 0.38
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..79cfd5e
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,44 @@
+use ExtUtils::MakeMaker;
+use strict;
+
+WriteMakefile1(
+    LICENSE => 'perl',
+    META_MERGE => {
+        resources => {
+            repository => 'https://github.com/jib/params-check',
+        },
+    },
+    NAME            => 'Params::Check',
+    VERSION_FROM    => 'lib/Params/Check.pm', # finds $VERSION
+    dist            => { COMPRESS => 'gzip -9f', SUFFIX => 'gz' },
+    PREREQ_PM       => {
+                        'Test::More'                => 0,
+                        'Locale::Maketext::Simple'  => 0,
+                    },
+    INSTALLDIRS     => ( $] >= 5.009005 ? 'perl' : 'site' ),
+    AUTHOR          => 'Jos Boumans <kane[at]cpan.org>',
+	ABSTRACT        => 'Templated based param validation'
+);
+
+sub WriteMakefile1 {  #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade.
+    my %params=@_;
+    my $eumm_version=$ExtUtils::MakeMaker::VERSION;
+    $eumm_version=eval $eumm_version;
+    die "EXTRA_META is deprecated" if exists $params{EXTRA_META};
+    die "License not specified" if not exists $params{LICENSE};
+    if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) {
+        #EUMM 6.5502 has problems with BUILD_REQUIRES
+        $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} };
+        delete $params{BUILD_REQUIRES};
+    }
+    delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52;
+    delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48;
+    delete $params{META_MERGE} if $eumm_version < 6.46;
+    delete $params{META_ADD} if $eumm_version < 6.46;
+    delete $params{LICENSE} if $eumm_version < 6.31;
+    delete $params{AUTHOR} if $] < 5.005;
+    delete $params{ABSTRACT_FROM} if $] < 5.005;
+    delete $params{BINARY_LOCATION} if $] < 5.005;
+
+    WriteMakefile(%params);
+}
diff --git a/README b/README
new file mode 100644
index 0000000..59396ec
--- /dev/null
+++ b/README
@@ -0,0 +1,38 @@
+This is the README file for Params::Check, a perl module for powerful
+template based param validation
+
+Please refer to 'perldoc Params::Check' after installation for details.
+
+#####################################################################
+
+* Description
+
+Params::Check
+
+    Allows for generic input checking and validating using a powerfull
+    templating system, providing default values and so on.
+
+#####################################################################
+
+* Installation
+
+Params::Check follows the standard perl module install process
+
+perl Makefile.PL
+make
+make test
+make install
+
+The module uses no C or XS parts, so no c-compiler is required.
+
+######################################################################
+
+AUTHOR
+    This module by Jos Boumans <kane@cpan.org>.
+
+COPYRIGHT
+    This module is copyright (c) 2002 Jos Boumans <kane@cpan.org>. All
+    rights reserved.
+
+    This library is free software; you may redistribute and/or modify it
+    under the same terms as Perl itself.
diff --git a/lib/Params/Check.pm b/lib/Params/Check.pm
new file mode 100644
index 0000000..1239442
--- /dev/null
+++ b/lib/Params/Check.pm
@@ -0,0 +1,695 @@
+package Params::Check;
+
+use strict;
+
+use Carp                        qw[carp croak];
+use Locale::Maketext::Simple    Style => 'gettext';
+
+BEGIN {
+    use Exporter    ();
+    use vars        qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
+                        $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
+                        $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
+                        $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
+                    ];
+
+    @ISA        =   qw[ Exporter ];
+    @EXPORT_OK  =   qw[check allow last_error];
+
+    $VERSION                = '0.38';
+    $VERBOSE                = $^W ? 1 : 0;
+    $NO_DUPLICATES          = 0;
+    $STRIP_LEADING_DASHES   = 0;
+    $STRICT_TYPE            = 0;
+    $ALLOW_UNKNOWN          = 0;
+    $PRESERVE_CASE          = 0;
+    $ONLY_ALLOW_DEFINED     = 0;
+    $SANITY_CHECK_TEMPLATE  = 1;
+    $WARNINGS_FATAL         = 0;
+    $CALLER_DEPTH           = 0;
+}
+
+my %known_keys = map { $_ => 1 }
+                    qw| required allow default strict_type no_override
+                        store defined |;
+
+=pod
+
+=head1 NAME
+
+Params::Check - A generic input parsing/checking mechanism.
+
+=head1 SYNOPSIS
+
+    use Params::Check qw[check allow last_error];
+
+    sub fill_personal_info {
+        my %hash = @_;
+        my $x;
+
+        my $tmpl = {
+            firstname   => { required   => 1, defined => 1 },
+            lastname    => { required   => 1, store => \$x },
+            gender      => { required   => 1,
+                             allow      => [qr/M/i, qr/F/i],
+                           },
+            married     => { allow      => [0,1] },
+            age         => { default    => 21,
+                             allow      => qr/^\d+$/,
+                           },
+
+            phone       => { allow => [ sub { return 1 if /$valid_re/ },
+                                        '1-800-PERL' ]
+                           },
+            id_list     => { default        => [],
+                             strict_type    => 1
+                           },
+            employer    => { default => 'NSA', no_override => 1 },
+        };
+
+        ### check() returns a hashref of parsed args on success ###
+        my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
+                            or die qw[Could not parse arguments!];
+
+        ... other code here ...
+    }
+
+    my $ok = allow( $colour, [qw|blue green yellow|] );
+
+    my $error = Params::Check::last_error();
+
+
+=head1 DESCRIPTION
+
+Params::Check is a generic input parsing/checking mechanism.
+
+It allows you to validate input via a template. The only requirement
+is that the arguments must be named.
+
+Params::Check can do the following things for you:
+
+=over 4
+
+=item *
+
+Convert all keys to lowercase
+
+=item *
+
+Check if all required arguments have been provided
+
+=item *
+
+Set arguments that have not been provided to the default
+
+=item *
+
+Weed out arguments that are not supported and warn about them to the
+user
+
+=item *
+
+Validate the arguments given by the user based on strings, regexes,
+lists or even subroutines
+
+=item *
+
+Enforce type integrity if required
+
+=back
+
+Most of Params::Check's power comes from its template, which we'll
+discuss below:
+
+=head1 Template
+
+As you can see in the synopsis, based on your template, the arguments
+provided will be validated.
+
+The template can take a different set of rules per key that is used.
+
+The following rules are available:
+
+=over 4
+
+=item default
+
+This is the default value if none was provided by the user.
+This is also the type C<strict_type> will look at when checking type
+integrity (see below).
+
+=item required
+
+A boolean flag that indicates if this argument was a required
+argument. If marked as required and not provided, check() will fail.
+
+=item strict_type
+
+This does a C<ref()> check on the argument provided. The C<ref> of the
+argument must be the same as the C<ref> of the default value for this
+check to pass.
+
+This is very useful if you insist on taking an array reference as
+argument for example.
+
+=item defined
+
+If this template key is true, enforces that if this key is provided by
+user input, its value is C<defined>. This just means that the user is
+not allowed to pass C<undef> as a value for this key and is equivalent
+to:
+    allow => sub { defined $_[0] && OTHER TESTS }
+
+=item no_override
+
+This allows you to specify C<constants> in your template. ie, they
+keys that are not allowed to be altered by the user. It pretty much
+allows you to keep all your C<configurable> data in one place; the
+C<Params::Check> template.
+
+=item store
+
+This allows you to pass a reference to a scalar, in which the data
+will be stored:
+
+    my $x;
+    my $args = check(foo => { default => 1, store => \$x }, $input);
+
+This is basically shorthand for saying:
+
+    my $args = check( { foo => { default => 1 }, $input );
+    my $x    = $args->{foo};
+
+You can alter the global variable $Params::Check::NO_DUPLICATES to
+control whether the C<store>'d key will still be present in your
+result set. See the L<Global Variables> section below.
+
+=item allow
+
+A set of criteria used to validate a particular piece of data if it
+has to adhere to particular rules.
+
+See the C<allow()> function for details.
+
+=back
+
+=head1 Functions
+
+=head2 check( \%tmpl, \%args, [$verbose] );
+
+This function is not exported by default, so you'll have to ask for it
+via:
+
+    use Params::Check qw[check];
+
+or use its fully qualified name instead.
+
+C<check> takes a list of arguments, as follows:
+
+=over 4
+
+=item Template
+
+This is a hash reference which contains a template as explained in the
+C<SYNOPSIS> and C<Template> section.
+
+=item Arguments
+
+This is a reference to a hash of named arguments which need checking.
+
+=item Verbose
+
+A boolean to indicate whether C<check> should be verbose and warn
+about what went wrong in a check or not.
+
+You can enable this program wide by setting the package variable
+C<$Params::Check::VERBOSE> to a true value. For details, see the
+section on C<Global Variables> below.
+
+=back
+
+C<check> will return when it fails, or a hashref with lowercase
+keys of parsed arguments when it succeeds.
+
+So a typical call to check would look like this:
+
+    my $parsed = check( \%template, \%arguments, $VERBOSE )
+                    or warn q[Arguments could not be parsed!];
+
+A lot of the behaviour of C<check()> can be altered by setting
+package variables. See the section on C<Global Variables> for details
+on this.
+
+=cut
+
+sub check {
+    my ($utmpl, $href, $verbose) = @_;
+
+    ### clear the current error string ###
+    _clear_error();
+
+    ### did we get the arguments we need? ###
+    if ( !$utmpl or !$href ) {
+      _store_error(loc('check() expects two arguments'));
+      return unless $WARNINGS_FATAL;
+      croak(__PACKAGE__->last_error);
+    }
+
+    ### sensible defaults ###
+    $verbose ||= $VERBOSE || 0;
+
+    ### XXX what type of template is it? ###
+    ### { key => { } } ?
+    #if (ref $args eq 'HASH') {
+    #    1;
+    #}
+
+    ### clean up the template ###
+    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 $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;
+
+            ### 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;
+
+    ### flag to see if we warned for anything, needed for warnings_fatal
+    my $warned;
+
+    for my $key (keys %$args) {
+        my $arg = $args->{$key};
+
+        ### you gave us this key, but it's not in the template ###
+        unless( $utmpl->{$key} ) {
+
+            ### but we'll allow it anyway ###
+            if( $ALLOW_UNKNOWN ) {
+                $defs{$key} = $arg;
+
+            ### warn about the error ###
+            } else {
+                _store_error(
+                    loc("Key '%1' is not a valid key for %2 provided by %3",
+                        $key, _who_was_it(), _who_was_it(1)), $verbose);
+                $warned ||= 1;
+            }
+            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( $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)),
+                $verbose
+            );
+            $warned ||= 1;
+            next;
+        }
+
+        ### check if you were supposed to provide defined() values ###
+        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;
+            next;
+        }
+
+        ### check if they should be of a strict type, and if it is ###
+        if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
+            (ref $arg ne ref $tmpl{'default'})
+        ) {
+            _store_error(loc(q|Key '%1' needs to be of type '%2'|,
+                        $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
+            $wrong ||= 1;
+            next;
+        }
+
+        ### check if we have an allow handler, to validate against ###
+        ### allow() will report its own errors ###
+        if( exists $tmpl{'allow'} and not do {
+                local $_ERROR_STRING;
+                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, "$arg", _who_was_it(),
+                            _who_was_it(1)), $verbose);
+            $wrong ||= 1;
+            next;
+        }
+
+        ### we got here, then all must be OK ###
+        $defs{$key} = $arg;
+
+    }
+
+    ### 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;
+
+    ### done with our loop... if $wrong is set, something went wrong
+    ### and the user is already informed, just return...
+    return if $wrong;
+
+    ### 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 (@want_store) {
+        next unless exists $defs{$key};
+        my $ref = $utmpl->{$key}{'store'};
+        $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
+    }
+
+    return \%defs;
+}
+
+=head2 allow( $test_me, \@criteria );
+
+The function that handles the C<allow> key in the template is also
+available for independent use.
+
+The function takes as first argument a key to test against, and
+as second argument any form of criteria that are also allowed by
+the C<allow> key in the template.
+
+You can use the following types of values for allow:
+
+=over 4
+
+=item string
+
+The provided argument MUST be equal to the string for the validation
+to pass.
+
+=item regexp
+
+The provided argument MUST match the regular expression for the
+validation to pass.
+
+=item subroutine
+
+The provided subroutine MUST return true in order for the validation
+to pass and the argument accepted.
+
+(This is particularly useful for more complicated data).
+
+=item array ref
+
+The provided argument MUST equal one of the elements of the array
+ref for the validation to pass. An array ref can hold all the above
+values.
+
+=back
+
+It returns true if the key matched the criteria, or false otherwise.
+
+=cut
+
+sub allow {
+    ### use $_[0] and $_[1] since this is hot code... ###
+    #my ($val, $ref) = @_;
+
+    ### it's a regexp ###
+    if( ref $_[1] eq 'Regexp' ) {
+        local $^W;  # silence warnings if $val is undef #
+        return if $_[0] !~ /$_[1]/;
+
+    ### it's a sub ###
+    } elsif ( ref $_[1] eq 'CODE' ) {
+        return unless $_[1]->( $_[0] );
+
+    ### it's an array ###
+    } elsif ( ref $_[1] eq 'ARRAY' ) {
+
+        ### loop over the elements, see if one of them says the
+        ### value is OK
+        ### also, short-circuit when possible
+        for ( @{$_[1]} ) {
+            return 1 if allow( $_[0], $_ );
+        }
+
+        return;
+
+    ### fall back to a simple, but safe 'eq' ###
+    } else {
+        return unless _safe_eq( $_[0], $_[1] );
+    }
+
+    ### we got here, no failures ###
+    return 1;
+}
+
+### helper functions ###
+
+sub _safe_eq {
+    ### only do a straight 'eq' if they're both defined ###
+    return defined($_[0]) && defined($_[1])
+                ? $_[0] eq $_[1]
+                : defined($_[0]) eq defined($_[1]);
+}
+
+sub _who_was_it {
+    my $level = $_[0] || 0;
+
+    return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
+}
+
+=head2 last_error()
+
+Returns a string containing all warnings and errors reported during
+the last time C<check> was called.
+
+This is useful if you want to report then some other way than
+C<carp>'ing when the verbose flag is on.
+
+It is exported upon request.
+
+=cut
+
+{   $_ERROR_STRING = '';
+
+    sub _store_error {
+        my($err, $verbose, $offset) = @_[0..2];
+        $verbose ||= 0;
+        $offset  ||= 0;
+        my $level   = 1 + $offset;
+
+        local $Carp::CarpLevel = $level;
+
+        carp $err if $verbose;
+
+        $_ERROR_STRING .= $err . "\n";
+    }
+
+    sub _clear_error {
+        $_ERROR_STRING = '';
+    }
+
+    sub last_error { $_ERROR_STRING }
+}
+
+1;
+
+=head1 Global Variables
+
+The behaviour of Params::Check can be altered by changing the
+following global variables:
+
+=head2 $Params::Check::VERBOSE
+
+This controls whether Params::Check will issue warnings and
+explanations as to why certain things may have failed.
+If you set it to 0, Params::Check will not output any warnings.
+
+The default is 1 when L<warnings> are enabled, 0 otherwise;
+
+=head2 $Params::Check::STRICT_TYPE
+
+This works like the C<strict_type> option you can pass to C<check>,
+which will turn on C<strict_type> globally for all calls to C<check>.
+
+The default is 0;
+
+=head2 $Params::Check::ALLOW_UNKNOWN
+
+If you set this flag, unknown options will still be present in the
+return value, rather than filtered out. This is useful if your
+subroutine is only interested in a few arguments, and wants to pass
+the rest on blindly to perhaps another subroutine.
+
+The default is 0;
+
+=head2 $Params::Check::STRIP_LEADING_DASHES
+
+If you set this flag, all keys passed in the following manner:
+
+    function( -key => 'val' );
+
+will have their leading dashes stripped.
+
+=head2 $Params::Check::NO_DUPLICATES
+
+If set to true, all keys in the template that are marked as to be
+stored in a scalar, will also be removed from the result set.
+
+Default is false, meaning that when you use C<store> as a template
+key, C<check> will put it both in the scalar you supplied, as well as
+in the hashref it returns.
+
+=head2 $Params::Check::PRESERVE_CASE
+
+If set to true, L<Params::Check> will no longer convert all keys from
+the user input to lowercase, but instead expect them to be in the
+case the template provided. This is useful when you want to use
+similar keys with different casing in your templates.
+
+Understand that this removes the case-insensitivity feature of this
+module.
+
+Default is 0;
+
+=head2 $Params::Check::ONLY_ALLOW_DEFINED
+
+If set to true, L<Params::Check> will require all values passed to be
+C<defined>. If you wish to enable this on a 'per key' basis, use the
+template option C<defined> instead.
+
+Default is 0;
+
+=head2 $Params::Check::SANITY_CHECK_TEMPLATE
+
+If set to true, L<Params::Check> will sanity check templates, validating
+for errors and unknown keys. Although very useful for debugging, this
+can be somewhat slow in hot-code and large loops.
+
+To disable this check, set this variable to C<false>.
+
+Default is 1;
+
+=head2 $Params::Check::WARNINGS_FATAL
+
+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;
+
+=head2 $Params::Check::CALLER_DEPTH
+
+This global modifies the argument given to C<caller()> by
+C<Params::Check::check()> and is useful if you have a custom wrapper
+function around C<Params::Check::check()>. The value must be an
+integer, indicating the number of wrapper functions inserted between
+the real function call and C<Params::Check::check()>.
+
+Example wrapper function, using a custom stacktrace:
+
+    sub check {
+        my ($template, $args_in) = @_;
+
+        local $Params::Check::WARNINGS_FATAL = 1;
+        local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
+        my $args_out = Params::Check::check($template, $args_in);
+
+        my_stacktrace(Params::Check::last_error) unless $args_out;
+
+        return $args_out;
+    }
+
+Default is 0;
+
+=head1 Acknowledgements
+
+Thanks to Richard Soderberg for his performance improvements.
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-params-check@rt.cpan.orgE<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/t/01_Params-Check.t b/t/01_Params-Check.t
new file mode 100644
index 0000000..f17d1cd
--- /dev/null
+++ b/t/01_Params-Check.t
@@ -0,0 +1,382 @@
+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 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 } ) };
+
+    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 concerning 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" );
+    }
+}
+