move tlperl.straw to tlperl

git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751

2 files changed, 1524 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/Params/Check.pm b/Master/tlpkg/tlperl/lib/Params/Check.pm
new file mode 100755
index 00000000000..7348cbc0d7f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Params/Check.pm
@@ -0,0 +1,712 @@
+package Params::Check;
+
+use strict;
+
+use Carp                        qw[carp croak];
+use Locale::Maketext::Simple    Style => 'gettext';
+
+use Data::Dumper;
+
+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.26';
+    $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 hashreference 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) = @_;
+
+    ### did we get the arguments we need? ###
+    return if !$utmpl or !$href;
+
+    ### 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') {
+    #    1;
+    #}
+
+    ### clean up the template ###
+    my $args = _clean_up_args( $href ) or return;
+
+    ### sanity check + defaults + required keys set? ###
+    my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
+                    or return;
+
+    ### deref only once ###
+    my %utmpl   = %$utmpl;
+    my %args    = %$args;
+    my %defs    = %$defs;
+
+    ### 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) {
+
+        ### 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} = $args{$key};
+
+            ### 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;
+        }
+
+        ### check if you're even allowed to override this key ###
+        if( $utmpl{$key}->{'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;
+        }
+
+        ### 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}
+        ) {
+            _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 $args{$key} 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( $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
+            _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
+                             q|provided by %4|,
+                            $key, "$args{$key}", _who_was_it(),
+                            _who_was_it(1)), $verbose);
+            $wrong ||= 1;
+            next;
+        }
+
+        ### we got here, then all must be OK ###
+        $defs{$key} = $args{$key};
+
+    }
+
+    ### 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, somethign 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 (keys %defs) {
+        if( 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-cicruit 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 ###
+
+### 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])
+                ? $_[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-insensitivy 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 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Richard Soderberg for his performance improvements.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2003,2004 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+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/Master/tlpkg/tlperl/lib/Params/Util.pm b/Master/tlpkg/tlperl/lib/Params/Util.pm
new file mode 100755
index 00000000000..b67e1c0aba3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Params/Util.pm
@@ -0,0 +1,812 @@
+package Params::Util;
+
+=pod
+
+=head1 NAME
+
+Params::Util - Simple, compact and correct param-checking functions
+
+=head1 SYNOPSIS
+
+  # Import some functions
+  use Params::Util qw{_SCALAR _HASH _INSTANCE};
+  
+  # If you are lazy, or need a lot of them...
+  use Params::Util ':ALL';
+  
+  sub foo {
+      my $object  = _INSTANCE(shift, 'Foo') or return undef;
+      my $image   = _SCALAR(shift)          or return undef;
+      my $options = _HASH(shift)            or return undef;
+      # etc...
+  }
+
+=head1 DESCRIPTION
+
+C<Params::Util> provides a basic set of importable functions that makes
+checking parameters a hell of a lot easier
+
+While they can be (and are) used in other contexts, the main point
+behind this module is that the functions B<both> Do What You Mean,
+and Do The Right Thing, so they are most useful when you are getting
+params passed into your code from someone and/or somewhere else
+and you can't really trust the quality.
+
+Thus, C<Params::Util> is of most use at the edges of your API, where
+params and data are coming in from outside your code.
+
+The functions provided by C<Params::Util> check in the most strictly
+correct manner known, are documented as thoroughly as possible so their
+exact behaviour is clear, and heavily tested so make sure they are not
+fooled by weird data and Really Bad Things.
+
+To use, simply load the module providing the functions you want to use
+as arguments (as shown in the SYNOPSIS).
+
+To aid in maintainability, C<Params::Util> will B<never> export by
+default.
+
+You must explicitly name the functions you want to export, or use the
+C<:ALL> param to just have it export everything (although this is not
+recommended if you have any _FOO functions yourself with which future
+additions to C<Params::Util> may clash)
+
+=head1 FUNCTIONS
+
+=cut
+
+use 5.00503;
+use strict;
+require overload;
+require Exporter;
+require Scalar::Util;
+require DynaLoader;
+
+use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS};
+
+$VERSION   = '1.00';
+@ISA       = qw{
+	Exporter
+	DynaLoader
+};
+@EXPORT_OK = qw{
+	_STRING     _IDENTIFIER
+	_CLASS      _CLASSISA   _SUBCLASS  _DRIVER
+	_NUMBER     _POSINT     _NONNEGINT
+	_SCALAR     _SCALAR0
+	_ARRAY      _ARRAY0     _ARRAYLIKE
+	_HASH       _HASH0      _HASHLIKE
+	_CODE       _CODELIKE
+	_INVOCANT   _REGEX      _INSTANCE
+	_SET        _SET0
+	_HANDLE
+};
+%EXPORT_TAGS = ( ALL => \@EXPORT_OK );
+
+eval {
+	local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
+	bootstrap Params::Util $VERSION;
+	1;
+} unless $ENV{PERL_PARAMS_UTIL_PP};
+
+
+
+
+
+#####################################################################
+# Param Checking Functions
+
+=pod
+
+=head2 _STRING $string
+
+The C<_STRING> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a normal non-false string of non-zero length.
+
+Note that this will NOT do anything magic to deal with the special
+C<'0'> false negative case, but will return it.
+
+  # '0' not considered valid data
+  my $name = _STRING(shift) or die "Bad name";
+  
+  # '0' is considered valid data
+  my $string = _STRING($_[0]) ? shift : die "Bad string";
+
+Please also note that this function expects a normal string. It does
+not support overloading or other magic techniques to get a string.
+
+Returns the string as a conveince if it is a valid string, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_STRING;
+sub _STRING ($) {
+	(defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _IDENTIFIER $string
+
+The C<_IDENTIFIER> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a string that is a valid Perl identifier.
+
+Returns the string as a convenience if it is a valid identifier, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_IDENTIFIER;
+sub _IDENTIFIER ($) {
+	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*\z/s) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _CLASS $string
+
+The C<_CLASS> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a string that is a valid Perl class.
+
+This function only checks that the format is valid, not that the
+class is actually loaded. It also assumes "normalised" form, and does
+not accept class names such as C<::Foo> or C<D'Oh>.
+
+Returns the string as a convenience if it is a valid class name, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_CLASS;
+sub _CLASS ($) {
+	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _CLASSISA $string, $class
+
+The C<_CLASSISA> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a string that is a particularly class, or a subclass of it.
+
+This function checks that the format is valid and calls the -E<gt>isa
+method on the class name. It does not check that the class is actually
+loaded.
+
+It also assumes "normalised" form, and does
+not accept class names such as C<::Foo> or C<D'Oh>.
+
+Returns the string as a convenience if it is a valid class name, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_CLASSISA;
+sub _CLASSISA ($$) {
+	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _SUBCLASS $string, $class
+
+The C<_SUBCLASS> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a string that is a subclass of a specified class.
+
+This function checks that the format is valid and calls the -E<gt>isa
+method on the class name. It does not check that the class is actually
+loaded.
+
+It also assumes "normalised" form, and does
+not accept class names such as C<::Foo> or C<D'Oh>.
+
+Returns the string as a convenience if it is a valid class name, or
+C<undef> if not.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SUBCLASS;
+sub _SUBCLASS ($$) {
+	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _NUMBER $scalar
+
+The C<_NUMBER> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a number. That is, it is defined and perl thinks it's a number.
+
+This function is basically a Params::Util-style wrapper around the
+L<Scalar::Util> C<looks_like_number> function.
+
+Returns the value as a convience, or C<undef> if the value is not a
+number.
+
+=cut
+
+eval <<'END_PERL' unless defined &_NUMBER;
+sub _NUMBER ($) {
+	( defined $_[0] and ! ref $_[0] and Scalar::Util::looks_like_number($_[0]) )
+	? $_[0]
+	: undef;
+}
+END_PERL
+
+=pod
+
+=head2 _POSINT $integer
+
+The C<_POSINT> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a positive integer (of any length).
+
+Returns the value as a convience, or C<undef> if the value is not a
+positive integer.
+
+The name itself is derived from the XML schema constraint of the same
+name.
+
+=cut
+
+eval <<'END_PERL' unless defined &_POSINT;
+sub _POSINT ($) {
+	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[1-9]\d*$/) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _NONNEGINT $integer
+
+The C<_NONNEGINT> function is intended to be imported into your
+package, and provides a convenient way to test to see if a value is
+a non-negative integer (of any length). That is, a positive integer,
+or zero.
+
+Returns the value as a convience, or C<undef> if the value is not a
+non-negative integer.
+
+As with other tests that may return false values, care should be taken
+to test via "defined" in boolean validy contexts.
+
+  unless ( defined _NONNEGINT($value) ) {
+     die "Invalid value";
+  }
+
+The name itself is derived from the XML schema constraint of the same
+name.
+
+=cut
+
+eval <<'END_PERL' unless defined &_NONNEGINT;
+sub _NONNEGINT ($) {
+	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^(?:0|[1-9]\d*)$/) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _SCALAR \$scalar
+
+The C<_SCALAR> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<SCALAR> reference, with content of non-zero length.
+
+For a version that allows zero length C<SCALAR> references, see
+the C<_SCALAR0> function.
+
+Returns the C<SCALAR> reference itself as a convenience, or C<undef>
+if the value provided is not a C<SCALAR> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SCALAR;
+sub _SCALAR ($) {
+	(ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _SCALAR0 \$scalar
+
+The C<_SCALAR0> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<SCALAR0> reference, allowing content of zero-length.
+
+For a simpler "give me some content" version that requires non-zero
+length, C<_SCALAR> function.
+
+Returns the C<SCALAR> reference itself as a convenience, or C<undef>
+if the value provided is not a C<SCALAR> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SCALAR0;
+sub _SCALAR0 ($) {
+	ref $_[0] eq 'SCALAR' ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _ARRAY $value
+
+The C<_ARRAY> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<ARRAY> reference containing B<at least> one element of any kind.
+
+For a more basic form that allows zero length ARRAY references, see
+the C<_ARRAY0> function.
+
+Returns the C<ARRAY> reference itself as a convenience, or C<undef>
+if the value provided is not an C<ARRAY> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_ARRAY;
+sub _ARRAY ($) {
+	(ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _ARRAY0 $value
+
+The C<_ARRAY0> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<ARRAY> reference, allowing C<ARRAY> references that contain no
+elements.
+
+For a more basic "An array of something" form that also requires at
+least one element, see the C<_ARRAY> function.
+
+Returns the C<ARRAY> reference itself as a convenience, or C<undef>
+if the value provided is not an C<ARRAY> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_ARRAY0;
+sub _ARRAY0 ($) {
+	ref $_[0] eq 'ARRAY' ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _ARRAYLIKE $value
+
+The C<_ARRAYLIKE> function tests whether a given scalar value can respond to
+array dereferencing.  If it can, the value is returned.  If it cannot,
+C<_ARRAYLIKE> returns C<undef>.
+
+=cut
+
+eval <<'END_PERL' unless defined &_ARRAYLIKE;
+sub _ARRAYLIKE {
+	(defined $_[0] and ref $_[0] and (
+		(Scalar::Util::reftype($_[0]) eq 'ARRAY')
+		or
+		overload::Method($_[0], '@{}')
+	)) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _HASH $value
+
+The C<_HASH> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<HASH> reference with at least one entry.
+
+For a version of this function that allows the C<HASH> to be empty,
+see the C<_HASH0> function.
+
+Returns the C<HASH> reference itself as a convenience, or C<undef>
+if the value provided is not an C<HASH> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_HASH;
+sub _HASH ($) {
+	(ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _HASH0 $value
+
+The C<_HASH0> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<HASH> reference, regardless of the C<HASH> content.
+
+For a simpler "A hash of something" version that requires at least one
+element, see the C<_HASH> function.
+
+Returns the C<HASH> reference itself as a convenience, or C<undef>
+if the value provided is not an C<HASH> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_HASH0;
+sub _HASH0 ($) {
+	ref $_[0] eq 'HASH' ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _HASHLIKE $value
+
+The C<_HASHLIKE> function tests whether a given scalar value can respond to
+hash dereferencing.  If it can, the value is returned.  If it cannot,
+C<_HASHLIKE> returns C<undef>.
+
+=cut
+
+eval <<'END_PERL' unless defined &_HASHLIKE;
+sub _HASHLIKE {
+	(defined $_[0] and ref $_[0] and (
+		(Scalar::Util::reftype($_[0]) eq 'HASH')
+		or
+		overload::Method($_[0], '%{}')
+	)) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _CODE $value
+
+The C<_CODE> function is intended to be imported into your package,
+and provides a convenient way to test for a raw and unblessed
+C<CODE> reference.
+
+Returns the C<CODE> reference itself as a convenience, or C<undef>
+if the value provided is not an C<CODE> reference.
+
+=cut
+
+eval <<'END_PERL' unless defined &_CODE;
+sub _CODE ($) {
+	ref $_[0] eq 'CODE' ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _CODELIKE $value
+
+The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>,
+which checks for an explicit C<CODE> reference, the C<_CODELIKE> function
+also includes things that act like them, such as blessed objects that
+overload C<'&{}'>.
+
+Please note that in the case of objects overloaded with '&{}', you will
+almost always end up also testing it in 'bool' context at some stage.
+
+For example:
+
+  sub foo {
+      my $code1 = _CODELIKE(shift) or die "No code param provided";
+      my $code2 = _CODELIKE(shift);
+      if ( $code2 ) {
+           print "Got optional second code param";
+      }
+  }
+
+As such, you will most likely always want to make sure your class has
+at least the following to allow it to evaluate to true in boolean
+context.
+
+  # Always evaluate to true in boolean context
+  use overload 'bool' => sub () { 1 };
+
+Returns the callable value as a convenience, or C<undef> if the
+value provided is not callable.
+
+Note - This function was formerly known as _CALLABLE but has been renamed
+for greater symmetry with the other _XXXXLIKE functions.
+
+The use of _CALLABLE has been deprecated. It will continue to work, but
+with a warning, until end-2006, then will be removed.
+
+I apologise for any inconvenience caused.
+
+=cut
+
+eval <<'END_PERL' unless defined &_CODELIKE;
+sub _CODELIKE($) {
+	(
+		(Scalar::Util::reftype($_[0])||'') eq 'CODE'
+		or
+		Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}')
+	)
+	? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _INVOCANT $value
+
+This routine tests whether the given value is a valid method invocant.
+This can be either an instance of an object, or a class name.
+
+If so, the value itself is returned.  Otherwise, C<_INVOCANT>
+returns C<undef>.
+
+=cut
+
+eval <<'END_PERL' unless defined &_INVOCANT;
+sub _INVOCANT($) {
+	(defined $_[0] and
+		(defined Scalar::Util::blessed($_[0])
+		or      
+		# We used to check for stash definedness, but any class-like name is a
+		# valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02
+		Params::Util::_CLASS($_[0]))
+	) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _INSTANCE $object, $class
+
+The C<_INSTANCE> function is intended to be imported into your package,
+and provides a convenient way to test for an object of a particular class
+in a strictly correct manner.
+
+Returns the object itself as a convenience, or C<undef> if the value
+provided is not an object of that type.
+
+=cut
+
+eval <<'END_PERL' unless defined &_INSTANCE;
+sub _INSTANCE ($$) {
+	(Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _REGEX $value
+
+The C<_REGEX> function is intended to be imported into your package,
+and provides a convenient way to test for a regular expression.
+
+Returns the value itself as a convenience, or C<undef> if the value
+provided is not a regular expression.
+
+=cut
+
+eval <<'END_PERL' unless defined &_REGEX;
+sub _REGEX ($) {
+	(defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef;
+}
+END_PERL
+
+=pod
+
+=head2 _SET \@array, $class
+
+The C<_SET> function is intended to be imported into your package,
+and provides a convenient way to test for set of at least one object of
+a particular class in a strictly correct manner.
+
+The set is provided as a reference to an C<ARRAY> of objects of the
+class provided.
+
+For an alternative function that allows zero-length sets, see the
+C<_SET0> function.
+
+Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
+the value provided is not a set of that class.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SET;
+sub _SET ($$) {
+	my $set = shift;
+	_ARRAY($set) or return undef;
+	foreach my $item ( @$set ) {
+		_INSTANCE($item,$_[0]) or return undef;
+	}
+	$set;
+}
+END_PERL
+
+=pod
+
+=head2 _SET0 \@array, $class
+
+The C<_SET0> function is intended to be imported into your package,
+and provides a convenient way to test for a set of objects of a
+particular class in a strictly correct manner, allowing for zero objects.
+
+The set is provided as a reference to an C<ARRAY> of objects of the
+class provided.
+
+For an alternative function that requires at least one object, see the
+C<_SET> function.
+
+Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
+the value provided is not a set of that class.
+
+=cut
+
+eval <<'END_PERL' unless defined &_SET0;
+sub _SET0 ($$) {
+	my $set = shift;
+	_ARRAY0($set) or return undef;
+	foreach my $item ( @$set ) {
+		_INSTANCE($item,$_[0]) or return undef;
+	}
+	$set;
+}
+END_PERL
+
+=pod
+
+=head2 _HANDLE
+
+The C<_HANDLE> function is intended to be imported into your package,
+and provides a convenient way to test whether or not a single scalar
+value is a file handle.
+
+Unfortunately, in Perl the definition of a file handle can be a little
+bit fuzzy, so this function is likely to be somewhat imperfect (at first
+anyway).
+
+That said, it is implement as well or better than the other file handle
+detectors in existance (and we stole from the best of them).
+
+=cut
+
+# We're doing this longhand for now. Once everything is perfect,
+# we'll compress this into something that compiles more efficiently.
+# Further, testing file handles is not something that is generally
+# done millions of times, so doing it slowly is not a big speed hit.
+eval <<'END_PERL' unless defined &_HANDLE;
+sub _HANDLE {
+	my $it = shift;
+
+	# It has to be defined, of course
+	unless ( defined $it ) {
+		return undef;
+	}
+
+	# Normal globs are considered to be file handles
+	if ( ref $it eq 'GLOB' ) {
+		return $it;
+	}
+
+	# Check for a normal tied filehandle
+	# Side Note: 5.5.4's tied() and can() doesn't like getting undef
+	if ( tied($it) and tied($it)->can('TIEHANDLE') ) {
+		return $it;
+	}
+
+	# There are no other non-object handles that we support
+	unless ( Scalar::Util::blessed($it) ) {
+		return undef;
+	}
+
+	# Check for a common base classes for conventional IO::Handle object
+	if ( $it->isa('IO::Handle') ) {
+		return $it;
+	}
+
+
+	# Check for tied file handles using Tie::Handle
+	if ( $it->isa('Tie::Handle') ) {
+		return $it;
+	}
+
+	# IO::Scalar is not a proper seekable, but it is valid is a
+	# regular file handle
+	if ( $it->isa('IO::Scalar') ) {
+		return $it;
+	}
+
+	# Yet another special case for IO::String, which refuses (for now
+	# anyway) to become a subclass of IO::Handle.
+	if ( $it->isa('IO::String') ) {
+		return $it;
+	}
+
+	# This is not any sort of object we know about
+	return undef;
+}
+END_PERL
+
+=pod
+
+=head2 _DRIVER $string
+
+  sub foo {
+    my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver";
+    ...
+  }
+
+The C<_DRIVER> function is intended to be imported into your
+package, and provides a convenient way to load and validate
+a driver class.
+
+The most common pattern when taking a driver class as a parameter
+is to check that the name is a class (i.e. check against _CLASS)
+and then to load the class (if it exists) and then ensure that
+the class returns true for the isa method on some base driver name.
+
+Return the value as a convenience, or C<undef> if the value is not
+a class name, the module does not exist, the module does not load,
+or the class fails the isa test.
+
+=cut
+
+eval <<'END_PERL' unless defined &_DRIVER;
+sub _DRIVER ($$) {
+	(defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
+}
+END_PERL
+
+1;
+
+=pod
+
+=head1 TO DO
+
+- Add _CAN to help resolve the UNIVERSAL::can debacle
+
+- Would be even nicer if someone would demonstrate how the hell to
+build a Module::Install dist of the ::Util dual Perl/XS type. :/
+
+- Implement an assertion-like version of this module, that dies on
+error.
+
+- Implement a Test:: version of this module, for use in testing
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util>
+
+For other issues, contact the author.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<Params::Validate>
+
+=head1 COPYRIGHT
+
+Copyright 2005 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut